From 233a89b7cde0215e23e4d20db14dca5ff6df8a5b Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Tue, 7 Sep 2021 17:46:36 -0400 Subject: [PATCH 01/31] add fix for file writing when dststatus_print=true * add local flag to control whether to write the dststatus file for a particular RH. This prevents writing a dststatus file for consf_aofrac which contains garbage (since the RH is a copy, and dststatus field is not set) or a dststatus file for mapcopy --- mediator/med_map_mod.F90 | 60 +++++++++++++++++++++++----------------- 1 file changed, 34 insertions(+), 26 deletions(-) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 4f8bda907..e017f4ffc 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -364,7 +364,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, integer :: srcMaskValue integer :: dstMaskValue character(len=ESMF_MAXSTR) :: lmapfile - logical :: rhprint = .false. + logical :: rhprint = .false., ldstprint = .false. integer :: ns integer(I4), pointer :: dof(:) => null() integer :: srcTermProcessing_Value = 0 @@ -385,6 +385,8 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, if (chkerr(rc,__LINE__,u_FILE_u)) return dststatusfield = ESMF_FieldCreate(dstmesh, ESMF_TYPEKIND_I4, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ! set local flag to false + ldstprint = .false. if (trim(coupling_mode) == 'cesm') then dstMaskValue = ispval_mask @@ -464,6 +466,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. end if else if (mapindex == mapfillv_bilnr) then if (mastertask) then @@ -479,6 +482,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mapbilnr_nstod) then if (mastertask) then write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string) @@ -494,6 +498,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mapconsf .or. mapindex == mapnstod_consf) then if (mastertask) then write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string) @@ -509,6 +514,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mapconsf_aofrac) then if (.not. ESMF_RouteHandleIsCreated(routehandles(mapconsf))) then if (mastertask) then @@ -525,6 +531,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else ! Copy existing consf RH if (mastertask) then @@ -548,6 +555,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mappatch .or. mapindex == mappatch_uv3d) then if (.not. ESMF_RouteHandleIsCreated(routehandles(mappatch))) then if (mastertask) then @@ -563,6 +571,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. end if else if (mastertask) then @@ -575,30 +584,28 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, end if ! Output destination status field to file if requested - if (dststatus_print) then - if (mapindex /= mapfcopy .or. lmapfile /= 'unset') then - fname = 'dststatus.'//trim(compname(n1))//'.'//trim(compname(n2))//'.'//trim(mapname)//'.nc' - call ESMF_LogWrite(trim(subname)//": writing dstStatusField to "//trim(fname), ESMF_LOGMSG_INFO) - - call ESMF_FieldWrite(dststatusfield, filename=trim(fname), variableName='dststatus', & - overwrite=.true., rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! the sequence index in order to sort the dststatus field - call ESMF_MeshGet(dstmesh, elementDistgrid=distgrid, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_DistGridGet(distgrid, localDE=0, elementCount=ns, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(dof(ns)) - call ESMF_DistGridGet(distgrid, localDE=0, seqIndexList=dof, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - doffield = ESMF_FieldCreate(dstmesh, dof, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldWrite(doffield, fileName='dof.'//trim(compname(n2))//'.nc', variableName='dof', & - overwrite=.true., rc=rc) - deallocate(dof) - call ESMF_FieldDestroy(doffield, rc=rc, noGarbage=.true.) - end if + if (dststatus_print .and. ldstprint) then + fname = 'dststatus.'//trim(compname(n1))//'.'//trim(compname(n2))//'.'//trim(mapname)//'.nc' + call ESMF_LogWrite(trim(subname)//": writing dstStatusField to "//trim(fname), ESMF_LOGMSG_INFO) + + call ESMF_FieldWrite(dststatusfield, filename=trim(fname), variableName='dststatus', & + overwrite=.true., rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the sequence index in order to sort the dststatus field + call ESMF_MeshGet(dstmesh, elementDistgrid=distgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_DistGridGet(distgrid, localDE=0, elementCount=ns, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(dof(ns)) + call ESMF_DistGridGet(distgrid, localDE=0, seqIndexList=dof, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + doffield = ESMF_FieldCreate(dstmesh, dof, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldWrite(doffield, fileName='dof.'//trim(compname(n2))//'.nc', variableName='dof', & + overwrite=.true., rc=rc) + deallocate(dof) + call ESMF_FieldDestroy(doffield, rc=rc, noGarbage=.true.) end if ! consd_nstod method requires a second routehandle @@ -613,9 +620,10 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. ! Output destination status field to file if requested - if (dststatus_print) then + if (dststatus_print .and. ldstprint) then fname = 'dststatus.'//trim(compname(n1))//'.'//trim(compname(n2))//'.'//trim(mapname)//'_2.nc' call ESMF_LogWrite(trim(subname)//": writing dstStatusField to "//trim(fname), ESMF_LOGMSG_INFO) From 843a1f14f081b971a3aebcdbe07dcd31a9c9280d Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 20 Oct 2021 19:20:00 -0600 Subject: [PATCH 02/31] add u10m,v10m from atm->wav --- mediator/esmFldsExchange_nems_mod.F90 | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index f6d88ab46..4e902cbc0 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -28,7 +28,7 @@ subroutine esmFldsExchange_nems(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, comprof, ncomps + use esmflds , only : compmed, compatm, compocn, compice, compwav, ncomps use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf use esmflds , only : mapconsf_aofrac @@ -353,6 +353,23 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end do deallocate(flds) + !===================================================================== + ! FIELDS TO WAV (compwav) + !===================================================================== + + ! to wav - 10m winds from atm + allocate(flds(2)) + flds = (/'Sa_u10m', 'Sa_v10m'/) + + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, maptype, 'one', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + end subroutine esmFldsExchange_nems end module esmFldsExchange_nems_mod From f0fa04c382d65d92bd6826e89facb8093b75f6b0 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 27 Oct 2021 07:48:14 -0600 Subject: [PATCH 03/31] add wave->atm field * sending only cpl_scalars back in export gave mediator error ESMF_GeomBaseGet Value unrecognized or out of range med_methods_mod.F90:424 --- mediator/esmFldsExchange_nems_mod.F90 | 5 +++++ mediator/med_methods_mod.F90 | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 4e902cbc0..81de079f2 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -159,6 +159,11 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addmap(fldListFr(compocn)%flds, 'So_t', compatm, maptype, 'ofrac', 'unset') call addmrg(fldListTo(compatm)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + ! to atm: surface roughness length from wav + call addfld(fldListFr(compwav)%flds, 'Sw_z0') + call addfld(fldListTo(compatm)%flds, 'Sw_z0') + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, maptype, 'wfrac', 'unset') + call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') !===================================================================== ! FIELDS TO OCEAN (compocn) !===================================================================== diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index f25b024cd..b24418fef 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -1863,7 +1863,7 @@ subroutine med_methods_Field_GeomPrint(field, string, rc) 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_Print(lmesh, string, rc) + !call med_methods_Mesh_Print(lmesh, string, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif From 5beead0ff69de03c9f535efe0aca1f61cc47ec07 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Fri, 29 Oct 2021 12:31:28 -0400 Subject: [PATCH 04/31] Update CMEPS (#58) * updates CMEPS with latests changes from ESCOMP, including - xgrid capablility (cesm only) - refactored accumulation field bundles - cleaned up med.F90 for mesh creation - refactored mediatory history functionality --- .github/workflows/extbuild.yml | 2 +- .travis.yml | 4 +- cime_config/buildexe | 2 +- cime_config/buildnml | 55 +- cime_config/config_component.xml | 103 +- cime_config/config_component_cesm.xml | 204 +- cime_config/config_component_ufs.xml | 28 +- cime_config/namelist_definition_drv.xml | 2271 +++++++------ cime_config/namelist_definition_drv_flds.xml | 16 + cime_config/runseq/driver_config.py | 10 +- cime_config/runseq/gen_runseq.py | 16 +- cime_config/runseq/runseq_general.py | 15 +- cime_config/testdefs/testlist_drv.xml | 274 +- .../testdefs/testmods_dirs/drv/y100k/README | 5 + .../testmods_dirs/drv/y100k/shell_commands | 1 + doc/source/CMEPS-grid1.png | Bin 0 -> 11651 bytes doc/source/CMEPS-grid2.png | Bin 0 -> 6924 bytes doc/source/CMEPS-grid3.png | Bin 0 -> 73445 bytes doc/source/addendum/fieldnames.rst | 171 + doc/source/addendum/index.rst | 11 + doc/source/addendum/req_attributes.rst | 68 + doc/source/addendum/req_attributes_cesm.rst | 134 + doc/source/conf.py | 1 - doc/source/esmflds.rst | 247 ++ doc/source/field_naming_convention.rst | 53 - doc/source/fractions.rst | 117 + doc/source/generic.rst | 145 + doc/source/index.rst | 7 +- doc/source/introduction.rst | 629 +++- doc/source/prep.rst | 85 + drivers/cime/esm.F90 | 17 +- drivers/cime/esm_time_mod.F90 | 6 +- mediator/esmFlds.F90 | 12 +- mediator/esmFldsExchange_cesm_mod.F90 | 2892 ++++++++++++----- mediator/esmFldsExchange_hafs_mod.F90 | 4 +- mediator/fd_cesm.yaml | 12 + mediator/med.F90 | 811 ++--- mediator/med_diag_mod.F90 | 156 +- mediator/med_fraction_mod.F90 | 40 +- mediator/med_internalstate_mod.F90 | 22 +- mediator/med_io_mod.F90 | 659 ++-- mediator/med_map_mod.F90 | 412 ++- mediator/med_merge_mod.F90 | 178 +- mediator/med_methods_mod.F90 | 107 +- mediator/med_phases_aofluxes_mod.F90 | 1372 ++++++-- mediator/med_phases_history_mod.F90 | 1972 +++++++++-- mediator/med_phases_ocnalb_mod.F90 | 12 +- mediator/med_phases_post_atm_mod.F90 | 12 + mediator/med_phases_post_glc_mod.F90 | 49 +- mediator/med_phases_post_ice_mod.F90 | 16 +- mediator/med_phases_post_lnd_mod.F90 | 148 +- mediator/med_phases_post_ocn_mod.F90 | 14 +- mediator/med_phases_post_rof_mod.F90 | 14 +- mediator/med_phases_post_wav_mod.F90 | 16 +- mediator/med_phases_prep_atm_mod.F90 | 37 +- mediator/med_phases_prep_glc_mod.F90 | 512 ++- mediator/med_phases_prep_ice_mod.F90 | 18 +- mediator/med_phases_prep_lnd_mod.F90 | 8 +- mediator/med_phases_prep_ocn_mod.F90 | 144 +- mediator/med_phases_prep_rof_mod.F90 | 311 +- mediator/med_phases_prep_wav_mod.F90 | 2 +- mediator/med_phases_restart_mod.F90 | 389 ++- mediator/med_time_mod.F90 | 73 +- nuopc_cap_share/nuopc_shr_methods.F90 | 12 +- 64 files changed, 10005 insertions(+), 5128 deletions(-) create mode 100644 cime_config/testdefs/testmods_dirs/drv/y100k/README create mode 100644 cime_config/testdefs/testmods_dirs/drv/y100k/shell_commands create mode 100644 doc/source/CMEPS-grid1.png create mode 100644 doc/source/CMEPS-grid2.png create mode 100644 doc/source/CMEPS-grid3.png create mode 100644 doc/source/addendum/fieldnames.rst create mode 100644 doc/source/addendum/index.rst create mode 100644 doc/source/addendum/req_attributes.rst create mode 100644 doc/source/addendum/req_attributes_cesm.rst create mode 100644 doc/source/esmflds.rst delete mode 100644 doc/source/field_naming_convention.rst create mode 100644 doc/source/fractions.rst create mode 100644 doc/source/generic.rst create mode 100644 doc/source/prep.rst diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml index 69ad954a3..a90bf338d 100644 --- a/.github/workflows/extbuild.yml +++ b/.github/workflows/extbuild.yml @@ -19,7 +19,7 @@ jobs: 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_47 + ESMF_VERSION: ESMF_8_2_0_beta_snapshot_14 PNETCDF_VERSION: pnetcdf-1.12.2 NETCDF_FORTRAN_VERSION: v4.5.2 # PIO version is awkward diff --git a/.travis.yml b/.travis.yml index 0a14a61ba..b81231976 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,9 +4,9 @@ install: - pip install pylint python: - - '2.7' - - '3.6' + - '3.7' - '3.8' + - '3.9' branches: only: diff --git a/cime_config/buildexe b/cime_config/buildexe index 52640d30b..e76fc7344 100755 --- a/cime_config/buildexe +++ b/cime_config/buildexe @@ -84,7 +84,7 @@ def _main_func(): if not os.path.isdir(bld_root): os.makedirs(bld_root) - with open(os.path.join(bld_root,'Filepath'), 'w') as out: + with open(os.path.join(bld_root,'Filepath'), 'w', encoding="utf-8") as out: 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") diff --git a/cime_config/buildnml b/cime_config/buildnml index 28e83bbd9..f8a43852b 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -47,8 +47,27 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): config['bfbflag'] = 'on' if case.get_value('BFBFLAG') else 'off' config['continue_run'] = '.true.' if case.get_value('CONTINUE_RUN') else '.false.' config['flux_epbal'] = 'ocn' if case.get_value('CPL_EPBAL') == 'ocn' else 'off' - config['atm_grid'] = case.get_value('ATM_GRID') config['mask_grid'] = case.get_value('MASK_GRID') + config['rest_option'] = case.get_value('REST_OPTION') + + atm_grid = case.get_value('ATM_GRID') + lnd_grid = case.get_value('LND_GRID') + ice_grid = case.get_value('ICE_GRID') + ocn_grid = case.get_value('OCN_GRID') + rof_grid = case.get_value('ROF_GRID') + wav_grid = case.get_value('WAV_GRID') + #pylint: disable=unused-variable + glc_grid = case.get_value('GLC_GRID') + + config['atm_grid'] = atm_grid + config['lnd_grid'] = lnd_grid + config['ice_grid'] = ice_grid + config['ocn_grid'] = ocn_grid + config['samegrid_atm_lnd'] = 'true' if atm_grid == lnd_grid else 'false' + config['samegrid_atm_ice'] = 'true' if atm_grid == ice_grid else 'false' + config['samegrid_atm_ocn'] = 'true' if atm_grid == ocn_grid else 'false' + config['samegrid_atm_wav'] = 'true' if atm_grid == wav_grid else 'false' + config['samegrid_lnd_rof'] = 'true' if lnd_grid == rof_grid else 'false' # determine if need to set atm_domainfile scol_lon = float(case.get_value('PTS_LON')) @@ -84,11 +103,6 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): #---------------------------------------------------- nmlgen.init_defaults(infile, config) - if case.get_value('MEDIATOR_READ_RESTART'): - nmlgen.set_value('mediator_read_restart', value='.true.') - else: - nmlgen.set_value('mediator_read_restart', value='.false.') - #-------------------------------- # Overwrite: set brnch_retain_casename #-------------------------------- @@ -273,7 +287,7 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): # the driver restart pointer will look like a mediator is present even if it is not nmlgen.set_value("drv_restart_pointer", value="rpointer.cpl") - logger.info("Writing nuopc_runseq for components {}".format(valid_comps)) + logger.info("Writing nuopc_runconfig for components {}".format(valid_comps)) nuopc_config_file = os.path.join(confdir, "nuopc.runconfig") nmlgen.write_nuopc_config_file(nuopc_config_file, data_list_path=data_list_path) @@ -282,7 +296,7 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): #-------------------------------- # Read nuopc.runconfig - with open(nuopc_config_file, 'r') as f: + with open(nuopc_config_file, 'r', encoding="utf-8") as f: lines_cpl = f.readlines() # Look for only active components except CPL @@ -294,7 +308,7 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): comp_config_file = os.path.join(caseroot,"Buildconf","{}conf".format(case.get_value("COMP_{}".format(comp))), "{}.configure".format(case.get_value("COMP_{}".format(comp)))) if os.path.isfile(comp_config_file): - with open(comp_config_file, 'r') as f: + with open(comp_config_file, 'r', encoding="utf-8") as f: lines_comp = f.readlines() if lines_comp: @@ -312,7 +326,7 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): lines_cpl_new.append(line_comp) # Write to a file - with open(nuopc_config_file, 'w') as f: + with open(nuopc_config_file, 'w', encoding="utf-8") as f: for line in lines_cpl_new: f.write(line) @@ -344,7 +358,7 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): dicts = {} for infile in infiles: dict_ = {} - with open(infile) as myfile: + with open(infile, "r", encoding="utf-8") as myfile: for line in myfile: if "=" in line and '!' not in line: name, var = line.partition("=")[::2] @@ -386,7 +400,7 @@ def _create_runseq(case, coupling_times, valid_comps): if len(valid_comps) == 1: # Create run sequence with no mediator - outfile = open(os.path.join(caseroot, "CaseDocs", "nuopc.runseq"), "w") + outfile = open(os.path.join(caseroot, "CaseDocs", "nuopc.runseq"), "w", encoding="utf-8") dtime = coupling_times[valid_comps[0].lower() + '_cpl_dt'] outfile.write ("runSeq:: \n") outfile.write ("@" + str(dtime) + " \n") @@ -469,11 +483,12 @@ def _create_component_modelio_namelists(confdir, case, files): for entry in entries: nmlgen.add_default(entry) - if model == "cpl": - modelio_file = "med_modelio.nml" + inst_string - else: - modelio_file = model + "_modelio.nml" + inst_string - nmlgen.write_nuopc_modelio_file(os.path.join(confdir, modelio_file)) + if inst_index == 1: + if model == "cpl": + modelio_file = "med_modelio.nml" + else: + modelio_file = model + "_modelio.nml" + nmlgen.write_nuopc_modelio_file(os.path.join(confdir, modelio_file)) # Output the following to nuopc.runconfig moddiro = case.get_value('RUNDIR') @@ -482,7 +497,7 @@ def _create_component_modelio_namelists(confdir, case, files): else: logfile = model + inst_string + ".log." + str(lid) - with open(nuopc_config_file, 'a') as outfile: + with open(nuopc_config_file, 'a', encoding="utf-8") as outfile: if model == 'cpl': name = "MED" else: @@ -516,11 +531,11 @@ def buildnml(case, caseroot, component): if component != "drv": raise AttributeError -# Do a check here of ESMF VERSION, requires 8.1.0 or newer (8.2.0 or newer for esmf_aware_threading) + # Do a check here of ESMF VERSION, requires 8.1.0 or newer (8.2.0 or newer for esmf_aware_threading) esmf_aware_threading = case.get_value("ESMF_AWARE_THREADING") esmfmkfile = os.getenv("ESMFMKFILE") expect(esmfmkfile and os.path.isfile(esmfmkfile),"ESMFMKFILE not found {}".format(esmfmkfile)) - with open(esmfmkfile, 'r') as f: + with open(esmfmkfile, 'r', encoding="utf-8") as f: major = None minor = None for line in f.readlines(): diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index ba73c96d6..49bc7d0d8 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -435,27 +435,6 @@ - - char - 1 - run_begin_stop_restart - env_run.xml - - Sets periodic model barriers with BARRIER_OPTION and BARRIER_DATE for synchronization - - - - - char - -999 - run_begin_stop_restart - env_run.xml - - Alternative date in yyyymmdd format - sets periodic model barriers with BARRIER_OPTION and BARRIER_N for synchronization - - - logical TRUE,FALSE @@ -841,6 +820,21 @@ machines. + + logical + TRUE,FALSE + FALSE + build_component_clm + env_build.xml + TRUE implies CLM is built with support for the PETSc + library. The Variably Saturated Flow Model (VSFM) solver in CLM + uses the PETSc library. In order to use the VSFM solver, CLM + must be built with PETSc support and linking to PETSc must occur + when building the ACME executable. This occurs if this variable + is set to TRUE. Note that is only available on a limited set of + machines/compilers. + + logical TRUE,FALSE @@ -2294,10 +2288,6 @@ standard full pathname of the cprnc executable - - - - logical TRUE,FALSE @@ -2307,38 +2297,6 @@ determine if per ice thickness category fields are passed from ice to ocean - DO NOT EDIT (set by POP build-namelist) - - - - - - char - none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,end - never - run_drv_history - env_run.xml - Sets driver snapshot history file frequency (like REST_OPTION) - - - - integer - - -999 - run_drv_history - env_run.xml - Sets driver snapshot history file frequency (like REST_N) - - - - - integer - - -999 - run_drv_history - env_run.xml - yyyymmdd format, sets coupler snapshot history date (like REST_DATE) - - integer 0,1,2,3,4,5,6,7,8,9 @@ -2348,22 +2306,6 @@ level of debug output, 0=minimum, 1=normal, 2=more, 3=too much - - logical - TRUE,FALSE - FALSE - build_component_clm - env_build.xml - TRUE implies CLM is built with support for the PETSc - library. The Variably Saturated Flow Model (VSFM) solver in CLM - uses the PETSc library. In order to use the VSFM solver, CLM - must be built with PETSc support and linking to PETSc must occur - when building the ACME executable. This occurs if this variable - is set to TRUE. Note that is only available on a limited set of - machines/compilers. - - - @@ -2541,6 +2483,21 @@ add aoflux calculation to runseq + + + + + + + logical + TRUE,FALSE + FALSE + run_flags + env_run.xml + turns on coupler bit-for-bit reproducibility with varying pe counts + + + ========================================= Notes: diff --git a/cime_config/config_component_cesm.xml b/cime_config/config_component_cesm.xml index 49ed73ed7..ba4bb69c0 100644 --- a/cime_config/config_component_cesm.xml +++ b/cime_config/config_component_cesm.xml @@ -18,10 +18,14 @@ Historic transient Twentieth century transient - CMIP5 rcp 2.6 forcing - CMIP5 rcp 4.5 forcing - CMIP5 rcp 6.0 forcing - CMIP5 rcp 8.5 forcing + CMIP6 SSP1-1.9 forcing + CMIP6 SSP1-2.6 forcing + CMIP6 SSP2-4.5 forcing + CMIP6 SSP3-7.0 forcing + CMIP6 SSP4-3.4 forcing + CMIP6 SSP4-6.0 forcing + CMIP6 SSP5-3.4 forcing + CMIP6 SSP5-8.5 forcing Biogeochemistry intercomponent with diagnostic CO2 with prognostic CO2 @@ -96,29 +100,6 @@ We will not document this further in this guide. - - logical - TRUE,FALSE - FALSE - run_flags - env_run.xml - turns on coupler bit-for-bit reproducibility with varying pe counts - - - - char - none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end - never - - ndays - - run_begin_stop_restart - env_run.xml - - sets frequency of full model barrier (same options as STOP_OPTION) for synchronization with BARRIER_N and BARRIER_DATE - - - char none,CO2A,CO2B,CO2C @@ -191,23 +172,39 @@ 144 288 288 - 72 - 48 - - - 24 - 24 - 24 - 24 - - - - - 24 - 24 - 48 - 48 - 1 + + + + 48 + 48 + 48 + 24 + 24 + + 72 + + + + 24 + 24 + + + + + + 24 + 144 + 24 + 24 + + + + 24 + 48 + 48 + + + 96 96 96 @@ -230,13 +227,11 @@ 72 144 288 - 48 - 48 - 24 - 24 - 1 - - + + + + + 1 run_coupling env_run.xml @@ -275,16 +270,14 @@ integer $ATM_NCPL - 24 24 - 4 + 1 24 24 - - - - + 48 + 48 1 + 24 run_coupling env_run.xml @@ -332,16 +325,16 @@ integer 8 - $ATM_NCPL - $ATM_NCPL - $ATM_NCPL - $ATM_NCPL - 1 - 8 - 8 - $ATM_NCPL - 1 - $ATM_NCPL + 1 + $ATM_NCPL + $ATM_NCPL + $ATM_NCPL + 1 + 8 + 8 + $ATM_NCPL + 1 + $ATM_NCPL run_coupling env_run.xml @@ -414,28 +407,65 @@ char - TIGHT,RASM + TIGHT,OPTION1,OPTION2 TIGHT - RASM - RASM - RASM - RASM - RASM - RASM - RASM - RASM + OPTION2 + OPTION2 + OPTION1 + OPTION1 + OPTION1 + OPTION2 + OPTION2 + OPTION2 run_coupling env_run.xml - RASM runs prep ocean before the ocean coupling reducing - most of the lags and field inconsistency but still allowing the ocean to run - concurrently with the ice and atmosphere. - TIGHT are consistent with the old variables ocean_tight_coupling = true in the driver. + OPTION1 (like RASM_OPTION1 in CPL7) runs prep_ocn_avg, + BEFORE the aoflux and ocnalb calculations, thereby reducing + most of the lags and field inconsistency but still allowing the + ocean to run concurrently with the ice and atmosphere. + OPTION2 (like CESM1_MOD in CPL7) runs prep_ocn_avg, + AFTER the aoflux and ocnalb calculations, thereby permitting maximum + concurrency + TIGHT (like CESM1_MOD_TIGHT), is a tight coupling run sequence + + + + + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + never + med_history + env_run.xml + Sets driver snapshot history file frequency (like REST_OPTION) + + + integer + + -999 + med_history + env_run.xml + Sets driver snapshot history file frequency (like REST_N) + + + integer + + -999 + med_history + env_run.xml + yyyymmdd format, sets coupler snapshot history date (like REST_DATE) + + + + + + char none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end @@ -443,11 +473,10 @@ nmonths - run_drv_history + med_history env_run.xml - Sets driver average history file frequency (like REST_OPTION) + Sets mediator average history file frequency (like REST_OPTION) - char @@ -455,18 +484,17 @@ 1 - run_drv_history + med_history env_run.xml - Sets driver average history file frequency (like REST_N) + Sets mediator average history file frequency (like REST_N) - integer -999 - run_drv_history + med_history env_run.xml - yyyymmdd format, sets driver average history date (like REST_DATE) + yyyymmdd format, sets mediator average history date (like REST_DATE) diff --git a/cime_config/config_component_ufs.xml b/cime_config/config_component_ufs.xml index 1516f97b0..bb32df7b5 100644 --- a/cime_config/config_component_ufs.xml +++ b/cime_config/config_component_ufs.xml @@ -422,6 +422,32 @@ + + char + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end + never + run_drv_history + env_run.xml + Sets driver snapshot history file frequency (like REST_OPTION) + + + integer + + -999 + run_drv_history + env_run.xml + Sets driver snapshot history file frequency (like REST_N) + + + + integer + + -999 + run_drv_history + env_run.xml + yyyymmdd format, sets coupler snapshot history date (like REST_DATE) + + char none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end @@ -433,7 +459,6 @@ env_run.xml Sets driver average history file frequency (like REST_OPTION) - char @@ -445,7 +470,6 @@ env_run.xml Sets driver average history file frequency (like REST_N) - integer diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index 71eca18ec..e909eaf9b 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -18,90 +18,24 @@ - - char - nuopc - MED_attributes - off,low,high,max - - $ESMF_VERBOSITY_LEVEL - - - - - char - nuopc - ATM_attributes - off,low,high,max - - $ESMF_VERBOSITY_LEVEL - - - - - char - nuopc - OCN_attributes - off,low,high,max - - $ESMF_VERBOSITY_LEVEL - - - - - char - nuopc - ICE_attributes - off,low,high,max - - $ESMF_VERBOSITY_LEVEL - - - - - char - nuopc - ROF_attributes - off,low,high,max - - $ESMF_VERBOSITY_LEVEL - - - - - char - nuopc - LND_attributes - off,low,high,max - - $ESMF_VERBOSITY_LEVEL - - - - - char - nuopc - GLC_attributes - off,low,high,max - - $ESMF_VERBOSITY_LEVEL - - - - + char - nuopc - off,low,high,max - WAV_attributes + cime_pes + PELAYOUT_attributes + + Determines what ESMF log files (if any) are generated when + 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. + 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. + - $ESMF_VERBOSITY_LEVEL + $ESMF_LOGFILE_KIND - - - - char expdef @@ -138,58 +72,6 @@ - - - - - - - - - - - - - - - real - control - DRIVER_attributes - - Wall time limit for run - default: -1.0 - - - -1.0 - - - - - char - control - DRIVER_attributes - day,month,year - - Force stop at the next month, day, etc when wall_time_limit is hit - default: month - - - month - - - - - logical - performance - DRIVER_attributes - - default: .false. - - - $COMP_RUN_BARRIERS - - - logical reprosum @@ -202,7 +84,6 @@ .false. - real reprosum @@ -215,7 +96,6 @@ -1.0e-8 - logical reprosum @@ -253,18 +133,6 @@ - - real - expdef - DRIVER_attributes - - Abort if cplstep time exceeds this value - - - 0. - - - char nuopc @@ -289,10 +157,6 @@ - - - - char wv_sat @@ -308,7 +172,6 @@ GoffGratch - real wv_sat @@ -326,7 +189,6 @@ 20.0D0 - logical wv_sat @@ -340,7 +202,6 @@ .false. - real wv_sat @@ -359,6 +220,16 @@ + + logical + nuopc + ALLCOMP_attributes + + .false. + .true. + + + char nuopc @@ -461,7 +332,7 @@ - + @@ -472,6 +343,18 @@ cesm + + char + mapping + ALLCOMP_attributes + + MESH for model mask (used to create masks and fractions at run time if different than model mesh) + + + $MASK_MESH + null + + char nuopc @@ -653,29 +536,6 @@ - - logical - expdef - ATM_attributes - - Perpetual flag - - - .false. - - - - integer - expdef - ATM_attributes - - Perpetual date - - - -999 - - - real single_column @@ -717,18 +577,6 @@ - - logical - expdef - ATM_attributes - - true => turn on aquaplanet mode in cam - - - .false. - - - logical flds @@ -778,7 +626,7 @@ - + @@ -794,7 +642,6 @@ 0.0 - integer control @@ -806,7 +653,6 @@ 5 - logical control @@ -825,6 +671,15 @@ + + char + nuopc + MED_attributes + off,low,high,max + + $ESMF_VERBOSITY_LEVEL + + integer control @@ -957,7 +812,6 @@ $WAV_NY - char control @@ -969,7 +823,6 @@ $COUPLING_MODE - char control @@ -1016,154 +869,50 @@ - - char - mapping - ALLCOMP_attributes + + logical + control + MED_attributes - MESH for model mask (used to create masks and fractions at run time if different than model mesh) + Only used for C,G compsets: if true, compute albedos to work with daily avg SW down - $MASK_MESH - null + $CPL_ALBAV - + char mapping - ATM_attributes + MED_attributes + ogrid,agrid,xgrid - MESH description of atm grid + Grid for atm ocn flux calc (untested) + default: ocn - $ATM_DOMAIN_MESH - null + ogrid - - char - mapping - LND_attributes + + real + control + MED_attributes - MESH description of lnd grid + wind gustiness factor - $LND_DOMAIN_MESH - null + 0.0D0 - - char - mapping - OCN_attributes + + logical + budget + MED_attributes - MESH description of ocn grid - - - $OCN_DOMAIN_MESH - null - - - - - char - mapping - ICE_attributes - - MESH description of ice grid - - - $ICE_DOMAIN_MESH - null - - - - - char - mapping - ROF_attributes - - MESH description of rof grid - - - $ROF_DOMAIN_MESH - null - - - - - char - mapping - GLC_attributes - - MESH description of glc grid - - - $GLC_DOMAIN_MESH - null - - - - - char - mapping - WAV_attributes - - MESH description of wav grid - - - $WAV_DOMAIN_MESH - null - - - - - logical - control - MED_attributes - - Only used for C,G compsets: if true, compute albedos to work with daily avg SW down - - - $CPL_ALBAV - - - - - char - mapping - MED_attributes - ocn,atm,exch - - Grid for atm ocn flux calc (untested) - default: ocn - - - ocn - - - - - real - control - MED_attributes - - wind gustiness factor - - - 0.0D0 - - - - - logical - budget - MED_attributes - - logical that turns on diagnostic budgets, false means budgets will never be written + logical that turns on diagnostic budgets, false means budgets will never be written $BUDGETS @@ -1286,657 +1035,1032 @@ - - - + + + - - logical - history - MED_attributes + + + + + + char + time + ALLCOMP_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end - logical to write an extra initial coupler history file + mediator history snapshot option (used with history_n and history_ymd) + set by HIST_OPTION in env_run.xml. + history_option alarms are: + [none/never], turns option off + [nstep/s] , history snapshot every history_n nsteps , relative to current run start time + [nsecond/s] , history snapshot every history_n nseconds, relative to current run start time + [nminute/s] , history snapshot every history_n nminutes, relative to current run start time + [nhour/s] , history snapshot every history_n nhours , relative to current run start time + [nday/s] , history snapshot every history_n ndays , relative to current run start time + [monthly/s] , history snapshot every month , relative to current run start time + [nmonth/s] , history snapshot every history_n nmonths , relative to current run start time + [nyear/s] , history snapshot every history_n nyears , relative to current run start time + [date] , history snapshot at history_ymd value + [ifdays0] , history snapshot at history_n calendar day value and seconds equal 0 + [end] , history snapshot at end - .false. + $HIST_OPTION - - - - - - - - - - - - - - - - - - - - - - - - - + + integer + time + ALLCOMP_attributes + + sets mediator snapshot history file frequency (like restart_n) + set by HIST_N in env_run.xml. + + + $HIST_N + + - - - - - - - - - - - - + + integer + time + CLOCK_attributes + + date associated with history_option date. yyyymmdd format. + set by HIST_DATE in env_run.xml. + + + $HIST_DATE + + - - - - - - - - - - - - + + + - - - - - - - - - - - - + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator history for mediator aoflux and oceean albedoes (used with history_n and history_ymd) + + + never + + + + integer + time + MED_attributes + + sets mediator aoflux and ocean albedoes snapshot history file frequency for atm import/export fields (like restart_n) + + + -999 + + - - - - - - - - - - - - + + + - - - - - - - - - - - - + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator history for atm import/export/fields snapshot option (used with history_n and history_ymd) + + + never + + + + integer + time + MED_attributes + + sets mediator snapshot history file frequency for atm import/export fields (like restart_n) + + + -999 + + + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator time average history option (used with histavg_n and histavg_ymd) + + + never + + + + integer + time + MED_attributes + + Sets mediator time-average history file frequency (like restart_option) + + + -999 + + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + logical + aux_hist + MED_attributes + Auxiliary mediator atm2med instantaneous history output every hour. + + .false. + + + + char + aux_hist + MED_attributes + Auxiliary mediator atm2med instantaneous history output every hour. + + Faxa_swndr:Faxa_swvdr:Faxa_swndf:Faxa_swvdf + + + + char + aux_hist + MED_attributes + history option type + + nhours + + + + char + aux_hist + MED_attributes + history option type + + 1 + + + + logical + aux_hist + MED_attributes + If true, use time average for aux file output. + + .false. + + + + char + aux_hist + MED_attributes + Auxiliary name identifier in history name + + atm.1h.inst + + + + integer + aux_hist + MED_attributes + Number of time sames per file. + + 24 + + - - - - - - - - - - - - + + + logical + aux_hist + MED_attributes + Auxiliary atm2med history output averaged over 1 hour. + + .false. + + + + char + aux_hist + MED_attributes + Auxiliary atm2med history output averaged over 1 hour. + + Sa_u:Sa_v + + + + char + aux_hist + MED_attributes + history option type + + nhours + + + + char + aux_hist + MED_attributes + history option type + + 1 + + + + logical + aux_hist + MED_attributes + If true, use time average for aux file output. + + .true. + + + + char + aux_hist + MED_attributes + Number of time sames per file. + + 24 + + + + char + aux_hist + MED_attributes + Auxiliary name identifier in history name + + atm.1h.avrg + + - - - - - - - - - - - - + + + logical + aux_hist + MED_attributes + + Auxiliary mediator atm2med precipitation history output every 3 hours + + + .false. + + + + char + aux_hist + MED_attributes + Auxiliary mediator atm2med precipitation history output every 3 hours + + Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl + + + + char + aux_hist + MED_attributes + history option type + + nhours + + + + char + aux_hist + MED_attributes + history option type + + 3 + + + + logical + aux_hist + MED_attributes + If true, use time average for aux file output. + + .true. + + + + char + aux_hist + MED_attributes + Number of time sames per file. + + 8 + + + + char + aux_hist + MED_attributes + Auxiliary name identifier in history name. + + atm.3hprec.avrg + + - - - - - - - - - - - - + + + logical + aux_hist + MED_attributes + + Auxiliary mediator a2x precipitation history output every 3 hours + + + .false. + + + + char + aux_hist + MED_attributes + + Auxiliary mediator a2x precipitation history output every 3 hours + + + Sa_z:Sa_topo:Sa_u:Sa_v:Sa_tbot:Sa_ptem:Sa_shum:Sa_dens:Sa_pbot:Sa_pslv:Faxa_lwdn:Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl:Faxa_swndr:Faxa_swvdr:Faxa_swndf:Faxa_swvdf:Sa_co2diag:Sa_co2prog + + + + char + aux_hist + MED_attributes + history option type + + nhours + + + + char + aux_hist + MED_attributes + history option type + + 3 + + + + logical + aux_hist + MED_attributes + If true, use time average for aux file output. + + .true. + + + + char + aux_hist + MED_attributes + Number of time sames per file. + + 8 + + + + char + aux_hist + MED_attributes + Auxiliary name identifier in history name. + + atm.3h.avrg + + - - - - - - - - - - - - + + + logical + aux_hist + MED_attributes + Auxiliary mediator a2x precipitation history output every 3 hours + + .false. + + + + char + aux_hist + MED_attributes + Auxiliary mediator a2x precipitation history output every 3 hours + + Faxa_bcph:Faxa_ocph:Faxa_dstwet:Faxa_dstdry:Sa_co2prog:Sa_co2diag + + + + char + aux_hist + MED_attributes + history option type + + ndays + + + + char + aux_hist + MED_attributes + history option type + + 1 + + + + logical + aux_hist + MED_attributes + If true, use time average for aux file output. + + .true. + + + + char + aux_hist + MED_attributes + Number of time sames per file. + + 1 + + + + char + aux_hist + MED_attributes + Auxiliary name identifier in history name + + atm.24h.avrg + + - - - - - - - - - - - - + + + - - - - - - - - - - - - + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator history for ice import/export/fields snapshot option (used with history_n and history_ymd) + + + never + + + + integer + time + MED_attributes + + sets mediator snapshot history file frequency for ice import/export fields (like restart_n) + + + -999 + + + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator time average history option (used with histavg_n and histavg_ymd) + + + never + + + + integer + time + MED_attributes + + Sets mediator time-average history file frequency (like restart_option) + + + -999 + + - - - - - - - - - - - + + + - - - - - - - - - - - + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator history for glc import/export/fields snapshot option (used with history_n and history_ymd) + + + never + + + + integer + time + MED_attributes + + sets mediator snapshot history file frequency for glc import/export fields (like restart_n) + + + -999 + + + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator time average history option (used with histavg_n and histavg_ymd) + + + never + + + + integer + time + MED_attributes + + Sets mediator time-average history file frequency (like restart_option) + + + -999 + + - - - - - - - - - - - + + + - - - - - - - - - - - + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator history for lnd import/export/fields snapshot option (used with history_n and history_ymd) + + + never + + + + integer + time + MED_attributes + + sets mediator snapshot history file frequency for lnd import/export fields (like restart_n) + + + -999 + + + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator time average history option (used with histavg_n and histavg_ymd) + + + never + + + + integer + time + MED_attributes + + Sets mediator time-average history file frequency (like restart_option) + + + -999 + + - - - - - - - - - - - + + + logical + aux_hist + MED_attributes + Auxiliary mediator l2x fields every lnd coupling interval + + .false. + + + + char + aux_hist + MED_attributes + Auxiliary mediator lnd2med output every lnd coupling interval + + all + + + + char + aux_hist + MED_attributes + history option type + + nsteps + + + + char + aux_hist + MED_attributes + history option type + + 1 + + + + logical + aux_hist + MED_attributes + If true, use time average for aux file output. + + .false. + + + + char + aux_hist + MED_attributes + Number of time sames per file. + + 1 + + + + char + aux_hist + MED_attributes + Auxiliary name identifier in history name + + lnd.ncpl.inst + + - - - - - - - - - - - + + + + + logical + aux_hist + ALLCOMP_attributes + Auxiliary mediator lnd2med fields every year + + .false. + + - - - + + + - + char - expdef - ALLCOMP_attributes + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end - name of the coupling field with scalar information + mediator history for ocn import/export/fields snapshot option (used with history_n and history_ymd) - cpl_scalars + never - - + integer - expdef - ALLCOMP_attributes + time + MED_attributes - total number of scalars in the scalar coupling field + sets mediator snapshot history file frequency for ocn import/export fields (like restart_n) - 4 + -999 - - - integer - expdef - ALLCOMP_attributes + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end - index of scalar containing global grid cell count in X dimension + mediator time average history option (used with histavg_n and histavg_ymd) - 1 + never - - + integer - expdef - ALLCOMP_attributes + time + MED_attributes - index of scalar containing global grid cell count in Y dimension + Sets mediator time-average history file frequency (like restart_option) - 2 + -999 - - integer - expdef - ALLCOMP_attributes + + + + + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end - index of scalar containing calendar day of nextsw computation from atm + mediator history for rof import/export/fields snapshot option (used with history_n and history_ymd) - 3 + never - - + integer - expdef - ALLCOMP_attributes + time + MED_attributes - index of scalar containing epbal precipitation factor from ocn (only for POP) + sets mediator snapshot history file frequency for rof import/export fields (like restart_n) - 4 - 0 + -999 - - + + char + time + MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end + + mediator time average history option (used with histavg_n and histavg_ymd) + + + never + + + integer - expdef - ALLCOMP_attributes + time + MED_attributes - number of glc ice sheets + Sets mediator time-average history file frequency (like restart_option) - 1 + -999 - + + logical - mapping + aux_hist MED_attributes - used for atm->ocn and atm-ice mapping of u and v; rotate u,v - to 3d cartesian space, map from src->dest, then rotate back + Auxiliary mediator rof2med precipitation history output every 3 hours - .true. + .false. - - + char - mapping - abs + aux_hist MED_attributes - atm to ocn flux mapping file for fluxes + Auxiliary mediator rof2med precipitation history output. - $ATM2OCN_FMAPNAME + all - - + char - mapping - abs + aux_hist MED_attributes - - atm to ocn state mapping file for states - + history option type - $ATM2OCN_SMAPNAME + ndays - - + char - mapping - abs + aux_hist MED_attributes - - atm to ocn state mapping file for velocity - + history option type - $ATM2OCN_VMAPNAME + 1 - - + char - mapping - abs + aux_hist MED_attributes - - ocn to atm mapping file for fluxes - + If true, use time average for aux file output. - $OCN2ATM_FMAPNAME + .true. - - + char - mapping - abs + aux_hist MED_attributes - - ocn to atm mapping file for states - + Number of time sames per file. + + 1 + + + + char + aux_hist + MED_attributes + Auxiliary name identifier in history name - $OCN2ATM_SMAPNAME + rof.24h.avrg - + + + + + char - mapping - abs + time MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end - atm to ice flux mapping file for fluxes + mediator history for wav import/export/fields snapshot option (used with history_n and history_ymd) - $ATM2OCN_FMAPNAME + never - - - char - mapping - abs + + integer + time MED_attributes - atm to ice state mapping file for states + sets mediator snapshot history file frequency for wav import/export fields (like restart_n) - $ATM2OCN_SMAPNAME + -999 - - + char - mapping - abs + time MED_attributes + none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end - atm to ice state mapping file for velocity + mediator time average history option (used with histavg_n and histavg_ymd) - $ATM2OCN_VMAPNAME + never - - - char - mapping - abs + + integer + time MED_attributes - ice to atm mapping file for fluxes + Sets mediator time-average history file frequency (like restart_option) - $OCN2ATM_FMAPNAME + -999 - - char + + + + + + logical mapping - abs MED_attributes - - ice to atm mapping file for states - + used for atm->ocn and atm-ice mapping of u and v; rotate u,v + to 3d cartesian space, map from src->dest, then rotate back - $OCN2ATM_SMAPNAME + .true. + .false. - + char mapping - abs MED_attributes - - atm to land mapping file for fluxes - + atm to ocn mapping, 'unset' or 'idmap' are normal possible values - $ATM2LND_FMAPNAME + unset + idmap - - + char mapping - abs MED_attributes - - atm to land mapping file for states - + atm to ocn mapping, 'unset' or 'idmap' are normal possible values - $ATM2LND_SMAPNAME + unset + idmap - - + char mapping - abs MED_attributes - - atm to land mapping file for states - + atm to lnd mapping, 'unset' or 'idmap' are normal possible values - $ATM2LND_SMAPNAME + unset + idmap - - + char mapping - abs MED_attributes - - land to atm mapping file for fluxes - + ocn to atm mapping, 'unset' or 'idmap' are normal possible values - $LND2ATM_FMAPNAME + unset + idmap - - + char mapping - abs MED_attributes - - land to atm mapping file for states - + ice to atm mapping, 'unset' or 'idmap' are normal possible values - $LND2ATM_SMAPNAME + unset + idmap - - + char mapping - abs MED_attributes - - lnd to runoff conservative mapping file - + lnd to atm mapping, 'unset' or 'idmap' are normal possible values - $LND2ROF_FMAPNAME + unset + idmap - - + char mapping abs MED_attributes - - runoff to lnd conservative mapping file - + lnd to rof mapping, 'unset' or 'idmap' are normal possible values - $ROF2LND_FMAPNAME + unset + idmap - - + char mapping abs MED_attributes - - runoff to lnd conservative mapping file - + rof to lnd mapping, 'unset' or 'idmap' are normal possible values - $ROF2LND_FMAPNAME + unset + idmap - - + char mapping - abs MED_attributes - - runoff to ocn area overlap conservative mapping file - + atm to wav mapping, 'unset' or 'idmap' are normal possible values - $ROF2OCN_FMAPNAME + unset + idmap @@ -1952,7 +2076,6 @@ $GLC2OCN_LIQ_RMAPNAME - char mapping @@ -1965,7 +2088,6 @@ $GLC2ICE_RMAPNAME - char mapping @@ -1978,21 +2100,19 @@ $GLC2OCN_ICE_RMAPNAME - - + char mapping abs MED_attributes - runoff to ocn nearest neighbor plus smoothing conservative mapping file + runoff to ocn area overlap conservative mapping file - $ROF2OCN_LIQ_RMAPNAME + $ROF2OCN_FMAPNAME - - + char mapping abs @@ -2001,36 +2121,21 @@ runoff to ocn nearest neighbor plus smoothing conservative mapping file - $ROF2OCN_ICE_RMAPNAME - - - - - char - mapping - abs - MED_attributes - - atm to wav state mapping file for states - - - $ATM2WAV_SMAPNAME + $ROF2OCN_LIQ_RMAPNAME - - + char mapping abs MED_attributes - atm to wav state mapping file for states + runoff to ocn nearest neighbor plus smoothing conservative mapping file - $ATM2WAV_SMAPNAME + $ROF2OCN_ICE_RMAPNAME - char mapping @@ -2043,7 +2148,6 @@ $OCN2WAV_SMAPNAME - char mapping @@ -2056,7 +2160,6 @@ $ICE2WAV_SMAPNAME - char mapping @@ -2070,6 +2173,95 @@ + + + + + + char + expdef + ALLCOMP_attributes + + name of the coupling field with scalar information + + + cpl_scalars + + + + + integer + expdef + ALLCOMP_attributes + + total number of scalars in the scalar coupling field + + + 4 + + + + + integer + expdef + ALLCOMP_attributes + + index of scalar containing global grid cell count in X dimension + + + 1 + + + + + integer + expdef + ALLCOMP_attributes + + index of scalar containing global grid cell count in Y dimension + + + 2 + + + + + integer + expdef + ALLCOMP_attributes + + index of scalar containing calendar day of nextsw computation from atm + + + 3 + + + + + integer + expdef + ALLCOMP_attributes + + index of scalar containing epbal precipitation factor from ocn (only for POP) + + + 4 + 0 + + + + + integer + expdef + ALLCOMP_attributes + + number of glc ice sheets + + + 1 + + + logical flds @@ -2505,152 +2697,6 @@ - - char - time - CLOCK_attributes - none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,monthly,nmonths,nmonth,nyears,nyear,date,ifdays0,end - - coupler history snapshot option (used with history_n and history_ymd) - set by HIST_OPTION in env_run.xml. - history_option alarms are: - [none/never], turns option off - [nstep/s] , history snapshot every history_n nsteps , relative to current run start time - [nsecond/s] , history snapshot every history_n nseconds, relative to current run start time - [nminute/s] , history snapshot every history_n nminutes, relative to current run start time - [nhour/s] , history snapshot every history_n nhours , relative to current run start time - [nday/s] , history snapshot every history_n ndays , relative to current run start time - [monthly/s] , history snapshot every month , relative to current run start time - [nmonth/s] , history snapshot every history_n nmonths , relative to current run start time - [nyear/s] , history snapshot every history_n nyears , relative to current run start time - [date] , history snapshot at history_ymd value - [ifdays0] , history snapshot at history_n calendar day value and seconds equal 0 - [end] , history snapshot at end - - - $HIST_OPTION - - - - - integer - time - CLOCK_attributes - - sets coupler snapshot history file frequency (like restart_n) - set by HIST_N in env_run.xml. - - - $HIST_N - - - - - integer - time - CLOCK_attributes - - date associated with history_option date. yyyymmdd format. - set by HIST_DATE in env_run.xml. - - - $HIST_DATE - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - char - time - CLOCK_attributes - none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,monthly,nmonth,nyears,nyear,date,ifdays0,end - - sets the driver barrier frequency to sync models across all tasks with barrier_n and barrier_ymd - barrier_option alarms are like restart_option - default: never - - - $BARRIER_OPTION - - - - - integer - time - CLOCK_attributes - - Sets model barriers with barrier_option and barrier_ymd (same options as stop_n) - default: 1 - - - $BARRIER_N - - - - - integer - time - CLOCK_attributes - - Date in yyyymmdd format, sets model barriers date with barrier_option and barrier_n - - - $BARRIER_DATE - - - char time @@ -2833,7 +2879,7 @@ - + @@ -2847,7 +2893,6 @@ $NINST - integer cime_pes @@ -2860,7 +2905,6 @@ $NTASKS_ATM - integer cime_pes @@ -2873,7 +2917,6 @@ $NTHRDS_ATM - integer cime_pes @@ -2886,7 +2929,6 @@ $ROOTPE_ATM - integer cime_pes @@ -2899,7 +2941,6 @@ $PSTRID_ATM - integer cime_pes @@ -2912,7 +2953,6 @@ $NTASKS_LND - integer cime_pes @@ -2925,7 +2965,6 @@ $NTHRDS_LND - integer cime_pes @@ -2938,7 +2977,6 @@ $ROOTPE_LND - integer cime_pes @@ -2951,7 +2989,6 @@ $PSTRID_LND - integer cime_pes @@ -2964,7 +3001,6 @@ $NTASKS_ICE - integer cime_pes @@ -2977,7 +3013,6 @@ $NTHRDS_ICE - integer cime_pes @@ -2990,7 +3025,6 @@ $ROOTPE_ICE - integer cime_pes @@ -3003,7 +3037,6 @@ $PSTRID_ICE - integer cime_pes @@ -3016,7 +3049,6 @@ $NTASKS_OCN - integer cime_pes @@ -3029,7 +3061,6 @@ $NTHRDS_OCN - integer cime_pes @@ -3042,7 +3073,6 @@ $ROOTPE_OCN - integer cime_pes @@ -3055,7 +3085,6 @@ $PSTRID_OCN - integer cime_pes @@ -3068,7 +3097,6 @@ $NTASKS_GLC - integer cime_pes @@ -3081,7 +3109,6 @@ $NTHRDS_GLC - integer cime_pes @@ -3094,7 +3121,6 @@ $ROOTPE_GLC - integer cime_pes @@ -3107,7 +3133,6 @@ $PSTRID_GLC - integer cime_pes @@ -3120,7 +3145,6 @@ $NTASKS_WAV - integer cime_pes @@ -3133,7 +3157,6 @@ $NTHRDS_WAV - integer cime_pes @@ -3146,7 +3169,6 @@ $ROOTPE_WAV - integer cime_pes @@ -3159,7 +3181,6 @@ $PSTRID_WAV - integer cime_pes @@ -3172,7 +3193,6 @@ $NTASKS_ROF - integer cime_pes @@ -3185,7 +3205,6 @@ $NTHRDS_ROF - integer cime_pes @@ -3198,7 +3217,6 @@ $ROOTPE_ROF - integer cime_pes @@ -3211,7 +3229,6 @@ $PSTRID_ROF - integer cime_pes @@ -3224,7 +3241,6 @@ $NTASKS_ESP - integer cime_pes @@ -3237,7 +3253,6 @@ $NTHRDS_ESP - integer cime_pes @@ -3250,7 +3265,6 @@ $ROOTPE_ESP - integer cime_pes @@ -3263,7 +3277,6 @@ $PSTRID_ESP - integer cime_pes @@ -3276,7 +3289,6 @@ $NTASKS_CPL - integer cime_pes @@ -3289,7 +3301,6 @@ $NTHRDS_CPL - integer cime_pes @@ -3302,7 +3313,6 @@ $ROOTPE_CPL - integer cime_pes @@ -3316,28 +3326,10 @@ - - char - cime_pes - PELAYOUT_attributes - - Determines what ESMF log files (if any) are generated when - 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. - 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. - - - $ESMF_LOGFILE_KIND - - - - - - - + + + + logical @@ -3365,7 +3357,6 @@ .true. - logical performance @@ -3376,7 +3367,6 @@ .false. - logical performance @@ -3388,7 +3378,6 @@ .true. - logical performance @@ -3399,7 +3388,6 @@ .false. - integer performance @@ -3410,7 +3398,6 @@ $TIMER_LEVEL - integer performance @@ -3421,7 +3408,6 @@ 0 - integer performance @@ -3432,7 +3418,6 @@ $TIMER_DETAIL - integer performance @@ -3446,7 +3431,6 @@ 3 - logical performance @@ -3458,7 +3442,6 @@ .false. - logical performance @@ -3470,7 +3453,6 @@ .false. - integer performance @@ -3482,7 +3464,6 @@ 1 - logical performance @@ -3495,10 +3476,10 @@ - - - - + + + + char @@ -3511,7 +3492,6 @@ PAPI_FP_OPS - char performance @@ -3523,7 +3503,6 @@ PAPI_NO_CTR - char performance @@ -3535,7 +3514,6 @@ PAPI_NO_CTR - char performance @@ -3548,9 +3526,9 @@ - - - + + + logical @@ -3816,4 +3794,219 @@ + + + + + + char + nuopc + ATM_attributes + off,low,high,max + + $ESMF_VERBOSITY_LEVEL + + + + char + mapping + ATM_attributes + + MESH description of atm grid + + + $ATM_DOMAIN_MESH + null + + + + logical + expdef + ATM_attributes + + Perpetual flag + + + .false. + + + + integer + expdef + ATM_attributes + + Perpetual date + + + -999 + + + + logical + expdef + ATM_attributes + + true => turn on aquaplanet mode in cam + + + .false. + + + + + + + + + char + nuopc + ICE_attributes + off,low,high,max + + $ESMF_VERBOSITY_LEVEL + + + + char + mapping + ICE_attributes + + MESH description of ice grid + + + $ICE_DOMAIN_MESH + null + + + + + + + + + char + nuopc + GLC_attributes + off,low,high,max + + $ESMF_VERBOSITY_LEVEL + + + + char + mapping + GLC_attributes + + MESH description of glc grid + + + $GLC_DOMAIN_MESH + null + + + + + + + + + char + nuopc + LND_attributes + off,low,high,max + + $ESMF_VERBOSITY_LEVEL + + + + char + mapping + LND_attributes + + MESH description of lnd grid + + + $LND_DOMAIN_MESH + null + + + + + + + + + char + nuopc + OCN_attributes + off,low,high,max + + $ESMF_VERBOSITY_LEVEL + + + + char + mapping + OCN_attributes + + MESH description of ocn grid + + + $OCN_DOMAIN_MESH + null + + + + + + + + + char + nuopc + ROF_attributes + off,low,high,max + + $ESMF_VERBOSITY_LEVEL + + + + char + mapping + ROF_attributes + + MESH description of rof grid + + + $ROF_DOMAIN_MESH + null + + + + + + + + + char + nuopc + off,low,high,max + WAV_attributes + + $ESMF_VERBOSITY_LEVEL + + + + char + mapping + WAV_attributes + + MESH description of wav grid + + + $WAV_DOMAIN_MESH + null + + + diff --git a/cime_config/namelist_definition_drv_flds.xml b/cime_config/namelist_definition_drv_flds.xml index cef475978..beceb238c 100644 --- a/cime_config/namelist_definition_drv_flds.xml +++ b/cime_config/namelist_definition_drv_flds.xml @@ -145,4 +145,20 @@ + + + + + + char + ozone_coupling + ozone_coupling_nl + + Frequency of surface ozone field passed from CAM to surface components. + Surface ozone is passed every coupling interval, but this namelist flag + indicates whether the timestep-level values are interpolated from a + coarser temporal resolution. + + + diff --git a/cime_config/runseq/driver_config.py b/cime_config/runseq/driver_config.py index c2b5556ba..e5fe2715d 100644 --- a/cime_config/runseq/driver_config.py +++ b/cime_config/runseq/driver_config.py @@ -46,10 +46,8 @@ def __compute_glc(self, case, coupling_times): ############################################### # In the mediator the glc_avg_period will be set as an alarm - # on the mediator clock - when this alarm rings - the - # averaging will be done AND an attribute will be set on set - # on the glc export state from the mediator saying that the - # data coming to glc is valid + # on the on the prep_glc_clock. When this alarm rings - the + # averaging will be done. comp_glc = case.get_value("COMP_GLC") @@ -71,7 +69,9 @@ def __compute_glc(self, case, coupling_times): if not case.get_value("CISM_EVOLVE"): stop_option = case.get_value('STOP_OPTION') stop_n = case.get_value('STOP_N') - if stop_option == 'nsteps': + if stop_option == 'nyears': + glc_coupling_time = coupling_times["glc_cpl_dt"] + elif stop_option == 'nsteps': glc_coupling_time = stop_n * coupling_times["glc_cpl_dt"] elif stop_option == 'ndays': glc_coupling_time = stop_n * 86400 diff --git a/cime_config/runseq/gen_runseq.py b/cime_config/runseq/gen_runseq.py index 3caa4feb9..12edace1f 100644 --- a/cime_config/runseq/gen_runseq.py +++ b/cime_config/runseq/gen_runseq.py @@ -7,7 +7,7 @@ def __init__(self, outfile): self.__outfile = None def __enter__(self): - self.__outfile = open(self.__outfile_name, "w") + self.__outfile = open(self.__outfile_name, "w", encoding="utf-8") self.__outfile.write("runSeq:: \n") return self @@ -30,9 +30,12 @@ def active_depth(self): else: return -1 - def enter_time_loop(self, coupling_time, active=True, newtime=True): + def enter_time_loop(self, coupling_time, active=True, newtime=True, addextra_atsign=False): if newtime: - self.__outfile.write ("@" + str(coupling_time) + " \n" ) + if addextra_atsign: + self.__outfile.write ("@@" + str(coupling_time) + " \n" ) + else: + self.__outfile.write ("@" + str(coupling_time) + " \n" ) if active: self.__time_loop.append((self.time_loop+1, self.active_depth+1)) else: @@ -42,14 +45,17 @@ def add_action(self, action, if_add): if if_add: self.__outfile.write (" {}\n".format(action)) - def leave_time_loop(self, leave_time, if_write_hist_rest=False ): + def leave_time_loop(self, leave_time, if_write_hist_rest=False, addextra_atsign=False ): if leave_time and self.__time_loop: _, active_depth = self.__time_loop.pop() if if_write_hist_rest or active_depth == 0: self.__outfile.write (" MED med_phases_history_write \n" ) self.__outfile.write (" MED med_phases_restart_write \n" ) self.__outfile.write (" MED med_phases_profile \n" ) - self.__outfile.write ("@ \n" ) + if addextra_atsign: + self.__outfile.write ("@@ \n" ) + else: + self.__outfile.write ("@ \n" ) def __exit_sequence(self): while self.__time_loop: diff --git a/cime_config/runseq/runseq_general.py b/cime_config/runseq/runseq_general.py index f565f8fdf..7bfa3aaa6 100644 --- a/cime_config/runseq/runseq_general.py +++ b/cime_config/runseq/runseq_general.py @@ -81,20 +81,29 @@ def gen_runseq(case, coupling_times): runseq.enter_time_loop(ocn_cpl_time, newtime=ocn_outer_loop) #------------------ - runseq.add_action("MED med_phases_prep_ocn_avg" , med_to_ocn and ocn_outer_loop) - runseq.add_action("MED -> OCN :remapMethod=redist" , med_to_ocn and ocn_outer_loop) + if (cpl_seq_option == 'OPTION2'): + runseq.add_action("MED med_phases_prep_ocn_avg" , med_to_ocn and ocn_outer_loop) + runseq.add_action("MED -> OCN :remapMethod=redist" , med_to_ocn and ocn_outer_loop) #------------------ runseq.enter_time_loop(atm_cpl_time, newtime=inner_loop) #------------------ - if (cpl_seq_option == 'RASM'): + if (cpl_seq_option == 'OPTION1' or cpl_seq_option == 'OPTION2'): if cpl_add_aoflux: 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_accum" , med_to_ocn) 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_diag_ocn" , run_ocn and diag_mode) + if (cpl_seq_option == 'OPTION1'): + if ocn_cpl_time != atm_cpl_time: + runseq.enter_time_loop(ocn_cpl_time, newtime=inner_loop, addextra_atsign=True) + runseq.add_action("MED med_phases_prep_ocn_avg" , med_to_ocn and ocn_outer_loop) + runseq.add_action("MED -> OCN :remapMethod=redist" , med_to_ocn and ocn_outer_loop) + if ocn_cpl_time != atm_cpl_time: + runseq.leave_time_loop(inner_loop, addextra_atsign=True) + runseq.add_action("MED med_phases_prep_lnd" , med_to_lnd) runseq.add_action("MED -> LND :remapMethod=redist" , med_to_lnd) diff --git a/cime_config/testdefs/testlist_drv.xml b/cime_config/testdefs/testlist_drv.xml index d255baa18..7368a1fd2 100644 --- a/cime_config/testdefs/testlist_drv.xml +++ b/cime_config/testdefs/testlist_drv.xml @@ -5,51 +5,19 @@ - - - - - - - - - - - - - - - - - - - - - - - + + - + - - - - - - - - - - - - - + + @@ -57,19 +25,8 @@ - - - - - - - - - - - - - + + @@ -77,19 +34,8 @@ - - - - - - - - - - - - - + + @@ -102,19 +48,8 @@ - - - - - - - - - - - - - + + @@ -122,55 +57,31 @@ - - - + + - - - - - - - - - - - - - - - - - - - - - + - - - + + - - + - - - + + @@ -183,9 +94,8 @@ - - - + + @@ -193,9 +103,8 @@ - - - + + @@ -203,34 +112,13 @@ - - - + + - - - - - - - - - - - - - - - - - - - - @@ -238,9 +126,8 @@ - - - + + @@ -248,19 +135,8 @@ - - - - - - - - - - - - - + + @@ -268,45 +144,22 @@ - - - + + - - - - - - - - - - - - - - - - - - - - - - - - + + @@ -314,52 +167,32 @@ - + - + - - - + - + - - - - - - - - - - - - - - - - - - + + - + - - - + - + @@ -369,9 +202,8 @@ - - - + + @@ -379,9 +211,8 @@ - - - + + @@ -389,9 +220,8 @@ - - - + + @@ -399,8 +229,8 @@ - - + + @@ -413,7 +243,7 @@ - + @@ -422,7 +252,7 @@ - + diff --git a/cime_config/testdefs/testmods_dirs/drv/y100k/README b/cime_config/testdefs/testmods_dirs/drv/y100k/README new file mode 100644 index 000000000..4b028c206 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/drv/y100k/README @@ -0,0 +1,5 @@ +This tests the ability to use 6-digit years. + +As of the time this test was created, the max year is about 214747 - +otherwise we exceed the limit of 4-byte integers when storing dates as +integers (yyyyyymmdd). diff --git a/cime_config/testdefs/testmods_dirs/drv/y100k/shell_commands b/cime_config/testdefs/testmods_dirs/drv/y100k/shell_commands new file mode 100644 index 000000000..1f1324a74 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/drv/y100k/shell_commands @@ -0,0 +1 @@ +./xmlchange RUN_STARTDATE=99999-12-28 diff --git a/doc/source/CMEPS-grid1.png b/doc/source/CMEPS-grid1.png new file mode 100644 index 0000000000000000000000000000000000000000..fab0ab0a83787bb825dbc21ce14cc7b35421771f GIT binary patch literal 11651 zcmeIYXH-*Bv@Qxr?}&haNE4z|X+a20I#MDcAia0#y^C~EAkw5plqOZWp(7mxq<2ty zZ=ol^+rYW!-SgwV@qWGW#<@3RBxA3gwbtBg?r)ZFt`+%GO@V}vjt~O_gG5PD_7w&O zW)pCY!p8-E&x=#*F)*-cZDeF#+Q}%$IKFjs(Qq;`vrw>buyC<4d!-Rhc@AN6az6%2LDmn2~$iPsX$s;mv1odr82DS@Y0*36H0`agH~KNG0C$b!nf z^yAw|yVurK^N#895!tjvC2t}j+tditV~NVs;FoLBxtl2vffSqCvN?+#KV-&krtc2I zY8Ph>QSc@Sb`O&}wS=37f5A08HbR^;E+qU54Q`gUIs>P{cNHu!l*qG6Z(in?uhHb_ z>?ORoMxKF+$(hl#VkMs_A{KKmPqWtp)8`z|vK$)0Ec!W`zdhBU>K{Hrr??Rtn`i3n{WN}X zzff>tP+%iT1p&_E&rib}2vy(Qp)h|eg*#6@Vf{Ur6qo;A@jcooqby4r`qgH!1JTNq zzLv&c371`6M!{!4`ztxj!zJERm(!tRil~Pz_6tMx%_t=UxP-AJ*=d>XP6iJc@+%#~ zocS?XyraZakK-SdQ=0FdPrP_5XDB8-c2WO9;8kv#+^k4t-52940S*;?jqxHb(&{kQ z-X|y=g9dbmQJMZam#}*E0&PaEcK?~t*(RF*m=kTA{Wow)d%wn|Q}=gWxk~HS+c&PB znsoNKi`09ADeaN%3`pnwC2cbKfTZq})zU))F&#%9Qu(4}oO9bVEn2mYvPFl%hvAi6 z4Iux=7aa|K{yqME{{8+f23RmiZ^mNdKOQGWSEG(&TO^(Cyf3x){Ti$FB)g&)%&c#z z9#Xsf0{>Gt;XeQoZPXU>vgAu zCk$GSs?QpqQ+{|PWBwrl{QBglHZqGP5xV@!hFk-pLHWIG1Vf4F0 z`Kyf~vpIh(oncXjO_Dw;PvxO_Q@TT15W+ur8GtYmM+JdtG{*-MPcq!!-Un zGD)2gbED+`7K&#frV=CR!MmVNR)_loJ$Q3C&yXQg<oaYxMXTKJs)QjKP4l~MV-iwVg&0;J12MnA{WS0B6YT=Ng1|{p#}xyEi1PZ2 ziIJLqA8;i)Hm~2fy-`&WHFLD*F)?>EwczoxcLI82V2F8%0+;p{ZYE4#_HP|rMZLsX zZhD9U*VngsS(t9RxY>!byitA0B;)8}!6d{Z$n%s%f{=-cNzBFEQuLLq{C^AwTH-9$ zZf;JZyu6;Co;;ocJdQ3_ynG@eBD_!edHMOdfgaqh-VSaiUfd3@thbZ=k9lM*T+Li; zoZM_29hk1?H8FK`cN1q}xfb-FpWEkjv$6cYB{{hM$FhJ0@?QVL%g6JS_dn+bhKgO^ z6@|LkSOAi*=a=9UyXpB~?)`@xG2Uz8|I@?VuJqEBuv~@ z{?RVmPOV4&5v}?19y!-zir1;lLrFN*{a5MH$a1baN28P) zWRef!j?k$}dgI(lB)RpV{c6CztbTCG_^=i(bO&whPn=4P|rndjpU@r@cDi3hJxjKeqd_XB7uMoTXj3^l$%; zRa6RbLnY3Z&=%A`ERaGkE^+n!ep8WS>VYc%wBj-Py991N^*NfS z*;hM54XdfwERqe_g@lCc(#Z?8ia!;W)V?^Lc9dM7sw#YoSWY@X&0iVX+SwV@TV;C7 zAJ4c#y;n0lmqs+8?tKsZ&ktdMUi^yX{I+*?MzxI+887$3d5Vi|Y;3NMN(0%DZ#gBS zt-X!BmlI8+XHub%ouA*PYjVF-|Js_Ym}NjV2i?hWoNsiQaqjF!4oL2zp9XRPsJU`N zK_xFL-!@$wmk-L*Blv5UN+;{~ei2y|7FWA?BJ$E*q9*vYu<^~6n`<#i#rC8;C63kx zTZIS=eYdL?;PZL#fZBSXe?NM^laY5d)3;>0+HU7-G>^+HzVB{B&6}xUQc=Z@545bn zdq^BsgY;EZ7S-+4ny!Aoz^$Zu%iY%!jMpo=S+rPE10;(I{UWOmL=L)G9QCI)?%FoajD3l(Hifg|?L zj!?PgVWO64(`fFQ%bmL2oprgDAz?7s$Hy75IPFkZ>^Yl2-+7H<`%h%8)hU_HUZMtfNlz{3X*)*S~1NU0+W&=de)~9mj8c{oGzmXx7 zYJ1hw4v?Bs$@`g;*4&?Y=TUPf`ubD`P@1lzLl!qw#{wYTLuvQtBB^JQOgL$Y3L6_+ zCRo6`??NcX2ea-cpu=R(g-DPOM~9LxM^Z83lURu)-P}jvxz96J-@FJOxR0o39^c91 z`uoGAb>?ii&J$Q$=d=~vUkq}!g&wKmHqeDwRUWl5RJa;CV$V9)fjK!iW<&~$Ip)Un z95X6&groZVPnxd$p^oP>`&lyKxrcI&m-=FL@>{z5r3}dS5_`$~r#>FV6VCq1k<()} zJzf{*M@aCTmziX$)p+oQ{2Mgo>`VY^U15AN_u1Cy z3&c|Rz2x~|tbYB`nBD;DpqF>n8725!$oVbzTKw1XVm;xL`KFS-OoH5u>Av=X7@bBB znKjhNYjhH?(N2%0aCf749c)Xt~Ush7JZVy+Ca9m4>r^`9=Y zlp*;wR8TBR*F64T= zH7Vd-v@S1tCVn)c!4oMYq&pmm!x?Ot;4pnMyDf-90s%r{>%x27z|-J>-mXI&wN(+1 zQWY)=9O%jR{8tiLx$aqg0eGG|86SlWiS5`Uv&$urq|#0WW{?}fg!fz3%`p<=U^(=U zNy{_@QmcJXGT{ITXuxxRT5;ofFfPI#l8i@u|8MoSM*Guch$KiY{c+NKidAMxJ)jW- z$hq63>19%BgSxz&d+~0bTE+(M>KoU>D@Ya=*SJyOg|4$moFrCZ;5O2#=`Z(YMhc3r zrm-lu<-A1&`$Btb0#&gUGH%(PJE$KxM~COu+4KXwI96)hvP)lii9;#ue}3?-=qN=k zU^oxzx!(V5k$4bPl1<_pn}u_QTB1<}ZwW!c=S7Iq>f;?5%8u91;RoqYr^u9sn~8+e zhKwNwSRUIp0=bk@b<7n30(Dwd%PlF^J{6Oxs{Stei|A^4VWPfL_h@YcgW1%SCCE66E_ff$N15WDHt0e0R>mD~%`yUyQpowTW!6&dyk=#&7f93~t zo*4a46V!22@t^M+c?s(Bu@AXD_NVTJk4cN3oq0BeKX6ez_+Is0+{i8MVTHZD7&$%j zxGo~Cv*zM8O@+VXF&bnweG*Lai&=_E1Ixqzf$vsXcMI2Xn-$an?A4B&mqYosSxK2W z!|ta|EfuHMPXm;y^+R3Jr2Z;Xk1d;0@4r4aYL5a@Wi(By?hET6xF5?D>8`x;dH(9} zl*Jv~3lMYNX=R|)TUoPVhyno2T-t32GQRrk40zAcAF*cbYi4ynrl|#pewMGiQdJv; z<*0_fMu{#1G3Xwro^lJ%n~Ks4lAV pejQu5tn}-wEKfocd%`<&FRY?df=6W2)BN z&qm*F!}`IRhFV0wHGHe~Pir zy2yTB%i2cO`V%be?HkE&B#{p5{R6Q{Y5^;Cp-mUtjsg59Hhtek2?Z?}-_L65A@h$+ z&RaqnY|hY&>wX(+!kvr#kX;q|n!J{9#(-yt0bJ}Mwx{+}f;6N3&UU(o!K4Q+X_v3@ zruX4XXpo?!!%H|2?0-=H#Czx^l{)uZhcP2#F$H&%@Q2pjI&i95+3BXy)kaCT$~J{0 z1gk9YKp@Kth>){r@w(_?SjxdlnqzGc7kGCd@N0#L3_G##j8pJLGnHMb@L+{ROEhoe z&-Uj`+?w49Pc&wR&4xi$Neemg@IE=ewXE=^-N36l%7fMlil z6hj3SpM1=NC+z3djrrmPQR)q5jn80s!w(rRE~^RxY} ziJGXg@gF`uJUZVj1vwtNB~(IIx5bXqXp86d6kxTkPlwU3+G`~0IZJ*@^B|V)4n86H z`b|Cqf9eY#QHmkw7{AMAaZS(JDx8;n2P`}&JDOz8TFDw@j2BCtROOZ{`nePQsA;{P zf&P6_y!rTjQ~Q01i^JiiN}OUAJ5FcUEA%=cSiCuAJ^r&C6gQAAm|?t%XV&jw8fsWD z|3_^lhh=xG{jwE>z0Z49_di5`a%vFn=dV{kGC;sKc~vC#rp_8-Zh{$Uj@j`}4a&R? zBa`YTZrzuMd6EeK3kuy<73E9Yia5_^OuR>{A}O;(JU^Rr0*@!H#uev>NRepWudmWO zr&2eJbH=o=p)~eRtFZ>!;GE{%lL;}%^f*NaX-tMEIJ`gR`%8owwKiTR!u~2YW0<-V z-m%D7<6Xz`<6m3B$);=Z=9a_>h``*#BV((d5oj*IPYilU}GobF2%5dtaj(!tR15AYQE} zLbXu^B&laT5l ze6g;ImvYvb7C5zL>B}ko=Xs#$>|N`z6RW;r>O*#oO3l`fQ)5ZVMHQ9o8vY0RWvwIwLQN)V*){XAO(p-by*_8QbZ9NMzgyp+)vc9QrfzkaKoFR16R`sm z!X}J*N5WFk;s|~?}NR}k}UGba==RA2791v0V zoK-(frhujczeA!qG|A4_l0kIpR9`t~KDL@44k;pBViv`$Q zgJ`SS4VUYJNg3kR*NZ5bPYH|oe3m(g;x`D(=fS&!`DnXfx5^;%Ob?3H+V1n8Tvl#pXfm*vAN zL^%rMP5~D*+=X%b@Wc4llXKCy19P*b#C`hSem%E123+%a(Gx+V0UB@n_g%CKOAefR zM2>5!6Nt{JtqOx`YL-tWzMkA`2o@@;(A^&mjh*ZtcFPq0p=@`_M{t-A4dg?23un=5 zhdi|W*?az@+O6H4jM0sS9QTZn=S$-a%E1pjn}5F~v`mRXnTt=_e#(O%$A;HDSZ?O65r0ncpq{Hy6B6_>yEB ze&s2mmEb-~P2;cof&zSw%qaKkZ7e@cZ++F)v&`v#?(E3W+upHJNiTLDH*&noOvJxe zWi|fMJfojkY_R?)DWZ|W@K8JlhtbeS$?aqNpPAo7`905W=Q^Zr~{gBDbQ5|HPGhR-!j${xKtZ7-jCB6v;ly(p#73kFvS z53kuj7XYoYA`e26>+;YXz~jBfC3C_76p|}rMHv16Rm>k|c#eZLdCIYSte+)p$iv0~2+&Y`u?jAI-U_a1&syU$GC^ z1CEYZq6>PKvXZMwNmMo6Q^X)1?^HgI3EyK(dY#yNkhq-1|E95A#n9VmX_O#~i5wa_ z@GGUJ=#qG`^z26g_(OU(B^LSP*I3?^O{BJn0a5pZ&Wd@W;w_r_ie%zB&#BK!LqS!k*D?Tx7gg$Nh++ zY-u{mkJ}mc{7qpUx=)l6*iZDP6&00q_jQ%w8(uaxDP5kzhTj)*kOtC+Mqg!nUO;jw zXWRGd_fGS+&4075sG>jEv8*@|<(%eBRp@1or#dubGc=+|h&cn1MUN~&rUqso1;Ms( z8O1Eu@XS|>nl&kPppR3JG8rWs!sPAU@#QbXG}S39YQqkv2UNKTLRH_=3X!1z)HwfN{ueY6IiEv=R(Ggh$!vZZm;g{XgW^g%2xMh4}M8S9u&F*G?EeMoO`w={=_uPtu&PXZeiF#l^w=fYl2f?-cZD z!nfu3%4+dsb7?FmvqwJ<*QYh)n+^icCzZqI(R!2iu?+ei17c@U=;Z;ZqWjT{Nt3)i ztsmVvTiMrzFLEoaGT#FvXPr8Hj7R(`w*06%t=sI|P69lGPZnpF@62cAfeykn@q_=O z`1j)CcnUJ&`P3N^f zh^?ut^6|zxMSuTb;+X(tZHvUjTEfaOSr+E;SwEQD)@$Zy&g3q4?YZTcCZQGaNvFl5 zRN{^+P1zpxRfr9Y>^ z{0P;;Fi8oabUt1ny2YU`XVb=O|M&Q;CmHwEMAZBT-X_>QSzW7;!9zZ;xCA@+{KGqV zn+!->m~v$~Q?^i0Ou*5$d8j{fG<^w7PmZ4`Rcgqx+W<032th54BfjPphHG$qczI#)P!{N3@SFWa+5bvTCcO!%* zEd=~D-do^sNSTFIeyPt-FU)Lu)#}2B`gp{0;NhlQGD=~s5KnN##?`vu$EpORmj>QP zp0@DR>bT}$A)oL2S0uwte7?sN^hV-Lr!eklpTYT%N#tLbYj$vBV7F{vs)XtUc-n<> ze0BVl|8~}XfdAlkm%%@qRft+Gj~Q?JO{TX`I67}C^#?m}*ilbjalXkI|5@IQum({I~o%u{nciQiP%p-U*Go&K)>iupuB_~l%B zrO$f#2a=`F#ulpIxpc?)UgJg=_AJB3WevTAJAav{=#S&lWKgh3{(P(q>F^u?d>7mea`(uzuXGFJ$jDc z+o$v;ZT;Cl+;ZgzD=)SyItLi14{fEQjoOmbl!CX&Ag-5Cp z)mDb9GOIkwB_O4lDp()4unLoed{r!p_2^N0OWGPV0fQYme!^cWO(*y6PJiAFR& zT-V`GW15H9H2Kj{5Q~{BRkvQ^opO}NK_`RwAot7?-RH(&490L?BH#sA{DBPC{L`q3n1H9X#odHBKVv|a4NFgpVIW6iKsy|8i z`}E+_mx2tgXM=>paE#~Hh&tT{y%$9lSvXYT9Y|6Q z8xZb-9cJM5?Qjg#s9rkDyO=9c2z{ql!q=6ZZN3c$`%)Yo@;1ImN~BQ-skgb9Z3{d~ zy8jqRjL6xrI199Uw5EyU`i^GPC_A9Alg_}l==^W5gK++G_GRL{B=`x~OZIcARi5)< z8vDZ))z;nkri&vRhJTYX$BdPEz7$nDHWHov+jhUikLMz3)boNwc+|<8evSw(he)*% z5Q~~SmR(WDi0?lY(Zws`GOT=kez;vF-_7oK{GL)Ouw)hmmw=-)Zyqh+&VKa86ATP| z+4y%PmNqj@#ij56O(7yqnkquo^qZp`otEoNIOExE^S;}l5e+KoCB$ZxDSl|l-g zifKY~(};p&Ec|~tOv;d^+E7P>1=`rCV|_1K%RMd=_-GHL16E|WIPZDCY} zzk1>6%ostxSmT8EIkkH?*X^ne>zV75M!)gWOj;RB^IX`l+&gfDQXnkNKc;&uRlYo^ zQ2_G#v$jUnQVr9oV(!}w}KI3EZMuiqC3% z3zcno(~qW{zPSA}UB6guQXT+ZWzdLaj+1|$9qM6wb-65D-p&Kcwikdsrg}06kP&L$ zF~|-b>}cF^H(g+$RBQJG>bOtLK6 zMVAt-)@MQCEfGeO={T=+HMxnxGg7Kc{p%drGwSS9JlriOcSsyL){ZU}P?z)?$$) zS`XhHE|qieQZZk8+CYi_gt$RwsX0SV?b*`@cW{H6(At;r$RC`QJ!xF7vnhW2km zzi4=qHSD8z`Z+tdl$CqgV2@#HROi7-mTNDk`1(G}5=BeRwG9xy*5W81l{cYMMUD@- zkGekPVx;Dx;F~1k3}iJbaQ{>6>Lr2pj8Tk~#*crV7q!>_+=Vo}xx?Rsgl93z(C4mp z7rVa)Q9pZx-Z;_G# zAjOC3?{y}FiC+ou-_nN2c*dJnh#JN|Q3IjV^`jdrE479v_%q8hiF|z7+J4%-^aqF%rCf$xbT1( z){?tsh4=J~K1^*2eMr4tH@PJwq`v3AZwl+^us+q*rm^i~4aiymx#D9het|N=)W6B% zl9B$g&QxJ=i;I{&n~t~53Xg|U(+aDZpC3w}yk45JI}&&C3_X`k1ZSTi<*Mf;w%493 za1l%~9p5B=7+9fzA~+A}e*K5a(gBq{dqsS6PDJW@v4jm_d$(%A0@Q*Nb1(Qt?=RPY zw;)~0j1IoZ6Pp2h4PtF)y3y@D(V+T1q}_-}RZLvCj`bk!f_*S~hbkFH^hL!pAP9rz|I zIH{i+ff|^R_dP8|b;Qy#DANg5(yHo~!V>=yc&n4{&*7$1QLfNs?Q7jw5+lAbh0SZc~=7e$Ox8j$9o(i$A|m8<%-3czO1|>7_>)SD~7J z<{meYKS^GfK^_{&ZiSzKT3dr{e?e@Ey7b~(_p=P!d9!rFyN$nJ?n#1mml98YnY=`0 zoQ8Eb_Xqc(!ZiY101i$V5BQf-jnJ+&J)(*~UN|?eW1k)H67`$#p_^hCTTs3DS^FpU z&@idb*yl%-A}jY{s=_40(T4|_!cg;34jAU0p=d_SqMjG9f&%N)TDR|A3+;n@RnJkO z8&yV+vg7syLlT510Sr99n_oV+hi4|~K z@;@VPQPnO5*khP(Ht{WxZmZwGp&Y=nf=rp-ol?ngzrwwNTvr6fe~~AJj>@8ba_7bb z&1Et6d+}*tx2fKJAV{{qj83>c@x>1iHH(nwu3I}M1|G~bU#{oY+0g=+=Km#Uek0&9 zF7RM{BP^ z=}mgC2?9Y0We(w+J2Pv|kNGw8XILw&v&(t=`|M|**oRswG*m29AP|T~O;t%31R|LR zp8F^-0RPQw%hW(1GG=E*#fPqnDvF+Np5A(1*0%O4_8#`$&bGQL_duXK2?++~PHYDB za`gyD?!S8V+{B(D3*>2T(7ZAf%dV;mo0^jFNL7=V;99lAZ}u>4Xnla%}zJ1zBxhmLesv8qSP(Hb;-%$@&-9c+rhgT*vz2qT1PDT zYHg8mYBD_uL;6P{Mv-|$bYhIGK+==wEXE7jMmp>Q=7kzy32kb>YO@)|&q0>s!&4`y zQj9YDHRxkbo66+^>X<|l+y{eiz9fN%$(-`*rW|;iRm^RLHdtWIobBirgj{HXv%{j` z{9p{Zfu2ju8%W~!_TS2v2)D~dEVDFSHi}l4a%|rEOl6gOVXaS4?yXKwciq2y=u1P% zJ;7Q(A_$1zSeeslQ!jdnQa+-bcXbc>#5Oyb`ZoEB{Dq{S)9L8^D_EsRC6g3IO{l!m z>bUEnD^DbL1?Pog`XpDn^;*Y@i(a+AYxQlzh@1ZU1t)8XtussC>GUSJ>t+60Sy~rQ z{}vRWbadDdpo$OiMoDe01+VTtNfn|vdjBRR>RMY=Ojx$^UHr=YN%_wQ5K?9rmL;_? z;g`9W&0q`W?)j^I>X#TLhd9+4HVz|nvrd&N2ZUl5@$rDu+_%ywX8U1^c|C0&)) z)7tbo<>c#E%cws!y;b~n(Q=Ut6)ZIc|6^s+<4z{*+WzeU{a!D8I%dz0nfE%b%Wc zf4fN_H*Y-Zuq=PHCMc=%X`VTw&Zzf~<)4is5xl^WOWthQqR|eeg#`v&e_DHNJNxeAokb&B<MaodqTQHdO~_bTFt@9@NXFlO>@FtoCwPfyvr_&=}Ztq029V>E!DN;!F6u8 zYa9&TpC#sWtVMqDUZS+Ur!y9jTDn1CK*2I)*)Q92E`K0AY7#aii6xYS_cTuo4D{E$ zQf{&vdTQQjx=Z)`FGaiODH8ezHAcJHT(7m4be$o3a6P)h@}ax5(UtkWS?*xM5&LkV zM}_YCfbDb$*kn-JV}qvWnxFc>D;pNH1b=G!`f5x8)3dJ{FP!wEC)`b0$+6RWiFS^iBgjL=VF10kt?`#r;=U-HTQrW^II=MZV`noBm$?xnwnW&g-WlvTOrk))-*u*y< ziui{f53T)dLzJutg;z_$Gn!|x$Pqb((_)ZgLKsOFD%gPZ5j7UTii=*VCI}FSn(pjJ z0!n|!1VD+2v%WFXSW`pV*3(_s+RoF)UfAE=3)l?;$@ohHkM8zJYpB1wn+HPLUzUrw zLmGHKn}%^giCd7avRuZR521>l-u6&&VKL!bTyj)UC{)JV&OusNN%>!|10z{3CnVBK z8V2+8^Aq+H754OYgx!{sl7ih5fr*F+0Xu{c0Uk(ee<2S9_qmXNm!o8lu=RHKLOOeT zK+oh_+j#mQWx2S{6#eseZYR>&;XgEaApYeR;2`X51$JBb7VIC{z^gK6v(nn$&h~)j zGx>72Wr#cf%iO>8$iU8&|0iS4JtfWpuF6r#!2SuF9F@jrUK0@LnwXl>U44I&ttsli z^_N0AcV@~MQzt9RN=hIhkq|Crur8^0x$=`duri&JT3)}Cs=;Bw&TYnlfg#AG+*qDr zvGdhTt17h=CnZiwXR=%dv3VM@+6xh{gKC7!$`~DjdIc-fGOVN1te4*%$gaTqxZyz_ z*wf>qM8ah4R;(CY^06X_gbbnpBGD$3_7|awf`)^@l+bVmjquqeC14s@Yf&VL9949C zc8@p$=Gp##9-{ES8HWfP+D_?(hp@&VU0BmKgU9{MlJ=x3v;K|ru_*=W%xr0tH5Qdk zf<9X*T_bK$KmzHNp#z&gsSvB1iPFvvxgD3xvj^t$H~lWparB+e*w=YGshA(`K(yqd zZ#LJf9jdN|;F+)!ns0IK7wdHAS50%NO9EF!WB2B?1}k1fUd$eR)Rf4W8)f)fr4c+Hb|>@ecB zwNv=&mM4spu6ei1weHroBmPG7YJ@)OT`;74Y-juEd5 zS{0qjDHW_Ce{=%d$8(MrW;dxZS`JvA;?S6)XvD>=NuIuu)pEtX$(7XN6aT1>DBsr} zO}4rvRri}sK3aY^FR8QT6?5{EM|az^5yL`F?%($IM^!+g&``dQ_~9EB2d9yDlU3V| zLZ*A06=MvX(xWLskLOtHR^XOH37BAI1ZRLnz2D~Ov+BvcS$X-wizv?0dPl9{x?!`c zFTR?e$9jSa7bDraP;~K)%lu-$^l9$!;ovh`pKX=EwU(xd5h0J-1(pP6xIQ=fciysG zgF=uW=Z|^;iGsw+sj4+0BcmDIiG+|zLyiyU_BjS5@hRYVoKjL#S1Aro6GuwNiz+H~ zuU)(5T(*lu92pMRbNONl3ZkT?H?%XKy9D)E(6AvxgXzr07QvAigD5zFA|P-VSZ4Sg z^jC}Da$$~R?eg(*z3JYeB8z|jAMa^_;lOxgOx1MaOyRa(Vd-1Hj^^QB+S8wbsPlIz z|DuL8T;%H9SRW3vvJ9y@tu@`p^OOd<=CZK9z4}SD5$@LZ^w4ThtCo{{q7o6d=`%Z2 zY8-ivU-2MqaX76FcXFyqh2)H!PNMAZ=gactZ2^mun%u&iB|>j~+w$fo+qB<}9rSv< z30_~Q+rr9!AT;mjtz`U2DEAXrNjdy_r-{?@${E^y7J@vM^GnCs6*V)VP{UboBx5o2bw*+!ZvBvYe_vym3a}T6REEY6Be33p+?=L|G z+%j{@m+M4)PSOgW{a;>_XHL`NwKnfBr(55Cv^SkM`L*ZTy3zX4&YbS6B9VgB?g!38 zd{I<6DGHQ=j|wD4scG8sz%sEmyvrXYHfXEp8kjRZISHMe!wbX1(lSS%FCFk5IncRE z6bA++SLNeuO{5|Tq`wj*^X9&k3Zimo=>LWrrOTP8i*@}yZ*h|~TlRh<@=N*sjv+h! z>)U-1yr`6XP0@V8NXbD%vHR6KGaiE{J6}Yma%U$W`{am15?OhNM>4Is4Y`w^w)AF5 zAO3I)@tR5!^yS~oC%ASvO}^k57@DMpCzYx+W96I=JaUV8{S#a$+M(g$YhcYA?D}Sy z&c8*tla*~&3=oQq2MtUJZCc4Dbh(%%c86?($o zsYE;{v)D-@G3-nX+{A=Eqy$EgA~rhWVH@E~MmgSaw2K zoW4U01sG3m%2m0qbgcMKM%+f;4y*0{(eaQ0Oi89VTi6+fCf9B(k;h8q$*mZyZKvt^ ztbM(E*rnK4c%l?#*i7JcpK4H7gs~TxAexFimNKgC2QMFYk~R-?REyUg6=h40BSn~) zzH{-ka9e1R0p?~YfL#qeMsg9MrDl%7TBrMMlKMVcPeb>xeQnC{vS!0wlyS}uoyscV zG$4B9j=bdmTZP7k!yCu;q@)uQ*!=Gg=+A(myG)xcm%aeJeA$IJj5 z_uJfOTX$LJJ=?G^uYY`8JhHX(ux*5<1}F161(#cQjUVLa-^LowBSKCFxupk0(sJl6 zx^$S7cBZghfMZ0{veC46GS4(V;oWk%iw~-M%(cz~RF4S>x?EIVUI;+y7)${-F{9`J z6vHzrHZ(jtE^`XGbK}^j;iE<0@j9)Gn<{6{%0aQAy@8+X))U{YY}@kDh(XQ7zMcHR z+X(hnR|m@iDiSh5hM2I1mGljm(NI9;P+RhWQ+JK$#(Xv@GVfDwK=f{F>Ug^(vMIh% zYa`flQ>JILX?#5q{c)sC=U{b9a-_IKudtmZB~!44nxcy<`0Si}_r7J|wY-b$XFAwV zG%3Nwz@q;KL(xI+p|0B$#&PCnT|&@`*~J-4nX2Z@5N9p7=FG_ zMou|hLw1g^5F9|M_Caaa&p60Es=tEy3zNQhZOUAPGz3I0-a3E5j!OaOkkcjsjKZ_Q z<&s9srmXfE7U8q9jnwKypoZ|pfLhHUhL__MYRFhJEiuj9M(z7&Z9Fk2jvQ!np%nzOmzdclvpw##oX{ z0}nES1yc5Cwt~8NuPap6z-%-gZ~ zQ9rq2do=Cf+iE%)&iY0YTF$M!H%1ROK2>Ax*SwiA=RU@Y4jdksvQ7Vl_S6Xf=1FWQ z(}I;wum=@kmUc6GmqxT@uZ?@JNgZ58hM6qK)oj=@+9!s%-*)jdar^e$x12Pe1FhG| zl~ItmzI5R0`iBs-|6Tz0L;Ov~hxyANe9LNR)baakXQ}_uRGi8DHavKlq3|rk}yGUTYw@s=phJ2`qMHoH5s>;uGfAGjXQ%5rRwFXP~Gr zvnBJ_6HFp%ZRjDP+FMPDxrcS|U_! zpbFYX?GPJLIWeiTeH2UC{QPo=bv6@4~*=OU|Z+5>UIvO2uX{<9G zxu;*hAdrDBBw$LR0U?vs+ay;nGY~#)MJ^ssdSpn4{yNf4oWWBTc52IqPF4#o_-#I% zBg3A2qQL)w=SE^subdGl!dwT%k1?ZMEWV|?gi*$qVHCUQf#yH?V%ATPqjsk*w*nVu z)S^7R_}NBvmvX6f!yruNVK3UJe72yqr?v7=Ohdh-ffGD7Y88+dKNA?EoK#^(vae?jJam-wGTuc zcy<}oef9^077}iDmE5z)*cj4t*Vj}gN9%~tM};qex6v^|iMWiQo6WF%!8^s{5_hx( zj^=4Oo%-XpT)a8ve1!!16O8r-pJ?wJ=zuaUk81sG$7RQ6gISE_n->6XIWhuS0e6FKW9O{z>kh>peYUvo2SjGW!XBl zAzr90+Al$jSM%MD%_Bz-8AM3Pju=C~;C2)agpG#CC7J0`-p? zRCfR<-F14enUKsGO!rer|H4hW2979EHsU?C27nN+1JpQoIN)EoN`uT|bx}MS+F&ck zm`I!^$tf)+;i|_(frbE>7*@yI5Rt+SxSY6Sq5H%G+W3Y7&U9Ef?*7@?U1lCWTiqBn z1i)i9!>oA^z8W=Kjds*09@kdopjOw%yL{}x##ye5_zY4qbck%O4N+S>pe_Eb${JA{ z9?*v0e;x;Di!dY+e);2pbq{;wXu6>eAJKFO02feXvJ{bS8*>8&4DwT*8K6u4o6WN* zc1@kqVi2wrLKGHp73xnqti^M7yMtQQ0X76i7tj)KF%Q9Ho>>!Jc4u6HOat&r6ARft zAaEW5v%1BTv z>l0y-^P8b78Ks4*>HTb?lDiNf%|Grh6N!>l0^pivF&{l(pX#;Q9)m)jeAxAWT%sg< z5I#$z4^O*v7D9ljk)hYvbL0SDpa~#GHPtBFRsMfm3Rk!VREHJ*wF!|mGx00nSSFad z&%R@bT$x>0O5;nbrfGFGlrOkI4CE{j$QIV`dw{SpaPW)Krjx7xp1`w{7YclO;&@Li zmoZ-8I3E?|S03kB5qEcn|U4F3kbE)^2<%f^9vD{_ILa`tTddfxZEF+k6$0g^5jwAM6!Nj5W zn}I%Y94X7vD{zc{#0OMrD86!NNly5>zi9jEpT76)@uE``ueL1UJT&Z38n(GEFFeis zNsgFzUWkugc`ev)`lf;5gY7RGiXN7Fuk_R;SDH626@D!f$=68c(UvIU1BkRQ5-Y5k zk-j#P>2}Z!*Jb2Iq9r!o{j%G>6dCRbmYiOl{Beox5^yb{QRYk|Cnn$qkboNrIcL-r z6k$aPX=q*Lt|WdQDpLZYlBbgrdlnVQC6Y)6g*07Kbtd0v&;;{(s&1y#vMX$3DM+Wpcg|T z9f<%F;RTSKxlMQ_u@rCsR_T_PY2qI9Q73P@~Pq?MMC?(W{iK5P5@ zp63BQ@BhO&<9s@=W9UHk-uJ!kwdT6!bzO6=9sEo|3JaYG9RUFWOGaA!IRe5BPVko% z4Hf)`$OqdJ{D;t7OzfG3n3R}}rH#F^t$~q=l!>*8y}8kIsV4{syy4-hI%XuQ_k?R5 zOsS}Qlr1>}96yR+J;aJp=jYQnZQ|)#}bcaThi>$pMJ2G6UViWzw;$A&#G}7WA>>Y0Ya)EJf z@GXj}@~gLTxRKvmPb4wV*h+`>(&b;Re_C10G)!`uO#f`VZE%@p)od29Z`G35n~)~_ zX4^pfjDhRn@~qM~*-!7%B+t?2EUdgLNoK}llcH~nphithC6?sg-WJy`9KZRgAuYS; zOUMK7jB`wHdwG_-l$%EjKE<>qH#>i;;(D>SCvc-F7^0Q9+irhmrJTCAytu}d z*zMsaeh#g3lRomYPvhHM^<3G16U%h-JSXnGKi)V0w>}w?kB^q;EYR9{Zy&7hrlz< zGl09m&!+*a{1ysrJZn%ry1WMRZDU$d)M@-tvwVMSRQ7vC_XtDuGF}o8FEtH5fAPJxOs-|aQp3ST zmBv9i(W1?v(k4S!P>u2fenVSNlXSrakc8?pK+v##$6UeL!W2 zM}}|zm3vmnfPIe!6V2#}(x_i-(fS#F8cV7WDYg;$Qr?+%1G5@p@Y!di1Nlo;Rh3oS z_jIIcHuAg;kMD+2iy4Q#=T2R|=b^_qLFKv5=~hT*=cGUL zt;?RT4H!*%A!!csTd!mNz;lruh%qE8;iivGTw8hj@qS>3T!fi&&@ZbO#3HC( z5z6lBeKE8;@y(%dnaTGHk3dS}^tR)$uqdnm!8F_lF+I&w6HRPXBh}qbiP;fDGGP6<&qf<~&2-+LJSy)_LT$o)rm~HG$S=jja_*hukS=iZ`z&n^6+^ii9T$!vLsQz`4e_u!3 z#KFkk+}6?D#+m|tT?0cKCr2SlO8AZb^XFgVbTohY-#b}5{PS4g0a@U$u&^<+vi#@T z;G=@@-|{Qko11_;!>=#QCiwfE*M9fUeFRzHH@`BNe?95%--1UKMi*rH&$J1n%YCKM zL_iQlkP&~Z;)=L2c`Nx|Ykku$>}%P?agqI7%Ag6_Ap83dX=z{25w^N6K76%MukT8f zmMLn;X+}wjYGin?85i$0Wn2eSv8%6rxv#c8dAAoMM%^h+kEKiR#+J6w;N*Tmuj#b2 zs=B(mm&aF!%W>5YcEfRR-XI{MQTSf_r&>DwO(^uK`fX7J#2dKR{%J%cmP^8*w! z{D??I#U93v_y7FB4K%YI!fTiKeZ`SmxP7*hR9P*5T}o8czxUc`eh;o%!Phr%os5uF z@~hD7xU$*)7l?i%)&Bz^iduz`4bEoYGB!2s-kPkv z>)Z%&T7MdZO?qdT4C}#lc*-sjZPV0yIz7v=mwDsGmsbzF<5*ZeJyluecUq$+qJHql z+bM8M5R?_>@D|*!tkl2ITpEIa7@i&DAokZQZ`FOdIOp)>veqp|ikV0SoWtC{@dpI_ znaM;c0pwCYVUz#0GME=xx7$W+&i*1W_&Q$C7$fE;^PaBu@%(igGzL*oDn^WezoGV@ z&t%(8J8%Aa2nO+i%VM|#ObWG#h#tMlM+z)r?t7D$Uo^{KKF_?dTg`d-meuj<^`#v^ zzBIo?v>n*tvHC?FDRNo;J&{Y+-oYVsj;>_!>)Bx^8Np}n zXoAXV+E*b>m`N-UbGOlHcgkZMkNA7v?XB@D#Zpg5)pbXoP}s9Nnb(fe(u0tY(4hOvPVII>Oq{NJe&2rbA8C6h7o6X!F5bnUP{0c_%K8m*4O6*)K>-^P&7P zjw!qj-gVh2QZlMgsdUu>wKC7sJ^j1k#5}RWUeFu+(PWO>Q##gQ*-C$syUrlG?f>BM zUoI;vJGU@%TpwoAcq!E9#C>^?Cz22%ax#OwI^EcqABK4)34r_gx}a#>8>;Q)o~0U` zl)OA&7Ll4PZZNscoNl-DoiKsjBqYCHip)(s1pTGiVun~y*Lq1K^GzHwOx;?qv!fZd zn}3d(K));aIPJ5M)JMOFR3VS2%RMPMYDF(Dz1N6|TXWb=y52T08OpUslJmUe`-7_N zR3q4!xt=2mxVe5{P>;2nZ$qhd-CK~M(}6g$>W%sh7d*>&y?T(ZoG0hT{^x!10Xx}T zPU`FbVmQ&OCsx10FL8;qALhG~EqU#7uh@M{3ZLjeJ;LL1}KdvfC6RGwT5 z9YHF+YB80N!; z2^AJ23ZK-9*2qWJeiqy^tDd_xD06jJi8hgeZFN*V@ahHEJke$V*&m~YfEJ^MP|V&tfRA1~t5kna&r#6`~?pFzN=Q7Vc}CTIpx8=0f{1M#vW z0jwRk4Mz~K?#{Q%d(rDP)X|YMJAg6F{vD~jg=crJVOlb(>_jEte(+I5|Fc00>R7d1 z)_W!`wHK9^tFU~vqQvz!u|E~V22c_PX-rIi>>&U~@2U-*i2~?@mQ05r`f0YiQh?5pmY56%WN!@ zmN5v@=2@;+L((9S2){dAqflEw5Y9#{zc15;r*i1QD%IH7SisS&smPgT#_}CI!=aB# zdus(Hs7XY;w&?(f+2a+5{q8cp<5H{Ln!nKkP^CLYQJ9cqj;U&ba=Q`c&Dx82HL$A1 zeCcSmTovfn7dNY>b&Xl6I5?COxvdh*E+6imDCJME8uO(GR$%x*24T5LOc$QuC^jActwYuES&t7Z$Ej>5nC-gHr4 z9!_*d-o0BSg09aLl6hyVcpX=wI>q;Eoj1{AKd|WO0t$%xJxHJrdYu|h`^dKhVo6M& zn1N*Wo_6+ob)pudBWcW!B%W??OJhL%K-R-o(o3Pt7RgU0S`crks}t<}@dL|Sn?bFR zcCqUN#uDE(Ru+eL(tsI_i-vxp+d85uOa-mEgs%IK5aMuKPq-cdlo!zY^6IDI_%0K( zyYot4hA9rYu%+c!$MbbP*sr0UCO>5P<;^bM{;&MQAa2rxVCVbt!o$mX%dpd4pBF6h zPp5(dS?YFPcXn5Ouzb!~ee3EvQL8m2_z=0suy%w_Rw!W5z6#4zOyf=&K971Jc5b6n zcRb~h+xR+(o`@Zy+{Mu=NClYA?slRf?}t4x8ZFP`Nf+<(+AWA|rPa7v_J`EQ?S`{# z#WZ0AC-<{d&O3Y{ufVF7iZE)nrW^IhyiaDc>G=Cu&Ha}pucEqs0Yd2OUtQ}BZGc)6 zZaDg*V!dv6x9xlw_XbORr6!t6Dr8snvapa5&SzorNJ8Y&Ad>E0^s_9&g~j=*q7QoV zo}y9$pF{4!_OysbY!@=ki@KA!&@!(x=ex4UTa$}=FlgLRkrt1}RHctp#zh+IG3KtAmRoL7eK7jwsLD&RnN9+xZ$#=C%+Wr60Ik zM|Osf{GsauLsCeQ-mpB4PSoeYC)2w9P0?&AE>mvoUQkD6))seNfAJT+@njwwY%nd3 zHugM{ar2e;Yy&t~k>stOudn2Jp!xJ`1)9~d@;t|_2|nJ|S-+cPw8J@a3G4&ac1Fte z^X-vId)D2f<{37c8hHyVl!bsgGQE@O6*=1|&*g`tY|XWX%9|*3j{e`?fsSUEIM)jU z8rxcJH~$)&MltpMK#uIq{Qy$4dUQPcc!e~6r>^%dT5SrUd=5+Tyaz?0(nwP7(OdTH zmZPkvvq9vqtqOH&)d0u6{as+ONkJ?xEZX~8*<>!Xz+3^pf1Btce!4=O$j9&F;1{lATJQ6V|%3IgGk4yw5nTWb$z7n`QAa!ka zs;={$~KgAeZlL{j!$1Z^3u{mM$7ChCUi} z5yXAodQlE^-W;>cs+$0&GCzfN#8tX@3n+o;XFUg2aw83Wn`)-tN1_Y>;OtjFKY6G9EKv7gPB(}PXfW9Qsji12qTX+9SL?RF zH1oy%S%Dgp@{|l=EoKU*B=q&wG4BFS^R_p#zzYddy#SXF_>hMM3POae`l8X}Axle3 ziNy|Qnd#0iG^(n@ox9$0r7M-cl#i)bW_KpyHwimHzDl{~2q@BTHyZq^Vzrs7!$nSU zAE@^@j;CG^t6Ab33$RhVTPkcaoYsdQ`2)1bT9*=-Rs7-lNKzLvA=CD7QIeUE z5d@@~hZD?nx;&gjw%54o7QQ|fmWzmp)Pe3a3G1VOq|XDfzz(nDNgCBpDz}-&%S=MU z$VGH@JvO<)HeMaO$O z<<~7IN8>g*z${<~X3FYBO*xDS8_O8(l)b%8^(6Oj#hL@m6OOKpp!7|#dDrWvz%dZL zw%g?na=jp{d>PSY04fvnXcc5-xcLK91Q|v=FMdVQ&V2T3fIXmsr8YSCT#D}Y(6l_6 z9?&Q=4yL2c9#ly6hOQdkax758f{K?#nSBl)Q+Yrb$nBJJO=(aB1Nk9CS*dRGAv*ej zP2)u+psN%cxQE@9T=7buROn#DB!9>(zC#ywM#p~Dl;JF`ImsBuwN3zuivzMO;Y(%N zBl3X;12)fVevfYbmI*am-dka!NiwOLS^03txPB8i+;wNP-FdlU9H**u3vz zVyMJ|us;A-P#UOw`Qroumts1b%^)uFkJ=h;GoFHtMOJxTl&q*JZ5+-U8VQ1KWfkUw zl8#>CU*B1$6)1ZxeNUijwfgyr)YQPL?YXs;fNJ2dx5obGuyBj3Y>na+iLl`dR?j0? zzIUfY>gL;NKUQ#TKk(q0@6R#2=pLf&Hy+UMXLKup7 zSl;H_AZSz}gcr!3O0Nt2W4w?8@H($0c*w<@mh(gj) zzRZt4X*IkW;G)=SINQ4MC0Y1~e!OsRV)PXbG~ozh`+|}&-I}eDy0u(TNIIZ?C@h*x9Cf-nV{?1j@{7uEBi@*Sepbjp7z4G=k zn0!n#?Q1#a_XGT&X3eCBuniKxF&7VPDw{(k^~sE1vF+Kfd}W$`mW0lyk;2fAb%63Vk7JSWK9h_fA^c7=-?SOn$y&BfW?coFCx_80 z3ZEKBEyrqEM;}l7h{P{nSwlZZV2{c`e30&oT#Z5aEHmE&qV{W$WZczYhJRGr1w@?m zv7+d`c{oxy0)H`t;k&96x+sJOQ~CH-ld#j#1mTqx6oC648EgIAXFwU-)a?dJNyQ}_ z7{rq-+q&2#UHssgW+ZxZD?3*{2^IS^{AzZGn=GD~@cFoj4tFCDg0A^&vnU#3RCO3R ze?{1gKA^a^J1sKH#hbsr$PO3lFjx#1MuTi715&xl$7hd;xGiZR7Z&9&e`Jf_nzNJe zlH6b)N=XI!pAk&+JHST3T4gNCqNW} z0k+ApqOX5jqxs+?xAWb0li@bxuU#g7*11axGTl*_J@#A;{FK#;js^ zoTGNrUdO@AUuztedxpMJ&u%%7S=6=}{~+$QyONeg`QZrAp0`!XhC?Q(5r{+1OrwyD zHeMbU7FN3W;-g*#T*W=<&Fj7;fECB2^=J~}6eAIeFVT9s+fLq{6Q{eD#(nQ+0CRz5 zUVS(13iFj`kbwh|inaAiygruhlDfT+{Oad9PxrpvRqP1CV_4XkZMi(;a7+pOzbR3; zLGF#3y8=ga6}Xsy<8*w}1Y8mDrwT^RGVus9p*2{M8xv3N#o2Lp3yz2-By=9!NE6uk#c8KnK%a=Q+)OOW-hl3cI}UH&GC>O_~j5X`mgivf;5?+dm&^ynF~E z4=c6`h~|SlkcI5qNnPN+zyI=5PYMH2K?Etq@46Pa&s1L6*<8V-2?}5(Vkve$@EZDe zDTLUon^IeJ{(Az)5*Crj9odENO?Q<`F#~9bjVL7c{vTAQhY~Mdl$~(_$gA zWzXI35m1C%VL)GT;oportV4}sZa6VirVvLqfD-nl@IU`BVVp)!wH5l`?dO|xBi?>4 zH*fKC!>jZxVE+t&5SdX4xJl-kKB@%#T1nuPS$=XkKe1C5)&YEaO$&cGUl8JIVbC1r zTa)T@G-isd3A34ObKIS4&1J7L-KcP>#k#nXLnsK5>N27+O}1{UrQ0udv0G16&(y@w zC_V*loB!!o>$#`}D(%;UQU zAgvH~k=0184;Ps<`64PsF70)*M6M*-He-5;QP9w|!vGQx!G2)^j(uVTtxB4sKXd5bOJgqRnP6RbC@I`%O zsCkcbKw)ulu`^pHMjRO*LR#RRF$L;S*>Sa*sY#f}o8zYJR->gEbb8uLUoluXRr`53 zpC^E2cuKQ%1qFSz0DM+2%D7dhwMUS~C}l~W5~LrzK%ml${DIv9YBTW=y(~#A<%ViG zU^B?6a$Ef}?(%qO6jZNndH*V{cLqDSR5`9P6tC|Ki(~CiLXMaBw0Nkf#1c8p=k$UM zfLKiR@W|5eeL_EKqLKN=?Z?c!hqCws{yVLZ;b1nrs`!tei?t#)%UrroR%x#6-+YiM zqMv$gG2sZG=#T0LdY=M`SL8#As#BW*#PR@e{PJIX`J`tBJdPWj-sk6|CLe7yJP&`W zH!GS~Xw6$s)$zF&kqv!P?S6m!q>b5wWt0{5%JOZ1Qkp>(>m~txdZ;)kcMUu0RvDA> z*=PIg_GeyZrhys}q=zZ=bs~R?Z&*s;aFJbB3cDee*-)V-2O^cT!d>TI0;cZ|uF{QV zIE~*b-}UTW`jJGyF8M!6y}^e@c^N>IS&p&yJ8^NYsAv!9m^m7#8x2_L)xY1UIDU86 z=n7kEVn*DjcB|cbQj7NH_U{5y1z0Zt#RsoZFz`E?{cp;Tti3>8jo;v`K;=Bz7^BLP zii~)xxo+-d1pMbXwsokHz@|=Q3&K?n@EWicY6^$Y9VDo_rxCpR#72CiL6ArSFFx^2 z?s1XEqy&=kJK|bAn?GGnivv)AC*uW5yKb`q1aeM}LGKHSAzdmRp>E6_(R z2KWy9`x+??zu_XSq%QSBjR#;Suzw)rI6K~s1Ex|Z$a3MWm-AFo5pUj0ykG^D#~Oep z{vs}uPH`)7_B_-ASO6Or7UT4|*)}F?M_~9rpoi=7i+*9TF6+bc6{&2K9^3VItmE!& z^wPENpK|d#T+1uBN&_YNg{*?YRi_dD->5zDf2qA-!dfhk<1HpH=s`4{a_)^F7;wy= zf<$PtGt&$Z%oL_YLe$aG(-V7}O7e}|%>kWPAeoWXO}YAB@P)eyH%cl-T-nspG=PGv z9#oKWt6h|NZhjf*0?_L(Bw#z^3(w>*Wl&A;r+Wld)_zfKn~^N+#lNA2(5kb(wBN}( zRK*#~sA-7)Xtg3HFU=dG!9V#))n6i-k@|(D5q3corbiG~!qyc=J3|ZaY*@3)RySp5 zXI}sVk442IdP7?6ZC;7W0ZJE(KK{VsAOO-hO)j2zhY;;;=faD!sPM!+E)a0&iY9;iqq7@%6f1bNM$#>WP>CkI>U_hFu)r zjN~g-NAU3QGQX;8SO8bt*&8&mynSoMFcY#^@JOe7cB^(fVuhc+_3w*A(7`@|2)nhB z-W#oP$OF|CF*ph1nRHYxO-4RLDXp507q}WrsvvN6y~@HcuFUmsP{qLj>a_(YF5{0f zH^t2V;Ui$IJ1r(=SD@qfyuqSpM2H9nz2&Y9c?gvVfJ?i@prKJ-^m`-oS%E19tIsb&hu_%`*2 zvGA^kGSG|ju`S!i>Kr=K7(3e%B&(*TrZV#Us_gt%u!O)p-L@6rRN8}fq;BA2eoYRq z`v_9RUMEc&?$F!hu*5&-Pn^0bGaWw{2rAj$RH1q7muBVs5+>&-yRiaMf0gz9Tv0$f z1my{+?{;NH3csSmgJq_{{YEY88VTm=8KivOdI&r*ijYbm6Wo0y7X>WCH`*h0ZVsBC z4N*b^13R8wDQW$Vc+m|oftb!fVMT#l+uOL3m!SdLXy_f5zDEOocRy6V9W-*p0VXcm z09|8Hu6g;gCwbLpooeC6pPeLV6u2>e$bK2y$)LBOq=7$MP`kO6K#!51sWlOh7$YXi z$Un9$0+Jn?ahqMyGIRZ02*bk3?))Bbyt;v-XbhUn>;WiBarJ~ULuj+Tb#-J7Cdy!5s14Wiahn#bYhdD+eT&nI zejrbAz`8v=nMqVM>+P~~rR5l9PpUwUjok|KBhWMy1Jq0x=*S|pm#>~wd_w=QY$m}} zJP=FPIJ6=FJWfYM2$qS`#cOjXyglqLr}fdq#7NYCz>HdRrm7K-kd3mFXVF;!(BIq5 z%ALKvaqxaF;7}T0Ko85TC;2sNor@MgYXRVWRAvu4RXsyv-hqMoiDML&3_nk8w0A5W z!@%}Y6s7vu{O@`{wY+HKHjvsxRWUZ=VBmRKwW)O=n_n_%DW(c)ipvM3@H>AuAk7rG z7PX?UZ=5v5P)Hy1h>22t=NMY00%G7@j%-{Y-}=`~Y*O)8!;S{+tDs$l_i6fflclZq z3^eu^hfD1C|Gtc9Cd$z^L1&MGV?o6-B1j&wLDjCihSNT2dMxdkZ=s+&=;^OYD~1tm zhj7bDh-zCnv8g#%>zK&-<7}zOdoHiXsX)s-O6;lRGuC+Y;}Li<`|B>h}a-b`JH>-Do`9trzUra+?|vdlB7UE zTI@Cs0WAZx3ciZLk5?|ww&TF2BzoFII(#5M;tI5>S1s~kwEN*&Kr#>h#>hwp<0?>n zvG0aV6cLd>7bC-MEbWKS>YpHkvl8xxj_?K@TJ4$9PEWpQ7sw8J@?+rc=CI33 zy9FHtSo4C4Oj~5Hlna|?b_u)YyN2-HekpPp&_KXs`qk8lSl!|&w6bUzJL-x8{_Vvz z86iCspP(55CoEZ*bWE@XXpk;s96{WH zK>TDuH+DuUPS?pyo!awOqKl%>VIK>e_Z)lbEBuG#h2NM~w0Sr89 z-$8R*JDGxTya;u^|CkiqUNkt>VTq!`6^J5OUoT z1UmN)H4YL%i)a_9E-eHSTcg$J`jb%q^?1@@0PjMxn6V+C`^{}NCk|c~jV)g)Y>4g$ ztQy`+Yw{zJtC@$@{b<9yc%|D56xSY@+`B^g{*^^UEkV)f)_m-T4-erGpm(vR4oWxk zX|FN|h700R4S3ptWJ)Q$g{&UtcVODs0z_s=7dzkXRSp6|(%VNA&v!Z|?c3 zM1cO2hxHE!_IIH4+y;y;+4Qj@t|&z~ig3zNj-__h50+;+FCNx7HF232HuqgoRJ8E= z#;)WL{63a=8jUXt&M$*`79B6mVP5p=`5@h>*%AGBhwQuttrYIFbnL(puq_h3%=bK< zht=a@zN~hpa3uL}toc#Hy;pYLDtP%B2??~dL}&QJnE48-ZiJj%u~QI`ZUgQA7B}P- z7`rGXN>4K1eA3H3oP^^}o?y$^$}5RPniy_$CrSMfy)D{AhtwXC8nv9}F1yr29Y6ct z^ohuS-#P)$l3u-GWB>v~Q5EsczrV#vOD z5x~9{aJ;Y(T*rBzP3%hFc#|%`;3Mb&KZsb0P!X*MCE+Kc4afBv0hZbFxOdjY$y|=DL8yZU!GtI0HEu6^Qp)7U&x%6bbrr5@m z@SN?lMvc#ArK0BpfyB0;Ht}MqiWV1q9qEWGkW#EmThn*BND&WZ!yx0$bG!dkERwVhb zX8+P6XL@roM^5untl0r49`Rq=WJceQN(#F>UWujCV>{x*#n}=5ufaPHpGwz5u@;wc zgsELF&L7ihmKkR_@%f25Rf@qG1I0+k&}XgFnz+Xku|D8!{99KRER>2b+2kUP2PH+U}Dqy$it`=TgUwnmoGw)uYQ~)Q@%T?`n_o4`<>g4U1S&_Fr-ccp z^?)3awrli?O3c@RG`;(e^jLbBH#is3vgOiu6s@`--@>o#Ecmj`-9B;dRNoueZ~4mI zKmTir-D@hY%&>(yLD=Q|gD-Vc8$7L`T`9<4S)3c}u0!LGS7g5N$&BV<{&HsDKWxTklwr>+xsTmA+Q9 z`Xzh12i#^SrtqH(u}NJW6j4t>pym%PPhHE0qOVaJzF#tCx3@KL2g;*D@D1|CgLOz7;_z$TdUDxD$b_s8tqpx+gjMJ%g?wFda^|COmcng&jaIwUw z$(0*pheLW4J^a4!mK(0!*B1-v_+o_0uIf{5;=x!pJC=COthjnU_B7OxaTWKNoVfeDI$uAR_(S zF}{Y&XuRV3183V^vb{K1tMb8j9xfz^)X_qd-uTAcI1%SxHSZ(1wu*q`k;}U)lEKn~ zzD~LI&5LClEi)VRD!u(5LWT}Mo^>m2Z#1hh3TUCggX|Hki-owxOL_P~7hX{K4ZNF* zWG2*iG-#k6|SHvBoAQ zW1|>}k`!$4(#n0Q7uP>S!n89vP_jsHJn`u4coS#k+!V+z_Mag1yASsLH?($>>w91j<)y-zG%DB_so@x++c7T$c% zBg6y^`48KL6De_uQjZY@SR!GbLJE5RB!JSr$laLi=Zo|YmT5(s;0FWj1_v`st_@F= z4GDCJML%xzerA8Xjgz0>9Hu^fpC%!}6A!aF1Dx%w%lP}mvfo#fTyI{b28{}e>?bXf z1l^%oQxx&HDaHJ>P|&(-4m>s3q5$1}%_#w!Xo3Njgz&h?FQ=RxVqpL^n*V#H|GPry4E$nK_G zAu}LiLI_5WT88HsT9vXaYwYc`f8?N1tASI2ch+SruHUWehVY52bJy07@Y~XrfPGMF zC7=E2Rr-offQ>ZwDEk^T{T>te3}U!(sDsEgw1CI#+kaZ-;Ol#xH+O;(Q?#YsR?uIs z*ntp!n-ul;d3B00Fo1VVJr`grbjaQK_V4ckxIQ2XYp@JHJT?gKw^Q$--A-v5okt#yf$1!yl=I)zi$GL;yf4` z$yb)*2c1tqdOp_GP4xu64&3(uXAMI^HBS~47AfPj?SnzrU2bVNiIT9x64*6!;-xGJ z2?@Y`7`eG0%xhb&NZCeiMeHiUAn65`jN&txS9nlh-yUtSDmmX8$!a-Tia2xcqVl)F z@?d`V^1=zIH~A#krgwo8S@L}eACc^DodBoM#w}-+#6BTmm?if z2H~e8cN=_rBpxgV)7yqBX0{RA2)MQ~bR2$0gBKZ~N1Mb)1JjpBRqTe}-j*&?(j|k! z#liXrOZF>JH(FdT=|%AuQy@YYK3%x$23*6%aht{uz#Js*NfuyK%6y~k*e|gMY|d_9 zMC2zuc@TY2=d_=68VPWu0tfp*zudj&WLAFTUYVpeb%(nl>QU=}v;pD{nyuI(D&{Et zYB)k+IMbPd93H>oBvK+)Cx(L4Q2YtmxT3y=<|;rLHzpq`#*VF_@a_6H+5+-VRL%3$#1e59c*k8nm-}fSYaKy((udUu_y9^ewYIZQfHVj-OG}Azg!~ZLeglKu zg5CjMjSY(WQ8j_l37Pl}cy{j;a zYXbF20_8!7^Ec2uo7r%r-U$7$qBj(t|0DqY()^)vu3YqDcU&l{0KDL$`YC=yjo)=A zePx^ox+M82rkJ!07!0M8eOz2q?(0RR%OMO0A&PeMazk#vpC2HN=p3lIQTM!y)uvAO zX^nXJBNbnZ;+uO(y$ANm@a%o27IIin@=^WaOzgpDn^$3MUo0(jIp(u`SkP+kr|%|8 zM@+8W?Ht|s=pRS=slq&{=_a`+u5$TjIUabAW!>3UZSL8s76F5L@q5rO-U%!<3Z@qo zJBku+Yx#NNBOj}m5-sEo!4XG_k_PCfd`7$kpYwV0+;LsE#SgjX;QTDvVPn1S9-G1F z`{wR{POi~nln!^FzNg-#78A|0 z1)aLQpS0i(kT5u9^s%_VYuJKby_gXk_XGZEOJz=Nj@gX34>2g_4Tg>R)opjLKkn15XuqmDwNFwy2R9I0> zEjGXYD?2ckIZ_6ySVP9SD?wM^9=yRTcO6~|?xGQZx5oB!aU#jMaGHZ2sSdR-J{RkH z$f}gkO}whrG&A;AE9G9 zg9TzrKgD|L&(C~1N5%@ox-5o^>3JqkW1{Ty@HAX_R!4IJ8be2>MmvX8C*7U5w^o)R zwXMsdTLxo|$Io{1st*+pI9?W(v_q<2DRsKbSGTH7&Z!RZ^2L!MRZTi4nWyt_QYZR& z6b;I6RnKE9d(5(HRaxUrJ{gXOIB&lCj_>X{W)hdsvpH5S1$50zdfAt4kXjl2b+z^3 zGIH;e49n>Tq0Hi%e$(x#`b#HqN2c2sx2g_{?RKDq7(-a++^B(JPRQ-U7D%B*kbVZ% zN53mTx}an;dr0&Bcx@f=KO7Q#e3GNf*`vf|U(eIhGhV|fG zp8={oAA-)N)pT{6$K7(fxJ~hyUQh$j;F^4h+gE*YG@hf9|Ge1&YI3pd1M^_j8}b|X zj35`;N<+^c^g|LM_c^yy5Sx#h z)gbdo$IP?!+r#UUZZBq%$6M-oYiajPXM1ia|Fycehc@}-IALxQl-){zGg`?8Czd9y zR*_zf*+yuyy6$i@46;0ehHCIhrHD4g8`Js*zcBEpa#!j6_N09Te&#tQFq;4RD%iTz zEx`~=D26lfi^Gd!z@(K|Nyru}+{P5l6XR@6_WI$i{;#Z6xuv(m2l=o$~M1h=}#Ut&e`J~p2$Jp~uX=jz~T)D*~6C(XvVo*81*55KH%xZ62ef03@dt3{FVQ9c271m2LR#6vBwnys(=JR|4k&z^Pb9&!~ zTyZ8Phfi#_K{?DqkV)ix$6urIeG>h>cXs~0;XG4jYZo+Wo`zjo9J4)A#CMhRO zyW0jnrytHww;Q9?HbZ=L_`xZHXG;Er?U8ur0V+0bI*mQK0($-RA5@B;H>+^Fef0#L zXJJ~Nkn?XOeWMLOc^bXDw@OJ;Xqb;?Nt|Z<{^M;!5r~pTP0h}wrSlZ<6+f<5U z(X)O95eqt*>fqqQmyje-{FyFEVNNl>ECO?*ScerALvsV!Bx-p-?*5vKP+m2{G6Sb} z9v{$X^Lw7yj`qeie9lU%x0M-@(S$gf{~k)M%eKC7tiOtT>wsP{Tq#e`0w*_IFQ3SFz#oY>JNvurklxUv<1YFO9{0R^$zpgZGZ`v9cE+_%6{@+MYu z7&#bY(^VeTA{yRw^Vy3@d#ex^!jRun^8RoY=T~`# z{sx~zx7k6ZhEvLOexkJAas?jqc@

fT#-6@G52Nrn6zPb*A0~=rAMyd6Ai4=#$b2 zN?s333nXTKJ@!YH0qGxkEc;?OK-B5+GovyEmRrf?vFj>i>lF#2lNvq(t?kfQNrQE> zH(DZ8tVdswh=%j|1LS#bRVWYHx<67v+W5bzY4(x>vs=PbSdVSdO;(bJ(TPsMhc=Y$=QksY>T}RSkON9aewI&smY0^G{)CXT5H=maz1SUBo*5|(L=@SWt`IXhSp zGY9SQ2k!HRpV}Py$pkvviTe6x-t01^HjReaSgRCkk5z0*SNpaF-=&coOmcLOJk<58 z3_aVVE}4UNxd8#ygaHIp-OfEiF%={b8XsbvaF^s@{FcQ0q^;GqlU()69C7@X%a+XF zdqtQyguio7=A0>x%hv3njI$&vK-s|}Vw3Sw?!T0*j0yX~M6;{~9e$jzQKK(}pkrjb zShd8X>1;htqs2pD=~Q5I#93FZf7w|4!C(^ICEq3_#2SlO`iGXz{XusozxC5_VBR_A zp|8h@>(EeY53JGxf8Hw=~!>V2{b3JRqWzfdam zem>FRb((~{7Ev)vP*Cchv_+B`kq8 zvZrzHibvvM==g%G&Hk+z>K&K$L2^{(TQ3d409N>k_?g<{febVK?movm$RoM_BxTr~ zM$aTEFG+hiKcT|XA=>;LOx=^bq&HjEhOc}vk(lqkb^H}<2MI=fGUs;D$eIaGODn*? zR0*66XI1UjZ>w|LH-tX1ctzXx9k2)!@Xa*21x1J$gED%OBmJeQdUHA?L&3s8D?h++ zdXbl+0dD2+gUh}ZZ;37%-0BY7wA(hdvVR@z{Buw zcgM9t_|d7G>lY2jc|qE!)n+y}>Kh?=9bNp#l>v57TPFyo|5@<__Cjl8`2ii zKo65YTAPVyK9J|iSIc^5_N*m7*1Kkye4+337tz7kmwJ7M5qB&LS$|2V@Sl8=O@~Mj zi?`mIo@bj?{zm<)58Hg(8etdPGkikQ2V0LI4R5>?z7*G|uRmKM7}v-pisvVhdI_3n zE`>Fc`dDT@XR{f#b*%JfWkH5Ih54h_i)$4eWq;PyISlSMoGuZMfpf$@;dmESBW6EA zAA3GHv9qE@1X`zN%%a3#n?KVd6_jsfgYQ?69?X?T9y9b2m@F7Ye1-^YEZZ7j25Mg- zta@)CwaN>yDe&}z?nkH4%M$I+$IM^Ud(LTV`!*$wR>!{6>2-Y0qA{!)`aH5S&JW3X zMX~Bb;&X9YLm}DoiOGItroV~KeEL+IBFp_pS7vj#D1Vg4H-e7QrQR2LNshIFtB(+A zygg*otIcTuAA)jA0ljb+mDRWd*KNk{=9AZikd=?jPZGQI1F`qOS@c`0T7v!~JcJP> ze0S{bDjfIwseto1;ITyqDB3`)?OHFhX4yCL3AAL48|?5ejUk#q%NFuDIzc8(j5LJ= z6W1XbEy0h`{HNuyK*O)wQ;$6yLtw2UrU^eMsd4(j`iLb~Wq*;B*0kQ6rzrcnBBfi_ znLe#uU0q=(?U0B-RF0Qk+N?q?4BqOxlfO9Mvk;^th1%#SiiueGIchF1`H8`{ABOg# zJT62GFBTdwt;fHMM%ar1S~puNO0xj)obUHu%)^sAeC;3mCs{*e4vHdNV-(t}ms369 z$M_z|uR`xZbJQAX^Y~Zw&cgG>gYP`gl}mW*Q@Cyh&bvsrMUvZCvTuCW@D2knU7K zkyHtl6lv*}2BoC?qlh3#hteY5B1lLnNK3a!Nk~gK%>91Q{oVVw=giESb=FzyteJmY zh`#m2{oHX~*S$TmdZ%ef$9ht^*Q>4+PG&YKnuyElw+D5G8G<94b6IdKO~?2KEG8hh zRNvPAdt=j&;wf7hbZj9HAac8X=rvmd~we91f89lz_VmTkxV<_C#84s~)?EIY!#vhP?pDQK4# z7Hyv{tz0fx`FOTBGq<%bS5t<=OhuUAr{W`C!=Q4^Q>&eyeyQwa(Zpeo9uF|4#_3h= zUzZ^Msy%f$ghkfLC)^$94ItL+E?Fko*q?_ZUhqtaSA5`^InQM!wm`T85vk$Q&a`qz z(m5;LN^-B8lwRX*I@Gm!Y`jk|L#PZ0Re6TY{l}NBl$T^QH5f{W(6vN9>+Icy4e zhdu||w{y4Ks%~yY`WOv1e)HT{la1#uR*S>H>}|u*`#DICH~Yrg$rF1@R%f^Ha;j>BwC#eun|)q$%DsWhN)e^kDnsvJpCWGNja!3iP;MyG=vgW))YLgz^>X#JXu;@j{K5qzFzMFK-TCGU-k}0?UsJ zyoZA{s5v>%?(sZf+@5&rfUbBOvrd2S`v*`z$zZNa6df%;nVYR-wHAAlJKlX`K!m4j z3G(6F#ZP%I9K4e9Q7ze3L?g@P%b})3WF>kw=yajwh?*Ti9fXAaEapOwN-RRPKbQ|} z9+=TxR~GdYirYz{5W4?s@KN&qK$%(8bJt4e4nf$Qy*A2ca-x(6?t@2LWEe!Tl;TV+InCH{Sd%7O3 zCL992aoT~B>w_oIKzG0Oe0aNkb+P=ssTI)Wk~CXRdf3SXp1?kbDJ!w(3aP?_V#WZH zpWWDJ@6|?smbuZPCp|i%!?#Ujq~|V8FJBDwef_7%Q}ex)6uM+W$1eQ5QH4f_B*A7U zh$ATyWJ&Z?-fgsBs0qxLSURWQT%l$PjFft(g_m*TWSJgs^7`^WWW1#2UD{Zf*Vkzr zx&P_eYmP{JZj3wmvh29wCdQH63vTBxb1ExdceEgFSRp?yclu{lMVYL43DJ@r;T&D! z*dl?&!QHnP{T<+~i3z{*E|7?$XBkk+Itca{9;5 z&UJ@YPxi*iVN9y4t9L>~F2XxetXh8iq&R|!9Yvt1R8GEUXg!X{IXsZr5z|T|Oulp7 zeJ7x0>&iFoZgU>C?Osn)OE!PT$NOLPiLv9Za7Lz5xW2S(CR>yto_ms5cij85Lm@ig zX0gbwyNVG{oWJOh^t6X_{CXTsd?7FoojAadUS~9(?|+xN+XLik!yIg-XE@h-d8F0~ zs)?wJw}|-eYo8YDtITIY?zlSkgtAQXQHcXapYxYXSE!Eimgm8!rld8hJ;6{s8QU;7k|=O~ldG8iP{%w5Ho zy?<+CLBOQ;`8ZHPOZQ`HTq149u_G6Hkk< zn;-mam#R3q(ph3A2>ODA9Elz4WUCl&>vlRQG~KheO$U=WFgkF4I;7WS(79xL?sHt8 zxsF|S?#a~)n+`t1HLse&apQ=KE&4bNB1(dCHoH&OM2NY*1)LzF0VoqSqmr|{xR`Wy z_;H(Hk`=?nu*JpDgal5@<*OTlL+?C3DaV*j;H*5n&1P!Uds!Q|Ibp=zx?rGYIS=ZY{(a&p)Z(eVV4q8BMC z=2&+`+(N9zTt;^IKP4ab?i_q&q^%}LWmyV zfvPFp)-ME^c>~kVF|^Ws_hihuVjPoShGbNuVLo_qw8)vx3K9t+7**X^A8$_gJ%%Am;Ivg-e7AKrXT=}oo}wA#AUhLju!9ORpu(cORjq_UFCGvK zNb@EjYEP!dSgv&UpTBz1?fe@_a`e=H0f`IJ0eyv3C{#RNh?obXlciZD7bPqf> z!7RTlpC(HQRETF$&oB1%|MK$>@<*F3IwFuJ@Rq-i06NhF^w%HL;Ky0FzE5OE-~aD_ z;J<;|KhB%<|4Jb`hVeI$>VLT(&25-Eg4+sb|LbEgV-fLHfwm{{{{#!b14X>Slcw`d z`WL$ihhGBF50B%q1d%B7uQx`1Lg7FfS`1F+ctJ)c*wUbW*8zA*gz0z^Yg^r+!(^Vf(A|4unRdfsOuz1#HnSVI3j z&hD76+Vk7g+W#$A@;~~Z28)DLxWra`bZ>jLz;x04wcw-I^ZP#%4JocOJ@Y3D@8)7m zE}VWW5v5`~HLpIfu}dv}f=!wIlBx=ufj7N?K>kvG%a*<$pY*^=O7cL$tXQaEeP^!D z!AFYg)(pmzQTNz6ie^=Ko4!@rJ9d(j#ZAID-9DA>x&)vOL!gX@#>aC&fhG);+N6Ke z!r%QBcNEFZ;~3Fn>*XZ|6LK2o)5LlHSetwCvw~W^ z+5NFb^_JU@3AZz75w`k=6#~`%^hros&*6mA;%GSG@2jE zR|X7-c5nH5uckPEdm|*4CSRMxBk%xeW8+la(4o@D(ntjhp_D9{)VSW0=l(G-vNKy3UXvKa&o7RustwaOGCIW$NLMt zM!K=SbCx&j?M~rZ`_gf1?#Bb`<7b}kT3+ACYI0 zH3pv^Z|Z08G-!xK0HeMc;?diwG8>o|nRaoy5Fl1{9LBqCnbtUmwZSQjOHq$jEcBV% zJV+g#Bg2T;b<_f#BHwD2j7BkJ`eux9gsR5x_pg%FtSU@`BJg=ef2WP=^z)!sW)U8A z-6}CamitUM-Z;MXN3ZDid@6+L4M*bL#!yBvc8OB_v9FszyScD#huUV*D#-`^#F39_ zq9Dv=2nkk@eW+?6w<@Ov?R4=@(D`yr=zRq$i|Larem6nigI*?@+pi24^g3Q%w<@?O zepW;r*|?}=WZ$wrkC0_Wo!G^*z*o+S3OjyciEsR_mQF2y(1zh*c_My02&3`yoWvdrY>l<1lS>ib7Wi}SNlzkq#y(Iz7!qt2P18Q?lE11N8( zNN2{EUA$%-00K3id=YIOM}elNctR`y74C^Y4+j1 z0(a00X`Vf}Us$>Sn@_KR*64&^mj+&LhN|*u6TU0X<8Ct>)2P7MmIliag9z#xH7Uh& z7#jrq4)d>iFBXLuIRr|DF_{hcU%12sVkCV`*IIBpJ39@BN^FuUzt#iD$m(3#EX5tw zvwU#~rdf-z+S@0~=bLt1#puArRyU%}%kO-@EZ4X0cUJXX+3tHx-3-Y<1BK+drs{V4 zJF?HU84`IXxv6LEGY14f^e@H8bFp+m3d8Cay5PDo50_F1B-x8SbMNaeUdKJh{*Eyi>=uY~c02$< zB60Ru<?z#=sOSeynBj)FC%jnGy7B%k*IIkoFZ0?dN)yNl-O_=W1Esl>< zTc3+^}L{DKh=au~Zdkn_Cg%>r%aOg)LqHqbB5DEHXLe9#qq?T7UX3n}%9NLK1 ztT^_aM?cLNTIw2~Q+puCOXpqFp^|sRO!%O6HY%irM&0K>KSoHlaS>aCfF70E(@f5o z5>YY4ugVOk9{qZ5^Fe2@;p-N)O2en+tFumDSz^63bh`F{E5`7ZOQztW@xUz(no%wk z)M_pY=7NZzO|ERFYTn{^>^uG~pQ<6ZI5Cr!&}-h1AY65Gt^JOM799psZ2)H5&GAfF zRji0e0KaY_>HNcsj}jWtsM6qA7+QwulFmzTe$MxQP_5iD)M&8l#hhKZG7#6EA1Q_K zsC}PRx5nK_fs?}a*XXUBlH(^%N`eMXVTmXv=mWC=m(ah&yvR|q92^YGi&v>gj}8$H zuj#2U7pEBth?o)Ej*sXYJ8~Jo$*l1_hR1@5vtlijSb`@1m=8+Z_h^XnkRhTZ*ZAWn z>Ek4)rAdSIt|9QuG|boU*8y#pQMb}f$T`LH`YK4@vub|GCQfJ&0Tf3vfQShA zXwyd8#~EsTm(dr|1a~9jv;M170JDI&WboS6j>){7_p;R&kYzcAp_C>Y0VCr-XzEUmw)_`xQ?eU*{HwMb6M}SO?6-Ng$Iy;G(aU!|T=bvU zgNu;E9b`C7-7nuy55AWmq}^>HFL3*`-o-&*qN72FeP8qXhj><)yxvBk5!dQ-M)5Y= z$yUZgr*|<#W!YW?^+@C~%7i*i!XcR;L+aWrJmH3;r86YN z!~~Cro{_kDChU`+5c<9OmAqtb#R*szUdP4q&@5F?mD~QZwa2|}BH%J1dVV9E136&F zaFO`Dz-8UMsumVt1RzVq_S7rgN_Ex!NjQ-f9;DPog^cv{HJouu^yB(J?~@OrStz4! z;IqdH`>Y*>ZE)b{TVh0imyHKWmycrn9Kt?<cLNw&IGJyL4mT^RFbUDL=n8s;x$MoxCCUF5KWOc5@78 z!my8?+1pa%1%oR=YT*euHKv0yRA2~lyj&tOw^`(A=G?uq&2q+|eD%t|X`{5rO<6Co z>^zIo>DqZ`}k2je&7ig2_UE07du;%q-+lFyB8$kmP_<9QU_ zz+UWBaL82c1!k8rw3zaU~a{K(r$vx(Dv*)c4fP2OoJ3%Ggn=2V~BWFs9rp^GV1F+F@fQ4OL_zVqLlAV^vWf#vqlAuYfZau*~(M{?e z_T3BDPn6~pMifaSC*!F!E%PsX+jL)JbWdfu7EbGYMIDnf{dLXD>nmn&&hYG`5SOy2 zjb~!cp8I+W9IXp#1ry_%sohFM_ly}9u5?{R1{uXb2uDie$?!#fO}$U^5e3FyjIEf> zdn&e6ZA>jcGcRk#Jtv>NKaNSy$CnPt+Qpxc&HOJs`=Y-#^h5!uPy+DT(@L zG66n<7Y4ZI|M+VfEZ%RlQ(!*eKn$xow_{OD{D*rR2R8Ct=P1KIi=Db_{`$P);A-hx z=}S_VRJo?s#WhAz?$3?t@TAKJnj$$FzaHG@?4+}0*q@!OYJPJ<;(>}oWB0gXmgVHD z2onD%^XAn4l?o>@{Lag74g)Kq0YtSK1qHPs(aQYApCk%W(NZAsnc}!KtoZK1mlD3E z|8dMbJ{&J{fkUfAeq-@F`A^0BHmX`S&$umz_%qAjwM<~{s%=CSpr_te2hO%wzEmH~ zQxvWIOmgc~92P1MTMI4}@0ChL_KiD_{fUyZvb%nVWc5Q#Q zA?`-;{TvNt(6)4*0qN(FbtmzgD-HC}|>n8zH`q zGr(SpP0V0AfGE{6JjK5kE2qTmOJ^u2<2yXIuhC`qeJc5{o8BmWbq%9`I^a@DnWi41 zZUaGRA`V3UVd3H7iDnOMmI0A5+!z2DXxgN4MCB1MN>LD@i-iZ(Mq%bx8Gb^innYT0 z88-MzW9LX1>1mL#Sn21)0Oya~Tt2Ce@n@61CIU^*PJ2j=lU-f^CbrV_p4#=`fs;_~ zx^Y^;Utux9QCNKW+Vu{h$o;g-n6`ICWK7k9K<`=-!7GENL=r^TzFoiL;&8A3y|`Gk z>L!qT%51DW3i|6Q15X_#Y0raQrsFt&Lu$18phn|ymI^2HiIc-twGk!dzBW`#Vf(vW zhW&|Gxg2-C2wof4_H>xF=*^73$x|ZX@Ium5hxr>bQD74Rj*=eqG|;%a-n<4f2>~VD z-S>aoWR^n!ETjMhQ+ehx`v8i;if?XX(N_X`czBWpPiQLIZQB`LG4>?i|~_5-fS-5E6nj@!+#0tpicX=)mY#Bt(voocOOHGT{JGU(d^m zIiJ{b%<>|Sa?OOgEfffC5RHkf4Oq{F>pPu#5*dmq69Xm*J)uZ|XAs^onSg zs8$@3NAGNsiDGal0HfR*D>VJ+>#{*wp-LRTgW|bG;Rm%BSYFXRRB)S7#CzOO7FhsA)9x>>iy`z;i|;dq*~&oxyAKb0jAN_zH)4>! z3LmUSILz}-7ukuqe^xI*5`{>>omm2{r;4mqPzX}#W1-cE(2@{2^hxO&54-B+&K1b! zjyU6?nqaRcsC4_*7sp(6Le_Gk4#pmy+?st)nj}>DV~5y&qR8vFutx;{8+L?AX&ObdDgB{|cx09ZDWO=e^1buKEqH#|s)12bB<~(bm``|*IkV)npZMW_+{g{}C zI-reKF3t%O%d(5=%7 zxP;~8MjD&t@-yThbZmY{Zsd&)twyq>Q}ekT>3es>S!f}6+PDy5H`34iJ-8DINUD{Q z(BHgd=HV5T%$#F`!FQc7!us_TwofbR7N?E#!YwJWn>_3Gl-N`nUECci!^=B=`e>|( zB%D($9#ekv!oJ6TUYlnKG;(D0U^?#cCZ&wkpyQBIq3dy=cby_rhAV%%}NLCK-+)7z*OY9U%H zC!Ly|je5C@HoalD4n6L#Oz2bVWS!nnA^42LFDD|%9ui_><2Q^b$y_tm(irYbktUge zCX^klt97w#a-h!)kz==b64F{n%X5ES5j0nqY$K6;HT0-q06j6DCWIDN{P3}R-4_;F zp}k*s)Qij`BHu&Ip~0_?(a+p0iEfetor_?gUH8IrH_dBgM?zFKY)3LScbo1SB@f%9 zqMQPDe@Y-}`N+yj=7rN%HyKjy5mNV9DC4i2**resJhr@PINAA9JYLsRhf}Fan<3{0 zH_vzrb0gR5cW#X*ou_-2r*fa!=SKFWf0fI@{{4Z8&`(MHEdWnVW3$2_;qJQmzMbxn z+zEoE3RkUHc|{Kg6on4=9xuFPI7`Njzg`LrbVOx>TL3oRzy-8T5Q_~M@;uxZ*WzXd zAs36E6_N!`ZFYeiSdSiwY7*h1sAUp01sx^fNK(kQ+NE{s~tagvPAGhC!Gz_A6dN&3~ zp=v%$cc?~NWBgLvX3oZ>X;_T;;M++F;IA69t@_ZN7a@-RI{hB1TjmZZMAB z@IJPIMCu~vPp79{?&j>BGJrCIx~%b5XGY_>qU3yF$bjtfFE^KT=;8Y$)I=h}f z^%iJk!;BnLC58g^Lh9n79%##c<;|xyL`^GtV?h4m>`VYeD|pRf6$LzCnb{XMay}Ma zL1km*w+;GS!eRL6Wj}IyeN7CSg?yg<;L;2(WK`tE%zNq;yu50tnVFg4vr>K8>Tem9 z#zk(J^8zXWpAT5k=%Ge4Y;9`eii?VPPc*t$%yGbap9$ku7ep z7?CO!CpE_lkUY0u)(NM!nY8MCkE3jm0^wx`0a%C30BrFu5m2vqgSG3++K8l&X!Mj& zzYZq#y6U%CWaMQ<_&4ZAfy2*}X2_SA}U$2>9a zQ9)mh1W46p7?%ZX27Nn*U!9H>aF@OGUd`{b2LJuUdjp{wq2E8Qc_v$s;F@CeTTnpB zHli9doeB>k*)9wi7OX#FgOpZJQ#0EY^KKTik;;k@Lvdg+7=a+yhnSXzOzHu@dZ8OG z6Gxf1FbKjN$j%Oi;-j=mADe+)^Dgo~j$zU^OGvl9$~+xCcTBs@foNlZDft*C#iigI z#Rqc1H=RFg&Q8z$n(5jxZdI=!{Su|)o+TsEBSbmfIS0k!?a-oHf&sOK zLKC`jE*b81kmn~_^u&cgGEpRY64!r!_nbsG*&HD$<6YvHELAat21`>NX-k$Q`9k_| zsO9=fLir{&g%k8)iFvUR-A5=|M1hE1%-f1-yqmwg5ZQW#s+FER5o}StC9hjae(3a% zKJJw_1jK}Xq3VflV*AveJ~}Q2rGIq2EPd}q6w7%94?gC);jeGyM!s{%LqYH*%@8Af z<-K0qm*DJ;FfM2czU%;-i)gnK=V6#X`2qQ_yMx8Ax9qp72>MMJ@1WaIdUav;6Lp)> zi@O?d$X7lf&1o6wTMF(5lj1B#hb$??0c9!sKiz_ZHw@{!T2;!m}# zk+YhRtWmgb?TUAGL?kme5)bCpx1I@^8=v%xw_~f=Hgz$ed>p(=W0n()`$r1^qaXXz z*m(>o4!!*p7x2Z=1ap_1&WyFGw-5|WC2qO_l#L50q3o5CA#^JsQSYnCe2wVj#$eFz z+A;R&D{sa|KfRrKM^I8GYxIu8eQSQ7)poDHG4VnyzsKD=w_i^qQ`MF~cP84LWe*hT z#ppMARC56{R67w49*-)uL+Be93es$t3uP`nAahoknWA7NY1We&L5wsCBjqymC00$B zr+qEtUZ$(T9&#F^|D#^;3>}iFI}dKG7FWC7H4Bs*t8>bT@JCbJb0!pFRrb_uH$E)% zfVsVJs8-x3nsSZ$(T(pk&MUQ>hbr&W*uzMuJ=?a**Mc_1WIphZS(jB12AI)fI9!mF zk_v$~fJzp_NGl=07!^RH1omMP`DKX5@FQ9ww=4M7N~+X)>9lbUx4D9=!P@LiwZ*vs@!SkuwUV-VDw&cxidp@^1`~`+7|pO z1>lhyA0Yg1hVCGR{OjI+8lB_bHH{mxzfxYJch)l0YUzbqyT^~A4xP*VA8tMRI6o4j zU#KED^Xt>E!)u?_oo3p}Ke$B!}cIiiN>9H}iB> zntln{Du2DiXjOR=73%zBR##Q~WaUO;`FaPTVy4~l<*sLsX}`P=dcK|S^R+K~dV6KY zIj8SExyr8As~~HNuQN4*j!Et%?(~!xmgnX3M0u!t)0kWO+@_H{i=6QOeI&SC>O5Ce ze@Er{pn(B|ms|#QXK>dtRU)i_v!!kn#5O$0tSp&Wl70#=xKYD_-{<%X+)GV<8~XME zqUdkP#c!A#;GcVP$z?WGHgfeQYraKa3YA<8lWjBm@UP*T7{i)e^{8AM;`^gR1CI;b z=cu;bYtC&O)O#pMOLsO!hQEmDN)DL*CR-oF>B&J@*Yb;ZW>?J0FPg@BWsJd<`Nnf| z*RQsGQW;6g<&9G=A70H^xnvn{-w(0!@n%EK;fQh|QZVXO9u-KxCPd*BD$0;J5<_qS zP(`L)!FYT{0>Wa1OE64!j`BK#`IG9#=V9}4^Rek4mTp?#mW}J+YnHjMnNEVz`<<_i zVJe<(BQYD^QzW*}TOWEXfZu+&_5xZ7m|{2!$_d|JzRajV{gHZ3#cG{bLGb(7TH~1> z0_FkNv2AKtGp|J|-L^#^ZDa^J2m|MR{85t2i_bG*q?z=x1;x8VU zt2{KpKQNH!g69&i>s*HN=D2Rx<8nndBxk9`am9JXaOs;W(H%g?YvtbBJj$v1R>AqX z%$FvP`GD;TgzmH730*@gv&MHm3Rl4L1=nIgC>P$+;_ph3?#>Nl_vqS+l;1iv{Yp>}o)_RK zJcY`~+PS$*GLX-!O*QNIv9KgXzkgd2DH_w@S5&vZxl@t%k`j7e+Rb*e?mTJuBg3u$ zHl2Wnl9V9-xkzL811^_N=?&8}Ip}Yu3yzFr%2Lg9kg}R#g8P6+v_S;5EW!F`D*plv ziQt2QellwPZ{6N`B#`<){+i&v_^(OIIJL6>b97YbrKkpFsQmk}yp85W zop}7W6V%y?srieAGPfh2;mGCR|o^wpNkX z&*l|;^{#6t5pSM)d4qoDZhPVHyf1I(y?slYKiID)r=abG$aTA)G_xc-*@3`Tkz9_o10fAqro3LW3 z*@lMK+)Z=C;5>7Y)Q*c@E`CVyoozIy^M@*CAY$G#HvD)cirDLoGpIw-Pzx(t->F()RgInGJfZz_FE*lERIybNf#Q_!9-?iW|UfJ3;arx)o|R6gI{mt1+b3 z-$8%@B}z2BRgI-xfjZx`^d<{rJlN;|dnw?g7q4~}=$t19f&@LU-lSGO5H(~|DDXAG z3t&@F)h-gZa}6+5enWWn{p{&woD%i_ZU*?*)b7u>K`&g&s@;elQigZ zw}|4YD{n%Oc?z#a?LX)71-M0{7iyE-hLMBwL2Pk((HkwDf^>phdB$=hmfcOGhWuLw zhKpf1YFdwO-W59n}+tY zY3aHv?h=VcEWgoGy-~HhIq_xkt`h&xa4FCZxY3!XD@^ZBC)-_#?yP+;%OOVp-ZIM> zbjY_1#{s_w&Wwl(IwQ=Xt(2DuF%O&5Mu&WYWFRDln{VWK(1P@90E1>{>X$2K&m#kA z@k6SicwV?>PT!n;Ze8X4I<5m!L;t9it#*}E*rPn1&ja)NZv@qFamp)Z)k?@md&`+( znp-*ixYCkKvwh^PUJmXz;f%X1@$C_(^{4k&W4Bor)gKV}{|JiPP4UdrU&)&mGUlSc zD}Uy#H$6GVIehsT+i1M?>pk-npqJlSAPn4CB)@Pz612I2^P;ZXzFYBdfQx-T^_Y(( z*(0>1U5T_8GxreBu++#m0|~i?*Im=)`!_x2!+S>v>t&lh?MnodU|=aFw;N%VkG(f( zZS0_D4zPH}(aec;YKrgkR2biLHx6myTpkJMHl^n9;3>YIs663>8ON_@2`-lDhtJSs zpb(T*nyhyDG?jquj8K+h)-Pza9uR;|3-5Dw+kgs{0N_zwj}1Ph%2<162N7=B4r*5A?P*qyW>ngz5PX+t2K_yZmEc?+0SmD3lbMqFm7 zTc=KXtPh+4G?k6J|Miu@k0gCcL5FM1&W`<0Z%3w?p|;C&y!3?!$>1Lvn?kqoS-Iyl#kTNbd#)>fm^c^4qUL zVli#XkW3$|IQV;7H#^ft=B7_BsrmI6UI||7hld`x_Xr@fE8gIiOP4bSIh7ZK?Ol%P zszI4){GSD~|4QASW6pZpsrEHn{|qHhEH@%cE&?!iCT==RdI1D*aQ7{_dE*K9>yqDn zRF9v3cFad1F$C*4=I8hp`KoTv6j3CEmcSvz4i+>+xU^@!?-1TbQ-w?*f*;FXPAa0s z^eOMr4BU6*3{ar2j4<-=BNYJPmgM#C-`47IF zLWI}>j3}LTTgDivLqP|gtS`)5@_9OfP`%Zxm1&saE93`y;Z5{KI1ELw)TIQ=?ao0u zGI!(NJ-cm-xokpfSZw(DrPTnCP64MNY2(!uYIB25q)8ss2EKOS3ab(lc04>49d_0+ zT3=Q}o)>X-y;d>RY{$#5zWsvsdvQv1^uPrItKeGI7ywPBnnB+FA>V8L`r|e2fp2fe zpofhPiH*;*ccNofn2OJ68W5n&LgB$?k3eLr2x{o{D$Vx_PY$wpy?J@^X(~F!D#~6R z8kRoOfOgkm0G5dm0cS@#10ZO7^a%Z`KCv?Fy7caNdO`pd>doRUv|Ca=fN}H9*!=R_ z_1~{}TjVHjh0Fc=s?#sMZ8%_Gwcsp=dFkWOaG;T0{IXzxDfkSzfA>jo#Elj9)Pbhs zw9ve*`+7Vi(f?$e2!D}Ow~u&VgzbFn_%xFF*}IyIee@)TqUyw3PYr>gra|pb#7YMt zQ7B;R&6Y7S0D{&3ObvaJ33AbYUJot;NV-u&Fs%ml=?iQOpjt?>PIf=A9pj=8FC7+o z(60fF!FsBsW0ryF6_5v7_VoQa-a}rpQCMf52`L@c+8{;E5~)#WSqM!vs2f{ay32BS z4+DA(eKhLO4&Nj|t2Kw+H?E>h!cjc=YA2OSOz(5K-z#&HCKzk6KUwA+6%k_BLE`TNw7a^ zY-so;J>Bi=bn$wRkHgW}>H-;HI*3;A$o~bWF+0Y~xHt^ty<05_0-J;0{O}1liTcRAWG=U;$CIg$uo4m^>mF&15bz%~W@?qsI>cMeflsn zap3CB7kHGvN+d1NYn@*XxrRqLk-X6sy+T;4zGBw`AWctg^44U6U|4A z(wi}2+6|Vp6UDDZN^R*rI%u1B7n;!(4~?H)5-gYEosYJkAv5_v=(IZ7X7u?L>9B)) z)lYU-$eJt+N7dzrz zd9Y#me`-VELTbe>S;bYV?)hWMXxc`-|DrZoWhmYA%!*f>d_lC^d6LQ z8OY_!emq2By;p4lT3tn4IuhxBiTh5kf#}Eg>*@jPp#XFst?tBdn>{!@*>xK|9iZe6 z?&T*u3=Cd^SD?aobHD$FxW(ZAN~m8w48C2ztD9+@KW5~9xom4fRY?lM3z3>TC!^i% zT88NTGKlLzSL)E$&Ngz#i-N>q?Gbk2oBvrNzF4*!MW+b(o}a-fQB7xvswr)@~Cixe#635 zRBxZ(%y}pN^XsNoAK}k8A`4xo^QZdqcKWQ?g+FfRP_A)~4AKcc%o&LmUfbH8Y-h{= zr#({p{a`j11CCW6aq%8wpFznKM~^5CmgPPN7%mNcq&E@Y~h z$mFcc;IwKIv3>;=U1^$|pjh^*#miO9z2?5TV(xmfwdN&Og{;q2ZVR>z%RNej|LJ1^ zOdgXeOjyI7{;*$&gAGp|wAFfQ&$l9mk6S7=w*#c#8*Y!bl&;$DJWL(&4jb`2U?+IP z)P3LH-;>aJ?1%IPU7ON|^fV5innq97v}pM*^2FyiS=nL6bUhvq%nm7*7x7nN9!zRV zch|fbw93(KTPQ!!tnWKTHYg{jzuu9TdA$2e_PXZkT*kgnpHi%jp2MokJQ{`-lIkJOs0nl~O+SU##+cS+vf|CUz26_r>2^UeI` z$mcn;0G+4nWgb18rOd_gpQCk`ay)l)w%OrcSGTs;EJBF&A5{(CP&(XPys*72!Rj%e z7@2Sk%p8De5n~o2a(8$rNl3s(OGSj?niA*s3Z2U<{G%iyWF#M>w&VQ*Bo6qdz9=TH zBB%br#m@gU+CkxC?4C=AeEj;MHTe_2W}N=piISh(6iaBTG6x@Ac{q&YardE+2sa)Q zY@iXPG`kpSH=CDRorEZ$XzPi>V2yV_CV-D~hsGpc`rO+Gp?_ao@P5c&JHVV1IL0&48RN-W^I;|9m1c3h0N5B9Pfa+ux@u z`T<9Opu8c(3Ay6JCjPfyqQ3}b3M1mH66p3{Z6ZzZ6?lR3;&Q*e(!YHbehw_xj;4_R zjLDz7o(DTF{`qIdzkA~)T>yVoLty3K$=uHX6_UItc;RR-|Me~49~Hvbh+dKq`ZMx> zo`Ns=3SI#BZQ6r>{fn;(jE(8!5%=V8_d14wi$JOM*Y5wV3+w+MCTB%FCgf;t1_(=_ zJoxb22N{S+m=WD;1d0kUXhc8}z@MxT^|k3>P5d>*bol-G9y!@M?^+rZ%33aTmQTuv zzaqq(N6y;s;@%rD!kwoPH6`e_$^aUh@v;0ibj=66rtKmKQWQZNLcWZ@*-q=PWm#~^ zdaXgJai5%u13xJ+#|G(X4TxZ*SQ44ID)%=utKtPW`VEjK>|0-A=uhHNUGCFy%@JsFZPg+3U=aPi zzk%Xkm7~L2qeDrd&k;(m$B7Ii4^<&}YN7W=0rMFJTuF-xHjTn`KosAmgsk&=W_{t{!b&5pImU%A4}MkF@fPD&F;c)p!NE4EPOm-r}7IKeajo z17ZCnr=%e5nvGzs6#%Z%3_xrB-xbJF8bQFf@g1!7|H~!xy|35Wk}%PQH_}s}oPA#` z-ec^->l;~q#B#@ue}oWHf0H1|9RL8PD8O>P*x5SA^X5%tthehP@Mk@wda|@3n4I|g zu-_XUMV(l=e>kjxaG;y#YDRvH5J#Uno`wTRZdQ7+8w8Ni$LuDTS($F5R?+RAQ?GwX zJ{`4z00aH$G5(w>IE=sM!`zKVh6ObWhWF!xPxkTlj>CHp!QjVoDHakU?9;@^h_(3v zC2-t-^np&?dR6uoBh6p8$j5Qp-cI9s)a0n~aG`8HW$D;qU#$foRP+qsCJ%4&bA!;s z5bG7_M~VP-0;mKB@e*Mp*-pm+Mw#$0W`rSQ{-Zf#(!D*U!O1QsaR(%QdC{D8cn~zv6d~=;?DhAJC`opF-CLX= zsUIgl94G*oO22hz*q=y6i^F#B3oQcdXV*BMf0c1H9=9mLexq1~D61+aks86njY z;>&9C-C1fDV4FeTCsH{}r7>P`=Tgso6A*NwMR;1!o3UvGH2;%-3dj8(FH|hSMXq10 z3NfhYAmNb?b%t=06(_+?dM|zahj#d39Z2VdO6px_W`=Zm01|k zjanf4v$#Y=aPRFOXl}1O-hX5^n{j5{?j$xwBLifC49R46z(NEP;jHzBLWQFV%osxP zJlCHFG>4M`%;$gKV~9Q9vCYzXqp{Kh$9&{Wk>}AJyv2_Itf=Jk4Pned<*-dw(uDUL z^K@r>a)l4J-U282_f{U&Ilj&?t+emj{N^b(kN08))rECq!gH9RG63anNsGufKFq+Avdep$VVlbryE;WqdKqUlP^U@7rYA~0SE>|~gcW$Izo;lW3N27%uu zv_xw(>dR@2Q$sxmsb0%(=MvENkd3U^a#ZzGK2*ii4oMcgTY}iwFeY$-%2f^oT<$l z3}~mjDQ#PGmJd)We@p<-wFZCCnmIlCk$!Are*4Za`EqJxvEHZKE45vmrZzn0J-wgd zC`^VU#;-fg5`HvCA;yorc!*BdZTVSm8z8V6e*_70%${W$qeyUD@q_GL4JRw%e~y_^ zbCkG@75=*4RDVe2SF79fIS&P9mi3lQU(n-W*bwL`wU=B`0@7rOav~(KJ+yVp>@v=f z^R{pb$=4#M1PI1|97(~zIwc9z;QevGzibU03hZ#qlpIwx8AL}ve6tJ#nD}nbe#^DC z2FU#EkAEdFC+q-VuoN(@1qNLY=HIu0s>6%_ELLQxl^}W>#R1&=qQ_9)I0)Dl+FY<# zm9@nR(DMyDz1;&Lvv9~{n)U%XoBa^93`Hw4*QXOadvh~HU_wP@e69cHGLIS`-)Og9 z{n_ORSP}nfL>%KWbTvlEsOxcpuD!db`rrW7%&pupXI0IO1-l~#r$+aj_6bTv*)V|g znt1mC#a{;_@`CE{f_y-CkvN7b!3}`ohDxp$D?lhVvR1(Y7eGO5seUPmHA(H=gCt%e zcHPQy)<~tlFA>)2gsmZg#Wk=L zB2R`rbyoGvwK(W>bOQ$taCyXm1S=N;e6Hu~gT3%qr-UYXEAb4KoM_6jTjYNtCtNH= z#g$!lGvz~vF_G$40G_^E{n^e7OXw~tQ#q>%6i24NpSiyfwG6z3MrhG#1Xxf|B6?0J(0} ztuN2XZ5D?FkbXV7D}{yJX5iQ9x+VGoh_n$3TSnl;*aAijv3U10?@Iw_osgw8XWV0N zS;8vD{bf@OUmh@}hDib%i^JR>VBm|XJP|@*G}l1X10Y6P3TC8u>vIejX-0^V|mKgs%l>aDUBly&IJbf^AuBF z*ewlfpFDGsM(hRA)$s+}q(S#@kBYZ>OaKPkS!kwIwIxX(yGUr}X%Is7UX4XjTo$)~ zU56sG3JI?7y}I&Aa$~uk8o^-)b`UUdVp|hL%sytt6yzoX`^9?Hu~u=&;V)aGp!6GGF<8^EH8Nyl8S` z#;#3zCI1)Z`@-Y)?w?5#%)&^QGoxG(dtQu~o!$^Y#1}vM#v}|Rn)`yly(~n82nZ$x zA5R4g+4pI$K<)WioE30qK%^-qSkBE`Tkp*I%oJYezI{%ulSJ2z78{T1j1&8P!-6gE z|Hj@|MpdG_$HikB4!Q zi_p6y+p+4zaHGf&5c@QNyST0G0UR^Zhba%UIt7>^)ZXN>zUgyNdQ(_`)?(}}cn#oX z>Moy1#9Gj_hH{8^Zi)?xM&1Dis)De716~^%L<+yMGzD*ZY?`Gd6V}ARJ?SwzzEjMF zdx~23fT#eBoAcaM?};6sD~P6Qhu6;UD}?J*suHZ)HqauQ$Q`(r!t(C#pDb>4AeQH& z-fR|q*_^Q=uHg_(yKndLu#J{Erg}loHK^2yMM1lBjS(;>>8b@iJ4q>FM);32cP}%` z^*M07eDbFAp&c&XgfqN2%bd#fAP)6h78owYFv{cMdZ(CHT|c>p8uif*=X}BtlAd-P z41a}sUw^{qT~ky_A;R1`3{B`+jYNgX@|xx9WqsVhQkqkXndLdIP)u9Vh%XmE zXL-|EqAgulVWTOXc`Zo7exj6QXGkhBJmyazR}V?o;GO74hB0`Eb!66MOxgz2!4;P3 z;Ve3YacP(1$sv|-lo*u&D6nXLwBhWm1BJVs3sCdtu%vF#_gllYYa1h#B`C-Yt+9^S zKvHvE*4TYTI{t8f+jE;j*)uRrF%6ZQ9?z|-F;?PkaE1I0e~5d5Dq9r(0;~NB^~>!l zq4zG}u8gQ9W%2=S?Jt`fX%&9Er!XAy+_@!Ne65@rJy!DAEB>|ACum8t>xY6~*fsRY zSvEGTq}kS1f9)VYp1{O(=#BVAdBqMq*by7L*VIVUswHE#05ay@a4kNI?z>1op`=Vn zHV{`QZhb}SjE;qIUBsN4#U$@lUOn2kj0|bvs(8@-@PjlX)RWLGKDtm%80@)HCJQ`( zDWCjdKK9!wX4-K*HiZr4=)%t_DdzFe4T4LZrbM8+6iRj` z-bsOS6ph;$mr%Pmw$-~b-Rzp)jZk*6C_=jHT{g?i2Z882S!Qn)B5Dp=zN)=fHO}#G zKx28bHLQy!3q_i#RhEy`K#W@SNMN%*FGM_7QsjypS~|9y&2b= z-Qujh_s(Dn48>v$Osoa<@!m@&t~985W4gP+>n!a~hI~xR`>RO}16SX6Z5ul3E-z7L z?5{m@FKE@?5{c(sKE;_mPbz4k?CkD7BfYMHpSfryq9)FC}VZb?B+xu z6;8d$;NbKU6XC#lO8_@;Yra1(sdoPc^j;tEBMmBx+PHX<-2NBv^sv#DBcfASfXj$*#) zwhCtOZ58N<-eqB0{Xb>u6RdFmUNK)T-NHqP&J?9jw`G<=<&$sLd4ZK-PCBdW5El1q zImE#r-?)Wtd?_xCO`=<3rbqXvHAFnafu7HdrI+yeQZLOtD7Vuet&x&90#S<;`|XeE zZ2UiElcS$UZD_PFPZ=Jb+5~QuYk_i32zK(X@mXLz6}VSM?38xtKH^4Vf6rQUC|g^E zm0=|?_Ghg%n9yH(JLj3_A=ic2!X<#q?ma{}$7BTj(l zHgm;PNe_FlrG>k3OSC4v{zlVW$Y|KW4K8`R2zK3DCr`V##=LMuu)nVmQa#3ImVWQ` z)4`D2hf;%HFEm^dw?uhtr)ZlTC>_OmHzW?{6-P-Wd+=TjUbF=$qH(6E+X$rA??6Js zDISNjIN54(U6%7EFY^MkJKSH*&HLS9gg}({PFx`E@0>-*Mo&5Ugj60C-Ja^JGx79} zM+F}D>kf#+@8^(oPwtL0x$qH}EGIigNM1lUKq=e@q*LO_Qjdj|Fh%ju3wMHO?Oj9z z`wsiBiszLxb4M||4K!uWM_j(r-7eK-!YL}jirt=+r|)a2IVoX!@FOko=#y>8=90HD zI-V`*TMQB@-9s`%??|tVtUgqe+syRkg^2BnmGYLF4gy1n$1j1I*cLVg?3^}y z%H+a1u7cY0{+xzQ5k=bI(>5<7OyNs@9nQ&fHyx61T1wBlY~^89c{05DaF^r9rG8l4 zt}9nzdpCXAMPLIHZHxC4+2P}n&^k!1=u0x%?O?6(j(qRn?n`(MbMd@VX6_h4w%;8A z1;f(rV%U;X(}lA&^VLaxNr%byT_)8mW5-9hJp^~GZNF7$P&h?_DZ5$czlF!9J$~Ev z(Q%$xBule|nt$N!h#^qUx3*W1h!-#+2_4^+3e`KYV|#s)7@8h%(K^ME1FTb`_>9!F zplz~6HTA-9n|LouGNUO_QqdqXe)x)7W@It?ZUP}G|9O3#!DMW+X%>5AbZqOhqG-z% zs=M`7ZctQ<#Plbsz>MNLbO>R!>I-ul35lICtdf;+l+dC54IjS6i&}ZG+&Dhdi)}d? zWe}F`&D79O&alVuU;q7OHkb#g%?HUB4LlQerkmCjr%0q6!+fhZnA=C zUk$ETHOCh2g@6vT*?W70O;LO|*_E}NhzfkG$r{MD@Q+z8cMj-{ORc){vlwz zp8Jm#KS#1XD|{9A6myldX#1td-leFzHgPZjp}~YxjD6Z_Rxh>t#65SY7Df!!`8*Tv zV|Otb7L(oJc1qXR6R44x_y(((pa*ZS)?2zh{T`p=2i>q%BgZO*F8}bgN8&7 zWzpl{*bwB&=U~<44YC_9&d3jjd`-l6oO(ZhHO_-HJM6moV>5Ff9X?%zyP`<-dE;NT z;k%5Adwud4|6lw9arr&rTqijif^B8f4F^h02>NdLA9MT*=P{cN5J?zAS=2gI4K{;O zO_irYC3bJoC&%UR_j9t!`OPy90?At|{Z*bNYJtwRw=3odp;o4wyJv=Vu=UpRQWzMN z)&vV@wJ2n^$lFx!nv{+E)Bof%@V?I~0wqV^Tm-s=75=~pldN26fWwv=<9~T$D%azB z5-fqwz5N?}OxuR3d-V%Gm3CML>(#6r%cAO$skzX)b?LEyA~w!_Pmr@Jn*9k%pqDgZ zaQ)sR&lo(!@5SQWQ?wF_w*>pa8zA?f=Cy8<#BXs*s~@PAUE@UErL(5hj@rYzPgQ*kFUA|mbd z$*2yqf&7%-Z7>P29B&F^vm94{5I4~DU=iq1EIWCQ=bB-N*yV+$t7D(AM?!jE|IqE| z9a}4978zip-k!t{?<;9Ln3r8Ptrh;XR(m7FbM%eFytS%D`)i$$&7So?iK4r&B}eO3 z0Qc)SV5h_$Xw`-~YS(Pn-p3DQtzN6WUTFc9w3Kkms8 z@6l9(_R9wK)7?O|d)Du@6s5Q95xbRQYM^8zQ3r=MgSAsUof+x!xt%uw#V2kRDRITh z`*CT9s@=LzTh+kEYRhINJ?U zSU;(A0FJkoie+B}Pkr&M@u&zK32_?^iCs$i&J7RSKs-aYJqZN0Ss2xa47ITIo^*PN zYhyl#DG#EAMhP-XKBkpK360M-neid(5(?=1k7`!#y;kg-U?*Srb6)bvR=8m4pG~X0 zg2Q|HabZ;V%SK*E06dM>lF=;DNb&({)vVyu&xpIsJuDaxSxk`1*r&_9Ui2R6q^EkO z{L!oOMvxy1j2d2L1aNvIPN!+bfl~M5w`w@TGp)58OC%M>UiFBzdNJH|kVX(6`pnIu z2V5PdP{TdLF)H@#=X|EIMW7+=%f`e0K^nH*D+}twA!JOVEEX4}7_lw#gPxP#M;n;O zlU}K#XsCT}mhbBeqkA0wV;y>t8gRCUq0m_=hkF_AMT>uuU5Uu<<00Z8{NQ)ErcI}S zt4fQ4*U?Mu5}R1CPa2+61~Vn;!%Mt6vLH1-5TG7{`Vp=4l9kUn*aejYN#9(FURZ7t zZ+djj=ZT(~pIi*U@S2W^)AdfXEzJIOjciwqv1JZ+gIwdcpR->DaZP-shhO!`M1K>X z+1hPuoo~(Y#%Q+(qNPVdTD?h~n9_1)oYvOYidf;5`E8hZz9OD=&Z_qC9<#V-mK(wy zyE_y!dNBCdk*@8S-@Aa^zQYX%Ar;BP32(@rS!8WjeW=^(4KoXmPGh@r*&iKS>#stVMC*M|JwqOp08D`OwCNI|`p-^|2sct_{5uJD+lKT$g>Aj zZJICVd$d|AF#BTZ(sVfKo9r#9p${LEAg^<`!ele%>SRpR1jtAw9_j z9{JLYHQ;=OQtF-SzO&bs_>Od6vyJbJF-{%EfYPetlzc zsPyROw~UFB-e6oJBg4u?dS{Pe&ro0c!} zuVg-DamxM}u>~UPsXT0V+#kN+;@w$6VVIEKBavG$*v_KlVTpL7vjL3iO-uzt7z;4V zE;I%kj!|#^Zgz>IwGfnBgpn2ay~rJPNRi=d`{%l?87SvOV!Xeu8zdF5jl7kpy6Wb)Ptd)w}!8!eiej3e-|=;5rAU2Z`_ zHNn2)gMR5euux*(ebwrfC9QkS4>L+~_RJ!pch*yrlV56B=xcK&hM!9-i3bCvM^INb z1*s@1%vpb1$LqR2{A+8F1RSFInP-di5x>*PCAh}_P;3A(D1v&hEbOQ3(WP;bn2AYC z+XQqb7ALkRjJ8)Wey3T58f*zR@CyzUP8J-EjaGdf;vWe-p-XY*(JvXM+bQ?z*{?CJ zea^B_ReqkZz=-ao-DJjQVS8@OxyjSz@HWsE%E;a$4g2g*B+q|G=~;bra@;NHix)3q zU1QtCwwJ;x+Qqh^XUxcK40@|9zM#)Ar>fU=#A+M6GHRK6TH%%yvD0)>X}Dg+qKB58 zjJfyn4~*LoV|Dp$NBgyz9Q67!)w(e`i{w+uEqpw_dQK-t~A>u{|o~C1G01;CAyI0Cm-I9OY4_ObQ620 zF2;3QqttjLH8&?~84V?Z=d-<)E2+4DKT#izver7ASL8wzVmX@QTrgw5b5V(-<3r!X zgrhO<$VlHLM^s^|B4Zg7YT8mH$1Z5OCjU`atP{IV-{Z6^&;P)|#kiKvX*w&%jzQ5Sj75O&biTrAS+g?N#QrdnYem-5`Tn%n?o`+~tV>0ez#NNU@A)O_KH@;v zi)U?W_D9farIaZdUc#1-`q71lJKjYA^Vour7Q4m$2Ct-b^b?Do%G?ZzK3m+WYT`GW ztC&!L`=o+8LL_d&QufQDr(<+OBj0Sv>{-SV>vDmPO_3+)F55lUKZ1Ja6OsS)!&Sd0ADJ z1xp!y!&G6VCl`WPBCuWlAr{5!F!f{Dbd4-%+GS-bOz|{SGvCSHgJ@R@JW^W3_#R=( zYg2WseqByy|M{y;HBw@^iTt~E&$}CLdIYW)bvwEqnuSO{C+ObCd@ksUycA!C<~S`U z@uYX){7u*wt`Tf5c8O%>d3iO$(4Cw`$==tk_p^ikebxvIQc17^(TAhIQcypESsWaQPM~l%@ItI9do%FUmV;G zGx87LH^gpJ$&)T`E_PVsf|tx`sH~>*Ym;eIxT=(;Q}5(zFGpLQfzsWxTop_CxxemX&k0Tzn1`?4dn);u7(Pio^Jq}^ zD)Kf}WWFXQe6a5(@=YhqEb7%5|B@P)KDcW!FKuOEUcC81(i-{wIEnxGrUUbm>u)s9 z!-yb%09mZaf6}kOjo-0Kz3`9g|9YUme(&!OsGcS7NV`z{h~gjDKTyE+*GX!B|K4BU z;CqdTz)Xc==*vH^Hxt11@5=1|zLVqMkfehBBmL#F%0I9FYoz}B2MIyAxOA%ZF4z9! zk&r)>a2>8Ah6%94^vLH!DM{&`&nuK)kx|9?OHdehh9TD}mdXzPJBuRidN`rrnt4|zm= zaDM#+nKk`b*!iIF^E5<#q`=n^!dBP3z1*UUb?Dc7PP#t-Py~_!WbNYnR*_<5f%I80)oX+qV0I#DuPCoAtR?I z%XtFw0AxT=OIDi&FuD*}W|x_WYcI!US8sh^bDG&3ijwUm(OgUtJ)XK994rZ)9ODHm zcu<))k_#eNznv4tgDyYL2fP4l7VqUyx|H9tKHuxI0!=XN2F+71`2=!j z3VQ9V@|gULv}?Ya`T`P~XQ`cAumBgCP1<6f2UP1MtKnvd7!Q&|NsvhJ*} zzNeTXcTy_c64-Mp9cXzCr0rdrHUZ#KxQsaW<$|^~_2dnM6VSxqq0nrMW35TFH8o@t z)bd+p*p2$lZrD@?U+JLg8!KioTutPO>{RofW+&p&>Xbf>tVttH=xsH$k>tvFc4w0L zh}P$5e=I^&SX>PhgE{YsIeS z3be^k&jl^oYR2)tWI$&ZIBPxCZ(L@$hpfsGw%?&)D+R7ITxVZODACxm#n{~znokb9 z4Jj(AO2$24>)5j&US|y9gy8GzQ=D-&iQRiIL-aDM_ZG^E_%1()e4B z>efX)_v4Z@{J^H42*DA;!zhqf_yn=pXX?ycT&ZRns?@7mRf$t5x zY&z3ydW&RmMbqrkVL7qtCiuNoa4d$vgzvGsdCG@cd>XCXT1Ij>?PNx2 z1=g47Jy{7=_VzTJS3neb8g$p(s&}5yJ_lz3F>ua>aJxA-m@yF?@Pg17s;|-F}r7zlk>3Tyi$R&Dou(5j$ z(uAgNF!jz@(oPdE7he0Ct4jS5Ig^y6a929gJ~jR7`GspQ{|e4z_HEUJg=$C@it17? zGB|bIN}*@J61-?#&(AY)I}uV&q>x~D-T@C-9i=49$UuQ98_^)8^gRakQ-uD`Jc0g_ z2`?lcYoodp+<~yU+=~-L%y%?YbEpY+)v|-<*I(h$Qv2RL#u4&FrBX?kQ{_`NDX&zw zmK6!Ny4&B`-m-ysiWmwS99J^33=Q|!0vc+q>t9m%HTe&l_P_12>40sZr*G_bty{@R zUL%ucj>!T1S9m~F%mcz!>Glwjl~QSq#KJ%7 zeu>{Fw$5?(5iI^_=Iy?Bd%jJ$?eziXv2Mzk5Az47f(g_EDWNY@)>-0BAY;v zAD`jTc60Ux0AFsDx>tSj>W43|&AC)(J`{mXxoPBs{aOP}063XmjAG=sPq#7#1khXjAAwto}0O>|isEo_h6%DCAYV^@f$S)E>$del>UgbM%ZQ zcxmy~FuMv2+tsZW<#=<3KK@cKSiKg!3ObXS-T|}a;>De`CTNm&8zk!N&dmxX8_);j z#Un+rqLJnLBB?E?Eq7t=>%}QD>+g+xPic11*Fp>gQ$_JB9bHd>%V*)UZoq0idVbEnbglIYG|eJ|C74s!`Pk$x2|EHcF&uWi zPfYz_=jV{9ZxtBgh(Td@cMD^S@o9^#lTRXltUC^QUAAqTLQ=RHnfdqo!6Hq{E7NH8 z_qX#{%rd-eQqX}mZ99Nh(l`iFPeXo|R08CrQkC+9fU0wkQ8hc!!8jR;z}`A>hEu$H z8&25kpnu4?*<$)1y8%Bt;Ln0bsgqC0U%Kkn{~75b|@(a*qq_z zPUs)xrjM~107IEpDcQX|xN()rnj#BzdjirkEV<9Vg55xEB(LG^@jdCaw%4`%B5Fcc z>duYWFJ}qXktpV5BY;&>5KyPniSkFiB?vv_NNfYWtb5OMxjZSYmhsx0dMkCBFi*kN zhL@)^^v>i^%y7RAax)`e)IlSPWG%07hLh`o7aX#DY?dnpBH2|K6LrV1>^fxH zb)?{~c%vWc1PkU%9(>yeVb%lkO6ZEtUiph(`PPN=UwOWrzm@O_&!%iT+-{>)aJKOP z1i0ecYLp?%)At64_4_Y}5*=?PlK@`%#eK`;t$jgjo89q^wmbI&_t#u6c7DR{u&>-c zYp?3<#CLu_&xI6EKan}jQ7)ik@mVAzcK;LR` zNNOzc1pwv@*E)mAerx<(N`y``ddOV!ss50R1-aQ-U)WX)N2EAKKig?1xd^JTojU9B zUL?8JkTyKyGek--(WC&$(lxg!cj2zR333~{ABeb$GI=p`ovigawbnhV zk2xO*)Qi{oN18mp_^;qXNfnl6x`W6QPNE0V0-Q0T+*g9^@f}_xlx>8sGYNli=n$ z98 zAz1Jb(F`VHu=|P=7*_)x>-vzo(+6os;K58ic&XAMTc}bgtrf1eSv387X9xe)dEQ*&AHZq7r9v8n$md1~(zx z!-!*aZH^Bnqc+oS+>gc|pykDNi<_N2{zXKEfLd@H8>P_v3rZ-coW;w-W?aK?6o$tgC4Y6VV9Fr)?koKtJ!rQz2*K*s0&sSnS zYQ-W~z`YUrNpzfUofjA!Ut-)oEyC1yHddo{Pu47az#tni%R zXb>UjPgv_^uT1nYc`hl3x|sfq47Fs#-pL$=Qzb!LUp+Lig8&DYl&!<8Z_Gbh@5E)~ zm@7ZK`s1FqLdLD0#IGQ)tAjAfQF{!KxrIH!9w0y8sIzv5Sxx3$<_OwlA;;tMq9p(E z^eb>=%utjS@1^)gd~fccni2W&oG?z`Saw0rb!5vSpR<4^lTF<#?t2~S$V?Z`xj*Ds zwRUp_;a6TKsUW0=ZyQl5);tn>-ah(~a0;KRZ0cQZ)8*(F&^XZ#lwTZ~ zh3`;N?hGQxU%n0B!&TqI_viN*;JkX~!karo_?|VlSHsdTHO?bFCVk;}YUAT;q1a!3 zxq5u}O2#;-liAlxyZ*_8#L|#=%vFA({@0BB^FO}Vhyetg8=n8?^)|TfG^#{=eAoXb z4J1DxJP65((?74z!gXQWH2mYc_}8{7nb3^zASYdg|9O1_uEz>?;~qcXUyB6p0q!4o zkmn+d|G54y>g#wh{=KSz2gwJ%|wxe|HP(WF74 z1On-Zm{&ouS5iJ{)d=z%bR%HlzrsqKZ9)I|0&2WS57e| z%;kP{?-DK*)sJ78k}Thb-*@zRlCt)i+1b8UJA`W>cpwRh7nDt_+ZqoWC9u2)*zFqb zo6V#G{VWJVGm5=`7L=iUOHgcf={bADEN~Bh#@N`^0Erh6N|l$Ymp{PSGQRDcJDA!M z9#B)gVSg&bMZJnh^k7z^$o-J9c*SFUnM~aJ!b{zelB&JtmT|yC8lO&}IkkRmR#mzA z9atE9t=+HI$Bm^7s<|>iaF*!7QP*?7reW+S zSqA#=42OpuCAu}MSWmQHdlYtY1sw}U*nVM+OqA4|dv<=f2)2ffIpiSNL_ZZ~JPKgGd^ACgelhoE z8PZttF#@B(_JCa3o}Fu@QqwR`vHONklW9jI?e)FC*9T{7SStrg)0%NIQMYJL~1@PrYeQSjNF{kX{DHOOJB&N?mXcF~@NEBF3|!Mupk& zC$Bz$a`q(+gBsKJxU!O%vnJpBDh3C+zg8cbykSuy^qp=A3)#Rd>c)ypG%xQ%bzJRL zHYS=0L$cxpqTHP9k^-1O2^4su4!;NrhFJ`?a`kQjjaS2|v;(@{i!zK|wpBe2^iEn~ z7e+ZliyJWfIxuNgq0(+@^gc9=jNySTXLv|DYH2=EoXl1UOy@PTYKr*rA_qzws zR&i>3Qenxnaxz&3MR}^*?U{G5V#11G^4D52>KA}rr@mvyYo{>Vb!0UDt}|7!uDccO z-dvf*8uN>2OH?eSj+>2(+xV_&-D1umKM6EAMK!#M!L#PBH?(|qr_cNF z+ae^z4*Cd-o-vx(kibq#)Q0$MCJpaV1wMOLFASD%ZBY4O2f2Uhsmrd09jw{DYdT%H zZXlU6vKepB0U=1!{j6l@5)%8vntkV8n${%Y77~w)<>JB?*1Ed>s=Y)Q8;xDol{&B( zHTYw^T=$^-=Et2%$6s0Fi5u-CwpF__7ixHT&9aK>uBOJG+mcw#tzF9BLRWb@?6gPQ z{_N9EG7tSl%%(-9AT-nArIWOhYuo)%&;~Za?qcAcEIhHB)shK2ykXB0sa!NGdW5(x z?DpjN@H2SKeY*7gTwWe+n$SX8(rv9P1#URMCc-e5d%g%wavCX2t{XcX8Ka_M`<15) z(A@NbEs!38PGXn)`zAB#9bqW}`J@6t zWALs{2MH!*vVU9G&i4H4kFYRrBvfeYjI-bj3J|tZAIlz|%(6U^u3^RaYt+Kwn z?~SU>Bf$UIzJO95-tC?HmL-;rvhvWF=8Oll-LeVO)t`Pp(izei8)Gd#!l8!E5sBO9`+G1OP{IV#WKCbO-dvsUoGV{C1A$5bNEZJAa277CO zONR~(0T9C%sSR_ww@Vy(Me^w1u4u2a8?RM6LANv{KmP}=^QBy~&VX_M#cYMwS5NY0 z*SJ4a=QpnURLU|(dSoxVGxH{z4fni+*!E^_i_O@R^LN*p*y3M2ite3OU$3$K8pI|t zv(GmB>~bKbsVK!*v%?|(IHR>e#4vX<#{z} zB=_-6L^o4EKi1^F&*1j!s)Pb5FxIcXy$Ms4AI(}_5!tAv3~4pXes>h(*0ei5|50(O zYfa(Zj{kd^v3|il*QaZgaEkaq7_nf=6`Xtm7i4j|6KQVS4ZMvEVL#;L>Pupv|EG|0 z%+_E(NCE1vWn`Wy9(HK4gOtsb4h4kV`~K&p-j$eh>r@KG0H!_9MKn0bdbPp2S0lr$Wpl7U;OIcFbS6D;R~Sq( zi72xxx$4{h`~E~79!fZxUt}bA1192(Y%suu%t{CMBMyVAQkzEIqrE;adXT8Mp(6$Z zU3EqG=8^)ht$oOXB5)FjI8AoI19RQDPuo>{g_Hv!*~D{1Tm*n+>j)LEZ&1)2>M!|x zAw+VLpz`1sao{%_p^28|a;%MzLD=dHJ?A2G)#mLMjMw-n;@TszdFC^&wZWF#`#5HN^PRu$>wq_r#OODat6xVH zX1#*&eSyN$qn|>B=1`PS-1d{R9C4=!DAh9?XT7@C8RjM^o7ttUN%FwSNV%gBo39ua zs+howH`A`DgF1z}>K>t?Nu*2nPV1m-^>lE7q6B{>c5v8>(*9GY;Twso@!3VOt;PM< z8HNhCWK#sTKD_HbPI)+$z_C;Ac`~L(6MteN#&75;PSayt>hPjs-2(wY;qEC#7R$}A zZ1HabN~3HAVc}6ZN>HDV0=VWpX_s;dz@C?lOtPQDPg>j1uFDSQzFhjl?G^?m>jrd!K==YLqWTnehCk*a& zl1-W0%9z`-K{qa4=oEi09EMI5L zVi<@t&W`D??JaV)8%9WxkEuN@&4O%`U(;!{ZSJ>|>>OI#zvQ@`ORG4Teu%#+NL0j2 zXUlE-&3#E>YfIDi;xFqmeka&jqFGrRaDshLX!<0)aaDme#CiVYg^4}{s%MoH51-U_ z8=W|067zVmqgu*;gvsN{35U~YeQ93Aw~d&DzFH?SbVgR@%*RV-at@1(gI}v>=^kx~ zT~|+>FXuMU-F{^C6nRiu2zmWKTAZ+!PuPiAfK=-B`Xa_=LZ*7bPy~4gnoL^iMwgg( zefC4PoSPp#efE*85x&6s$EzZ1q$~{~1@(QEyi`opc~y=^Iz25?r9D!woJ;D-4y#b}qYz3VlnOU^RiS93{y zL`}0usjZsYlPQE3ofGJkZ2VzFV*ZwR=UP{oz}7OvgH z(gLsDbvy7xdI5$N;-O<26JQvjdA?#4HtWZc4(IR|G~nJA*}fwOm%r|?o%|Eqjh7gM z!`kJ=v0?rQ(e3!lXH6oCj;g9$N&ObhVw^|s=+~ebHG1=k)C0Xa+oHr_^Lr|3i9`bO zcXa9qtSXj^KMAGTBOD-71)Tg1{AKIz&}hF;qa1si57zCo8-H`6ijA=#?Gr@&+yg5o z>LD}9h~Q1>E#P=*desesrFF8{`up}s79@Pz2(1JxGI$E-xPs$#Z=UA>qx(I2n%&Bo z^!Q5()iO0c`W1{d;XlIe(&)w8B)vf9j)fc$(8V)yw(J}okQ3&CT!C~3?{9M5*r+YF z(8!uD1(7WBNFiujE48Ni@U+nHr_w`^osprvVe&v7Tp2FZ++2fA&mU5Mf*jDe;U@dG z`+Q2oie*(gfxAX$H?u=bDHeM)>N)=Q zaEloUPsOvWQB9+ZP3Y|-pUE?>corl`CMUzO-da7V8hb5RO4RTYci#1Ae z@D06>SNsA2Q1ZfUZSVAb(O$D6$JB%Ci1Xv>2t=lf2<48GOa6>5{pVe2WJ!#miMyDV zL(?UF(75lG+nWMCI1XbhH`P#o&NPMssykO!!C_^#1%WXFqi&NtJ_kEmL;vD;Uw!+4 zHPMVRUL*F;1QLLCCcg(3t0sFL;AW3pj6pX%* z><>;-oUQUt;CIWdzyCARY%CKFxvg|bc4)5w( zLHs4#EQJisjNK(m=b6oDP*$~>mCH@ee?$@5Rt>BV_PV9kwR0(md-M$sOhn6b?f20) zYuqg?nxq#C@lHaWqLo0VmM-uwMG^rrN;tkyn-Ku`?;4V`U$)>B_gDudNPxV+z(q_c ztZ9FUvDjQ2Wi3(?pY6;wLo=vautzxqudOKY*WUg7oSa=gI^1O{+UrguJjM%B`kUBO zMT;HQ#Y4Qq&h5|j>pqL{Sus-TjqwV~9`hY8fHd-N(0Dw&fRh{1z1_n}c{)_m2a-7+8 z10u(9Q4^`t)`w!T^P|=jV_Ij%^nP`6V#5$Iq8m(vS`chIEZQTic$u@%gsDBtr~mbT^PeS{TvRc%pz-mA{Ub#!Zyc(}MbUpCiFhOKCJ|CFGS$VfiPy}uJ4RH+5E8{uDhZ62jP?fG`j309 zil1=!$`Kyj@!RXU+!2={e&K*)L~4Qi2z{u{6-l93+K`r&;iAL#mvj#ce9E|puOulk z((+V4-g~PlksS;b|`Rv7y;eX~RCLuA(*QP~p z&PeniR+t~U7jp>am%jN9DI&FiB)*Hsv7Bb6*JLS&=pMw?&!eaEV9H z{F(gm?S;qJcoZs|AcF_gd)8|ABgLM(w$8{$F|0gxt+(`>56Sx4pT0gm1qiwm5Sqa5 zm(xe&Z~vQC=PQSi{(C|H`!XO-I9=&t__UE^#eaMvmi+!dU=8@;EQM7f!;Et7{VnhvEp`PM=vT+o{!xoF*W|%U>f0t z-Owd?-itL*&zN8AV0}X>7KQcP`@*)dOnOe3!>VxY@~)GotGN2AkDJ-v^WD1QVUM8> z)Yq?G<%1$2t!`H;_uE9MM3$o<B19czZh)U;(;*467>I)2%bq44@CUK$+|{F~5^ z*gYon2@&xx^uqP1ZgvF`_UfYUk#M|?^(?eAAxe#P(TL=?RI_Y2fAS94s8A~0oPLk! zIn)+aZfwBLPX;;C%>JuD#O}XX1pSlNwm(%}7rF0A^2npnigD&QLOcjX_a$k>a}4eG zWqXtnyIbqH;p{Tz7;iUSRP!TssAA(tK`ig;QwLLQ?khGO#;yI)PrFVR(PQy_*NU7wZxT0`)*6gxy=gD5;8)t+S(9jx{vx6@?Ujb8cp6q@ltI=7$d6EfUE*2&u^I3Y1cE*4Ii zH*k3qlq+NHY6-`a!xV_XbAoKm{ynHOGfVF`If)kUtbM>aaq>m{!4%th@n?B^3mLP$ zzYzK&aTF{N&dP)^#cEm_7WJsHyT7rZI&I-`+7qBGbY`81Wn&yzXv$@sbS3eXA&*>J z4GP(9z+C?)5{PZjPhmtUho;Q%=6Fd8!M6*={AoHq?P28a=#yfM4Toxy<_>{9!L>Ikxh*syf8; zvXJ+Uy~KGpV-2A0d@)VmROwvetEhrHkVH}2K(?Oz`L!qg6N48(7HZv4{_EwRb5EEu zQV^X56M%bs7Tfj0OXmoCVtv2D+cbwK;kUj+ykg^$NPl+;=z zol`rjXow865|SO{m+(8;5%m?J`XADu6YdTP44Ng8*W9;8q4pzR zfxOUahZLuT(U@Hw=|@5{zU`ui@g(e*zA)kzap#uKDFiBOri_J>pP*$VG~irWXVf1g$X&%nyz#MAFUuuwv}p{m0&IW0o>m$r2d=#Z@DmPOi@y*G!4}Z8<dJWTSG#$YG0V>iPz*ZWyA57F2(IREL-{n7 z0QBzbgj((EnMs8FXOY9hECSS5gAFMT;rJ6#)RtLAYAcIdL$-=e81PMMk7y7+#pt9| z?FB7x1M?xnC9F&BI^jWYPx`v_?Htq|)PX@GV>K3&!?sWuj!2j^=PY2T2AnAsAdMZVrH+SG_PIKKCE2gQe$e&TW=p6^8CgZre3tJKrAhi(t- z%gbVY|QC?bI9iaOh&B|2AV_!Z8txrHGQaf7ef4VF^Y!WI?HjP)54;q$7Px4v4uj!zqI zn{xShzGx!zC62kuGCHc0Nf)Xc~*M7q?Ee#__kN|8fi2REk(3 z#~|XEl4?zWXwY}*AX(muZj2=r9Om&_w$zoIQoROTwij#V&cv%SX910hWnpm(FpGZQ z0S2!3WAnR~MWI2?H~=bZR}uT=x8N01G16G%EXhe%%zt?rkM5pcQm|kXnc&HDL?zAv zIn2caK8>}RrHz1S)myFV>^>{(f!eO@f2uy6iX9-##kGA<`P{4?IUGlOl z5gYQ>TEoHUsf%7d7I>Ih0p9u^he|>xOL}G8Cpqo4^<a23D~JXu?E++$ zTR$?H-qrh{sz#`3Q)c`!|K-$oYn+8m&+Qj#lcpx}k1*=U_p!tLh zm{QFH^gsD~oL3&Ev$8OXr}HJCY$00wPo?oyH7oCSTRK? zB5Rq29Du18GkIF>|E)ywZ>m-Fme!5Q$VtWKR7-2q0?uNRMuDtD<<_iGk__|NW33hl zbhoQbQExVLW$-8HZz%x%CXLp08~3BqnU6|i2_@Hy{QZ`tLkZXQaHem(?Ow@DBg2@< znK6rryeiRq(IO;67a#f}uh~KiK>Bw!rR@SvM4U_|O#7Vf?^W&Vapsr~C7Jyv9Xk1` zo>yW|!jRG#yDI@eXxm=*ASJcLO)2J0rGtkdV?s^cgIurm>E$;+(V=V<#_ zDyRBg%cs$wRKG~0w&YUBV8L+~>{o;v$3_L7fF-$hY_L|O!^SPjlx@ZA*tD+$O zV;l#-t2k8>Ub9B2i8NYf+xDV;jhr;&>8`s>7feS2Q2_9X@DnGaB7I=tE@g1)#OL|5p0a)03AQn&nDjstA$K|%#rYBhg2O9m6XmFVu)mMCFuwxiy>b} zYN~EPDo%Mf$NtFe!Ao0}JcNRQ!5^Rj4cpf2U9ubh&`pm1?{$+qAkNruo@|4$qd_3& z4@(76`0nw?HTSC%AydFja!jo~+=$nJzn>%x7=FWGw8R_U1AO5o?u50|XIXf*5B3I^H z{;}4!L505NI2ES$_trfD++Av+lqbvoXQ7n&p(~8~vlcezUV&XVQ@r6fIGEw#s>nPi zh>A4ZVcZmUhx5*qaY@7F-|M%0DWA=lsHF*BrjZkm<0IMwG&YYG)!YrV`$c%3a6 zti9P%^k|~*L&;M1bE)qMqoyzKlyhF(J+dr-{4n8uOskACX5*kjkSY2ytV~Dt&jfWR_WIK(|1pH&-0sYuT2_U zTFscHOUYpB7bLP$WBQ9{B&6QI=b9WMy-8pI36{rMlJLje#o_p{#b`YrsY%O|%`^G9 z<4o)D)l5oJ{L`NcJm3UP&l4GzX;YAVL5xZPy|X2G#EdYv{@$6lrgS^bewsl6IOxbI z^mk#KCSKp^MTTPshSCxATuRXb&mYII>d~AH+`Rpa3=>S$4sL+fdDBt@n9dd))KGLp zD&)1@ip~!FoPPBJSDuzg02>A&n`$_w&6sH5xq*i7Cb5GA1EC}p35vAnPQvkSjQ(_3 zdQNB5e`fI8H3FFp2^MyvEkw*sNrbK11_e$@(QsWoE$(W(854=b+(wBjfX~PFG2Go9 zZQ)oHmj_v!Z=Z0_dCaqF7Ph%2CZogWQEI#5;DM`F6~!JzO(ZyT2C=Myw}3PWSS!Sl zvm2Fw1o15G#c4YGm}Sm_uyFX%(14yin-fxPKy9(7aX;hX5O{oKyt-;UC7l8)7&wqu zeUTVYkgzn=FX%jAoP=5;@%mH)SlGHbF|r0I>^5+P8*beI%hVM~)PUY81Wyncqk_UC z5HE;o`2Z0@xTZy8Xtdt4kb;kLErBbz_ls2j3zc=&gMdwbK@lkGl|3*BfQ<-i2bA>C za*t#X`i;&XA47FXm6sJ@ovUc?RI^+uq8IH{8je(C;SD)-S`-J>4ncV?5_mq@#bnEc zor1tdV8TXn<9`iZkog0#+z}~puX5CSMTJyfD&rg))265cG_Fvf+M39rtCXPwc@~&} zu^wYRHtS(&Vgd)G2_|sTF#8x16Wm> zqB7w|Hys78>xDeAkUhGt$D14KjGp_NudEaG3=O6l=Yb(Vki9$h!TbVm&3-H6?;f(f z+H4@M{+FSZ!=_DepW5h!?P8I&ZPam~(RsQ3qRDg-`jwVx zLD(RitWm4V6%Wi>~HwAYdvo$Th7U&>xo0A#GVzd;Q(Yc_5Ic-&VgB&h?{5P*z7QdXz~ zRU}EYt}7=^9jI0VQ>*QD(Xm|aB4GYH1gIuOzLH~o1$FA1S`Sof?Kok|F_6uU8UU)B zm^k%D)&f-;%VbgRXID@U0<<0!MNm-#P(INR9bx?5n6Y}V5GMF?6k{WQ=tQXQp;LH@ zdSwrcU|>St1AaTacX`!&hM)QukySur literal 0 HcmV?d00001 diff --git a/doc/source/addendum/fieldnames.rst b/doc/source/addendum/fieldnames.rst new file mode 100644 index 000000000..471d52e7a --- /dev/null +++ b/doc/source/addendum/fieldnames.rst @@ -0,0 +1,171 @@ +.. _field_naming_convention: + +CMEPS field names +================= + +The following state names are currently supported. Note that each application might only use a subset of these fields. + +.. csv-table:: "Atmospheric State Names (import to mediator)" + :header: "stat name", "description" + :widths: 20, 60 + + "Sa_co2diag", "diagnostic CO2 at the lowest model level" + "Sa_co2prog", "prognostic CO2 at the lowest model level" + "Sa_dens", "air density at lowest model layer" + "Sa_pbot", "air pressure at lowest model layer" + "Sa_pslv", "air pressure at land and sea surface" + "Sa_ptem", "potential temperature at lowest model layer" + "Sa_shum", "air specific humidity at lowest model layer" + "Sa_tbot", "air temperature at lowest model layer" + "Sa_topo", "surface topographic height" + "Sa_u", "air zonal wind at lowest model layer" + "Sa_v", "air meridional wind at lowest model layer" + "Sa_z", "air height wind at lowest model layer" + +.. csv-table:: "Sea Ice State Names (import to mediator)" + :header: "name", "description" + :widths: 20, 60 + + "Si_anidf", "sea ice near infrared diffuse albedo" + "Si_anidr", "sea ice near infrared direct albedo" + "Si_avsdf", "sea ice visible diffuse albedo" + "Si_avsdr", "sea ice visible direct albedo" + "Si_ifrac", "sea ice fraction" + "Si_imask", "sea ice land mask" + "Si_ifrac_n", "ice fraction by thickness category" + "Si_qref", "reference height specific humidity" + "Si_qref_wiso", "reference specific water isotope humidity at 2 meters" + "Si_t", "sea ice surface temperature" + "Si_tref", "reference height temperature" + "Si_u10", "10m wind speed" + "Si_vice", "volume of sea ice per unit area" + "Si_snowh", "surface snow water equivalent" + "Si_vsno", "volume of snow per unit area" + +.. csv-table:: "Land State Names (import to mediator)" + :header: "name", "description" + :widths: 20, 60 + + "Sl_anidf", "" + "Sl_anidr", "" + "Sl_avsdf", "" + "Sl_avsdr", "" + "Sl_ddvel", "" + "Sl_fv", "" + "Sl_fztop", "" + "Sl_lfrac", "" + "Sl_lfrin", "" + "Sl_qref", "" + "Sl_qref_wiso", "" + "Sl_ram1", "" + "Sl_snowh", "" + "Sl_snowh_wiso", "" + "Sl_t", "" + "Sl_topo_elev", "" + "Sl_topo", "" + "Sl_tsrf_elev", "" + "Sl_tsrf", "" + "Sl_tref", "" + "Sl_u10", "" + +.. csv-table:: "Ocean State Names (import to mediator)" + :header: "name", "description" + :widths: 20, 60 + + "So_blddepth", "ocean boundary layer depth" + "So_anidf", "ocean near infrared diffuse albedo" + "So_anidr", "ocean near infrared direct albedo" + "So_avsdf", "ocean visible diffuse albedo" + "So_avsdr", "ocean visible direct albedo" + "So_bldepth", "ocean mixed layer depth" + "So_dhdx", "sea surface slope in meridional direction" + "So_dhdy", "sea surface slope in zonal direction" + "So_duu10n", "10m wind speed" + "So_fswpen", "shortwave penetration through sea ice (all bands)" + "So_ofrac", "ocean fraction" + "So_omask", "ocean land mask" + "So_qref", "reference specific humidity at 2 meters" + "So_re", "square of exchange coefficient for tracers (mediator aoflux)" + "So_s", "sea surface salinity" + "So_ssq", "surface saturation specific humidity in ocean (mediator aoflux)" + "So_t", "sea surface temperature" + "So_tref", "reference temperature at 2 meters" + "So_u", "ocean current in zonal direction" + "So_u10", "10m wind speed" + "So_ustar", "friction velocity (mediator aoflux)" + "So_v", "ocean current in meridional direction" + +.. csv-table:: "Land Ice State Names (import to mediator)" + :header: "name", "description" + :widths: 20, 60 + + "Sg_ice_covered", "" + "Sg_ice_covered_elev", "" + "Sg_icemask", "" + "Sg_icemask_coupled_fluxes", "" + "Sg_topo", "" + "Sg_topo_elev", "" + +.. csv-table:: "Wave State Names (import to mediator) " + :header: "name", "description" + :widths: 20, 60 + + "Sw_hstokes", "Stokes drift depth" + "Sw_lamult", "Langmuir multiplier" + "Sw_ustokes", "Stokes drift u-component" + "Sw_vstokes", "Stokes drift v-component" + +.. csv-table:: "Mediator State Names (export from mediator)" + :header: "name", "description" + :widths: 20, 60 + + "Sx_anidf", "" + "Sx_anidr", "" + "Sx_avsdf", "" + "Sx_avsdr", "" + "Sx_qref", "merged reference specific humidity at 2 meters" + "Sx_t", "merged ice and ocean surface temperature" + "Sx_tref", "merged reference temperature at 2 meters" + "Sx_u10", "merged 10m wind speed" + +State Variables +~~~~~~~~~~~~~~~ + +The following flux prefixes are used: + +.. csv-table:: + :header: "flux prefix", "description" + :widths: 20, 60 + + "Faxa\_", "atm flux computed by atm" + "Fall\_", "lnd-atm flux computed by lnd" + "Fioi\_", "ice-ocn flux computed by ice" + "Faii\_", "ice_atm flux computed by ice" + "Flrr\_", "lnd-rof flux computed by rof" + "Firr\_", "rof-ice flux computed by rof" + "Faxx\_", "mediator merged fluxes sent to the atm" + "Foxx\_", "mediator merged fluxes sent to the ocn" + "Fixx\_", "mediator merged fluxes sent to the ice" + +The following flux-names are used: + +.. csv-table:: + :header: "flux name", "description" + :widths: 20, 60 + + "_evap", "air-ice evaporative water flux, positive downwards" + "_lat", "air-ice latent heat, positive downwards" + "_lwup", "air-ice surface longwave flux, positive downwards" + "_sen", "air-ice sensible heat, positive downwards" + "_swnet", "net short wave, positive downwards" + "_melth", "net heat flux to ocean from ice" + "_meltw", "fresh water flux to ocean from ice" + "_salt", "salt to ocean from ice" + "_swpen", "flux of shortwave through ice to ocean" + "_swpen_vdr", "flux of visible direct shortwave through ice to ocean" + "_swpen_vdf", "flux of visible diffuse shortwave through ice to ocean" + "_swpen_idr", "flux of near infrared direct through ice to ocean" + "_swpen_idf", "flux of near infrared diffuse through ice to ocean" + "_taux", "zonal stress, positive downwards" + "_tauy", "air-ice meridional stress, positive downwards" + "_q", "ice-ocn freezing melting potential" diff --git a/doc/source/addendum/index.rst b/doc/source/addendum/index.rst new file mode 100644 index 000000000..18f94418c --- /dev/null +++ b/doc/source/addendum/index.rst @@ -0,0 +1,11 @@ +.. _addendum: + +Addendum +======== + +.. toctree:: + :maxdepth: 1 + + req_attributes.rst + req_attributes_cesm.rst + fieldnames.rst diff --git a/doc/source/addendum/req_attributes.rst b/doc/source/addendum/req_attributes.rst new file mode 100644 index 000000000..d6b844282 --- /dev/null +++ b/doc/source/addendum/req_attributes.rst @@ -0,0 +1,68 @@ +.. _attributes: + +========================================== + CMEPS Application Independent Attributes +========================================== + +The following attributes are obtained from the respective driver and +available to all components that the driver uses. In the case of +NEMS, the NEMS driver ingests these attributes from the +``nems.configure`` file. In the case of CESM, the CESM driver ingests +these attributes from the ``nuopc.runconfig`` file. The list of +attributes below are separated into application independent attributes +and at this time additional attributes required by CESM. There are no +NEMS-specific attributes required by the NEMS application. + + +General +------- + +**coupling_mode** (required) + + The coupling_mode attribute determines which + ``esmFlds_exchange_xxx_mod.F90`` and ``fd_xxx.yaml`` is used by + CMEPS and is also leveraged in some of the custom calculations in + the ``prep`` modules. + + The currently supported values for ``coupling_mode`` are ``cesm``, ``nems_orig``, ``nems_frac`` and ``hafs``. + +Scalar attributes +----------------- + +**ScalarFieldCount** + The maximum number of scalars that are going to be communicated + between the mediator and a component. Currently scalar values are + put into a field bundle that only contains an undistributed + dimension equal to the size of ``ScalarFieldCount`` and communicated + between the component and the mediator on the `master task` of each + component. + +**ScalarFieldName** (required) + This is the name of the scalar field bundle. By default it is ``cpl_scalars``. + +**ScalarFieldIdxGridNX**, **ScalarFieldIdxGridNY** (required) + The global number of longitude and latitude points. For unstructured grids:: + + ScalarFieldIdxGridNY = 1 + ScalarFieldIdxGridNX = global size of mesh + + For cases where ``ScalarFieldIdxGridNY`` is not 1, this scalar data + is needed by the mediator for the history output. + +**ScalarFieldIdxNextSwCday** (optional) + Send by the atmosphere component to specify the calendar day of its + next short wave computation. This is subsequently used by other + components (e.g. cesm-land and sea-ice) in determining the zenith + angle for its albedo calculation. It is also used in the mediator + routine ``med_phases_ocnalb_mod.F90`` to determine the zenith angle + in the ocean albedo calculation. + +Mediator history and restart attributes +--------------------------------------- + +**history_option**, **history_n** (required) + Determines the write frequency for a mediator history file (see :ref:`mediator history writes`). +**restart_option**, **restart_n** (required) + Determines the write frequency for a mediator restart file (see :ref:`mediator restart writes`). +**read_restart** (required) + Determines if a mediator restart file is read in. diff --git a/doc/source/addendum/req_attributes_cesm.rst b/doc/source/addendum/req_attributes_cesm.rst new file mode 100644 index 000000000..c8d6ff7fa --- /dev/null +++ b/doc/source/addendum/req_attributes_cesm.rst @@ -0,0 +1,134 @@ +.. _cesm-attributes: + +======================= + CMEPS CESM attributes +======================= + +The following *additional* attributes are required for CESM model applications. + +General +-------------- + +**diro**, **logfile** + Specifies the full pathname of the directory and filename of the directory and file name for mediator log output. + For CESM this is determine in the attribute group ``MED_modelio`` that is generated by the CIME case control system. + +**flds_i2o_per_cat** + if true, select per ice thickness category fields are passed to the ocean. + +Toggle for active compoenents +----------------------------- + +**ATM_model**, **GLC_model**, **ICE_model**, **LND_model**, **ROF_model**, **OCN_model**, **WAV_model** + In CESM, stub components are still used. These attributes determine if the component is a stub component and sets the + mediator present flag for that component to ``false``. + +Mediator Mapping file attributes +-------------------------------- + + If a mapping file value is set to ``unset``, then CMEPS will create an online route handle instead. + +**ice2atm_fmapname**, **ice2atm_smapname** + ice -> atm fluxes and state mapping files +**lnd2atm_fmapname**, **lnd2atm_smapname** + land -> atm fluxes and state mapping files +**ocn2atm_smapname**, **ocn2atm_fmapname** + ocean -> atm fluxes and state mapping files +**atm2lnd_fmapname**, **atm2lnd_smapname** + atm -> land fluxes and state mapping files +**atm2ice_fmapname**, **atm2ice_smapname**, **atm2ice_vmapname** + atmosphere -> sea-ice fluxes, state, and velocities +**atm2ocn_fmapname**, **atm2ocn_smapname**, **atm2ocn_vmapname** + atmosphere -> ocean fluxes, state, and velocities +**rof2lnd_fmapname** + river -> land flux mapping file +**glc2lnd_fmapname**, **glc2lnd_smapname** + land-ice -> land fluxes and state mapping files +**glc2ice_rmapname** + "smoothed" land-ice -> sea-ice liquid mapping file +**glc2ocn_liq_rmapname**, **glc2ocn_ice_rmapname** + "smoothed" land-ice -> ocean liquid and ice mapping files +**rof2ocn_liq_rmapname**, **rof2ocn_ice_rmapname** + "smoothed" river -> ocean liquid and ice mapping file +**wav2ocn_smapname** + wave -> ocean state mapping file +**lnd2rof_fmapname** + land -> river flux mapping file +**lnd2glc_fmapname**, **lnd2glc_smapname** + land -> land-ice flux and state mapping file +**atm2wav_smapname**, **ice2wav_smapname**, **ocn2wav_smapname** + atmosphere -> wave, ice -> wave and ocean -> wave state mapping files + +**mapuv_with_cart3d** + used for atm->ocn and atm-ice mapping of u and v + if true, rotate u,v to 3d cartesian space, map from src->dest, then rotate back + +Mediator ocean albedo attributes +-------------------------------- + + The following are used by CMEPS to calculate ocean albedoes in used in ``med_phases_ocnalb_mod.F90`` + +**start_type** + Determines if start type of the run. The currently supported values are ``startup``, ``continue`` and ``branch``. +**orb_mode** + orbital model setting configured. The supported values are:: + + fixed_year: uses the orb_iyear and other orb inputs are ignored. In + this mode, the orbital parameters are constant and based on the year. + + variable_year: uses the orb_iyear and orb_iyear_align. In this mode, + the orbital parameters vary as the model year advances and the model + year orb_iyear_align has the equivalent orbital year of orb_iyear. + + fixed_parameters: uses the orb_eccen, orb_mvelp, and orb_obliq to set + the orbital parameters which then remain constant through the model integration + +**orb_iyear** + year of orbit, used when orb_mode is fixed_year or variable_year +**orb_iyear_align** + model year associated with orb_iyear when orb_mode is variable_year +**orb_obliq** + obliquity of orbit in degrees, used when orb_mode is fixed_parameters +**orb_eccen** + eccentricity of orbit, used when orb_mode is fixed_parameters. +**orb_mvelp** + location of vernal equinox in longitude degrees, used when orb_mode is fixed_parameters + +Mediator land-ice component attribtes +------------------------------------- + +**glc_renormalize_smb** + Whether to renormalize the surface mass balance (smb) sent from lnd to glc so that the + global integral on the glc grid agrees with the global integral on the lnd grid. + + Unlike most fluxes, smb is remapped with bilinear rather than conservative mapping weights, + so this option is needed for conservation. However, conservation is not required in many + cases, since we often run glc as a diagnostic (one-way-coupled) component. + + Allowable values are: + ``on``: always do this renormalization + + ``off``: never do this renormalization (see WARNING below) + + ``on_if_glc_coupled_fluxes``: Determine at runtime whether to do this renormalization. + Does the renormalization if we're running a two-way-coupled glc that sends fluxes + to other components (which is the case where we need conservation). + Does NOT do the renormalization if we're running a one-way-coupled glc, or if + we're running a glc-only compset (T compsets). + (In these cases, conservation is not important.) + Only used if running with a prognostic GLC component. + WARNING: Setting this to 'off' will break conservation when running with an + evolving, two-way-coupled glc. + +**glc_avg_period** + Period at which coupler averages fields sent to GLC (the land-ice component). + This supports doing the averaging to GLC less frequently than GLC is called + (i.e., separating the averaging frequency from the calling frequency). + This is useful because there are benefits to only averaging the GLC inputs + as frequently as they are really needed (yearly for CISM), but GLC needs to + still be called more frequently than that in order to support mid-year restarts. + Setting glc_avg_period to 'glc_coupling_period' means that the averaging is + done exactly when the GLC is called (governed by GLC_NCPL). + +**glc_cpl_dt** + glc coupling interval in seconds diff --git a/doc/source/conf.py b/doc/source/conf.py index 521cbb6ef..80334e199 100644 --- a/doc/source/conf.py +++ b/doc/source/conf.py @@ -39,7 +39,6 @@ 'sphinx.ext.autosummary', 'sphinx.ext.viewcode', 'sphinx.ext.todo', - 'sphinxcontrib.programoutput' ] todo_include_todos=True diff --git a/doc/source/esmflds.rst b/doc/source/esmflds.rst new file mode 100644 index 000000000..960789491 --- /dev/null +++ b/doc/source/esmflds.rst @@ -0,0 +1,247 @@ +.. _api-for-esmflds: + +================================ + CMEPS application specific code +================================ + +For each supported application, CMEPS contains two specific files that determine: + +* the allowed field names in the mediator and aliases for those names that the components might have +* the fields that are exchanged between components +* how source fields are mapped to destination fields +* how source fields are merged after mapping to destination fields + +Three application specific versions are currently contained within CMEPS: + +* for CESM: **esmFldsExchange_cesm_mod.F90** and **fd_cesm.yaml** +* for UFS-S2S: **esmFldsExchange_nems_mod.F90** and **fd_nems.yaml** +* for UFS-HAFS: **esmFldsExchange_hafs_mod.F90** and **fd_hafs.yaml** + +CMEPS advertises **all possible fields** that can be imported to and +exported by the mediator for the target coupled system. Not all of +these fields will be connected to the various components. The +connections will be determined by what the components advertise in +their respective advertise phase. + +Across applications, component-specific names for the same fields may vary. The field +dictionary is used to define how the application or component-specific name relates +to the name that the CMEPS mediator uses for that field. The mediator variable +names and their application specific aliases are found in the YAML field dictionary. + +Details of the naming conventions and API's of this file can be found +in the description of the :ref:`exchange of fields in +CMEPS`. + +Field Naming Convention +----------------------- + +The CMEPS field name convention in the YAML files is independent of the model components. +The convention differentiates between variables that are state fields versus flux fields. +The naming convention assumes the following one letter designation for the various components as +well as the mediator. + +**import to mediator**:: + + a => atmosphere + i => sea-ice + l => land + g => land-ice + o => ocean + r => river + w => wave + +**export from mediator (after mapping and merging)**:: + + x => mediator + +**State Variables**: + + State variables have a 3 character prefix followed by the state + name. The prefix has the form ``S[a,i,l,g,o,r,w,x]_`` and is followed by + the field name. + + As an example, ``Sx_t`` is the merged surface + temperature from land, ice and ocean sent to the atmosphere for CESM. + +**Flux variables**: + + Flux variables specify both source and destination components and have a + 5 character prefix followed by an identifier name of the flux. The first 5 + characters of the flux prefix ``Flmn_`` indicate a flux between + components l and m, computed by component n. The flux-prefix is followed + by the relevant flux-name. + + **mediator import flux prefixes**:: + + Faxa_, atm flux computed by atm + Fall_, lnd-atm flux computed by lnd + Fioi_, ice-ocn flux computed by ice + Faii_, ice_atm flux computed by ice + Flrr_, lnd-rof flux computed by rof + Firr_, rof-ice flux computed by rof + + **mediator export flux prefixes**:: + + Faxx_, mediator merged fluxes sent to the atm + Foxx_, mediator merged fluxes sent to the ocn + Fixx_, mediator merged fluxes sent to the ice + +Exchange of fields +------------------ + +The application specific module, ``esmFldsExchange_xxx.F90`` contains +all of the information to determine how the mediator performs the +exchange of fields between components. In particular, this module uses the subroutines +``addfld``, ``addmap`` and ``addmrg`` to do the following: + +* ``addfld`` advertises all possible fields that the mediator can send + to and receive from each component that is part of the target + application + +* ``addmap`` determines how each source field is mapped from its + source mesh to a target destinations mesh. Note that a given source + field may be mapped to more than one destination meshes and so there + can be more than one call to ``addmap`` for that source field. + +* ``addmrg`` determines how a collection of mapped source fields + is merged to the target destination field. + +.. note:: In all these functions, specific components are accessed using a comp_index, where comp_index can be any of [compatm, compice, compglc, complnd, compocn, comprof, compwav]. + +This section describes the API for the calls that determine the above +information. All of the API's discussed below use the code in the +generic module ``esmFlds.F90``. + +.. _addfld: + +`addfld` +~~~~~~~~~~ +CMEPS advertises all possible fields that it can receive from a component or send to any component via a call to ``addfld``. +The API for this call is: + +.. code-block:: Fortran + + call addfld(fldListFr(comp_index)%flds, 'field_name') + call addfld(fldListTo(comp_index)%flds, 'field_name') + +where: + +* ``comp_index`` is the component index + +* ``'field_name'`` is the field name that will be advertised + +.. _addmap: + +`addmap` +~~~~~~~~~~ +CMEPS determines how to map each source field from its source mesh to a target destination mesh via a call to ``addmap``. +The API for this call is: + +.. code-block:: Fortran + + call addmap(FldListFr(comp_index_src)%flds, 'field_name', comp_index_dst, maptype, mapnorm, mapfile) + +where + +* ``comp_index_src`` is the source component index + +* ``comp_index_dst`` is the destination component index + +* **maptype** determines the mapping type and can have values of: + + * ``mapbilnr``: bilinear mapping + + * ``mapconsf``: first order conservative mapping with normalization type of conservative fraction. + + * ``mapconsd``: first order conservative mapping with normalization type of conservative fraction. + + * ``mappatch``: patch mapping + + * ``mapfcopy``: redist mapping + + * ``mapnstod``: nearest source to destination mapping + + * ``mapnstod_consd``: nearest source to destination followed by conservative destination + + * ``mapnstod_consf``: nearest source to destination followed by conservative fraction + +.. _normalization: + +* **mapnorm** determines the mapping normalization and can have values of: + + * ``unset`` : no normalization is set, should only be used if maptype is 'mapfcopy' + + * ``none`` : no normalization is done, should only be used if maptype is not 'mapfcopy' + + * ``one`` : normalize by 1. (see description below for normalization) + + * ``lfrin`` : normalize by the ``lfrin`` field in FBFrac(complnd). Used to map lnd->atm (see description of :ref:`fractions`). + + * ``ifrac`` : normalize by the 'ifrac' field in FBFrac(compice). Used to map ice->atm (see description of :ref:`fractions`). + + * ``ofrac`` : normalize by the 'ofrac' field in FBFrac(compocn). Used to map ice->atm (see description of :ref:`fractions`). + + * ``custom`` : custom mapping and normalization will be done in the prep phase for the corresponding field (used to map glc->lnd). + + .. note:: When **mapnorm** is used, the field will first be scaled by the relevant ``FBfrac`` before mapping and then unscaled by the same ``FBfrac`` after mapping. For example, when ``ifrac`` is the normalization, the field will be scaled by ``FBfrac(compice)[ifrac]`` before mapping and unscaled by the mapped ``FBFrac(compice)[ifrac]`` after mapping. + +* **mapfile** determines if a mapping file will be read in or the route handle will be generated at run time: + + * ``unset`` : online route handles will be generated + + * ``mapfile``: read in corresponding full pathname. The ```` is obtained as an attribute from the driver + +**Normalization** : +Fractional normalization is needed to improve the accuracy field exchanges between ice and ocean and atmosphere. Consider the case where one cell has an ice +fraction of 0.3 and the other has a fraction of 0.5. Mapping the ice fraction to the atmospheric cell results in a value of 0.4. If the same temperatures are +mapped in the same way, a temperature of -1.5 results which is reasonable, but not entirely accurate. Because of the relative ice fractions, the weight of the +second cell should be greater than the weight of the first cell. Taking this into account properly results in a fraction weighted ice temperature of -1.625 in +this example. This is the fraction correction that is carried out whenever ocean and ice fields are mapped to the atmosphere grid. Note that time varying +fraction corrections are not required in other mappings to improve accuracy because their relative fractions remain static. + +**Example** : + +.. code-block:: Fortran + + call addmap(fldListFr(compice)%flds, 'Si_snowh', compatm, mapconsf, 'ifrac', 'unset') + +This will create an entry in ``fldListFr(compatm)`` specifying that the ``Si_snowh`` field from the ice should be mapped conservatively to the atmosphere using +fractional normalization where the ice fraction is obtained from ``FBFrac(compice)[snowh]``. The route handle for this mapping will be created at run time. + +.. _addmrg: + +`addmrg` +~~~~~~~~~~ +CMEPS determines how to map a set of one or more mapped source fields to create the target destination field in the export state. +The API for this call is: + +.. code-block:: Fortran + + call addmrg(fldListTo(comp_index_dst)%flds, dst_fieldname, & + mrg_from1, mrg_fld1, mrg_type1, mrg_fracname1, & + mrg_from2, mrg_fld2, mrg_type2, mrg_fracname2, & + mrg_from3, mrg_fld3, mrg_type3, mrg_fracname3, & + mrg_from4, mrg_fld4, mrg_type4, mrg_fracname4) + +where + +* ``mrg_fromN``, ``mrgfldN``, ``mrgtypeN`` and ``mrg_fracnameN``, where ``N=[1,2,3,4]``, are optional arguments. + ``mrgfrom1`` is corresponds to the first source component index (e.g. ``compatm``). + +* **mrg_fromN**: is an integer corresponding to the source component index + +* **mrg_fldN** : is a character string corresponding to the field name in the mapped field bundle of the source component with index ``mrg_fromN`` + +* **mrg_typeN**: the type of merging that will be carried out for component with index ``mrg_fromN``. The allowed values are: + + * ``copy``: simply copy the source mapped field into the destination field bundle + + * ``copy_with_weights``: weight the mapped source field by its fraction on the destination mesh. + + * ``sum_with_weights``: do a cumulative sum of all the mapped source fields where each field is weighed by by its fraction on the destination mesh. + + * ``sum_with_weights``: do a cumulative sum of all the mapped source fields. + +For ``copy_with_weights`` and ``sum_with_weights``, the mapped source field is weighted by ``mrg_fracnameN`` in ``FBFrac(comp_index_dst)``. If +copy_with_weights is chose as the ``mrg_typeN`` value then ``mrg_fracnameN`` is also required as an argument. If sum_with_weights is chose as the ``mrg_typeN`` +value then ``mrg_fracnameN`` is also required as an argument. diff --git a/doc/source/field_naming_convention.rst b/doc/source/field_naming_convention.rst deleted file mode 100644 index 66eae269d..000000000 --- a/doc/source/field_naming_convention.rst +++ /dev/null @@ -1,53 +0,0 @@ -.. _field_naming_convention: - -Application Specific Field Exchange Specification -================================================= - -CMEPS contains two component specific files that determine: - - the fields that are exchanged between components - - how source fields are mapped to destination fields - - how source fields are merged after mapping to destination fields - - -Field Naming Convention -======================= - -The mediator variable names can be seen in the application specific YAML field dictionary. Currently, three -field dictionaries are supported:: - - fd_cesm.yaml - fd_nems.yaml - -The CMEPS field name convention in these YAML files is independent of the model components. -The convention differentiates between variables that are state fields versus flux fields. - -State variables have a prefix that always start with an ``S`` followned by a two character string:: - - state-prefix - first 3 characters: Sx_, Sa_, Si_, Sl_, So_ - one letter indices: x,a,l,i,o,g,r - x => mediator (mapping, merging) - a => atmosphere - l => land - i => sea-ice - o => ocean - g => land-ice - r => river - w => wave - - state-name - what follows state prefix - -As an example, ``Sx_t`` is the merged surface temperature from land, ice and ocean sent to the atmopshere for CESM. - -Flux variables that specifies both source and destination components and have a 5 character prefix:: - - flux-prefix - first 5 characters: Flmn_ - lm => between components l and m - n => computed by component n - example: Fioi => ice-ocn flux computed by ice - example: Fall => atm-lnd flux computed by lnd - - flux-name - what follows flux-prefix diff --git a/doc/source/fractions.rst b/doc/source/fractions.rst new file mode 100644 index 000000000..77d712e80 --- /dev/null +++ b/doc/source/fractions.rst @@ -0,0 +1,117 @@ +.. _fractions: + +========================== + CMEPS `fractions` module +========================== + +The component fractions on their corresponding meshes are defined and +updated in ``med_fractions_mod.F90.`` + +CMEPS component fractions are defined as follows: + +* An array of field bundles, ``Frac(:)`` is created, where the size of + ``Frac`` corresponds to the number of active components. + +* For each active component, a fraction field bundle is created, ``Frac(comp_index)``, where the fields in the field bundle are unique. + Below, ``Frac(comp_index)[fieldname]`` refers to the field in the ``Frac(comp_index)`` field bundle that has the name ``fieldname``. + +.. note:: comp_index can be any of [compatm, compice, compglc, complnd, compocn, comprof, compwav]. + +* The following are the field names for each component of FBFrac:: + + Frac(compatm) = afrac,ifrac,ofrac,lfrac,lfrin + Frac(compocn) = afrac,ifrac,ofrac,ifrad,ofrad + Frac(compice) = afrac,ifrac,ofrac + Frac(complnd) = afrac,lfrac,lfrin + Frac(compglc) = gfrac,lfrac + Frac(comprof) = lfrac,rfrac + Frac(compwav) = wfrac + +where:: + + afrac = fraction of atm on a grid + 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 + rfrac = fraction of rof on a grid + wfrac = fraction of wav on a grid + ifrad = fraction of ocn on a grid at last radiation time + ofrad = fraction of ice on a grid at last radiation time + + As an example, ``Frac(compatm)[lfrac]`` is the land fraction on + the atmosphere mesh. + +* ``lfrin`` and ``lfrac`` can be different from ``lfrac`` when the + atmosphere and land meshes are different. ``lfrac`` is the land + fraction consistent with the ocean mask where ``lfrin`` is the land + fraction in the land component. + +* ``ifrad`` and ``ofrad`` are fractions at the last radiation + timestep. These fractions preserve conservation of heat in the net + shortwave calculation because the net shortwave calculation is one + timestep behind the ice fraction evolution in the system. + +The following assumptions are made regarding fractions: + +* The ocean and ice are on the same meshes with same masks +* The ice fraction can evolve in time +* The land fraction does not evolve in time +* the ocean fraction is just the complement of the ice fraction over the region + of the ocean/ice mask. +* The component fractions 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 + 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 mesh cell: + + * ``Frac(:)[afrac]`` = 1.0 + * ``Frac(:)[ifrac]`` + ``Frac(:)[ofrac]`` + ``Frac(:)[lfrac]`` = 1.0 + +Initialization of the fractions occurs as follows (note that all mapping is first order conservative): + +* ``Frac(compatm)[afrac]`` = 1.0 + +* ``Frac(compocn)[afrac]`` = map atm -> ocn ``Frac(compatm)[afrac]`` + +* ``Frac(compice)[afrac]`` = map atm -> ice ``Frac(compatm)[afrac]`` + +* ``Frac(complnd)[afrac]`` = map atm -> lnd ``Frac(compatm)[afrac]`` + +* ``FBfrac(:)[ifrac]`` = 0.0 + +* ``Frac(compocn)[ofrac]`` = ocean mask provided by ocean + +* ``Frac(complnd)[lfrin]`` = land fraction provided by land + +* ``Frac(compatm)[ofrac]`` = map ocn -> atm ``Frac(compocn)[ofrac]`` + +* ``Frac(compatm)[lfrin]`` = map lnd -> atm ``Frac(complnd)[lfrin]`` + +* ``Frac(compatm)[lfrac]`` = 1.0 - ``Frac(compatm)[ofrac]`` + (this is truncated to zero for very small values (< 0.001) to attempt to preserve non-land gridcells.) + +* ``Frac(complnd)[lfrac]`` = map atm -> lnd ``Frac(compatm)[lfrac]`` + +* ``Frac(comprof)[lfrac]`` = map lnd -> rof ``Frac(complnd)[lfrac]`` + +* ``Frac(compglc)[lfrac]`` = map lnd -> glc ``Frac(complnd)[lfrac]`` + +Run time calculation of fractions is as follows: + +* ``Frac(compice)[ofrac]`` = 1.0 - ``Frac(compice)[ifrac]`` + (Note: the relative fractions are corrected to total fractions) + +* ``Frac(compocn)[ifrac]`` = map ice -> ocn ``Frac(compice)[ifrac]`` + +* ``Frac(compocn)[ofrac]`` = map ice -> ocn ``Frac(compice)[ofrac]`` + +* ``Frac(compatm)[ifrac]`` = map ice -> atm ``Frac(compice)[ifrac]`` + +* ``Frac(compatm)[ofrac]`` = map ice -> atm ``Frac(compice)[ofrac]`` + +* ``Frac(compatm)[lfrac]`` + ``Frac(compatm)[ofrac]`` + ``Frac(compatm)[ifrac]`` ~ 1.0 + (0.0-eps < Frac(:)[*] < 1.0+eps) diff --git a/doc/source/generic.rst b/doc/source/generic.rst new file mode 100644 index 000000000..62055af1c --- /dev/null +++ b/doc/source/generic.rst @@ -0,0 +1,145 @@ +.. _generic_modules: + +========================= + CMEPS `generic` modules +========================= + +The following describes in some detail the CMEPS modules that are not +application specific and provide general functionality. + +**med.F90** + + This module is initializes the CMEPS mediator functionality by performing the following functions: + + * adding a namespace (i.e. nested state) for each import and export + component state in the mediator's InternalState + + * initializing the mediator component specific fields via a call to + ``esmFldsExchange_xxx_`` (where currently xxx can be ``cesm``, ``nems`` or ``hafs``). + + * determining which components are present + + * advertising the import and export mediator fields + + * creating import (``FBImp``), export (``FBExp``) and accumulation (``FBExpAccum``) field bundles + + * initializing the mediatory route handles and field bundles needed for normalization + + * initializing component ``FBFrac`` field bundles + + * reading mediator restarts + + * optionally carrying out initializations for atmosphere/ocean flux + calculations and ocean albedo calculations (these are needed by CESM) + + * carrying out the NUOPC data initialization via the ``DataInitialize`` routine. + + .. note:: After the first DataInitialize() of CMEPS returns, + NUOPC will note that its InitializeDataComplete is not yet true. The + NUOPC Driver will then execute the Run() phase of all of the Connectors that + fit the xxx-TO-MED pattern. After that, it will call CMEPS + DataInitialize() again. Note that the time stamps are only set + when the Run() phase of all the connectors are run and the + Connectors Run() phase is called before the second call of the + CMEPS DataInitialize phase. As a result, CMEPS will see the + correct timestamps, which also indicates that the actual data has + been transferred reliably, and CMEPS can safely use it. + +**med_map_mod.F90** + + This module creates the required route handles that are needed for + the model run. The route handles are stored in the multi-dimensional array + ``RH(ncomps,ncomps,nmappers)`` in the module ``med_internal_state_mod.F90``. + + ``nmappers`` is the total number of mapping types that CMEPS supports (currently 8). + These are described in :ref:`mapping types`. + + ``ncomps,ncomps`` corresponds to the source and destination component indices. + + As an example ``RH(compatm,compocn,mapbilnr)`` is the atm->ocn bilinear route handle. + + **med_map_mod.F90** also initializes additional field bundles that + are needed for mapping fractional normalization (see the + :ref:`mapping normalization `). Normalization is + normally done using the relevant field from ``FBFrac(:)``. + + The default call to carry out mediator mapping is done in the + :ref:`prep_modules` by calling + ``med_map_FB_Regrid_Norm``. Mapping is done by using the + ``fldListFr(:)`` data that was initialized in the + ``esmFldsExchange_xxxx_mod.F90`` calls to ``addmap``. + +**med_merge_mod.F90** + + This module carries out merging of one or more mapped source fields + to the target destination field (see :ref:`merging + types`). The :ref:`prep_modules` carry out + merging via the call to ``med_merge_auto`` Merging is done by using + the ``fldListTo(:)`` data that was initialized in the + ``esmFldsExchange_xxx_mod.F90`` calls to ``addmrg``. + +**med_io_mod.F90** + + CMEPS uses the PIO2 parallel library to carry out all IO. PIO + provides a netCDF-like API, and allows users to designate some + subset of processors to perform IO. Computational code calls + netCDF-like functions to read and write data, and PIO uses the IO + processors to perform all necessary IO. This module contains + wrapper layers to PIO for writing and reading mediator restart + files and for writing mediator history files. + +.. _history_writes: + +**med_phases_history_mod.F90** + + This module writes mediator history files. The freqency of CMEPS + history writes is controlled via the NUOPC attributes + ``history_option`` and ``history_n``. These attributes control + instantaneous mediator history output as follows: + + ============== ============================================================= + history_option description + ============== ============================================================= + none do not write any history files + never do not write any history files + nsteps write files every ``history_n`` mediator coupling intervals + nseconds write files every ``history_n`` seconds + nminutes write files every ``history_n`` minutes + nhours write files every ``history_n`` hours + ndays write files every ``history_n`` days + nmonths write files every ``history_n`` months + nyears write files every ``history_n`` years + monthly write files on the month boundary + yearly write files on the year boundary + ============== ============================================================= + + .. note:: It is assumed that the NUOPC attributes ``history_option`` and ``history_n`` + are obtained by the model driver and passed down to the mediator. + +.. _restart_writes: + +**med_phases_restart_mod.F90** + + This module reads and writes mediator restart files. The freqency of CMEPS + restart writes is controlled via the NUOPC attributes + ``restart_option`` and ``restart_n``. These attributes control + instantaneous mediator history output as follows: + + ============== ============================================================= + restart_option description + ============== ============================================================= + none do not write any restart files + never do not write any restart files + nsteps write files every ``restart_n`` mediator coupling intervals + nseconds write files every ``restart_n`` seconds + nminutes write files every ``restart_n`` minutes + nhours write files every ``restart_n`` hours + ndays write files every ``restart_n`` days + nmonths write files every ``restart_n`` months + nyears write files every ``restart_n`` years + monthly write files on the month boundary + yearly write files on the year boundary + ============== ============================================================= + + .. note:: It is assumed that the NUOPC attributes ``restart_option`` and ``restart_n`` + are obtained by the model driver and passed down to the mediator. diff --git a/doc/source/index.rst b/doc/source/index.rst index e316fa48e..c03f6276e 100644 --- a/doc/source/index.rst +++ b/doc/source/index.rst @@ -15,6 +15,11 @@ Table of contents ----------------- .. toctree:: :maxdepth: 2 + :numbered: introduction.rst - field_naming_convention.rst + esmflds.rst + fractions.rst + prep.rst + generic.rst + addendum/index.rst diff --git a/doc/source/introduction.rst b/doc/source/introduction.rst index 8507d8ccb..3b79e1ed0 100644 --- a/doc/source/introduction.rst +++ b/doc/source/introduction.rst @@ -1,4 +1,631 @@ Introduction ============ -Content to go here: +CMEPS is a NUOPC-compliant mediator which uses ESMF to couple earth grid components in a hub and spoke system. + +As a mediator, CMEPS is responsible for transferring field information from one +model component to another. This transfer can require one or more operations on +the transferred fields, including mapping of fields between component grids, +merging of fields between different components and time-averaging of fields +over varying coupling periods. + + + +Components share information via import and export states, which are containers +for ESMF data types that wrap native model data. The states also contain +metadata, which includes physical field names, the underlying grid structure +and coordinates, and information on the parallel decomposition of the fields. +Note that while CMEPS itself is a mesh based mediator, component models coupled +by the CMEPS mediator can be either grid or mesh based. + +Each component model using the CMEPS mediator is serviced by a NUOPC-compliant +cap. The NUOPC cap is a small software layer between the underlying model code +and the mediator. Fields for which the mediator has created a connection +between model components are placed in either the import or export state of the +component within the NUOPC cap. The information contained within these states +is then passed into native model arrays or structures for use by the component +model. + +Field connections made by the CMEPS mediator between components rely on +matching of standard field names. These standard names are defined in a field +dictionary. Since CMEPS is a community mediator, these standard names are +specific to each application. + + +Organization of the CMEPS mediator code +####################################### + + +When you check out the code you will files, which can be organized into three +groups: + +* totally generic components that carry out the mediator functionality such as mapping, + merging, restarts and history writes. Included here is a a "fraction" module that + determines the fractions of different source model components on every source + destination mesh. + +* application specific code that determines what fields are exchanged between + components and how they are merged and mapped. + +* prep phase modules that carry out the mapping and merging from one or more + source components to the destination component. + +=========================== ============================ =========================== + Generic Code Application Specific Code Prep Phase Code +=========================== ============================ =========================== +med.F90 esmFldsExchange_cesm_mod.F90 med_phases_prep_atm_mod.F90 +esmFlds.F90 esmFldsExchange_nems_mod.F90 med_phases_prep_ice_mod.F90 +med_map_mod.F90 esmFldsExchange_hafs_mod.F90 med_phases_prep_ocn_mod.F90 +med_merge_mod.F90 fd_cesm.yaml med_phases_prep_glc_mod.F90 +med_frac_mod.F90 fd_nems.yaml med_phases_prep_lnd_mod.F90 +med_internalstate_mod.F90 fd_hafs.yaml med_phases_prep_rof_mod.F90 +med_methods_mod.F90. +med_phases_aofluxes_mod.F90 +med_phases_ocnalb_mod.F90 +med_phases_history_mod.F90 +med_phases_restart_mod.F90 +med_phases_profile_mod.F90 +med_io_mod.F90 +med_constants_mod.F90 +med_kind_mod.F90 +med_time_mod.F90 +med_utils_mod.F90 +=========================== ============================ =========================== + +.. note:: Some modules, such as med_phases_prep_ocn.F90 and med_frac_mod.F90 also contain application specific-code blocks. + +Mapping and Merging Primer +####################################### + +This section provides a primer on mapping (interpolation) and merging of gridded +coupled fields. Masks, support for partial fractions on grids, weights generation, +and fraction +weighted mapping and merging all play roles in the conservation and quality of the +coupled fields. + +A pair of atmosphere and ocean/ice grids can be used to highlight the analysis. + +.. image:: CMEPS-grid1.png + :width: 400 + :alt: Sample CMEPS grids + +The most general CMEPS mediator assumes the ocean and sea ice surface grids are +identical while the atmosphere and land grids are also identical. The ocean/ice +grid defines the mask which means each ocean/ice gridcell is either a fully +active ocean/ice gridcell or not (i.e. land). Other configurations have been +and can be implemented and analyzed as well. + +The ocean/ice mask interpolated to the atmosphere/land grid +determines the complementary ocean/ice and land masks on the atmosphere grid. +The land model supports partially active gridcells such that each atmosphere +gridcell may contain a fraction of land, ocean, and sea ice. + +Focusing on a single atmosphere grid cell. + +.. image:: CMEPS-grid2.png + :width: 400 + :alt: Sample CMEPS gridcell overlap + +The gridcells can be labeled as follows. + +.. image:: CMEPS-grid3.png + :width: 300 + :alt: Sample CMEPS gridcell naming convention + +The atmosphere gridcell is labeled "a". On the atmosphere gridcell (the red box), +in general, +there is a land fraction (fal), an ocean fraction (fao), and a sea ice fraction +(fai). The sum of the surface fractions should always be 1.0 in these +conventions. There is also a gridbox average field on the atmosphere grid (Fa). +This could be a flux or a state that is +derived from the equivalent land (Fal), ocean (Fao), and sea ice (Fai) fields. +The gridbox average field is computed by merging the various surfaces:: + + Fa = fal*Fal + fao*Fao + fai*Fai + +This is a standard merge where:: + + fal + fao + fai = 1.0 + +and each surface field, Fal, Fao, and Fai are the values of the surface fields +on the atmosphere grid. + +The ocean gridcells (blue boxes) are labeled 1, 2, 3, and 4 in this example. +In general, +each ocean/ice gridcell partially overlaps multiple atmosphere gridcells. +Each ocean/ice gridcell has an overlapping Area (A) and a Mask (M) associated with it. +In this example, land is colored green, ocean blue, and sea ice white so just for +the figure depicted:: + + M1 = 0 + M2 = M3 = M4 = 1 + +Again, the ocean/ice areas (A) are overlapping areas so the sum of the overlapping +areas is equal to the atmophere area:: + + Aa = A1 + A2 + A3 + A4 + +The mapping weight (w) defined in this example allows a field on the ocean/ice +grid to be interpolated to the atmosphere/land grid. The mapping weights can +be constructed to be conservative, bilinear, bicubic, or with many other +approaches. The main point is that the weights represent a linear sparse matrix +such that in general:: + + Xa = [W] * Xo + +where Xa and Xo represent the vector of atmophere and ocean gridcells respectively, +and W is the sparse matrix weights linking each ocean gridcell to a set of atmosphere +gridcells. Nonlinear interpolation is not yet supported in most coupled systems. + +Mapping weights can be defined in a number of ways even beyond conservative +or bilinear. They can be masked or normalized using multiple approaches. The +weights generation is intricately tied to other aspects of the coupling method. +In CMEPS, area-overlap conservative weights are defined as follows:: + + w1 = A1/Aa + w2 = A2/Aa + w3 = A3/Aa + w4 = A4/Aa + +This simple approach which does not include any masking or normalization provides a +number of useful attributes. The weights always add up to 1.0:: + + w1 + w2 + w3 + w4 = 1.0 + +and a general area weighted average of fields on the ocean/ice grid mapped to +the atmosphere grid would be:: + + Fa = w1*F1 + w2*F2 + w3*F3 + w4*F4 + +These weights conserve area:: + + w1*Aa + w2*Aa + w3*Aa + w4*Aa = Aa + +and can be used to interpolate the ocean/ice mask to the atmosphere grid to compute +the land fraction:: + + f_ocean = w1*M1 + w2*M2 + w3*M3 + w4*M4 + f_land = (1-f_ocean) + +These weights also can be used to interpolate surface fractions:: + + fal = w1*fl1 + w2*fl2 + w3*fl3 + w4*fl4 + fao = w1*fo1 + w2*fo2 + w3*fo3 + w4*fo4 + fai = w1*fi1 + w2*fi2 + w3*fi3 + w4*fi4 + +Checking sums:: + + fal + fao + fai = w1*(fl1+fo1+fi1) + w2*(fl2+fo2+fi2) + w3*(fl3+fo3+fi3) + w4*(fl4+fo4+fi4) + fal + fao + fai = w1 + w2 + w3 + w4 = 1.0 + +And the equation for f_land and fal above are consistent if fl1=1-M1:: + + f_land = 1 - f_ocean + f_land = 1 - (w1*M1 + w2*M2 + w3*M3 + w4*M4) + + fal = w1*(1-M1) + w2*(1-M2) + w3*(1-M3) + w4*(1-M4) + fal = w1 + w2 + w3 + w4 - (w1*M1 + w2*M2 + w3*M3 + w4*M4) + fal = 1 - (w1*M1 + w2*M2 + w3*M3 + w4*M4) + +Clearly defined and consistent weights, areas, fractions, and masks is critical +to generating conservation in the system. + +When mapping masked or fraction weighted fields, these weights require that the +mapped field be normalized by the mapped fraction. Consider a case where sea +surface temperature (SST) is to be mapped to the atmosphere grid with:: + + M1 = 0; M2 = M3 = M4 = 1 + w1, w2, w3, w4 are defined as above (ie. A1/Aa, A2/Aa, A3/Aa, A4/Aa) + +There are a number of ways to compute the mapped field. The direct weighted +average equation, **Fa = w1*Fo1 + w2*Fo2 + w3*Fo3 + w4*Fo4, is ill-defined** +because w1 is non-zero and Fo1 is underfined since it's a land gridcell +on the ocean grid. A masked weighted average, +**Fa = M1*w1*Fo1 + M2*w2*Fo2 + M3*w3*Fo3 + M4*w4*Fo4 is also problematic** +because M1 is zero, so the contribution of the first term is zero. But the sum +of the remaining weights (M2*w2 + M3*w3 + M4*w4) is now not identically 1 +which means the weighted average is incorrect. (To test this, assume all the +weights are each 0.25 and all the Fo values are 10 degC, Fa would then be 7.5 degC). +Next consider a masked weighted normalized average, +**f_ocean = (w1*M1 + w2*M2 + w3*M3 + w4*M4) combined with +Fa = (M1*w1*Fo1 + M2*w2*Fo2 + M3*w3*Fo3 + M4*w4*Fo4) / (f_ocean) which produces a reasonable but incorrect result** +because the weighted average uses the mask instead of the fraction. The +mask only produces a correct result +in cases where there is no sea ice because sea ice impacts the surface fractions. +Finally, consider +a fraction weighted normalized average using the dynamically varying +ocean fraction that is exposed to the atmosphere:: + + fo1 = 1 - fi1 + fo2 = 1 - fi2 + fo3 = 1 - fi3 + fo4 = 1 - fi4 + fao = w1*fo1 + w2*fo2 + w3*fo3 + w4*fo4 + Fao = (fo1*w1*Fo1 + fo2*w2*Fo2 + fo3*w3*Fo3 + fo4*w4*Fo4) / (fao) + +where fo1, fo2, fo3, and fo4 are the ocean fractions on the ocean gridcells +and depend on the sea ice fraction, +fao is the mapped ocean fraction on the atmosphere gridcell, and Fa +is the mapped SST. The ocean fractions are only defined where the ocean +mask is 1, otherwise the ocean and sea ice fractions are zero. +Now, the SST in each ocean gridcell is weighted by the fraction of the ocean +box exposed to the atmosphere and that weighted average is normalized by +the mapped dynamically varying fraction. This produces a reasonable result +as well as a conservative result. + +The conservation check involves thinking of Fo and Fa as a flux. On the +ocean grid, the quantity associated with the flux is:: + + Qo = (Fo1*fo1*A1 + Fo2*fo2*A2 + Fo3*fo3*A3 + Fo4*fo4*A4) * dt + +on the atmosphere grid, that quantity is the ocean fraction times the mapped +flux times the area times the timestep:: + + Qa = foa * Fao * Aa * dt + +Via some simple math, it can be shown that Qo = Qa if:: + + fao = w1*fo1 + w2*fo2 + w3*fo3 + w4*fo4 + Fao = (fo1*w1*Fo1 + fo2*w2*Fo2 + fo3*w3*Fo3 + fo4*w4*Fo4) / (fao) + +In practice, the fraction weighted normlized mapping field is computed +by mapping the ocean fraction and the fraction +weighted field from the ocean to the atmosphere grid separately and then +using the mapped fraction to normalize the field as a four step process:: + + Fo' = fo*Fo (a) + fao = w1*fo1 + w2*fo2 + w3*fo3 + w4*fo4 (b) + Fao' = w1*Fo1' + w2*Fo2' + w3*Fo3' + w4*Fo4' (c) + Fao = Fao'/fao (d) + +Steps (b) and (c) above are the sparse matrix multiply by the standard +conservative weights. +Step (a) fraction weighs the field and step (d) normalizes the mapped field. + +Another way to think of this is that the mapped flux (Fao') is normalized by the +same fraction (fao) that is used in the merge, so they actually cancel. +Both the normalization at the end of the mapping and the fraction weighting +in the merge can be skipped and the results should be identical. But then the mediator +will carry around Fao' instead of Fao and that field is far less intuitive +as it no longer represents the gridcell average value, but some subarea average +value. +In addition, that approach is only valid when carrying out full surface merges. If, +for instance, the SST is to be interpolated and not merged with anything, the field +must be normalized after mapping to be useful. + +The same mapping and merging process is valid for the sea ice:: + + fai = w1*fi1 + w2*fi2 + w3*fi3 + w4*fi4 + Fai = (fi1*w1*Fi1 + fi2*w2*Fi2 + fi3*w3*Fi3 + fi4*w4*Fi4) / (fai) + +Putting this together with the original merge equation:: + + Fa = fal*Fal + fao*Fao + fai*Fai + +where now:: + + fal = 1 - (fao+fai) + fao = w1*fo1 + w2*fo2 + w3*fo3 + w4*fo4 + fai = w1*fi1 + w2*fi2 + w3*fi3 + w4*fi4 + Fal = Fl1 = Fl2 = Fl3 = Fl4 as defined by the land model on the atmosphere grid + Fao = (fo1*w1*Fo1 + fo2*w2*Fo2 + fo3*w3*Fo3 + fo4*w4*Fo4) / (fao) + Fai = (fi1*w1*Fi1 + fi2*w2*Fi2 + fi3*w3*Fi3 + fi4*w4*Fi4) / (fai) + +will simplify to an equation that contains twelve distinct terms for each of the +four ocean gridboxes and the three different surfaces:: + + Fa = (w1*fl1*Fl1 + w2*fl2*Fl2 + w3*fl3*Fl3 + w4*fl4*Fl4) + + (w1*fo1*Fo1 + w2*fo2*Fo2 + w3*fo3*Fo3 + w4*fo4*Fo4) + + (w1*fi1*Fi1 + w2*fi2*Fi2 + w3*fi3*Fi3 + w4*fi4*Fi4) + +and this further simplifies to something that looks like a mapping +of the field merged on the ocean grid:: + + Fa = w1*(fl1*Fl1+fo1*Fo1+fi1*Fi1) + + w2*(fl2*Fl2+fo2*Fo2+fi2*Fi2) + + w3*(fl3*Fl3+fo3*Fo3+fi3*Fi3) + + w4*(fl4*Fl4+fo4*Fo4+fi4*Fi4) + +Like the exercise with Fao above, these equations can be shown to be +fully conservative. + +To summarize, multiple features such as area calculations, +weights, masking, normalization, fraction weighting, and merging approaches +have to be considered together to ensure conservation. The CMEPS mediator +uses unmasked and unnormalized weights and then generally +maps using the fraction weighted normalized approach. Merges are carried +out with fraction weights. +This is applied to both state and flux fields, with conservative, bilinear, +and other mapping approaches, and for both merged and unmerged fields. +This ensures that the fields are always useful gridcell average values +when being coupled or analyzed throughout the coupling implementation. + + +Area Corrections +####################################### + +Area corrections are generally necessary when coupling fluxes between different +component models if conservation is important. The area corrections adjust +the fluxes such that the quantity is conserved between different models. The +area corrections are necessary because different model usually compute gridcell +areas using different approaches. These approaches are inherently part of the +model discretization, they are NOT ad-hoc. + +If the previous section, areas and weights were introduced. Those areas +were assumed to consist of the area overlaps between gridcells and were computed +using a consistent approach such that the areas conserve. ESMF is able to compute +these area overlaps and the corresponding mapping weights such that fluxes can +be mapped and quantities are conserved. + +However, the ESMF areas don't necessarily agree with the model areas that are inherently +computed in the individual component models. As a result, the fluxes need to +be corrected by the ratio of the model areas and the ESMF areas. Consider a +simple configuration where two grids are identical, the areas computed by +ESMF are identical, and all the weights are 1.0. So:: + + A1 = A2 (from ESMF) + w1 = 1.0 (from ESMF) + F2 = w1*F1 (mapping) + F2*A2 = F1*A1 (conservation) + +Now lets assume that the two models have fundamentally different discretizations, +different area algorithms (i.e. great circle vs simpler lon/lat approximations), +or even different +assumptions about the size and shape of the earth. The grids can be identical in +terms of the longitude and latitude of the +gridcell corners and centers, but the areas can also +be different because of the underlying model implementation. When a flux is passed +to or from each component, the quantity associated with that flux is proportional to +the model area, so:: + + A1 = A2 (ESMF areas) + w1 = 1.0 + F2 = w1*F1 (mapping) + F2 = F1 + A1m != A2m (model areas) + F1*A1m != F2*A2m (loss of conservation) + +This can be corrected by multiplying the fluxes +by an area correction. For each model, outgoing fluxes should be multiplied +by the model area divided by the ESMF area. Incoming fluxes should be multiplied +by the ESMF area divided by the model area. So:: + + F1' = A1m/A1*F1 + F2' = w1*F1' + F2 = F2'*A2/A2m + + Q2 = F2*A2m + = (F2'*A2/A2m)*A2m + = F2'*A2 + = (w1*F1')*A2 + = w1*(A1m/A1*F1)*A2 + = A1m*F1 + = Q1 + +and now the mapped flux conserves in the component models. The area corrections +should only be applied to fluxes. These area corrections +can actually be applied a number of ways. + +* The model areas can be passed into ESMF as extra arguments and then the weights will be adjusted. In this case, weights will no longer sum to 1 and different weights will need to be generated for mapping fluxes and states. +* Models can pass quantities instead of fluxes, multiplying the flux in the component by the model area. But this has a significant impact on the overall coupling strategy. +* Models can pass the areas to the mediator and the mediator can multiple fluxes by the source model area before mapping and divide by the destination model area area after mapping. +* Models can pass the areas to the mediator and implement an area correction term on the incoming and outgoing fluxes that is the ratio of the model and ESMF areas. This is the approach shown above and is how CMEPS traditionally implements this feature. + +Model areas should be passed to the mediator at initialization so the area corrections +can be computed and applied. These area corrections do not vary in time. + + +Lags, Accumulation and Averaging +####################################### + +In a coupled model, the component model sequencing and coupling frequency tend to introduce +some lags as well as a requirement to accumulate and average. This occurs when +component models are running sequentially or concurrently. In general, the component +models advance in time separately and the "current time" in each model becomes out of +sync during the sequencing loop. This is not unlike how component models take a timestep. +It's generally more important that the coupling be conservative than synchronous. + +At any rate, a major concern is conservation and consistency. As a general rule, when +multiple timesteps are taken between coupling periods in a component model, the fluxes and +states should be averaged over those timesteps before being passed back out to the +coupler. In the same way, the fluxes and states passed into the coupler should be +averaged over shorter coupling periods for models that are coupled at longer coupling +periods. + +For conservation of mass and energy, the field that is accumluated should be consistent +with the field that would be passed if there were no averaging required. Take for +example a case where the ocean model is running at a longer coupling period. The ocean +model receives a fraction weighted merged atmosphere/ocean and ice/ocean flux written as:: + + Fo = fao*Fao + fio*Fio + +The averaged flux over multiple time periods, n, would then be:: + + Fo = 1/n * sum_n(fao*Fao + fio*Fio) + +where sum_n represents the sum over n time periods. This can also be written as:: + + Fo = 1/n * (sum_n(fao*Fao) + sum_n(fio*Fio)) + +So multiple terms can be summed and accumulated or the individual terms fao*Fao +and fio*Fio can be accumulated and later summed and averaged in either order. +Both approaches produce identical results. +Finally, **it's important to note that sum_n(fao)*sum_n(Fao) does not produce the same +results as the sum_n(fao*Fao)**. In other words, the fraction weighted flux has to be +accumulated and NOT the fraction and flux separately. This is important for conservation +in flux coupling. The same approach should be taken with merged states to compute the +most accurate representation of the average state over the slow coupling period. +An analysis and review of each coupling field should be carried out to determine +the most conservative and accurate representation of averaged fields. This is particularly +important for models like the sea ice model where fields may be undefined at gridcells +and timesteps where the ice fraction is zero. + +Next, consider how mapping interacts with averaging. A coupled field +can be accumulated on the grid where that field is used. As in the example above, +the field that would be passed to the ocean model can be accumulated on the ocean grid +over fast coupling periods as if the ocean model were called each fast coupling period. +If the flux is computed on another grid, it would save computational efforts if the +flux were accumulated and averaged on the flux computation grid over fast coupling +periods and only mapped to the destination grid on slow coupling periods. Consider +just the atmosphere/ocean term above:: + + 1/n * sum_n(fao_o*Fao_o) + +which is accumulated and averaged on the ocean grid before being passed to the ocean +model. The _o notation has been added to denote the field on on the ocean grid. +However, if Fao is computed on the atmosphere grid, then each fast coupling period +the following operations would need to be carried out + +* Fao_a is computed on the atmosphere grid +* fao_a, the ocean fraction on the atmosphere grid is known +* fao_o = map(fao_a), the fraction is mapped from atmosphere to ocean +* Fao_o = map(Fao_a), the flux is mapped from atmosphere to ocean +* fao_o*Fao_o is accumulated over fast coupling periods +* 1/n * sum_n(fao_o*Fao_o), the accumulation is averaged every slow coupling period + +Writing this in equation form:: + + Fo = 1/n * sum_n(mapa2o(fao_a) * mapa2o(fao_a*Fao_a)/mapa2o(fao_a)) + +where Fao_o is a fraction weighted normalized mapping as required for conservation +and fao_o is the mapped ocean fraction on the atmosphere grid. +Simplifying the above equation:: + + Fo = 1/n * sum_n(mapa2o(fao_a*Fao_a) + +Accumulation (sum_n) and mapping (mapa2o) are both linear operations so this can +be written as:: + + Fo = 1/n * mapa2o(sum_n(fao_a*Fao_a)) + Fo = mapa2o(1/n*sum_n(fao_a*Fao_a)) + +which suggests that the accumulation can be done on the source side (i.e. atmosphere) +and only mapped on the slow coupling period. But again, fao_a*Fao_a has to be +accumulated and then when mapped, NO fraction would be applied to the merge as this +is already included in the mapped field. In equation form, the full merged ocean +field would be implemented as:: + + Fao'_o = mapa2o(1/n*sum_n(fao_a*Fao_a)) + Fo = Fao'_o + fio_o*Fio_o + +where a single accumulated field is only mapped once each slow coupling period +and an asymmetry is introduced in the merge in terms of the use of the fraction +weight. In the standard approach:: + + fao_o = mapa2o(fao_a) + Fao_o = mapa2o(fao_a*Fao_a)/mapa2o(fao_a) + Fo = fao_o*Fao_o + fio_o*Fio_o + +two atmosphere fields are mapped every fast coupling period, the merge is now +fraction weighted for all terms, and the mapped fields, fao_o and Fao_o, have +physically meaningful values. Fao'_o above does not. This implementation +has a parallel with the normalization step. As suggested above, there are two +implementations for conservative mapping and merging in general. The one outlined +above with fraction weighted normalized mapping and fraction weighted +merging:: + + fao_o = mapa2o(fao_a) + Fao_o = mapa2o(fao_a*Fao_a)/mapa2o(fao_a) + Fo = fao_o*Fao_o + +or an option where the fraction weighted mapped field is NOT normalized and the +fraction is NOT applied during the merge:: + + Fao'_o = mapa2o(fao_a*Fao_a) + Fo = Fao'_o + +These will produce identical results in the same way that their accumulated averages +do. + + + +Flux Calculation Grid +####################################### + +The grid that fluxes are computed on is another critical issue to consider. Consider +the atmosphere/ocean flux again. Generally, the atmosphere/ice flux is computed +in the ice model due to subgrid scale processes that need to be resolved. In addition, +the ice model is normally run at a fast coupling period and advances +one sea ice timestep per coupling period. On the other hand, the ocean model is often coupled +at a slower coupling period and atmosphere/ocean fluxes are computed outside the +ocean model at the faster atmopshere coupling period. In some models, the atmosphere/ocean +fluxes are computed in the mediator, on the ocean grid, from ocean and mapped +atmosphere states, and those atmosphere/ocean fluxes are mapped conservatively to +the atmosphere grid. In other models, the atmosphere/ocean fluxes are computed +on the atmosphere grid in the atmosphere model, from atmosphere and mapped ocean states, +and then those atmosphere/ocean fluxes are mapped conservatively to the ocean +grid. Those implementations are different in many respects, but they share basic +equations:: + + fo_o = 1 - fi_o + fl_a = 1 - mapo2a(Mo) + fo_a = mapo2a(fo_o) + fi_a = mapo2a(fi_o) + Fa = fl_a*Fal_a + fo_a*Fao_a + fi_a*Fai_a + Fo = fo_o*Fao_o + fi_o*Fio_o + +The above equations indicate that the land fraction on the atmosphere grid is the +complement of the mapped ocean mask and is static. The ice and ocean fractions are +determined from the ice model and are dynamic. Both can be mapped to the atmosphere +grid. Finally, the atmosphere flux is a three-way merge of the land, ocean, and +ice terms on the atmosphere grid while the ocean flux is a two-way merge of the +atmosphere and ice terms on the ocean grid. + +When the atmosphere/ocean and atmosphere/ice fluxes are both computed on the same +grid, at the same frequency, and both are mapped to the atmosphere grid, conservative +mapping and merging is relatively straight-forward:: + + fo_a = mapo2a(fo_o) + Fao_a = mapo2a(fo_o*Fao_o)/fo_a + fi_a = mapo2a(fi_o) + Fai_a = mapo2a(fi_o*Fai_o)/fi_a + +and everything conserves relatively directly:: + + fo_o + fi_o = Mo + fl_a + fo_a + fi_a = 1.0 + fo_a*Fao_a = fo_o*Fao_o + fi_a*Fai_a = fi_o*Fai_o + +When the atmosphere/ice fluxes are computed on the ocean grid while +the atmosphere/ocean fluxes are computed on the atmosphere grid, +extra care is needed with regard to fractions and conservation. In this case:: + + fo_a = mapo2a(fo_o) + Fao_o = mapa2o(fo_a*Fao_a)/mapa2o(fo_a) + fi_a = mapo2a(fi_o) + Fai_a = mapo2a(fi_o*Fai_o)/fi_a + +fo_o, fi_o, Fai_o, and Fao_a are specified and Fao_o has to be computed. The most +important point here is that during the ocean merge, the mapped ocean fraction on the +atmosphere grid is used so:: + + Fo = mapa2o(fo_a)*(mapa2o(fo_a*Fao_a)/mapa2o(fo_a)) + fi_o*Fio_o + +This is conservative because from basic mapping/merging principles:: + + fo_a * Fao_a = mapa2o(fo_a)*(mapa2o(fo_a*Fao_a)/mapa2o(fo_a)) + +fo_a is the mapped ocean fraction while Fao_a is the computed flux on the atmosphere +grid. Note that **mapa2o(fo_a) != fo_o** which also means that fi_o + mapa2o(fo_a) != 1. +Since the ocean fraction is computed on the ocean grid while the atmosphere/ocean +flux is computed on the atmosphere grid, an extra mapping is introduced which results in +extra diffusion. As a result, the atmosphere/ocean +and ice/ocean fluxes are computed and applied differently to the different grids. And +while the fraction weights in the two-way merge don't sum to 1 at each gridcell, the +fluxes still conserve. Again, the normalized fraction weighted mapped atmosphere/ocean +flux from the atmosphere grid should NOT be merged with the original ocean fraction on the +ocean grid. They must be merged with the atmosphere ocean fraction mapped to the ocean +grid which is two mappings removed from the original ocean fraction on the ocean grid. + +An open question exists whether there is atmosphere/ocean flux (Fao"_o) that conserves and +allows the two-way ocean merge equation to use the original fo_o fraction weight +such that:: + + fo_o * Fao"_o = mapa2o(fo_a)*(mapa2o(fo_a*Fao_a)/mapa2o(fo_a) + +It has been suggested that if Fao"_o is mapo2a(Fao_a), the system conserves:: + + fo_o * mapa2o(Fao_a) =? mapa2o(fo_a)*mapa2o(fo_a*Fao_a)/mapa2o(fo_a) + +But this still needs to be verified. diff --git a/doc/source/prep.rst b/doc/source/prep.rst new file mode 100644 index 000000000..07595cb45 --- /dev/null +++ b/doc/source/prep.rst @@ -0,0 +1,85 @@ +.. _prep_modules: + +====================== + CMEPS `prep` modules +====================== + +The following modules comprise the "prep phase" CMEPS code: + +**med_phases_prep_atm_mod.F90**: prepares the mediator export state to the atmosphere component + +**med_phases_prep_ice_mod.F90**: prepares the mediator export state to the sea-ice component + +**med_phases_prep_glc_mod.F90**: prepares the mediator export state to the land-ice component + +**med_phases_prep_lnd_mod.F90**: prepares the mediator export state to the land component + +**med_phases_prep_ocn_mod.F90**: prepares the mediator export state to the ocean component + +**med_phases_prep_rof_mod.F90**: prepares the mediator export state to the river component + +**med_phases_prep_wav_mod.F90**: prepares the mediator export state to the wave component + + +Each prep phase module has several sections: + +1. Mapping each source field that needs to be mapped to the destination mesh. + This is obtained from the ``addmap`` calls in the application specific ``esmFldsExchange_xxxx_mod.F90``. + Each `prep` module will call the generic routine ``med_map_FB_Regrid_Norm`` to do this mapping. + +2. Merging the set of source fields that have been mapped to the destination mesh. + This is obtained from the ``addmrg`` calls in the application specific ``esmFldsExchange_xxxx_mod.F90``. + +3. Carrying out optional custom calculations that cannot be specified + via ``addmap`` or ``addmrg`` calls. Custom calculations are the + only part of the CMEPS prep phases that can be can be application + specific. The attribute ``coupling_mode`` is utilized to by the + prep phases to determine if a particular customization is targeted + for only one application. Currently prep phase customization + encompasses the following: + + * ``med_phases_prep_atm``: + + * Calculation of ocean albedos and atmosphere/ocean fluxes (for CESM). + * Calculation of land, ice and ocean fractions to send to the atmosphere if those components are present. + * ``med_phases_prep_ice``: + + * Update the scalar data for the time of the next short wave calculation carried out by the atmosphere, used by the + ice component to determine the zenith angle (for CESM) + * applicate of precipitation factor received from the ocean component (for CESM) + + * ``med_phases_prep_glc``: + + * the land-ice component prep phase `ONLY` uses custom code. Land + import fields that are destined for the land-ice component are + in elevation classes, whereas the land-ice components requires + import data that is not in elevation classes. In addition, the + land-ice component couples at a much longer time scale than the + land component. The custom code in this module carries out the + mapping and merged to take data from the land component, + accumulate it and map the data both in resolution and in the + compression of elevation class input to non-elevation class + output. (for CESM) + + * ``med_phases_prep_lnd``: + + * carry out land-ice to land mapping if land-ice is present (for CESM) + * update the scalar data for the time of the next short + wave calculation caried out by the atmosphere (this is needed to the + land component to determine the zenith angle) (for CESM) + + * ``med_phases_prep_ocn``: + + * computation of net shortwave that is sent to the ocean. + * apply precipitation fractor to scale rain and snow sent to ocean (for CESM) + * carry out custom merges for NEMS coupling modes (for NEMS) + + * ``med_phases_prep_rof``: + + * reset the irrigation flux to the river model by pulling in + irrigation out of the rof cells that are proportial to the + river volume in each cell (for CESM). + + * ``med_phases_prep_wav``: + + * currently there are no custom calculations. diff --git a/drivers/cime/esm.F90 b/drivers/cime/esm.F90 index e1a18f135..d28ddacb0 100644 --- a/drivers/cime/esm.F90 +++ b/drivers/cime/esm.F90 @@ -429,7 +429,6 @@ subroutine InitAttributes(driver, rc) real(R8) :: reprosum_diffmax ! setup reprosum, set rel_diff_max logical :: reprosum_recompute ! setup reprosum, recompute if tolerance exceeded character(LEN=CS) :: tfreeze_option ! Freezing point calculation - real(R8) :: wall_time_limit ! wall time limit in hours integer :: glc_nec ! number of elevation classes in the land component for lnd->glc character(LEN=CS) :: wv_sat_scheme real(R8) :: wv_sat_transition_start @@ -639,7 +638,6 @@ subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, n character(len=CS) :: attribute integer :: componentCount character(len=*), parameter :: subname = "(esm.F90:AddAttributes)" - logical :: lvalue = .false. !------------------------------------------- rc = ESMF_Success @@ -655,18 +653,13 @@ subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, n if (chkerr(rc,__LINE__,u_FILE_u)) return !------ - ! Add restart flag a to gcomp attributes + ! Add driver restart flag a to gcomp attributes !------ attribute = 'read_restart' - call NUOPC_CompAttributeAdd(gcomp, (/trim(attribute)/), rc=rc) + call NUOPC_CompAttributeGet(driver, name=trim(attribute), value=cvalue, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(driver, name="mediator_read_restart", value=cvalue, rc=rc) + call NUOPC_CompAttributeAdd(gcomp, (/trim(attribute)/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) lvalue - if (.not. lvalue) then - call NUOPC_CompAttributeGet(driver, name=trim(attribute), value=cvalue, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end if call NUOPC_CompAttributeSet(gcomp, name=trim(attribute), value=trim(cvalue), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -675,13 +668,10 @@ subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, n !------ call ReadAttributes(gcomp, config, trim(compname)//"_attributes::", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ReadAttributes(gcomp, config, "ALLCOMP_attributes::", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ReadAttributes(gcomp, config, trim(compname)//"_modelio"//trim(inst_suffix)//"::", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ReadAttributes(gcomp, config, "CLOCK_attributes::", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -723,7 +713,6 @@ subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, n !------ ! Add single column and single point attributes !------ - call esm_set_single_column_attributes(compname, gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return diff --git a/drivers/cime/esm_time_mod.F90 b/drivers/cime/esm_time_mod.F90 index 49c0226bb..40c57b87c 100644 --- a/drivers/cime/esm_time_mod.F90 +++ b/drivers/cime/esm_time_mod.F90 @@ -161,9 +161,9 @@ subroutine esm_time_clockInit(ensemble_driver, instance_driver, logunit, mastert return end if close(unitn) - call ESMF_LogWrite(trim(subname)//" read driver restart from file = "//trim(restart_file), & - ESMF_LOGMSG_ERROR) - + if (mastertask) then + write(logunit,'(a)') trim(subname)//" reading driver restart from file = "//trim(restart_file) + end if call esm_time_read_restart(restart_file, start_ymd, start_tod, curr_ymd, curr_tod, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return diff --git a/mediator/esmFlds.F90 b/mediator/esmFlds.F90 index 70057f340..c2bc91c5b 100644 --- a/mediator/esmFlds.F90 +++ b/mediator/esmFlds.F90 @@ -35,6 +35,8 @@ module esmflds integer, public :: compglc(max_icesheets) = (/compglc1,compglc2/) integer, public :: num_icesheets ! obtained from attribute logical, public :: ocn2glc_coupling ! obtained from attribute + logical, public :: lnd2glc_coupling ! obtained in med.F90 + logical, public :: accum_lnd2glc ! obtained in med.F90 (this can be true even if lnd2glc_coupling is false) logical, public :: dststatus_print = .false. @@ -188,7 +190,7 @@ subroutine med_fldList_AddFld(flds, stdname, shortname) ! local variables integer :: n,oldsize,id logical :: found - type(med_fldList_entry_type), pointer :: newflds(:) => null() + type(med_fldList_entry_type), pointer :: newflds(:) character(len=*), parameter :: subname='(med_fldList_AddFld)' ! ---------------------------------------------- @@ -386,10 +388,10 @@ subroutine med_fldList_Realize(state, fldList, flds_scalar_name, flds_scalar_num character(ESMF_MAXSTR) :: transferActionAttr type(ESMF_StateIntent_Flag) :: stateIntent character(ESMF_MAXSTR) :: transferAction - 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(ESMF_MAXSTR), pointer :: StandardNameList(:) + character(ESMF_MAXSTR), pointer :: ConnectedList(:) + character(ESMF_MAXSTR), pointer :: NameSpaceList(:) + character(ESMF_MAXSTR), pointer :: itemNameList(:) character(len=*),parameter :: subname='(med_fldList_Realize)' ! ---------------------------------------------- diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index 3b84c7223..e853d7073 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -27,25 +27,34 @@ module esmFldsExchange_cesm_mod 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) :: 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) :: 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' + ! currently required mapping files + character(len=CX) :: glc2ice_rmap ='unset' + character(len=CX) :: glc2ocn_liq_rmap ='unset' + character(len=CX) :: glc2ocn_ice_rmap ='unset' + character(len=CX) :: rof2ocn_fmap ='unset' + character(len=CX) :: rof2ocn_ice_rmap ='unset' + character(len=CX) :: rof2ocn_liq_rmap ='unset' + character(len=CX) :: wav2ocn_smap ='unset' + character(len=CX) :: ice2wav_smap ='unset' + character(len=CX) :: ocn2wav_smap ='unset' + + ! no mapping files (value is 'idmap' or 'unset') + character(len=CX) :: atm2ice_map='unset' + character(len=CX) :: atm2ocn_map='unset' + character(len=CX) :: atm2lnd_map='unset' + character(len=CX) :: ice2atm_map='unset' + character(len=CX) :: ocn2atm_map='unset' + character(len=CX) :: lnd2atm_map='unset' + character(len=CX) :: lnd2rof_map='unset' + character(len=CX) :: rof2lnd_map='unset' + character(len=CX) :: atm2wav_map='unset' + logical :: mapuv_with_cart3d logical :: flds_i2o_per_cat logical :: flds_co2a logical :: flds_co2b logical :: flds_co2c + logical :: flds_wiso character(*), parameter :: u_FILE_u = & __FILE__ @@ -82,20 +91,13 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! local variables: type(InternalState) :: is_local integer :: n, ns - logical :: is_lnd, is_glc - character(len=5) :: iso(2) character(len=CL) :: cvalue - character(len=CS) :: name, fldname - character(len=CS), allocatable :: flds(:) - character(len=CS), allocatable :: suffix(:) + character(len=CS) :: name character(len=*) , parameter :: subname=' (esmFldsExchange_cesm) ' !-------------------------------------- rc = ESMF_SUCCESS - iso(1) = ' ' - iso(2) = '_wiso' - !--------------------------------------- ! Get the internal state !--------------------------------------- @@ -109,74 +111,42 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if (phase == 'advertise') then ! 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) + call NUOPC_CompAttributeGet(gcomp, name='ice2atm_map', value=ice2atm_map, 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 (mastertask) write(logunit, '(a)') trim(subname)//'ice2atm_map = '// trim(ice2atm_map) + call NUOPC_CompAttributeGet(gcomp, name='lnd2atm_map', value=lnd2atm_map, 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 (mastertask) write(logunit, '(a)') trim(subname)//'lnd2atm_map = '// trim(lnd2atm_map) + call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_map', value=ocn2atm_map, 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) + if (mastertask) write(logunit, '(a)') trim(subname)//'ocn2atm_map = '// trim(ocn2atm_map) ! 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) + call NUOPC_CompAttributeGet(gcomp, name='atm2lnd_map', value=atm2lnd_map, 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 (mastertask) write(logunit, '(a)') trim(subname)//'atm2lnd_map = '// trim(atm2lnd_map) + call NUOPC_CompAttributeGet(gcomp, name='rof2lnd_map', value=rof2lnd_map, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit, '(a)') trim(subname)//'rof2lnd_fmapname = '// trim(rof2lnd_fmap) + if (mastertask) write(logunit, '(a)') trim(subname)//'rof2lnd_map = '// trim(rof2lnd_map) ! 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) + call NUOPC_CompAttributeGet(gcomp, name='atm2ice_map', value=atm2ice_map, 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) - + if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ice_map = '// trim(atm2ice_map) 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) ! 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) + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_map', value=atm2ocn_map, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ocn_vmapname = '// trim(atm2ocn_vmap) - + if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ocn_map = '// trim(atm2ocn_map) 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) @@ -188,20 +158,20 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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) ! mapping to rof - call NUOPC_CompAttributeGet(gcomp, name='lnd2rof_fmapname', value=lnd2rof_fmap, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='lnd2rof_map', value=lnd2rof_map, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2rof_fmapname = '// trim(lnd2rof_fmap) + if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2rof_map = '// trim(lnd2rof_map) ! mapping to wav - call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', value=atm2wav_smap, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='atm2wav_map', value=atm2wav_map, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit,'(a)') trim(subname)//'atm2wav_smapname = '// trim(atm2wav_smap) + if (mastertask) write(logunit,'(a)') trim(subname)//'atm2wav_map = '// trim(atm2wav_map) + 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) @@ -212,10 +182,9 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! 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 - ! co2 transfer between componetns + ! is co2 transfer between components enabled? call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) flds_co2a @@ -236,13 +205,20 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) ocn2glc_coupling + ! are water isotope exchanges enabled? + call NUOPC_CompAttributeGet(gcomp, name='flds_wiso', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_wiso + ! write diagnostic output if (mastertask) then - write(logunit,'(a)') trim(subname)//' flds_co2a = '// trim(cvalue) - write(logunit,'(a)') trim(subname)//' flds_co2b = '// trim(cvalue) - write(logunit,'(a)') trim(subname)//' flds_co2c = '// trim(cvalue) - write(logunit,'(a)') trim(subname)//' flds_i2o_per_cat = '// trim(cvalue) - write(logunit,'(a)') trim(subname)//' ocn2glc_coupling = '// trim(cvalue) + write(logunit,'(a,l7)') trim(subname)//' flds_co2a = ',flds_co2a + write(logunit,'(a,l7)') trim(subname)//' flds_co2b = ',flds_co2b + write(logunit,'(a,l7)') trim(subname)//' flds_co2c = ',flds_co2b + write(logunit,'(a,l7)') trim(subname)//' flds_wiso = ',flds_wiso + write(logunit,'(a,l7)') trim(subname)//' flds_i2o_per_cat = ',flds_i2o_per_cat + write(logunit,'(a,l7)') trim(subname)//' ocn2glc_coupling = ',ocn2glc_coupling + write(logunit,'(a,l7)') trim(subname)//' mapuv_with_cart3d = ',mapuv_with_cart3d end if end if @@ -281,53 +257,50 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! --------------------------------------------------------------------- ! to med: atm and ocn fields required for atm/ocn flux calculation' ! --------------------------------------------------------------------- - if (phase /= 'advertise') then + if (phase == 'advertise') then call addfld(fldListFr(compatm)%flds, 'Sa_u') call addfld(fldListFr(compatm)%flds, 'Sa_v') - 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) - call addfld(fldListFr(compatm)%flds, 'Sa_tbot') - call addmap(fldListFr(compatm)%flds, 'Sa_tbot', compocn, mapbilnr, 'one', atm2ocn_smap) - call addfld(fldListFr(compatm)%flds, 'Sa_pbot') - call addmap(fldListFr(compatm)%flds, 'Sa_pbot', compocn, mapbilnr, 'one', atm2ocn_smap) - 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 + if (flds_wiso) then call addfld(fldListFr(compatm)%flds, 'Sa_shum_wiso') - call addmap(fldListFr(compatm)%flds, 'Sa_shum_wiso', compocn, mapbilnr, 'one', atm2ocn_smap) + end if + else + if (is_local%wrap%aoflux_grid == 'ogrid') then + if (mapuv_with_cart3d) then + call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, mappatch_uv3d, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, mappatch_uv3d, 'one', atm2ocn_map) + else + call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, mappatch, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, mappatch, 'one', atm2ocn_map) + end if + call addmap(fldListFr(compatm)%flds, 'Sa_z' , compocn, mapbilnr, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_tbot', compocn, mapbilnr, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_pbot', compocn, mapbilnr, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_shum', compocn, mapbilnr, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_ptem', compocn, mapbilnr, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_dens', compocn, mapbilnr, 'one', atm2ocn_map) + if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_shum_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_shum_wiso', compocn, mapbilnr, 'one', atm2ocn_map) + end if end if end if ! --------------------------------------------------------------------- ! to med: swnet fluxes used for budget calculation ! --------------------------------------------------------------------- - ! TODO (mvertens, 2019-01-11): budget implemention needs to be done in CMEPS if (phase == 'advertise') then call addfld(fldListFr(complnd)%flds, 'Fall_swnet') call addfld(fldListFr(compice)%flds, 'Faii_swnet') call addfld(fldListFr(compatm)%flds, 'Faxa_swnet') else if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swnet', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compice, mapconsf, 'one' , atm2ice_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compocn, mapconsf, 'one' , atm2ocn_fmap) + call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compice, mapconsf, 'one' , atm2ice_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compocn, mapconsf, 'one' , atm2ocn_map) end if if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_swnet', rc=rc)) then call addmap(fldListFr(compice)%flds, 'Faii_swnet', compocn, mapfcopy, 'unset', 'unset') @@ -339,53 +312,248 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) !===================================================================== ! --------------------------------------------------------------------- - ! from atm: ! to lnd: height at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_z') + call addfld(fldListTo(complnd)%flds, 'Sa_z') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_z', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_z', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_z', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_z', mrg_from=compatm, mrg_fld='Sa_z', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: surface height from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_topo') + call addfld(fldListTo(complnd)%flds, 'Sa_topo') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_topo', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_topo', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_topo', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_topo', mrg_from=compatm, mrg_fld='Sa_topo', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: zonal wind at the lowest model level from atm ! to lnd: meridional wind at the lowest model level from atm - ! to lnd: Temperature at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_u') + call addfld(fldListTo(complnd)%flds, 'Sa_u') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_u', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_u', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_u', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_u', mrg_from=compatm, mrg_fld='Sa_u', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_v') + call addfld(fldListTo(complnd)%flds, 'Sa_v') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_v', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_v', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_v', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_v', mrg_from=compatm, mrg_fld='Sa_v', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- + ! to lnd: pressure at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_pbot') + call addfld(fldListTo(complnd)%flds, 'Sa_pbot') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_pbot', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_pbot', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_pbot', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_pbot', mrg_from=compatm, mrg_fld='Sa_pbot', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- + ! to lnd: o3 at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_o3') + call addfld(fldListTo(complnd)%flds, 'Sa_o3') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_o3', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_o3', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_o3', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_o3', mrg_from=compatm, mrg_fld='Sa_o3', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- + ! to lnd: temperature at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_tbot') + call addfld(fldListTo(complnd)%flds, 'Sa_tbot') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_tbot', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_tbot', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_tbot', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_tbot', mrg_from=compatm, mrg_fld='Sa_tbot', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: potential temperature at the lowest model level from atm - ! to lnd: Pressure at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_ptem') + call addfld(fldListTo(complnd)%flds, 'Sa_ptem') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_ptem', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_ptem', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_ptem', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_ptem', mrg_from=compatm, mrg_fld='Sa_ptem', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: specific humidity at the lowest model level from atm ! --------------------------------------------------------------------- - - allocate(flds(9)) - flds = (/'Sa_z ',& - 'Sa_topo ',& - 'Sa_u ',& - 'Sa_v ',& - 'Sa_tbot ',& - 'Sa_ptem ',& - 'Sa_pbot ',& - 'Sa_shum ',& - 'Sa_shum_wiso'/) - - do n = 1,size(flds) - fldname = trim(flds(n)) + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_shum') + call addfld(fldListTo(complnd)%flds, 'Sa_shum') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_shum', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_shum', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_shum', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_shum', mrg_from=compatm, mrg_fld='Sa_shum', mrg_type='copy') + end if + end if + if (flds_wiso) then if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(complnd)%flds, trim(fldname)) + call addfld(fldListFr(compatm)%flds, 'Sa_shum_wiso') + call addfld(fldListTo(complnd)%flds, 'Sa_shum_wiso') else - if ( fldchk(is_local%wrap%FBexp(complnd) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm ), trim(fldname), rc=rc)) then - call addmap(fldListFr(compatm)%flds, trim(fldname), & - complnd, mapbilnr, 'one', atm2lnd_smap) - call addmrg(fldListTo(complnd)%flds, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Sa_shum_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_shum_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_shum_wiso', complnd, mapbilnr, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sa_shum_wiso', mrg_from=compatm, mrg_fld='Sa_shum_wiso', mrg_type='copy') end if end if - end do - deallocate(flds) - + end if ! --------------------------------------------------------------------- ! to lnd: convective and large scale precipitation rate water equivalent from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_rainc') + call addfld(fldListTo(complnd)%flds, 'Faxa_rainc') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_rainc', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_rainc', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_rainc', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_rainc', mrg_from=compatm, mrg_fld='Faxa_rainc', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_rainl') + call addfld(fldListTo(complnd)%flds, 'Faxa_rainl') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_rainl', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_rainl', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_rainl', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_rainl', mrg_from=compatm, mrg_fld='Faxa_rainl', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: convective and large-scale (stable) snow rate from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_snowc') + call addfld(fldListTo(complnd)%flds, 'Faxa_snowc') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_snowc', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_snowc', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snowc', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_snowc', mrg_from=compatm, mrg_fld='Faxa_snowc', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_snowl') + call addfld(fldListTo(complnd)%flds, 'Faxa_snowl') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_snowl', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_snowl', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snowl', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_snowl', mrg_from=compatm, mrg_fld='Faxa_snowl', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: downward longwave heat flux from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') + call addfld(fldListTo(complnd)%flds, 'Faxa_lwdn') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_lwdn', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_lwdn', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_lwdn', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_lwdn', mrg_from=compatm, mrg_fld='Faxa_lwdn', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: downward direct near-infrared incident solar radiation from atm ! to lnd: downward direct visible incident solar radiation from atm ! to lnd: downward diffuse near-infrared incident solar radiation from atm ! to lnd: downward Diffuse visible incident solar radiation from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swndr') + call addfld(fldListTo(complnd)%flds, 'Faxa_swndr') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_swndr', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_swndr', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swndr', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_swndr', mrg_from=compatm, mrg_fld='Faxa_swndr', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swvdr') + call addfld(fldListTo(complnd)%flds, 'Faxa_swvdr') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_swvdr', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_swvdr', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdr', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_swvdr', mrg_from=compatm, mrg_fld='Faxa_swvdr', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swndf') + call addfld(fldListTo(complnd)%flds, 'Faxa_swndf') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_swndf', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_swndf', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swndf', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_swndf', mrg_from=compatm, mrg_fld='Faxa_swndf', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swvdf') + call addfld(fldListTo(complnd)%flds, 'Faxa_swvdf') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_swvdf', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_swvdf', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdf', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_swvdf', mrg_from=compatm, mrg_fld='Faxa_swvdf', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_bcph') + call addfld(fldListTo(complnd)%flds, 'Faxa_bcph') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_bcph', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_bcph', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_bcph', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_bcph', mrg_from=compatm, mrg_fld='Faxa_bcph', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: black carbon deposition fluxes from atm ! - hydrophylic black carbon dry deposition flux ! - hydrophobic black carbon dry deposition flux @@ -394,77 +562,148 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! - hydrophylic organic carbon dry deposition flux ! - hydrophobic organic carbon dry deposition flux ! - hydrophylic organic carbon wet deposition flux + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_ocph') + call addfld(fldListTo(complnd)%flds, 'Faxa_ocph') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_ocph', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_ocph', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_ocph', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_ocph', mrg_from=compatm, mrg_fld='Faxa_ocph', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: dust wet deposition flux (sizes 1-4) from atm ! to lnd: dust dry deposition flux (sizes 1-4) from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_dstwet') + call addfld(fldListTo(complnd)%flds, 'Faxa_dstwet') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_dstwet', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_dstwet', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_dstwet', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_dstwet', mrg_from=compatm, mrg_fld='Faxa_dstwet', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_dstdry') + call addfld(fldListTo(complnd)%flds, 'Faxa_dstdry') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_dstdry', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_dstdry', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_dstdry', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_dstdry', mrg_from=compatm, mrg_fld='Faxa_dstdry', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to lnd: nitrogen deposition fields from atm ! --------------------------------------------------------------------- - - ! TODO (mvertens, 2018-12-13): the nitrogen deposition fluxes here - ! are not treated the same was as in cesm2.0 release - ! TODO (mvertens, 2019-03-10): add water isotopes from atm - - allocate(flds(14)) - flds = (/'Faxa_rainc ',& - 'Faxa_rainl ',& - 'Faxa_snowc ',& - 'Faxa_snowl ',& - 'Faxa_lwdn ',& - 'Faxa_swndr ',& - 'Faxa_swvdr ',& - 'Faxa_swndf ',& - 'Faxa_swvdf ',& - 'Faxa_bcph ',& - 'Faxa_ocph ',& - 'Faxa_dstwet',& - 'Faxa_dstdry',& - 'Faxa_ndep ' /) - - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(complnd)%flds, trim(fldname)) - else - if (fldchk(is_local%wrap%FBexp(complnd) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm ), trim(fldname), rc=rc)) then - call addmap(fldListFr(compatm)%flds, trim(fldname), & - complnd, mapconsf, 'one', atm2lnd_fmap) - call addmrg(fldListTo(complnd)%flds, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_ndep') + call addfld(fldListTo(complnd)%flds, 'Faxa_ndep') + else + if ( fldchk(is_local%wrap%FBexp(complnd) , 'Faxa_ndep', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Faxa_ndep', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_ndep', complnd, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Faxa_ndep', mrg_from=compatm, mrg_fld='Faxa_ndep', mrg_type='copy') end if - end do - deallocate(flds) + end if ! --------------------------------------------------------------------- ! to lnd: river channel total water volume from rof ! to lnd: river channel main channel water volume from rof ! to lnd: river water flux back to land due to flooding + ! to lnd: tributary water depth + ! to lnd: tributary channel depth ! --------------------------------------------------------------------- - allocate(flds(6)) - flds = (/'Flrr_volr ',& - 'Flrr_volr_wiso ',& - 'Flrr_volrmch ',& - 'Flrr_volrmch_wiso',& - 'Flrr_flood ',& - 'Flrr_flood_wiso '/) + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Flrr_volr') + call addfld(fldListTo(complnd)%flds, 'Flrr_volr') + else + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Flrr_volr', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_volr', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_volr', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Flrr_volr', mrg_from=comprof, mrg_fld='Flrr_volr', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Flrr_volrmch') + call addfld(fldListTo(complnd)%flds, 'Flrr_volrmch') + else + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Flrr_volrmch', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_volrmch', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_volrmch', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Flrr_volrmch', mrg_from=comprof, mrg_fld='Flrr_volrmch', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Flrr_flood') + call addfld(fldListTo(complnd)%flds, 'Flrr_flood') + else + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Flrr_flood', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_flood', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Flrr_flood', mrg_from=comprof, mrg_fld='Flrr_flood', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Sr_tdepth') + call addfld(fldListTo(complnd)%flds, 'Sr_tdepth') + else + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Sr_tdepth', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Sr_tdepth', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Sr_tdepth', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sr_tdepth', mrg_from=comprof, mrg_fld='Sr_tdepth', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Sr_tdepth_max') + call addfld(fldListTo(complnd)%flds, 'Sr_tdepth_max') + else + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Sr_tdepth_max', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Sr_tdepth_max', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Sr_tdepth_max', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Sr_tdepth_max', mrg_from=comprof, mrg_fld='Sr_tdepth_max', mrg_type='copy') + end if + end if - do n = 1,size(flds) - fldname = trim(flds(n)) + if (flds_wiso) then + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Flrr_volr_wiso') + call addfld(fldListTo(complnd)%flds, 'Flrr_volr_wiso') + else + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Flrr_volr_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_volr_wiso', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_volr_wiso', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Flrr_volr_wiso', & + mrg_from=comprof, mrg_fld='Flrr_volr_wiso', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Flrr_volrmch_wiso') + call addfld(fldListTo(complnd)%flds, 'Flrr_volrmch_wiso') + else + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Flrr_volrmch_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_volrmch_wiso', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_volrmch_wiso', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Flrr_volrmch_wiso', & + mrg_from=comprof, mrg_fld='Flrr_volrmch_wiso', mrg_type='copy') + end if + end if if (phase == 'advertise') then - call addfld(fldListFr(comprof)%flds, trim(fldname)) - call addfld(fldListTo(complnd)%flds, trim(fldname)) + call addfld(fldListFr(comprof)%flds, 'Flrr_flood_wiso') + call addfld(fldListTo(complnd)%flds, 'Flrr_flood_wiso') else - if ( fldchk(is_local%wrap%FBExp(complnd) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(comprof, comprof), trim(fldname), rc=rc)) then - call addmap(fldListFr(comprof)%flds, trim(fldname), & - complnd, mapconsf, 'one', rof2lnd_fmap) - call addmrg(fldListTo(complnd)%flds, trim(fldname), & - mrg_from=comprof, mrg_fld=trim(fldname), mrg_type='copy') + if ( fldchk(is_local%wrap%FBExp(complnd) , 'Flrr_flood_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood_wiso', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_flood_wiso', complnd, mapconsf, 'one', rof2lnd_map) + call addmrg(fldListTo(complnd)%flds, 'Flrr_flood_wiso', & + mrg_from=comprof, mrg_fld='Flrr_flood_wiso', mrg_type='copy') end if end if - end do - deallocate(flds) + end if ! --------------------------------------------------------------------- ! to lnd: ice sheet grid coverage on global grid from glc @@ -530,44 +769,113 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! to atm: merged direct albedo (near-infrared radiation) ! to atm: merged diffuse albedo (near-infrared radiation) ! --------------------------------------------------------------------- - allocate(suffix(4)) - suffix = (/'avsdr',& - 'avsdf',& - 'anidr',& - 'anidf'/) + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Sl_avsdr') + call addfld(fldListFr(compice)%flds, 'Si_avsdr') + call addfld(fldListMed_ocnalb%flds , 'So_avsdr') + call addfld(fldListTo(compatm)%flds, 'Sx_avsdr') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_avsdr', rc=rc)) then + ! Note that for aqua-plant there will be no import from complnd or compice - and the + ! current logic below takes care of this. + if (fldchk(is_local%wrap%FBImp(complnd,complnd), 'Sl_avsdr', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_avsdr', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_avsdr', & + mrg_from=complnd, mrg_fld='Sl_avsdr', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Si_avsdr', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_avsdr', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_avsdr', & + mrg_from=compice, mrg_fld='Si_avsdr', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_ocnalb_a, 'So_avsdr', rc=rc)) then + call addmap(fldListMed_ocnalb%flds , 'So_avsdr', compatm, mapconsf, 'ofrac', ocn2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_avsdr', & + mrg_from=compmed, mrg_fld='So_avsdr', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if - do n = 1,size(suffix) - if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, 'Sl_'//trim(suffix(n))) - call addfld(fldListFr(compice)%flds, 'Si_'//trim(suffix(n))) - call addfld(fldListMed_ocnalb%flds , 'So_'//trim(suffix(n))) - call addfld(fldListTo(compatm)%flds, 'Sx_'//trim(suffix(n))) - else - if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_'//trim(suffix(n)), rc=rc)) then - ! Note that for aqua-plant there will be no import from complnd or compice - and the - ! current logic below takes care of this. - if (fldchk(is_local%wrap%FBImp(complnd,complnd), 'Sl_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListFr(complnd)%flds, 'Sl_'//trim(suffix(n)), & - compatm, mapconsf, 'lfrin', lnd2atm_smap) - call addmrg(fldListTo(compatm)%flds, 'Sx_'//trim(suffix(n)), & - mrg_from=complnd, mrg_fld='Sl_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='lfrac') - end if - if (fldchk(is_local%wrap%FBImp(compice,compice), 'Si_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Si_'//trim(suffix(n)), & - compatm, mapconsf, 'ifrac', ice2atm_smap) - call addmrg(fldListTo(compatm)%flds, 'Sx_'//trim(suffix(n)), & - mrg_from=compice, mrg_fld='Si_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ifrac') - end if - if (fldchk(is_local%wrap%FBMed_ocnalb_a, 'So_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListMed_ocnalb%flds , 'So_'//trim(suffix(n)), & - compatm, mapconsf, 'ofrac', ocn2atm_smap) - call addmrg(fldListTo(compatm)%flds, 'Sx_'//trim(suffix(n)), & - mrg_from=compmed, mrg_fld='So_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ofrac') - end if + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Sl_avsdf') + call addfld(fldListFr(compice)%flds, 'Si_avsdf') + call addfld(fldListMed_ocnalb%flds , 'So_avsdf') + call addfld(fldListTo(compatm)%flds, 'Sx_avsdf') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_avsdf', rc=rc)) then + ! Note that for aqua-plant there will be no import from complnd or compice - and the + ! current logic below takes care of this. + if (fldchk(is_local%wrap%FBImp(complnd,complnd), 'Sl_avsdf', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_avsdf', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_avsdf', & + mrg_from=complnd, mrg_fld='Sl_avsdf', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Si_avsdf', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_avsdf', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_avsdf', & + mrg_from=compice, mrg_fld='Si_avsdf', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_ocnalb_a, 'So_avsdf', rc=rc)) then + call addmap(fldListMed_ocnalb%flds , 'So_avsdf', compatm, mapconsf, 'ofrac', ocn2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_avsdf', & + mrg_from=compmed, mrg_fld='So_avsdf', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Sl_anidr') + call addfld(fldListFr(compice)%flds, 'Si_anidr') + call addfld(fldListMed_ocnalb%flds , 'So_anidr') + call addfld(fldListTo(compatm)%flds, 'Sx_anidr') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_anidr', rc=rc)) then + ! Note that for aqua-plant there will be no import from complnd or compice - and the + ! current logic below takes care of this. + if (fldchk(is_local%wrap%FBImp(complnd,complnd), 'Sl_anidr', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_anidr', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_anidr', & + mrg_from=complnd, mrg_fld='Sl_anidr', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Si_anidr', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_anidr', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_anidr', & + mrg_from=compice, mrg_fld='Si_anidr', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_ocnalb_a, 'So_anidr', rc=rc)) then + call addmap(fldListMed_ocnalb%flds , 'So_anidr', compatm, mapconsf, 'ofrac', ocn2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_anidr', & + mrg_from=compmed, mrg_fld='So_anidr', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Sl_anidf') + call addfld(fldListFr(compice)%flds, 'Si_anidf') + call addfld(fldListMed_ocnalb%flds , 'So_anidf') + call addfld(fldListTo(compatm)%flds, 'Sx_anidf') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_anidf', rc=rc)) then + ! Note that for aqua-plant there will be no import from complnd or compice - and the + ! current logic below takes care of this. + if (fldchk(is_local%wrap%FBImp(complnd,complnd), 'Sl_anidf', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_anidf', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_anidf', & + mrg_from=complnd, mrg_fld='Sl_anidf', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Si_anidf', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_anidf', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_anidf', & + mrg_from=compice, mrg_fld='Si_anidf', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_ocnalb_a, 'So_anidf', rc=rc)) then + call addmap(fldListMed_ocnalb%flds , 'So_anidf', compatm, mapconsf, 'ofrac', ocn2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sx_anidf', & + mrg_from=compmed, mrg_fld='So_anidf', mrg_type='merge', mrg_fracname='ofrac') end if end if - end do - deallocate(suffix) + end if ! --------------------------------------------------------------------- ! to atm: merged reference temperature at 2 meters @@ -575,41 +883,232 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! to atm: merged reference specific humidity at 2 meters ! to atm: merged reference specific water isoptope humidity at 2 meters ! --------------------------------------------------------------------- - allocate(suffix(4)) - suffix = (/'tref ',& - 'u10 ',& - 'qref ',& - 'qref_wiso'/) - do n = 1,size(suffix) - if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds , 'Sl_'//trim(suffix(n))) - call addfld(fldListFr(compice)%flds , 'Si_'//trim(suffix(n))) - call addfld(fldListMed_aoflux%flds , 'So_'//trim(suffix(n))) - call addfld(fldListTo(compatm)%flds , 'Sx_'//trim(suffix(n))) - else - if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_'//trim(suffix(n)), rc=rc)) then - if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListFr(complnd)%flds , 'Sl_'//trim(suffix(n)), compatm, mapconsf, 'lfrin', lnd2atm_fmap) - call addmrg(fldListTo(compatm)%flds , 'Sx_'//trim(suffix(n)), & - mrg_from=complnd, mrg_fld='Sl_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='lfrac') - end if - if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListFr(compice)%flds , 'Si_'//trim(suffix(n)), compatm, mapconsf, 'ifrac', ice2atm_fmap) - call addmrg(fldListTo(compatm)%flds , 'Sx_'//trim(suffix(n)), & - mrg_from=compice, mrg_fld='Si_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ifrac') + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_tref') + call addfld(fldListFr(compice)%flds , 'Si_tref') + call addfld(fldListMed_aoflux%flds , 'So_tref') + call addfld(fldListTo(compatm)%flds , 'Sx_tref') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_tref', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_tref', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_tref', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_tref', & + mrg_from=complnd, mrg_fld='Sl_tref', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_tref', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_tref', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_tref', & + mrg_from=compice, mrg_fld='Si_tref', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_tref', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'So_tref', compatm, mapconsf, 'ofrac', ocn2atm_map) end if - if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListMed_aoflux%flds , 'So_'//trim(suffix(n)), compocn, mapbilnr, 'one' , atm2ocn_fmap) ! map atm->ocn - call addmap(fldListMed_aoflux%flds , 'So_'//trim(suffix(n)), compatm, mapconsf, 'ofrac', ocn2atm_fmap) ! map ocn->atm - call addmrg(fldListTo(compatm)%flds , 'Sx_'//trim(suffix(n)), & - mrg_from=compmed, mrg_fld='So_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ofrac') + call addmrg(fldListTo(compatm)%flds , 'Sx_tref', & + mrg_from=compmed, mrg_fld='So_tref', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_u10') + call addfld(fldListFr(compice)%flds , 'Si_u10') + call addfld(fldListMed_aoflux%flds , 'So_u10') + call addfld(fldListTo(compatm)%flds , 'Sx_u10') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_u10', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_u10', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_u10', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_u10', & + mrg_from=complnd, mrg_fld='Sl_u10', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_u10', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_u10', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_u10', & + mrg_from=compice, mrg_fld='Si_u10', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_u10', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds, 'So_u10', compatm, mapconsf, 'ofrac', ocn2atm_map) end if + call addmrg(fldListTo(compatm)%flds , 'Sx_u10', & + mrg_from=compmed, mrg_fld='So_u10', mrg_type='merge', mrg_fracname='ofrac') end if end if - end do - deallocate(suffix) + end if + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_qref') + call addfld(fldListFr(compice)%flds , 'Si_qref') + call addfld(fldListMed_aoflux%flds , 'So_qref') + call addfld(fldListTo(compatm)%flds , 'Sx_qref') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_qref', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_qref', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_qref', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref', & + mrg_from=complnd, mrg_fld='Sl_qref', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_qref', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_qref', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref', & + mrg_from=compice, mrg_fld='Si_qref', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_qref', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds, 'So_qref', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Sx_qref', & + mrg_from=compmed, mrg_fld='So_qref', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (flds_wiso) then + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_qref_wiso') + call addfld(fldListFr(compice)%flds , 'Si_qref_wiso') + call addfld(fldListMed_aoflux%flds , 'So_qref_wiso') + call addfld(fldListTo(compatm)%flds , 'Sx_qref_wiso') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_qref_wiso', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_qref_wiso', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_qref_wiso', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref_wiso', & + mrg_from=complnd, mrg_fld='Sl_qref_wiso', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_qref_wiso', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_qref_wiso', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref_wiso', & + mrg_from=compice, mrg_fld='Si_qref_wiso', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_qref_wiso', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'So_qref_wiso', compatm, mapconsf, 'ofrac', ocn2atm_map) ! map ocn->atm + end if + call addmrg(fldListTo(compatm)%flds , 'Sx_qref_wiso', & + mrg_from=compmed, mrg_fld='So_qref_wiso', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + end if + + ! --------------------------------------------------------------------- + ! to atm: merged reference temperature at 2 meters + ! to atm: merged 10m wind speed + ! to atm: merged reference specific humidity at 2 meters + ! to atm: merged reference specific water isoptope humidity at 2 meters + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_tref') + call addfld(fldListFr(compice)%flds , 'Si_tref') + call addfld(fldListMed_aoflux%flds , 'So_tref') + call addfld(fldListTo(compatm)%flds , 'Sx_tref') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_tref', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_tref', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_tref', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_tref', & + mrg_from=complnd, mrg_fld='Sl_tref', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_tref', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_tref', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_tref', & + mrg_from=compice, mrg_fld='Si_tref', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_tref', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'So_tref', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Sx_tref', & + mrg_from=compmed, mrg_fld='So_tref', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_u10') + call addfld(fldListFr(compice)%flds , 'Si_u10') + call addfld(fldListMed_aoflux%flds , 'So_u10') + call addfld(fldListTo(compatm)%flds , 'Sx_u10') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_u10', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_u10', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_u10', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_u10', & + mrg_from=complnd, mrg_fld='Sl_u10', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_u10', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_u10', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_u10', & + mrg_from=compice, mrg_fld='Si_u10', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_u10', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds, 'So_u10', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Sx_u10', & + mrg_from=compmed, mrg_fld='So_u10', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_qref') + call addfld(fldListFr(compice)%flds , 'Si_qref') + call addfld(fldListMed_aoflux%flds , 'So_qref') + call addfld(fldListTo(compatm)%flds , 'Sx_qref') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_qref', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_qref', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_qref', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref', & + mrg_from=complnd, mrg_fld='Sl_qref', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_qref', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_qref', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref', & + mrg_from=compice, mrg_fld='Si_qref', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_qref', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds, 'So_qref', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Sx_qref', & + mrg_from=compmed, mrg_fld='So_qref', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (flds_wiso) then + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds , 'Sl_qref_wiso') + call addfld(fldListFr(compice)%flds , 'Si_qref_wiso') + call addfld(fldListMed_aoflux%flds , 'So_qref_wiso') + call addfld(fldListTo(compatm)%flds , 'Sx_qref_wiso') + else + if ( fldchk(is_local%wrap%FBexp(compatm), 'Sx_qref_wiso', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_qref_wiso', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Sl_qref_wiso', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref_wiso', & + mrg_from=complnd, mrg_fld='Sl_qref_wiso', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_qref_wiso', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Si_qref_wiso', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Sx_qref_wiso', & + mrg_from=compice, mrg_fld='Si_qref_wiso', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'So_qref_wiso', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds, 'So_qref_wiso', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Sx_qref_wiso', & + mrg_from=compmed, mrg_fld='So_qref_wiso', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + end if ! --------------------------------------------------------------------- ! to atm: merged zonal surface stress ! to atm: merged meridional surface stress @@ -619,43 +1118,196 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! to atm: evaporation water flux from water ! to atm: evaporation water flux from water isotopes ! --------------------------------------------------------------------- - allocate(suffix(7)) - suffix = (/'taux ',& - 'tauy ',& - 'lat ',& - 'sen ',& - 'lwup ',& - 'evap ',& - 'evap_wiso'/) + if (phase == 'advertise') then + call addfld(fldListTo(compatm)%flds, 'Faxx_taux') + call addfld(fldListFr(complnd)%flds, 'Fall_taux') + call addfld(fldListFr(compice)%flds, 'Faii_taux') + call addfld(fldListMed_aoflux%flds , 'Faox_taux') + else + if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_taux', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_taux', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Fall_taux', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_taux', & + mrg_from=complnd, mrg_fld='Fall_taux', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_taux', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Faii_taux', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_taux', & + mrg_from=compice, mrg_fld='Faii_taux', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_taux', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'Faox_taux', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Faxx_taux', & + mrg_from=compmed, mrg_fld='Faox_taux', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListTo(compatm)%flds, 'Faxx_tauy') + call addfld(fldListFr(complnd)%flds, 'Fall_tauy') + call addfld(fldListFr(compice)%flds, 'Faii_tauy') + call addfld(fldListMed_aoflux%flds , 'Faox_tauy') + else + if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_tauy', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_tauy', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Fall_tauy', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_tauy', & + mrg_from=complnd, mrg_fld='Fall_tauy', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_tauy', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Faii_tauy', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_tauy', & + mrg_from=compice, mrg_fld='Faii_tauy', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_tauy', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'Faox_tauy', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Faxx_tauy', & + mrg_from=compmed, mrg_fld='Faox_tauy', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListTo(compatm)%flds, 'Faxx_lat') + call addfld(fldListFr(complnd)%flds, 'Fall_lat') + call addfld(fldListFr(compice)%flds, 'Faii_lat') + call addfld(fldListMed_aoflux%flds , 'Faox_lat') + else + if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_lat', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_lat', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Fall_lat', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_lat', & + mrg_from=complnd, mrg_fld='Fall_lat', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_lat', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Faii_lat', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_lat', & + mrg_from=compice, mrg_fld='Faii_lat', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_lat', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'Faox_lat', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Faxx_lat', & + mrg_from=compmed, mrg_fld='Faox_lat', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListTo(compatm)%flds, 'Faxx_sen') + call addfld(fldListFr(complnd)%flds, 'Fall_sen') + call addfld(fldListFr(compice)%flds, 'Faii_sen') + call addfld(fldListMed_aoflux%flds , 'Faox_sen') + else + if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_sen', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_sen', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Fall_sen', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_sen', & + mrg_from=complnd, mrg_fld='Fall_sen', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_sen', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Faii_sen', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_sen', & + mrg_from=compice, mrg_fld='Faii_sen', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_sen', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'Faox_sen', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Faxx_sen', & + mrg_from=compmed, mrg_fld='Faox_sen', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if - do n = 1,size(suffix) + if (phase == 'advertise') then + call addfld(fldListTo(compatm)%flds, 'Faxx_evap') + call addfld(fldListFr(complnd)%flds, 'Fall_evap') + call addfld(fldListFr(compice)%flds, 'Faii_evap') + call addfld(fldListMed_aoflux%flds , 'Faox_evap') + else + if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_evap', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_evap', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Fall_evap', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_evap', & + mrg_from=complnd, mrg_fld='Fall_evap', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_evap', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Faii_evap', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_evap', & + mrg_from=compice, mrg_fld='Faii_evap', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_evap', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'Faox_evap', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Faxx_evap', & + mrg_from=compmed, mrg_fld='Faox_evap', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (phase == 'advertise') then + call addfld(fldListTo(compatm)%flds, 'Faxx_lwup') + call addfld(fldListFr(complnd)%flds, 'Fall_lwup') + call addfld(fldListFr(compice)%flds, 'Faii_lwup') + call addfld(fldListMed_aoflux%flds , 'Faox_lwup') + else + if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_lwup', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_lwup', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Fall_lwup', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_lwup', & + mrg_from=complnd, mrg_fld='Fall_lwup', mrg_type='merge', mrg_fracname='lfrac') + end if + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_lwup', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Faii_lwup', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_lwup', & + mrg_from=compice, mrg_fld='Faii_lwup', mrg_type='merge', mrg_fracname='ifrac') + end if + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_lwup', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds, 'Faox_lwup', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds, 'Faxx_lwup', & + mrg_from=compmed, mrg_fld='Faox_lwup', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + end if + + if (flds_wiso) then if (phase == 'advertise') then - call addfld(fldListTo(compatm)%flds, 'Faxx_'//trim(suffix(n))) - call addfld(fldListFr(complnd)%flds, 'Fall_'//trim(suffix(n))) - call addfld(fldListFr(compice)%flds, 'Faii_'//trim(suffix(n))) - call addfld(fldListMed_aoflux%flds , 'Faox_'//trim(suffix(n))) + call addfld(fldListTo(compatm)%flds, 'Faxx_evap_wiso') + call addfld(fldListFr(complnd)%flds, 'Fall_evap_wiso') + call addfld(fldListFr(compice)%flds, 'Faii_evap_wiso') + call addfld(fldListMed_aoflux%flds , 'Faox_evap_wiso') else - if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_'//trim(suffix(n)), rc=rc)) then - if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListFr(complnd)%flds , 'Fall_'//trim(suffix(n)), compatm, mapconsf, 'lfrin', lnd2atm_fmap) - call addmrg(fldListTo(compatm)%flds , 'Faxx_'//trim(suffix(n)), & - mrg_from=complnd, mrg_fld='Fall_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='lfrac') + if (fldchk(is_local%wrap%FBexp(compatm), 'Faxx_evap_wiso', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_evap_wiso', rc=rc)) then + call addmap(fldListFr(complnd)%flds , 'Fall_evap_wiso', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_evap_wiso', & + mrg_from=complnd, mrg_fld='Fall_evap_wiso', mrg_type='merge', mrg_fracname='lfrac') end if - if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListFr(compice)%flds , 'Faii_'//trim(suffix(n)), compatm, mapconsf, 'ifrac', ice2atm_fmap) - call addmrg(fldListTo(compatm)%flds , 'Faxx_'//trim(suffix(n)), & - mrg_from=compice, mrg_fld='Faii_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ifrac') + if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_evap_wiso', rc=rc)) then + call addmap(fldListFr(compice)%flds , 'Faii_evap_wiso', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds , 'Faxx_evap_wiso', & + mrg_from=compice, mrg_fld='Faii_evap_wiso', mrg_type='merge', mrg_fracname='ifrac') end if - if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListMed_aoflux%flds , 'Faox_'//trim(suffix(n)), compatm, mapconsf, 'ofrac', ocn2atm_fmap) - call addmrg(fldListTo(compatm)%flds , 'Faxx_'//trim(suffix(n)), & - mrg_from=compmed, mrg_fld='Faox_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ofrac') + if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_evap_wiso', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds, 'Faox_evap_wiso', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'Faxx_evap_wiso', & + mrg_from=compmed, mrg_fld='Faox_evap_wiso', mrg_type='merge', mrg_fracname='ofrac') end if end if end if - end do - deallocate(suffix) - + end if ! --------------------------------------------------------------------- ! to atm: merged surface temperature and unmerged temperatures from ice and ocn ! --------------------------------------------------------------------- @@ -668,24 +1320,23 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if (fldchk(is_local%wrap%FBexp(compatm), 'Sx_t', rc=rc)) then if (fldchk(is_local%wrap%FBImp(complnd,complnd), 'Sl_t', rc=rc)) then - call addmap(fldListFr(complnd)%flds, 'Sl_t', compatm, mapconsf , 'lfrin', lnd2atm_fmap) + call addmap(fldListFr(complnd)%flds, 'Sl_t', compatm, mapconsf , 'lfrin', lnd2atm_map) call addmrg(fldListTo(compatm)%flds, 'Sx_t', & mrg_from=complnd, mrg_fld='Sl_t', mrg_type='merge', mrg_fracname='lfrac') end if if (fldchk(is_local%wrap%FBImp(compice,compice), 'Si_t', rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Si_t', compatm, mapconsf , 'ifrac', ice2atm_fmap) + call addmap(fldListFr(compice)%flds, 'Si_t', compatm, mapconsf , 'ifrac', ice2atm_map) call addmrg(fldListTo(compatm)%flds, 'Sx_t', & mrg_from=compice, mrg_fld='Si_t', mrg_type='merge', mrg_fracname='ifrac') end if if (fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_t', rc=rc)) then - call addmap(fldListFr(compocn)%flds, 'So_t', compatm, mapconsf, 'ofrac', ocn2atm_fmap) + call addmap(fldListFr(compocn)%flds, 'So_t', compatm, mapconsf, 'ofrac', ocn2atm_map) call addmrg(fldListTo(compatm)%flds, 'Sx_t', & mrg_from=compocn, mrg_fld='So_t', mrg_type='merge', mrg_fracname='ofrac') end if end if if (fldchk(is_local%wrap%FBexp(compatm), 'So_t', rc=rc)) then - call addmrg(fldListTo(compatm)%flds, 'So_t', & - mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + call addmrg(fldListTo(compatm)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') end if end if @@ -694,158 +1345,179 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! to atm: mean ice volume per unit area from ice ! to atm: mean snow volume per unit area from ice ! --------------------------------------------------------------------- - allocate(flds(3)) - flds = (/'Si_snowh',& - 'Si_vice ',& - 'Si_vsno '/) - - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) - else - if ( fldchk(is_local%wrap%FBexp(compatm) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compice,compice), trim(fldname), rc=rc)) then - call addmap(fldListFr(compice)%flds, trim(fldname), & - compatm, mapconsf, 'ifrac', ice2atm_fmap) - call addmrg(fldListTo(compatm)%flds, trim(fldname), & - mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') - end if + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Si_snowh') + call addfld(fldListTo(compatm)%flds, 'Si_snowh') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Si_snowh', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Si_snowh', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_snowh', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Si_snowh', mrg_from=compice, mrg_fld='Si_snowh', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Si_vice') + call addfld(fldListTo(compatm)%flds, 'Si_vice') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Si_vice', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Si_vice', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_vice', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Si_vice', mrg_from=compice, mrg_fld='Si_vice', mrg_type='copy') end if - end do - deallocate(flds) + end if + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Si_vsno') + call addfld(fldListTo(compatm)%flds, 'Si_vsno') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Si_vsno', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Si_vsno', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_vsno', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Si_vsno', mrg_from=compice, mrg_fld='Si_vsno', mrg_type='copy') + end if + end if ! --------------------------------------------------------------------- ! to atm: surface saturation specific humidity in ocean from med aoflux ! to atm: square of exch. coeff (tracers) from med aoflux ! to atm: surface fraction velocity from med aoflux ! --------------------------------------------------------------------- - allocate(flds(3)) - flds = (/'So_ssq ',& - 'So_re ',& - 'So_ustar'/) - - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListMed_aoflux%flds , trim(fldname)) - call addfld(fldListTo(compatm)%flds , trim(fldname)) - else - if ( fldchk(is_local%wrap%FBexp(compatm) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o , trim(fldname), rc=rc)) then - call addmap(fldListMed_aoflux%flds , trim(fldname), & - compatm, mapconsf, 'ofrac', ocn2atm_fmap) ! map ocn->atm - call addmrg(fldListTo(compatm)%flds , trim(fldname), & - mrg_from=compmed, mrg_fld=trim(fldname), mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'So_ssq') + call addfld(fldListTo(compatm)%flds , 'So_ssq') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'So_ssq', rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'So_ssq', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'So_ssq', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'So_ssq', mrg_from=compmed, mrg_fld='So_ssq', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'So_re') + call addfld(fldListTo(compatm)%flds , 'So_re') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'So_re', rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'So_re', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'So_re', compatm, mapconsf, 'ofrac', ocn2atm_map) + end if + call addmrg(fldListTo(compatm)%flds , 'So_re', mrg_from=compmed, mrg_fld='So_re', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'So_ustar') + call addfld(fldListTo(compatm)%flds , 'So_ustar') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'So_ustar', rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'So_ustar', rc=rc)) then + if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then + call addmap(fldListMed_aoflux%flds , 'So_ustar', compatm, mapconsf, 'ofrac', ocn2atm_map) end if + call addmrg(fldListTo(compatm)%flds , 'So_ustar', mrg_from=compmed, mrg_fld='So_ustar', mrg_type='copy') end if - end do - deallocate(flds) + end if ! --------------------------------------------------------------------- ! to atm: surface fraction velocity from land ! to atm: aerodynamic resistance from land ! to atm: surface snow water equivalent from land ! --------------------------------------------------------------------- - allocate(flds(3)) - flds = (/'Sl_fv ',& - 'Sl_ram1 ',& - 'Sl_snowh'/) - - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) - else - if ( fldchk(is_local%wrap%FBexp(compatm) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(complnd,complnd ), trim(fldname), rc=rc)) then - call addmap(fldListFr(complnd)%flds, trim(fldname), & - compatm, mapconsf, 'lfrin', lnd2atm_fmap) - call addmrg(fldListTo(compatm)%flds, trim(fldname), & - mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='copy') - end if + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Sl_fv') + call addfld(fldListTo(compatm)%flds, 'Sl_fv') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Sl_fv', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_fv', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_fv', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sl_fv', mrg_from=complnd, mrg_fld='Sl_fv', mrg_type='copy') end if - end do - deallocate(flds) - + end if + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Sl_ram1') + call addfld(fldListTo(compatm)%flds, 'Sl_ram1') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Sl_ram1', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_ram1', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_ram1', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sl_ram1', mrg_from=complnd, mrg_fld='Sl_ram1', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Sl_snowh') + call addfld(fldListTo(compatm)%flds, 'Sl_snowh') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Sl_snowh', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(complnd,complnd ), 'Sl_snowh', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_snowh', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sl_snowh', mrg_from=complnd, mrg_fld='Sl_snowh', mrg_type='copy') + end if + end if ! --------------------------------------------------------------------- ! to atm: dust fluxes from land (4 sizes) ! --------------------------------------------------------------------- - fldname = 'Fall_flxdst' if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) + call addfld(fldListFr(complnd)%flds, 'Fall_flxdst') + call addfld(fldListTo(compatm)%flds, 'Fall_flxdst') else - if ( fldchk(is_local%wrap%FBImp(complnd, complnd), trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compatm) , trim(fldname), rc=rc)) then - call addmap(fldListFr(complnd)%flds, trim(fldname), compatm, mapconsf, 'lfrin', lnd2atm_fmap) - call addmrg(fldListTo(compatm)%flds, trim(fldname), & - mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='lfrac') + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Fall_flxdst', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compatm) , 'Fall_flxdst', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Fall_flxdst', compatm, mapconsf, 'lfrin', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Fall_flxdst', & + mrg_from=complnd, mrg_fld='Fall_flxdst', mrg_type='copy_with_weights', mrg_fracname='lfrac') end if end if - !----------------------------------------------------------------------------- ! to atm: MEGAN emissions fluxes from land !----------------------------------------------------------------------------- - fldname = 'Fall_voc' if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) + call addfld(fldListFr(complnd)%flds, 'Fall_voc') + call addfld(fldListTo(compatm)%flds, 'Fall_voc') else - if ( fldchk(is_local%wrap%FBImp(complnd, complnd), trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compatm) , trim(fldname), rc=rc)) then - call addmap(fldListFr(complnd)%flds, trim(fldname), compatm, mapconsf, 'one', atm2lnd_fmap) - call addmrg(fldListTo(compatm)%flds, trim(fldname), & - mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='merge', mrg_fracname='lfrac') + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Fall_voc', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compatm) , 'Fall_voc', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Fall_voc', compatm, mapconsf, 'one', atm2lnd_map) + call addmrg(fldListTo(compatm)%flds, 'Fall_voc', & + mrg_from=complnd, mrg_fld='Fall_voc', mrg_type='merge', mrg_fracname='lfrac') end if end if - !----------------------------------------------------------------------------- ! to atm: fire emissions fluxes from land !----------------------------------------------------------------------------- ! 'wild fire emission fluxes' - fldname = 'Fall_fire' if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) + call addfld(fldListFr(complnd)%flds, 'Fall_fire') + call addfld(fldListTo(compatm)%flds, 'Fall_fire') else - if ( fldchk(is_local%wrap%FBImp(complnd, complnd), trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compatm) , trim(fldname), rc=rc)) then - call addmap(fldListFr(complnd)%flds, trim(fldname), compatm, mapconsf, 'one', lnd2atm_fmap) - call addmrg(fldListTo(compatm)%flds, trim(fldname), & - mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='merge', mrg_fracname='lfrac') + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Fall_fire', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compatm) , 'Fall_fire', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Fall_fire', compatm, mapconsf, 'one', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Fall_fire', & + mrg_from=complnd, mrg_fld='Fall_fire', mrg_type='merge', mrg_fracname='lfrac') end if end if - ! 'wild fire plume height' - fldname = 'Sl_fztop' if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) + call addfld(fldListFr(complnd)%flds, 'Sl_fztop') + call addfld(fldListTo(compatm)%flds, 'Sl_fztop') else - if ( fldchk(is_local%wrap%FBImp(complnd, complnd), trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compatm) , trim(fldname), rc=rc)) then - call addmap(fldListFr(complnd)%flds, trim(fldname), compatm, mapconsf, 'one', lnd2atm_smap) - call addmrg(fldListTo(compatm)%flds, trim(fldname), & - mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='copy') + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Sl_fztop', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compatm) , 'Sl_fztop', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_fztop', compatm, mapconsf, 'one', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sl_fztop', mrg_from=complnd, mrg_fld='Sl_fztop', mrg_type='copy') end if end if - !----------------------------------------------------------------------------- ! to atm: dry deposition velocities from land !----------------------------------------------------------------------------- - fldname = 'Sl_ddvel' if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) + call addfld(fldListFr(complnd)%flds, 'Sl_ddvel') + call addfld(fldListTo(compatm)%flds, 'Sl_ddvel') else - if ( fldchk(is_local%wrap%FBImp(complnd, complnd), trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compatm) , trim(fldname), rc=rc)) then - call addmap(fldListFr(complnd)%flds, trim(fldname), compatm, mapconsf, 'one', lnd2atm_smap) - call addmrg(fldListTo(compatm)%flds, trim(fldname), & - mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='copy') + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Sl_ddvel', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compatm) , 'Sl_ddvel', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Sl_ddvel', compatm, mapconsf, 'one', lnd2atm_map) + call addmrg(fldListTo(compatm)%flds, 'Sl_ddvel', mrg_from=complnd, mrg_fld='Sl_ddvel', mrg_type='copy') end if end if @@ -871,28 +1543,61 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! 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'/) - - 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_from=compatm, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='ofrac') - end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') + call addfld(fldListTo(compocn)%flds, 'Faxa_lwdn') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_lwdn', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwdn', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_lwdn', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_lwdn', & + mrg_from=compatm, mrg_fld='Faxa_lwdn', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swndr') + call addfld(fldListTo(compocn)%flds, 'Faxa_swndr') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_swndr', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swndr', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swndr', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_swndr', & + mrg_from=compatm, mrg_fld='Faxa_swndr', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swndf') + call addfld(fldListTo(compocn)%flds, 'Faxa_swndf') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_swndf', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swndf', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swndf', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_swndf', & + mrg_from=compatm, mrg_fld='Faxa_swndf', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swvdr') + call addfld(fldListTo(compocn)%flds, 'Faxa_swvdr') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_swvdr', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swvdr', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdr', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_swvdr', & + mrg_from=compatm, mrg_fld='Faxa_swvdr', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swvdf') + call addfld(fldListTo(compocn)%flds, 'Faxa_swvdf') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_swvdf', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swvdf', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdf', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_swvdf', & + mrg_from=compatm, mrg_fld='Faxa_swvdf', mrg_type='copy_with_weights', mrg_fracname='ofrac') end if - end do - deallocate(flds) + end if ! --------------------------------------------------------------------- ! to ocn: surface upward longwave heat flux from mediator @@ -907,7 +1612,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) mrg_from=compmed, mrg_fld='Faox_lwup', mrg_type='merge', mrg_fracname='ofrac') end if end if - ! --------------------------------------------------------------------- ! to ocn: merged longwave net heat flux ! --------------------------------------------------------------------- @@ -920,14 +1624,13 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_lwnet', rc=rc) .and. & fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup' , rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwdn' , rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_lwdn', compocn, mapconsf, 'one' , atm2ocn_fmap) + call addmap(fldListFr(compatm)%flds, 'Faxa_lwdn', compocn, mapconsf, 'one' , atm2ocn_map) call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', & mrg_from=compmed, mrg_fld='Faox_lwup', mrg_type='merge', mrg_fracname='ofrac') call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', & mrg_from=compatm, mrg_fld='Faxa_lwdn', mrg_type='merge', mrg_fracname='ofrac') end if end if - ! --------------------------------------------------------------------- ! to ocn: downward shortwave heat flux ! --------------------------------------------------------------------- @@ -937,12 +1640,11 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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 addmap(fldListFr(compatm)%flds, 'Faxa_swdn', compocn, mapconsf, 'one', atm2ocn_map) call addmrg(fldListTo(compocn)%flds, 'Faxa_swdn', & mrg_from=compatm, mrg_fld='Faxa_swdn', mrg_type='copy') end if end if - ! --------------------------------------------------------------------- ! to ocn: net shortwave radiation from med ! --------------------------------------------------------------------- @@ -992,10 +1694,10 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', rc=rc) .and. & fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', rc=rc) .and. & fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', rc=rc))) then - call addmap(fldListFr(compatm)%flds, 'Faxa_swvdr', compocn, mapconsf, 'one', atm2ocn_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_swvdf', compocn, mapconsf, 'one', atm2ocn_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_swndr', compocn, mapconsf, 'one', atm2ocn_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_swndf', compocn, mapconsf, 'one', atm2ocn_fmap) + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdr', compocn, mapconsf, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdf', compocn, mapconsf, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_swndr', compocn, mapconsf, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_swndf', compocn, mapconsf, 'one', atm2ocn_map) end if end if @@ -1041,66 +1743,81 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListFr(compatm)%flds, 'Faxa_rainl') call addfld(fldListFr(compatm)%flds, 'Faxa_rain' ) call addfld(fldListTo(compocn)%flds, 'Faxa_rain' ) - - call addfld(fldListFr(compatm)%flds, 'Faxa_rainc_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_rainl_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_rain_wiso' ) - call addfld(fldListTo(compocn)%flds, 'Faxa_rain_wiso' ) - call addfld(fldListFr(compatm)%flds, 'Faxa_snowc') call addfld(fldListFr(compatm)%flds, 'Faxa_snowl') call addfld(fldListFr(compatm)%flds, 'Faxa_snow' ) call addfld(fldListTo(compocn)%flds, 'Faxa_snow' ) - - call addfld(fldListFr(compatm)%flds, 'Faxa_snowc_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_snowl_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_snow_wiso' ) - call addfld(fldListTo(compocn)%flds, 'Faxa_snow_wiso' ) else - do n = 1,2 + ! Note that the mediator atm/ocn flux calculation needs Faxa_rainc for the gustiness parameterization + ! which by default is not actually used + 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_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_rainc', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_rain' , mrg_from=compatm, mrg_fld='Faxa_rainc:Faxa_rainl', & + mrg_type='sum_with_weights', mrg_fracname='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_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_rain', mrg_from=compatm, mrg_fld='Faxa_rain', mrg_type='copy') + end if + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_snow' , rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowl', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowc', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snowl', compocn, mapconsf, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_snowc', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_snow' , & + mrg_from=compatm, mrg_fld='Faxa_snowc:Faxa_snowl', mrg_type='sum_with_weights', mrg_fracname='ofrac') + else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_snow', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snow', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snow', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_snow', mrg_from=compatm, mrg_fld='Faxa_snow', mrg_type='copy') + end if + end if + + if (flds_wiso) then + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_rainc_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_rainl_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_rain_wiso' ) + call addfld(fldListTo(compocn)%flds, 'Faxa_rain_wiso' ) + call addfld(fldListFr(compatm)%flds, 'Faxa_snowc_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_snowl_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_snow_wiso' ) + call addfld(fldListTo(compocn)%flds, 'Faxa_snow_wiso' ) + else ! Note that the mediator atm/ocn flux calculation needs Faxa_rainc for the gustiness parameterization ! which by default is not actually used - if ( fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl'//iso(n), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc'//iso(n), rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_rain' //iso(n), rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_rainl'//iso(n), compocn, mapconsf, 'one', atm2ocn_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_rainc'//iso(n), compocn, mapconsf, 'one', atm2ocn_fmap) - if (iso(n) == ' ') then - call addmrg(fldListTo(compocn)%flds, 'Faxa_rain'//iso(n) , & - mrg_from=compatm, mrg_fld='Faxa_rainc:Faxa_rainl', & - mrg_type='sum_with_weights', mrg_fracname='ofrac') - else - call addmrg(fldListTo(compocn)%flds, 'Faxa_rain'//iso(n) , & - mrg_from=compatm, mrg_fld=trim('Faxa_rainc'//iso(n))//':'//trim('Faxa_rainl'//iso(n)), & - mrg_type='sum_with_weights', mrg_fracname='ofrac') - end if - else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_rain'//iso(n), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rain'//iso(n), rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_rain'//iso(n), compocn, mapconsf, 'one', atm2ocn_fmap) - call addmrg(fldListTo(compocn)%flds, 'Faxa_rain'//iso(n), & - mrg_from=compatm, mrg_fld='Faxa_rain'//iso(n), mrg_type='copy') - end if - if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_snow' //iso(n), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowl'//iso(n), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowc'//iso(n), rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_snowl'//iso(n), compocn, mapconsf, 'one', atm2ocn_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_snowc'//iso(n), compocn, mapconsf, 'one', atm2ocn_fmap) - if (iso(n) == ' ') then - call addmrg(fldListTo(compocn)%flds, 'Faxa_snow' //iso(n) , & - mrg_from=compatm, mrg_fld='Faxa_snowc:Faxa_snowl', & - mrg_type='sum_with_weights', mrg_fracname='ofrac') - else - call addmrg(fldListTo(compocn)%flds, 'Faxa_snow' //iso(n) , & - mrg_from=compatm, mrg_fld=trim('Faxa_snowc'//iso(n))//':'//trim('Faxa_snowl'//iso(n)), & - mrg_type='sum_with_weights', mrg_fracname='ofrac') - end if - else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_snow'//iso(n), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snow'//iso(n), rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_snow'//iso(n), compocn, mapconsf, 'one', atm2ocn_fmap) - call addmrg(fldListTo(compocn)%flds, 'Faxa_snow'//iso(n), & - mrg_from=compatm, mrg_fld='Faxa_snow'//iso(n), mrg_type='copy') + if ( fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_rain_wiso' , rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_rainl_wiso', compocn, mapconsf, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_rainc_wiso', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_rain_wiso' , & + mrg_from=compatm, mrg_fld=trim('Faxa_rainc_wiso')//':'//trim('Faxa_rainl_wiso'), & + mrg_type='sum_with_weights', mrg_fracname='ofrac') + else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_rain_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rain_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_rain_wiso', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_rain_wiso', & + mrg_from=compatm, mrg_fld='Faxa_rain_wiso', mrg_type='copy') end if - end do + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_snow_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowl_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowc_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snowl_wiso', compocn, mapconsf, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_snowc_wiso', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_snow_wiso', & + mrg_from=compatm, mrg_fld=trim('Faxa_snowc_wiso')//':'//trim('Faxa_snowl_wiso'), & + mrg_type='sum_with_weights', mrg_fracname='ofrac') + else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_snow_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snow_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snow_wiso', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_snow_wiso', & + mrg_from=compatm, mrg_fld='Faxa_snow_wiso', mrg_type='copy') + end if + end if end if ! --------------------------------------------------------------------- @@ -1123,49 +1840,46 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! to ocn: surface latent heat flux and evaporation water flux ! --------------------------------------------------------------------- if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, 'Faxa_lat' ) call addfld(fldListMed_aoflux%flds , 'Faox_lat' ) call addfld(fldListMed_aoflux%flds , 'Faox_evap') call addfld(fldListTo(compocn)%flds, 'Foxx_lat' ) call addfld(fldListTo(compocn)%flds, 'Foxx_evap') else - if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_lat', rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_lat', rc=rc)) then + if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_lat', rc=rc)) then call addmrg(fldListTo(compocn)%flds, 'Foxx_lat', & mrg_from=compmed, mrg_fld='Faox_lat', mrg_type='merge', mrg_fracname='ofrac') end if - if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_evap', rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_evap', rc=rc)) then + if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_evap', rc=rc)) then call addmrg(fldListTo(compocn)%flds, 'Foxx_evap', & mrg_from=compmed, mrg_fld='Faox_evap', mrg_type='merge', mrg_fracname='ofrac') end if end if - if (phase == 'advertise') then - call addfld(fldListMed_aoflux%flds , 'Faox_lat_wiso' ) - call addfld(fldListTo(compocn)%flds, 'Foxx_lat_wiso' ) - else - if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_lat_wiso', rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_lat_wiso', rc=rc)) then - call addmrg(fldListTo(compocn)%flds, 'Foxx_lat_wiso', & - mrg_from=compmed, mrg_fld='Faox_lat_wiso', mrg_type='merge', mrg_fracname='ofrac') + if (flds_wiso) then + if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'Faox_lat_wiso' ) + call addfld(fldListTo(compocn)%flds, 'Foxx_lat_wiso' ) + else + if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_lat_wiso', rc=rc)) then + call addmrg(fldListTo(compocn)%flds, 'Foxx_lat_wiso', & + mrg_from=compmed, mrg_fld='Faox_lat_wiso', mrg_type='merge', mrg_fracname='ofrac') + end if end if end if ! --------------------------------------------------------------------- ! to ocn: wind speed squared at 10 meters from med ! --------------------------------------------------------------------- + ! Note that this is a field output by the atm/ocn flux computation + ! If the aoflux grid is ogrid - then nothing needs to be done to send to the ocean + ! All other mappings are set in med_phases_aoflux_mod.F90 if (phase == 'advertise') then call addfld(fldListMed_aoflux%flds , 'So_duu10n') call addfld(fldListTo(compocn)%flds, 'So_duu10n') else - if ( fldchk(is_local%wrap%FBMed_aoflux_o, 'So_duu10n', rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compocn), 'So_duu10n', rc=rc)) then - - call addmap(fldListMed_aoflux%flds , 'So_duu10n', compatm, mapconsf, 'ofrac', ocn2atm_fmap) ! map ocn->atm - call addmrg(fldListTo(compocn)%flds, 'So_duu10n', & - mrg_from=compmed, mrg_fld='So_duu10n', mrg_type='copy') + if (fldchk(is_local%wrap%FBExp(compocn), 'So_duu10n', rc=rc)) then + call addmrg(fldListTo(compocn)%flds, 'So_duu10n', mrg_from=compmed, mrg_fld='So_duu10n', mrg_type='copy') end if end if @@ -1178,10 +1892,8 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBImp(compatm, compatm), 'Sa_pslv', rc=rc) .and. & fldchk(is_local%wrap%FBExp(compocn) , 'Sa_pslv', rc=rc)) then - - call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, mapbilnr, 'one', atm2ocn_smap) - call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compice, mapbilnr, 'one', atm2ocn_smap) - + call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, mapbilnr, 'one', atm2ocn_map) + call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compice, mapbilnr, 'one', atm2ocn_map) call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', & mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') end if @@ -1200,99 +1912,181 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! to ocn: dust dry deposition flux (sizes 1-4) from atm ! to ocn: nitrogen deposition fields (2) from atm ! --------------------------------------------------------------------- - allocate(flds(5)) - flds = (/'Faxa_bcph ', 'Faxa_ocph ', 'Faxa_dstwet' , 'Faxa_dstdry', 'Faxa_ndep ' /) - - 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, mapconsf, 'one', atm2ocn_fmap) - call addmrg(fldListTo(compocn)%flds, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='ofrac') - end if + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds, 'Faxa_bcph') + call addfld(fldListFr(compatm)%flds, 'Faxa_bcph') + else + if ( fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_bcph', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_bcph', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_bcph', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_bcph', & + mrg_from=compatm, mrg_fld='Faxa_bcph', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds, 'Faxa_ocph') + call addfld(fldListFr(compatm)%flds, 'Faxa_ocph') + else + if ( fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_ocph', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_ocph', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_ocph', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_ocph', & + mrg_from=compatm, mrg_fld='Faxa_ocph', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds, 'Faxa_dstwet') + call addfld(fldListFr(compatm)%flds, 'Faxa_dstwet') + else + if ( fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_dstwet', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_dstwet', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_dstwet', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_dstwet', & + mrg_from=compatm, mrg_fld='Faxa_dstwet', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds, 'Faxa_dstdry') + call addfld(fldListFr(compatm)%flds, 'Faxa_dstdry') + else + if ( fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_dstdry', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_dstdry', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_dstdry', compocn, mapconsf, 'one', atm2ocn_map) + call addmrg(fldListTo(compocn)%flds, 'Faxa_dstdry', & + mrg_from=compatm, mrg_fld='Faxa_dstdry', mrg_type='copy_with_weights', mrg_fracname='ofrac') end if - end do - deallocate(flds) + end if ! --------------------------------------------------------------------- - ! to ocn: merge zonal surface stress from ice and (atm or med) + ! to ocn: merge zonal and meridional surface stress from ice and (atm or med) ! --------------------------------------------------------------------- - allocate(suffix(2)) - suffix = (/'taux', 'tauy'/) - - do n = 1,size(suffix) - if (phase == 'advertise') then - call addfld(fldListMed_aoflux%flds , 'Faox_'//trim(suffix(n))) - call addfld(fldListFr(compice)%flds , 'Fioi_'//trim(suffix(n))) - call addfld(fldListFr(compatm)%flds , 'Faxa_'//trim(suffix(n))) - call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(suffix(n))) - else - if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_'//trim(suffix(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_'//trim(suffix(n)), rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(suffix(n)), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(suffix(n)), & - mrg_from=compmed, mrg_fld='Faox_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ofrac') - call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(suffix(n)), & - mrg_from=compice, mrg_fld='Fioi_'//trim(suffix(n)), mrg_type='merge', mrg_fracname='ifrac') + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds , 'Foxx_taux') + call addfld(fldListFr(compice)%flds , 'Fioi_taux') + call addfld(fldListMed_aoflux%flds , 'Faox_taux') + else + if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_taux', rc=rc)) then + if (fldchk(is_local%wrap%FBimp(compice,compice), 'Fioi_taux', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_taux', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Foxx_taux', & + mrg_from=compice, mrg_fld='Fioi_taux', mrg_type='merge', mrg_fracname='ifrac') end if + call addmrg(fldListTo(compocn)%flds, 'Foxx_taux', & + mrg_from=compmed, mrg_fld='Faox_taux', mrg_type='merge', mrg_fracname='ofrac') end if - end do - deallocate(suffix) - - ! --------------------------------------------------------------------- - ! to ocn: water flux due to melting ice from ice - ! --------------------------------------------------------------------- - do n = 1,size(iso) + end if + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds , 'Foxx_tauy') + call addfld(fldListFr(compice)%flds , 'Fioi_tauy') + call addfld(fldListMed_aoflux%flds , 'Faox_tauy') + else + if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_tauy', rc=rc)) then + if (fldchk(is_local%wrap%FBimp(compice,compice), 'Fioi_tauy', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_tauy', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Foxx_tauy', & + mrg_from=compice, mrg_fld='Fioi_tauy', mrg_type='merge', mrg_fracname='ifrac') + end if + call addmrg(fldListTo(compocn)%flds, 'Foxx_tauy', & + mrg_from=compmed, mrg_fld='Faox_tauy', mrg_type='merge', mrg_fracname='ofrac') + end if + end if + ! --------------------------------------------------------------------- + ! to ocn: water flux due to melting ice from ice + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds , 'Fioi_meltw') + call addfld(fldListTo(compocn)%flds , 'Fioi_meltw') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Fioi_meltw', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_meltw', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_meltw', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Fioi_meltw', & + mrg_from=compice, mrg_fld='Fioi_meltw', mrg_type='copy_with_weights', mrg_fracname='ifrac') + end if + end if + if (flds_wiso) then if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds , 'Fioi_meltw'//iso(n)) - call addfld(fldListTo(compocn)%flds , 'Fioi_meltw'//iso(n)) + call addfld(fldListFr(compice)%flds , 'Fioi_meltw_wiso') + call addfld(fldListTo(compocn)%flds , 'Fioi_meltw_wiso') else - if ( fldchk(is_local%wrap%FBexp(compocn) , 'Fioi_meltw'//iso(n), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_meltw'//iso(n), rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Fioi_meltw'//iso(n), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Fioi_meltw'//iso(n), & - mrg_from=compice, mrg_fld='Fioi_meltw'//iso(n), mrg_type='copy_with_weights', mrg_fracname='ifrac') + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Fioi_meltw_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_meltw_wiso', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_meltw_wiso', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Fioi_meltw_wiso', & + mrg_from=compice, mrg_fld='Fioi_meltw_wiso', mrg_type='copy_with_weights', mrg_fracname='ifrac') end if end if - end do - + end if ! --------------------------------------------------------------------- ! to ocn: heat flux from melting ice from ice + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Fioi_melth') + call addfld(fldListTo(compocn)%flds, 'Fioi_melth') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Fioi_melth', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_melth', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_melth', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Fioi_melth', & + mrg_from=compice, mrg_fld='Fioi_melth', mrg_type='copy_with_weights', mrg_fracname='ifrac') + end if + end if + ! --------------------------------------------------------------------- ! to ocn: salt flux from ice + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Fioi_salt') + call addfld(fldListTo(compocn)%flds, 'Fioi_salt') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Fioi_salt', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_salt', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_salt', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Fioi_salt', & + mrg_from=compice, mrg_fld='Fioi_salt', mrg_type='copy_with_weights', mrg_fracname='ifrac') + end if + end if + ! --------------------------------------------------------------------- ! to ocn: hydrophylic black carbon deposition flux from ice + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Fioi_bcphi') + call addfld(fldListTo(compocn)%flds, 'Fioi_bcphi') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Fioi_bcphi', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_bcphi', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_bcphi', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Fioi_bcphi', & + mrg_from=compice, mrg_fld='Fioi_bcphi', mrg_type='copy_with_weights', mrg_fracname='ifrac') + end if + end if + ! --------------------------------------------------------------------- ! to ocn: hydrophobic black carbon deposition flux from ice + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Fioi_bcpho') + call addfld(fldListTo(compocn)%flds, 'Fioi_bcpho') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Fioi_bcpho', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_bcpho', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_bcpho', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Fioi_bcpho', & + mrg_from=compice, mrg_fld='Fioi_bcpho', mrg_type='copy_with_weights', mrg_fracname='ifrac') + end if + end if + ! --------------------------------------------------------------------- ! to ocn: dust flux from ice ! --------------------------------------------------------------------- - ! TODO (mvertens, 2019-01-07): is fioi_melth being handled here? - ! Is fd.yaml correctly aliasing Fioi_melth? - - allocate(flds(5)) - flds = (/'Fioi_melth ',& - 'Fioi_salt ',& - 'Fioi_bcphi ',& - 'Fioi_bcpho ',& - 'Fioi_flxdst'/) - - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(compice)%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(compice, compice), trim(fldname), rc=rc)) then - call addmap(fldListFr(compice)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, trim(fldname), & - mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='ifrac') - end if + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Fioi_flxdst') + call addfld(fldListTo(compocn)%flds, 'Fioi_flxdst') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Fioi_flxdst', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice, compice), 'Fioi_flxdst', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_flxdst', compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Fioi_flxdst', & + mrg_from=compice, mrg_fld='Fioi_flxdst', mrg_type='copy_with_weights', mrg_fracname='ifrac') end if - end do - deallocate(flds) + end if !----------------------------- ! to ocn: liquid runoff from rof and glc components @@ -1301,100 +2095,182 @@ 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 + ! 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 + do ns = 1, num_icesheets + call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofl') + end do + call addfld(fldListFr(comprof)%flds, 'Forr_rofl') + call addfld(fldListTo(compocn)%flds, 'Foxx_rofl') + call addfld(fldListTo(compocn)%flds, 'Flrr_flood') + do ns = 1, num_icesheets + call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofi') + end do + call addfld(fldListFr(comprof)%flds, 'Forr_rofi') + call addfld(fldListTo(compocn)%flds, 'Foxx_rofi') + else + if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofl' , rc=rc)) then + ! liquid from river and possibly flood from river to ocean + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl' , rc=rc)) then + if (trim(rof2ocn_liq_rmap) == 'unset') then + call addmap(fldListFr(comprof)%flds, 'Forr_rofl', compocn, mapconsd, 'none', 'unset') + else + call addmap(fldListFr(comprof)%flds, 'Forr_rofl', compocn, map_rof2ocn_liq, 'none', rof2ocn_liq_rmap) + end if + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_flood', compocn, mapconsd, 'one', rof2ocn_fmap) + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl', mrg_from=comprof, mrg_fld='Forr_rofl:Flrr_flood', mrg_type='sum') + else + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl', mrg_from=comprof, mrg_fld='Forr_rofl', mrg_type='sum') + end if + end if + ! liquid from glc to ocean do ns = 1, num_icesheets - call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofl'//iso(n)) + if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofl' , rc=rc)) then + ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? + call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofl', compocn, map_glc2ocn_liq, 'one' , glc2ocn_liq_rmap) + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl', mrg_from=compglc(ns), mrg_fld='Fogg_rofl', mrg_type='sum') + end if end do - call addfld(fldListFr(comprof)%flds, 'Forr_rofl'//iso(n)) - call addfld(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n)) - call addfld(fldListTo(compocn)%flds, 'Flrr_flood'//iso(n)) + end if + if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofi' , rc=rc)) then + ! ice from river to ocean + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi' , rc=rc)) then + if (trim(rof2ocn_ice_rmap) == 'unset') then + call addmap(fldListFr(comprof)%flds, 'Forr_rofi', compocn, mapconsd, 'none', 'unset') + else + call addmap(fldListFr(comprof)%flds, 'Forr_rofi', compocn, map_rof2ocn_ice, 'none', rof2ocn_ice_rmap) + end if + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi', mrg_from=comprof, mrg_fld='Forr_rofi', mrg_type='sum') + end if + ! ice from glc to ocean do ns = 1, num_icesheets - call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofi'//iso(n)) + if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofi' , rc=rc)) then + ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? + call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofi', compocn, map_glc2ocn_ice, 'one', glc2ocn_ice_rmap) + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi', mrg_from=compglc(ns), mrg_fld='Fogg_rofi', mrg_type='sum') + end if end do - call addfld(fldListFr(comprof)%flds, 'Forr_rofi'//iso(n)) - call addfld(fldListTo(compocn)%flds, 'Foxx_rofi'//iso(n)) - end do - else - do n = 1,size(iso) - if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofl'//iso(n) , rc=rc)) then + end if + end if + + if (flds_wiso) then + if (phase == 'advertise') then + do ns = 1, num_icesheets + call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofl_wiso') + end do + call addfld(fldListFr(comprof)%flds, 'Forr_rofl_wiso') + call addfld(fldListTo(compocn)%flds, 'Foxx_rofl_wiso') + call addfld(fldListTo(compocn)%flds, 'Flrr_flood_wiso') + do ns = 1, num_icesheets + call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofi_wiso') + end do + call addfld(fldListFr(comprof)%flds, 'Forr_rofi_wiso') + call addfld(fldListTo(compocn)%flds, 'Foxx_rofi_wiso') + else + if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofl_wiso' , rc=rc)) then ! liquid from river and possibly flood from river to ocean - if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n) , rc=rc)) then - call addmap(fldListFr(comprof)%flds, 'Forr_rofl'//iso(n), & - compocn, map_rof2ocn_liq, 'none', rof2ocn_liq_rmap) - if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood'//iso(n), rc=rc)) then - call addmap(fldListFr(comprof)%flds, 'Flrr_flood'//iso(n), & - compocn, mapconsd, 'one', rof2ocn_fmap) - call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n), & + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl_wiso' , rc=rc)) then + if (trim(rof2ocn_liq_rmap) == 'unset') then + call addmap(fldListFr(comprof)%flds, 'Forr_rofl_wiso', compocn, mapconsd, 'none', 'unset') + else + call addmap(fldListFr(comprof)%flds, 'Forr_rofl_wiso', compocn, map_rof2ocn_liq, 'none', rof2ocn_liq_rmap) + end if + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood_wiso', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Flrr_flood_wiso', compocn, mapconsd, 'one', rof2ocn_fmap) + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl_wiso', & mrg_from=comprof, mrg_fld='Forr_rofl:Flrr_flood', mrg_type='sum') else - call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n), & + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl_wiso', & mrg_from=comprof, mrg_fld='Forr_rofl', mrg_type='sum') end if end if ! liquid from glc to ocean do ns = 1, num_icesheets - if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofl'//iso(n) , rc=rc)) then + if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofl_wiso' , rc=rc)) then ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? - call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofl'//iso(n), & - compocn, map_glc2ocn_liq, 'one' , glc2ocn_liq_rmap) - call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n), & - mrg_from=compglc(ns), mrg_fld='Fogg_rofl'//iso(n), mrg_type='sum') + call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofl_wiso', compocn, map_glc2ocn_liq, 'one' , glc2ocn_liq_rmap) + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl_wiso', & + mrg_from=compglc(ns), mrg_fld='Fogg_rofl_wiso', mrg_type='sum') end if end do end if - if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofi'//iso(n) , rc=rc)) then + if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofi_wiso' , rc=rc)) then ! ice from river to ocean - if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi'//iso(n) , rc=rc)) then - 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_from=comprof, mrg_fld='Forr_rofi', mrg_type='sum') + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi_wiso' , rc=rc)) then + if (trim(rof2ocn_ice_rmap) == 'unset') then + call addmap(fldListFr(comprof)%flds, 'Forr_rofi_wiso', compocn, mapconsd, 'none', 'unset') + else + call addmap(fldListFr(comprof)%flds, 'Forr_rofi_wiso', compocn, map_rof2ocn_ice, 'none', rof2ocn_ice_rmap) + end if + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi_wiso', mrg_from=comprof, mrg_fld='Forr_rofi', mrg_type='sum') end if ! ice from glc to ocean do ns = 1, num_icesheets - if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofi'//iso(n) , rc=rc)) then + if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofi_wiso' , rc=rc)) then ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? - call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofi'//iso(n), & - compocn, map_glc2ocn_ice, 'one', glc2ocn_ice_rmap) - call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi'//iso(n), & - mrg_from=compglc(ns), mrg_fld='Fogg_rofi'//iso(n), mrg_type='sum') + call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofi_wiso', compocn, map_glc2ocn_ice, 'one', glc2ocn_ice_rmap) + call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi_wiso', & + mrg_from=compglc(ns), mrg_fld='Fogg_rofi_wiso', mrg_type='sum') end if end do end if - end do + end if end if !----------------------------- ! to ocn: Langmuir multiplier from wave + !----------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_lamult') + call addfld(fldListTo(compocn)%flds, 'Sw_lamult') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_lamult', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_lamult', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_lamult', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_lamult', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- ! to ocn: Stokes drift u component from wave + !----------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_ustokes') + call addfld(fldListTo(compocn)%flds, 'Sw_ustokes') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_ustokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_ustokes', mrg_from=compwav, mrg_fld='Sw_ustokes', mrg_type='copy') + end if + end if + !----------------------------- ! to ocn: Stokes drift v component from wave + !----------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_vstokes') + call addfld(fldListTo(compocn)%flds, 'Sw_vstokes') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_vstokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_vstokes', mrg_from=compwav, mrg_fld='Sw_vstokes', mrg_type='copy') + end if + end if + !----------------------------- ! to ocn: Stokes drift depth from wave !----------------------------- - allocate(flds(4)) - flds = (/'Sw_lamult ',& - 'Sw_ustokes',& - 'Sw_vstokes',& - 'Sw_hstokes'/) - - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(compwav)%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(compwav, compwav), trim(fldname), rc=rc)) then - call addmap(fldListFr(compwav)%flds, trim(fldname), & - compocn, mapbilnr, 'one', wav2ocn_smap) - call addmrg(fldListTo(compocn)%flds, trim(fldname), & - mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') - end if + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_hstokes') + call addfld(fldListTo(compocn)%flds, 'Sw_hstokes') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_hstokes', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_hstokes', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_hstokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_hstokes', mrg_from=compwav, mrg_fld='Sw_hstokes', mrg_type='copy') end if - end do - deallocate(flds) + end if !===================================================================== ! FIELDS TO ICE (compice) @@ -1402,45 +2278,125 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! --------------------------------------------------------------------- ! to ice: downward longwave heat flux from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') + call addfld(fldListTo(compice)%flds, 'Faxa_lwdn') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_lwdn', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwdn', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_lwdn', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_lwdn', mrg_from=compatm, mrg_fld='Faxa_lwdn', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: downward direct near-infrared incident solar radiation from atm ! to ice: downward direct visible incident solar radiation from atm ! to ice: downward diffuse near-infrared incident solar radiation from atm ! to ice: downward Diffuse visible incident solar radiation from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swndr') + call addfld(fldListTo(compice)%flds, 'Faxa_swndr') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_swndr', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swndr', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swndr', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_swndr', mrg_from=compatm, mrg_fld='Faxa_swndr', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swvdr') + call addfld(fldListTo(compice)%flds, 'Faxa_swvdr') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_swvdr', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swvdr', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdr', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_swvdr', mrg_from=compatm, mrg_fld='Faxa_swvdr', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swndf') + call addfld(fldListTo(compice)%flds, 'Faxa_swndf') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_swndf', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swndf', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swndf', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_swndf', mrg_from=compatm, mrg_fld='Faxa_swndf', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_swvdf') + call addfld(fldListTo(compice)%flds, 'Faxa_swvdf') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_swvdf', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swvdf', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_swvdf', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_swvdf', mrg_from=compatm, mrg_fld='Faxa_swvdf', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: hydrophylic black carbon dry deposition flux from atm ! to ice: hydrophobic black carbon dry deposition flux from atm ! to ice: hydrophylic black carbon wet deposition flux from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_bcph') + call addfld(fldListTo(compice)%flds, 'Faxa_bcph') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_bcph', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_bcph', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_bcph', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_bcph', mrg_from=compatm, mrg_fld='Faxa_bcph', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: hydrophylic organic carbon dry deposition flux from atm ! to ice: hydrophobic organic carbon dry deposition flux from atm ! to ice: hydrophylic organic carbon wet deposition flux from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_ocph') + call addfld(fldListTo(compice)%flds, 'Faxa_ocph') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_ocph', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_ocph', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_ocph', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_ocph', mrg_from=compatm, mrg_fld='Faxa_ocph', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: dust wet deposition flux (size 1) from atm ! to ice: dust wet deposition flux (size 2) from atm ! to ice: dust wet deposition flux (size 3) from atm ! to ice: dust wet deposition flux (size 4) from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_dstwet') + call addfld(fldListTo(compice)%flds, 'Faxa_dstwet') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_dstwet', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_dstwet', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_dstwet', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_dstwet', mrg_from=compatm, mrg_fld='Faxa_dstwet', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: dust dry deposition flux (size 1) from atm ! to ice: dust dry deposition flux (size 2) from atm ! to ice: dust dry deposition flux (size 3) from atm ! to ice: dust dry deposition flux (size 4) from atm ! --------------------------------------------------------------------- - allocate(flds(9)) - flds = (/'Faxa_lwdn ' , 'Faxa_swndr ' , 'Faxa_swvdr ' , 'Faxa_swndf ' , 'Faxa_swvdf ', & - 'Faxa_bcph ' , 'Faxa_ocph ' , 'Faxa_dstwet' , 'Faxa_dstdry' /) - - 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, mapconsf, 'one', atm2ice_fmap) - call addmrg(fldListTo(compice)%flds, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_dstdry') + call addfld(fldListTo(compice)%flds, 'Faxa_dstdry') + else + if ( fldchk(is_local%wrap%FBExp(compice) , 'Faxa_dstdry', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_dstdry', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_dstdry', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_dstdry', mrg_from=compatm, mrg_fld='Faxa_dstdry', mrg_type='copy') end if - end do - deallocate(flds) - + end if ! --------------------------------------------------------------------- ! to ice: convective and large scale precipitation rate water equivalent from atm ! to ice: rain and snow rate from atm @@ -1450,145 +2406,281 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListFr(compatm)%flds, 'Faxa_rainl') call addfld(fldListFr(compatm)%flds, 'Faxa_rain' ) call addfld(fldListTo(compice)%flds, 'Faxa_rain' ) - - call addfld(fldListFr(compatm)%flds, 'Faxa_rainc_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_rainl_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_rain_wiso' ) - call addfld(fldListTo(compice)%flds, 'Faxa_rain_wiso' ) else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_rain' , rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_rainc', compice, mapconsf, 'one', atm2ice_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_rainl', compice, mapconsf, 'one', atm2ice_fmap) - call addmrg(fldListTo(compice)%flds, 'Faxa_rain' , & - mrg_from=compatm, mrg_fld='Faxa_rainc:Faxa_rainl', mrg_type='sum') + call addmap(fldListFr(compatm)%flds, 'Faxa_rainc', compice, mapconsf, 'one', atm2ice_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_rainl', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_rain' , mrg_from=compatm, mrg_fld='Faxa_rainc:Faxa_rainl', mrg_type='sum') else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_rain', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rain', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_rain', compice, mapconsf, 'one', atm2ice_fmap) - call addmrg(fldListTo(compice)%flds, 'Faxa_rain', & - mrg_from=compatm, mrg_fld='Faxa_rain', mrg_type='copy') - end if - if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_rain_wiso' , rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl_wiso', rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc_wiso', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_rainc_wiso', compice, mapconsf, 'one', atm2ice_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_rainl_wiso', compice, mapconsf, 'one', atm2ice_fmap) - call addmrg(fldListTo(compice)%flds, 'Faxa_rain_wiso' , & - mrg_from=compatm, mrg_fld='Faxa_rainc_wiso:Faxa_rainl_wiso', mrg_type='sum') - else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_rain_wiso', rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rain_wiso', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_rain_wiso', compice, mapconsf, 'one', atm2ice_fmap) - call addmrg(fldListTo(compice)%flds, 'Faxa_rain_wiso', & - mrg_from=compatm, mrg_fld='Faxa_rain_wiso', mrg_type='copy') + call addmap(fldListFr(compatm)%flds, 'Faxa_rain', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_rain', mrg_from=compatm, mrg_fld='Faxa_rain', mrg_type='copy') end if end if - if (phase == 'advertise') then call addfld(fldListFr(compatm)%flds, 'Faxa_snowc') call addfld(fldListFr(compatm)%flds, 'Faxa_snowl') call addfld(fldListFr(compatm)%flds, 'Faxa_snow' ) call addfld(fldListTo(compice)%flds, 'Faxa_snow' ) - - call addfld(fldListFr(compatm)%flds, 'Faxa_snowc_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_snowl_wiso') - call addfld(fldListFr(compatm)%flds, 'Faxa_snow_wiso' ) - call addfld(fldListTo(compice)%flds, 'Faxa_snow_wiso' ) else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_snow' , rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowl', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowc', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_snowc', compice, mapconsf, 'one', atm2ice_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_snowl', compice, mapconsf, 'one', atm2ice_fmap) + call addmap(fldListFr(compatm)%flds, 'Faxa_snowc', compice, mapconsf, 'one', atm2ice_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_snowl', compice, mapconsf, 'one', atm2ice_map) call addmrg(fldListTo(compice)%flds, 'Faxa_snow' , & mrg_from=compatm, mrg_fld='Faxa_snowc:Faxa_snowl', mrg_type='sum') else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_snow', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snow', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_snow', compice, mapconsf, 'one', atm2ice_fmap) + call addmap(fldListFr(compatm)%flds, 'Faxa_snow', compice, mapconsf, 'one', atm2ice_map) call addmrg(fldListTo(compice)%flds, 'Faxa_snow', & mrg_from=compatm, mrg_fld='Faxa_snow', mrg_type='copy') end if - if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_snow_wiso', rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowl_wiso', rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowc_wiso', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_snowc_wiso', compice, mapconsf, 'one', atm2ice_fmap) - call addmap(fldListFr(compatm)%flds, 'Faxa_snowl_wiso', compice, mapconsf, 'one', atm2ice_fmap) - call addmrg(fldListTo(compice)%flds, 'Faxa_snow_wiso' , & - mrg_from=compatm, mrg_fld='Faxa_snowc_wiso:Faxa_snowl_wiso', mrg_type='sum') - else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_snow_wiso', rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snow_wiso', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_snow_wiso', compice, mapconsf, 'one', atm2ice_fmap) - call addmrg(fldListTo(compice)%flds, 'Faxa_snow_wiso', & - mrg_from=compatm, mrg_fld='Faxa_snow_wiso', mrg_type='copy') + end if + + if (flds_wiso) then + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_rainc_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_rainl_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_rain_wiso' ) + call addfld(fldListTo(compice)%flds, 'Faxa_rain_wiso' ) + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_rain_wiso' , rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_rainc_wiso', compice, mapconsf, 'one', atm2ice_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_rainl_wiso', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_rain_wiso' , & + mrg_from=compatm, mrg_fld='Faxa_rainc_wiso:Faxa_rainl_wiso', mrg_type='sum') + else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_rain_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rain_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_rain_wiso', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_rain_wiso', & + mrg_from=compatm, mrg_fld='Faxa_rain_wiso', mrg_type='copy') + end if + end if + + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_snowc_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_snowl_wiso') + call addfld(fldListFr(compatm)%flds, 'Faxa_snow_wiso' ) + call addfld(fldListTo(compice)%flds, 'Faxa_snow_wiso' ) + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_snow_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowl_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowc_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snowc_wiso', compice, mapconsf, 'one', atm2ice_map) + call addmap(fldListFr(compatm)%flds, 'Faxa_snowl_wiso', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_snow_wiso' , & + mrg_from=compatm, mrg_fld='Faxa_snowc_wiso:Faxa_snowl_wiso', mrg_type='sum') + else if ( fldchk(is_local%wrap%FBexp(compice) , 'Faxa_snow_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snow_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_snow_wiso', compice, mapconsf, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Faxa_snow_wiso', mrg_from=compatm, mrg_fld='Faxa_snow_wiso', mrg_type='copy') + end if end if end if ! --------------------------------------------------------------------- ! to ice: height at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_z') + call addfld(fldListTo(compice)%flds, 'Sa_z') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_z', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_z', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_z', compice, mapbilnr, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Sa_z', mrg_from=compatm, mrg_fld='Sa_z', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: pressure at the lowest model level fromatm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_pbot') + call addfld(fldListTo(compice)%flds, 'Sa_pbot') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_pbot', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_pbot', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_pbot', compice, mapbilnr, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Sa_pbot', mrg_from=compatm, mrg_fld='Sa_pbot', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: temperature at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_tbot') + call addfld(fldListTo(compice)%flds, 'Sa_tbot') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_tbot', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_tbot', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_tbot', compice, mapbilnr, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Sa_tbot', mrg_from=compatm, mrg_fld='Sa_tbot', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: potential temperature at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_ptem') + call addfld(fldListTo(compice)%flds, 'Sa_ptem') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_ptem', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_ptem', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_ptem', compice, mapbilnr, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Sa_ptem', mrg_from=compatm, mrg_fld='Sa_ptem', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: density at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_dens') + call addfld(fldListTo(compice)%flds, 'Sa_dens') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_dens', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_dens', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_dens', compice, mapbilnr, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Sa_dens', mrg_from=compatm, mrg_fld='Sa_dens', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: zonal wind at the lowest model level from atm ! to ice: meridional wind at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_u') + call addfld(fldListTo(compice)%flds, 'Sa_u') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_u', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_u', rc=rc)) then + if (mapuv_with_cart3d) then + call addmap(fldListFr(compatm)%flds, 'Sa_u', compice, mappatch_uv3d, 'one', atm2ice_map) + else + call addmap(fldListFr(compatm)%flds, 'Sa_u', compice, mappatch, 'one', atm2ice_map) + end if + call addmrg(fldListTo(compice)%flds, 'Sa_u', mrg_from=compatm, mrg_fld='Sa_u', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_v') + call addfld(fldListTo(compice)%flds, 'Sa_v') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_v', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_v', rc=rc)) then + if (mapuv_with_cart3d) then + call addmap(fldListFr(compatm)%flds, 'Sa_v', compice, mappatch_uv3d, 'one', atm2ice_map) + else + call addmap(fldListFr(compatm)%flds, 'Sa_v', compice, mappatch, 'one', atm2ice_map) + end if + call addmrg(fldListTo(compice)%flds, 'Sa_v', mrg_from=compatm, mrg_fld='Sa_v', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: specific humidity at the lowest model level from atm ! to ice: specific humidity for water isotopes at the lowest model level from atm ! --------------------------------------------------------------------- - allocate(flds(9)) - flds = (/'Sa_z ', 'Sa_pbot ', 'Sa_tbot ', 'Sa_ptem ', & - 'Sa_dens ', 'Sa_u ', 'Sa_v ', 'Sa_shum ', 'Sa_shum_wiso'/) - - do n = 1,size(flds) - fldname = trim(flds(n)) + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_shum') + call addfld(fldListTo(compice)%flds, 'Sa_shum') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_shum', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_shum', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_shum', compice, mapbilnr, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Sa_shum', mrg_from=compatm, mrg_fld='Sa_shum', mrg_type='copy') + end if + end if + if (flds_wiso) then if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(compice)%flds, trim(fldname)) + call addfld(fldListFr(compatm)%flds, 'Sa_shum_wiso') + call addfld(fldListTo(compice)%flds, 'Sa_shum_wiso') 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 - if (trim(fldname) == 'Sa_u' .or. trim(fldname) == 'Sa_v') then - if (mapuv_with_cart3d) then - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mappatch_uv3d, 'one', atm2ice_vmap) - else - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mappatch, 'one', atm2ice_vmap) - end if - else - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mapbilnr, 'one', atm2ice_smap) - end if - call addmrg(fldListTo(compice)%flds, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + if ( fldchk(is_local%wrap%FBexp(compice) , 'Sa_shum_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_shum_wiso', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_shum_wiso', compice, mapbilnr, 'one', atm2ice_map) + call addmrg(fldListTo(compice)%flds, 'Sa_shum_wiso', mrg_from=compatm, mrg_fld='Sa_shum_wiso', mrg_type='copy') end if end if - end do - deallocate(flds) + end if ! --------------------------------------------------------------------- ! to ice: sea surface temperature from ocn + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_t') + call addfld(fldListTo(compice)%flds, 'So_t') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'So_t', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_t', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_t', compice, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compice)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: sea surface salinity from ocn + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_s') + call addfld(fldListTo(compice)%flds, 'So_s') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'So_s', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_s', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_s', compice, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compice)%flds, 'So_s', mrg_from=compocn, mrg_fld='So_s', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- ! to ice: zonal sea water velocity from ocn ! to ice: meridional sea water velocity from ocn - ! to ice: zonal sea surface slope from ocean + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_u') + call addfld(fldListTo(compice)%flds, 'So_u') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'So_u', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_u', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_u', compice, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compice)%flds, 'So_u', mrg_from=compocn, mrg_fld='So_u', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_v') + call addfld(fldListTo(compice)%flds, 'So_v') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'So_v', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_v', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_v', compice, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compice)%flds, 'So_v', mrg_from=compocn, mrg_fld='So_v', mrg_type='copy') + end if + end if + ! --------------------------------------------------------------------- + ! to ice: zonal sea surface slope from ocn ! to ice: meridional sea surface slope from ocn ! --------------------------------------------------------------------- - allocate(flds(6)) - flds = (/'So_t ', 'So_s ', 'So_u ', 'So_v ', 'So_dhdx', 'So_dhdy'/) - - 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_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end if + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_dhdx') + call addfld(fldListTo(compice)%flds, 'So_dhdx') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'So_dhdx', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_dhdx', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_dhdx', compice, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compice)%flds, 'So_dhdx', mrg_from=compocn, mrg_fld='So_dhdx', mrg_type='copy') end if - end do - deallocate(flds) - + end if + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_dhdy') + call addfld(fldListTo(compice)%flds, 'So_dhdy') + else + if ( fldchk(is_local%wrap%FBexp(compice) , 'So_dhdy', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_dhdy', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_dhdy', compice, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compice)%flds, 'So_dhdy', mrg_from=compocn, mrg_fld='So_dhdy', mrg_type='copy') + end if + end if ! --------------------------------------------------------------------- ! to ice: ocean melt and freeze potential from ocn ! --------------------------------------------------------------------- @@ -1599,55 +2691,72 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'Fioo_q', rc=rc) .and. & fldchk(is_local%wrap%FBExp(compice) , 'Fioo_q', rc=rc)) then call addmap(fldListFr(compocn)%flds, 'Fioo_q', compice, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compice)%flds, 'Fioo_q', & - mrg_from=compocn, mrg_fld='Fioo_q', mrg_type='copy') + call addmrg(fldListTo(compice)%flds, 'Fioo_q', mrg_from=compocn, mrg_fld='Fioo_q', mrg_type='copy') end if end if - !----------------------------- ! to ice: Ratio of ocean surface level abund. H2_16O/H2O/Rstd from ocean !----------------------------- - if (phase == 'advertise') then - call addfld(fldListFr(compocn)%flds, 'So_roce_wiso') - call addfld(fldListTo(compice)%flds, 'So_roce_wiso') - else - if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'So_roce_wiso', rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compice) , 'So_roce_wiso', rc=rc)) then - call addmap(fldListFr(compocn)%flds, 'So_roce_wiso', compice, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compice)%flds, 'So_roce_wiso', & - mrg_from=compocn, mrg_fld='So_roce_wiso', mrg_type='copy') + if (flds_wiso) then + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_roce_wiso') + call addfld(fldListTo(compice)%flds, 'So_roce_wiso') + else + if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'So_roce_wiso', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compice) , 'So_roce_wiso', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_roce_wiso', compice, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compice)%flds, 'So_roce_wiso', mrg_from=compocn, mrg_fld='So_roce_wiso', mrg_type='copy') + end if end if end if ! --------------------------------------------------------------------- ! to ice: frozen runoff from rof and glc ! --------------------------------------------------------------------- - do n = 1,size(iso) + if (phase == 'advertise') then + call addfld(fldListFr(comprof)%flds, 'Firr_rofi') ! water flux into sea ice due to runoff (frozen) + do ns = 1, num_icesheets + call addfld(fldListFr(compglc(ns))%flds, 'Figg_rofi') ! glc frozen runoff_iceberg flux to ice + end do + call addfld(fldListTo(compice)%flds, 'Fixx_rofi') ! total frozen water flux into sea ice + else + if ( fldchk(is_local%wrap%FBExp(compice), 'Fixx_rofi', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Forr_rofi', compice, mapconsf, 'none', rof2ocn_ice_rmap) + call addmrg(fldListTo(compice)%flds, 'Fixx_rofi', mrg_from=comprof, mrg_fld='Firr_rofi', mrg_type='sum') + end if + do ns = 1, num_icesheets + if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Figg_rofi', rc=rc)) then + call addmap(fldListFr(compglc(ns))%flds, 'Figg_rofi', compice, mapconsf, 'one' , glc2ice_rmap) + call addmrg(fldListTo(compice)%flds, 'Fixx_rofi', mrg_from=compglc(ns), mrg_fld='Figg_rofi', mrg_type='sum') + end if + end do + end if + end if + if (flds_wiso) then if (phase == 'advertise') then - call addfld(fldListFr(comprof)%flds, 'Firr_rofi'//iso(n)) ! water flux into sea ice due to runoff (frozen) + call addfld(fldListFr(comprof)%flds, 'Firr_rofi_wiso') ! water flux into sea ice due to runoff (frozen) do ns = 1, num_icesheets - call addfld(fldListFr(compglc(ns))%flds, 'Figg_rofi'//iso(n)) ! glc frozen runoff_iceberg flux to ice + call addfld(fldListFr(compglc(ns))%flds, 'Figg_rofi_wiso') ! glc frozen runoff_iceberg flux to ice end do - call addfld(fldListTo(compice)%flds, 'Fixx_rofi'//iso(n)) ! total frozen water flux into sea ice + call addfld(fldListTo(compice)%flds, 'Fixx_rofi_wiso') ! total frozen water flux into sea ice else - if ( fldchk(is_local%wrap%FBExp(compice), 'Fixx_rofi'//iso(n), rc=rc)) then - if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi'//iso(n), rc=rc)) then - call addmap(fldListFr(comprof)%flds, 'Forr_rofi'//iso(n), & - compice, mapconsf, 'none', rof2ocn_ice_rmap) - call addmrg(fldListTo(compice)%flds, 'Fixx_rofi'//iso(n), & - mrg_from=comprof, mrg_fld='Firr_rofi'//iso(n), mrg_type='sum') + if ( fldchk(is_local%wrap%FBExp(compice), 'Fixx_rofi_wiso', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi_wiso', rc=rc)) then + call addmap(fldListFr(comprof)%flds, 'Forr_rofi_wiso', compice, mapconsf, 'none', rof2ocn_ice_rmap) + call addmrg(fldListTo(compice)%flds, 'Fixx_rofi_wiso', & + mrg_from=comprof, mrg_fld='Firr_rofi_wiso', mrg_type='sum') end if do ns = 1, num_icesheets - if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Figg_rofi'//iso(n), rc=rc)) then - call addmap(fldListFr(compglc(ns))%flds, 'Figg_rofi'//iso(n), & - compice, mapconsf, 'one' , glc2ice_rmap) - call addmrg(fldListTo(compice)%flds, 'Fixx_rofi'//iso(n), & - mrg_from=compglc(ns), mrg_fld='Figg_rofi'//iso(n), mrg_type='sum') + if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Figg_rofi_wiso', rc=rc)) then + call addmap(fldListFr(compglc(ns))%flds, 'Figg_rofi_wiso', compice, mapconsf, 'one' , glc2ice_rmap) + call addmrg(fldListTo(compice)%flds, 'Fixx_rofi_wiso', & + mrg_from=compglc(ns), mrg_fld='Figg_rofi_wiso', mrg_type='sum') end if end do end if end if - end do + end if !===================================================================== ! FIELDS TO WAVE (compwav) @@ -1664,58 +2773,103 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_ifrac', rc=rc)) then ! By default will be using a custom map - but if one is not available, use a generated bilinear instead call addmap(fldListFr(compice)%flds, 'Si_ifrac', compwav, mapbilnr, 'one', ice2wav_smap) - call addmrg(fldListTo(compwav)%flds, 'Si_ifrac', & - mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') + call addmrg(fldListTo(compwav)%flds, 'Si_ifrac', mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') end if end if ! --------------------------------------------------------------------- - ! to wav: ocean boundary layer depth from ocn - ! to wav: ocean currents from ocn ! to wav: ocean surface temperature from ocn ! --------------------------------------------------------------------- - allocate(flds(4)) - flds = (/'So_t ', 'So_u ', 'So_v ', 'So_bldepth'/) + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_t') + call addfld(fldListTo(compwav)%flds, 'So_t') + else + if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'So_t', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compwav) , 'So_t', rc=rc)) then + ! By default will be using a custom map - but if one is not available, use a generated bilinear instead + call addmap(fldListFr(compocn)%flds, 'So_t', compwav, mapbilnr, 'one', ocn2wav_smap) + call addmrg(fldListTo(compwav)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + end if + end if - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(compocn)%flds, trim(fldname)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - else - if ( fldchk(is_local%wrap%FBImp(compocn, compocn), trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBExp(compwav) , trim(fldname), rc=rc)) then - ! By default will be using a custom map - but if one is not available, use a generated bilinear instead - call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapbilnr, 'one', ocn2wav_smap) - call addmrg(fldListTo(compwav)%flds, trim(fldname), & - mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end if + ! --------------------------------------------------------------------- + ! to wav: ocean currents from ocn + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_u') + call addfld(fldListTo(compwav)%flds, 'So_u') + else + if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'So_u', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compwav) , 'So_u', rc=rc)) then + ! By default will be using a custom map - but if one is not available, use a generated bilinear instead + call addmap(fldListFr(compocn)%flds, 'So_u', compwav, mapbilnr, 'one', ocn2wav_smap) + call addmrg(fldListTo(compwav)%flds, 'So_u', mrg_from=compocn, mrg_fld='So_u', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_v') + call addfld(fldListTo(compwav)%flds, 'So_v') + else + if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'So_v', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compwav) , 'So_v', rc=rc)) then + ! By default will be using a custom map - but if one is not available, use a generated bilinear instead + call addmap(fldListFr(compocn)%flds, 'So_v', compwav, mapbilnr, 'one', ocn2wav_smap) + call addmrg(fldListTo(compwav)%flds, 'So_v', mrg_from=compocn, mrg_fld='So_v', mrg_type='copy') end if - end do - deallocate(flds) + end if ! --------------------------------------------------------------------- - ! to wav: zonal wind at the lowest model level from atm - ! to wav: meridional wind at the lowest model level from atm + ! to wav: ocean boundary layer depth from ocn ! --------------------------------------------------------------------- - allocate(flds(3)) - flds = (/'Sa_u ', 'Sa_v ', 'Sa_tbot'/) + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_bldepth') + call addfld(fldListTo(compwav)%flds, 'So_bldepth') + else + if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'So_bldepth', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compwav) , 'So_bldepth', rc=rc)) then + ! By default will be using a custom map - but if one is not available, use a generated bilinear instead + call addmap(fldListFr(compocn)%flds, 'So_bldepth', compwav, mapbilnr, 'one', ocn2wav_smap) + call addmrg(fldListTo(compwav)%flds, 'So_bldepth', mrg_from=compocn, mrg_fld='So_bldepth', mrg_type='copy') + end if + end if - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - else - if ( fldchk(is_local%wrap%FBexp(compwav) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm ), trim(fldname), rc=rc)) then - call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapbilnr, 'one', atm2wav_smap) - call addmrg(fldListTo(compwav)%flds, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if + ! --------------------------------------------------------------------- + ! to wav: zonal and meridional winds at the lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_u') + call addfld(fldListTo(compwav)%flds, 'Sa_u') + else + if ( fldchk(is_local%wrap%FBexp(compwav) , 'Sa_u', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_u', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_u', compwav, mapbilnr, 'one', atm2wav_map) + call addmrg(fldListTo(compwav)%flds, 'Sa_u', mrg_from=compatm, mrg_fld='Sa_u', mrg_type='copy') + end if + end if + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_v') + call addfld(fldListTo(compwav)%flds, 'Sa_v') + else + if ( fldchk(is_local%wrap%FBexp(compwav) , 'Sa_v', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_v', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_v', compwav, mapbilnr, 'one', atm2wav_map) + call addmrg(fldListTo(compwav)%flds, 'Sa_v', mrg_from=compatm, mrg_fld='Sa_v', mrg_type='copy') + end if + end if + + ! --------------------------------------------------------------------- + ! to wav: temperature at lowest model level from atm + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_tbot') + call addfld(fldListTo(compwav)%flds, 'Sa_tbot') + else + if ( fldchk(is_local%wrap%FBexp(compwav) , 'Sa_tbot', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm ), 'Sa_tbot', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_tbot', compwav, mapbilnr, 'one', atm2wav_map) + call addmrg(fldListTo(compwav)%flds, 'Sa_tbot', mrg_from=compatm, mrg_fld='Sa_tbot', mrg_type='copy') end if - end do - deallocate(flds) + end if !===================================================================== ! FIELDS TO RIVER (comprof) @@ -1723,35 +2877,78 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! --------------------------------------------------------------------- ! to rof: water flux from land (liquid surface) + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Flrl_rofsur') + call addfld(fldListTo(comprof)%flds, 'Flrl_rofsur') + else + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Flrl_rofsur', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(comprof) , 'Flrl_rofsur', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Flrl_rofsur', comprof, mapconsf, 'lfrac', lnd2rof_map) + call addmrg(fldListTo(comprof)%flds, 'Flrl_rofsur', & + mrg_from=complnd, mrg_fld='Flrl_rofsur', mrg_type='copy_with_weights', mrg_fracname='lfrac') + end if + end if + + ! --------------------------------------------------------------------- + ! to rof: water flux from land (ice surface) + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Flrl_rofi') + call addfld(fldListTo(comprof)%flds, 'Flrl_rofi') + else + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Flrl_rofi', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(comprof) , 'Flrl_rofi', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Flrl_rofi', comprof, mapconsf, 'lfrac', lnd2rof_map) + call addmrg(fldListTo(comprof)%flds, 'Flrl_rofi', & + mrg_from=complnd, mrg_fld='Flrl_rofi', mrg_type='copy_with_weights', mrg_fracname='lfrac') + end if + end if + + ! --------------------------------------------------------------------- ! to rof: water flux from land (liquid glacier, wetland, and lake) - ! to rof: water flux from land (liquid subsurface) - ! to rof: water flux from land direct to ocean - ! to rof: irrigation flux from land (withdrawal from rivers) ! --------------------------------------------------------------------- - ! TODO (mvertens, 2019-01-13): the following isotopes have not yet been defined in the NUOPC field dict - ! allocate(flds(12)) - ! flds = (/'Flrl_rofsur', 'Flrl_rofsur_wiso', 'Flrl_rofgwl', 'Flrl_rofgwl_wiso', & - ! 'Flrl_rofsub', 'Flrl_rofsub_wiso', 'Flrl_rofdto', 'Flrl_rofdto_wiso', & - ! 'Flrl_rofi' , 'Flrl_rofi_wiso' , 'Flrl_irrig' , 'Flrl_irrig_wiso' /) + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Flrl_rofgwl') + call addfld(fldListTo(comprof)%flds, 'Flrl_rofgwl') + else + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Flrl_rofgwl', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(comprof) , 'Flrl_rofgwl', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Flrl_rofgwl', comprof, mapconsf, 'lfrac', lnd2rof_map) + call addmrg(fldListTo(comprof)%flds, 'Flrl_rofgwl', & + mrg_from=complnd, mrg_fld='Flrl_rofgwl', mrg_type='copy_with_weights', mrg_fracname='lfrac') + end if + end if - allocate(flds(6)) - flds = (/'Flrl_rofsur', 'Flrl_rofgwl', 'Flrl_rofsub', 'Flrl_rofdto', 'Flrl_rofi ', 'Flrl_irrig '/) + ! --------------------------------------------------------------------- + ! to rof: water flux from land (liquid subsurface) + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Flrl_rofsub') + call addfld(fldListTo(comprof)%flds, 'Flrl_rofsub') + else + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Flrl_rofsub', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(comprof) , 'Flrl_rofsub', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Flrl_rofsub', comprof, mapconsf, 'lfrac', lnd2rof_map) + call addmrg(fldListTo(comprof)%flds, 'Flrl_rofsub', & + mrg_from=complnd, mrg_fld='Flrl_rofsub', mrg_type='copy_with_weights', mrg_fracname='lfrac') + end if + end if - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(complnd)%flds, trim(fldname)) - call addfld(fldListTo(comprof)%flds, trim(fldname)) - 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, mapconsf, 'lfrac', lnd2rof_fmap) - call addmrg(fldListTo(comprof)%flds, trim(fldname), & - mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='lfrac') - end if + ! --------------------------------------------------------------------- + ! to rof: irrigation flux from land (withdrawal from rivers) + ! --------------------------------------------------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(complnd)%flds, 'Flrl_irrig') + call addfld(fldListTo(comprof)%flds, 'Flrl_irrig') + else + if ( fldchk(is_local%wrap%FBImp(complnd, complnd), 'Flrl_irrig', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(comprof) , 'Flrl_irrig', rc=rc)) then + call addmap(fldListFr(complnd)%flds, 'Flrl_irrig', comprof, mapconsf, 'lfrac', lnd2rof_map) + call addmrg(fldListTo(comprof)%flds, 'Flrl_irrig', & + mrg_from=complnd, mrg_fld='Flrl_irrig', mrg_type='copy_with_weights', mrg_fracname='lfrac') end if - end do - deallocate(flds) + end if !===================================================================== ! FIELDS TO LAND-ICE (compglc) @@ -1844,8 +3041,8 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListTo(complnd)%flds, 'Sa_co2prog') call addfld(fldListTo(compocn)%flds, 'Sa_co2prog') else - call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', complnd, mapbilnr, 'one', atm2lnd_smap) - call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', compocn, mapbilnr, 'one', atm2ocn_smap) + call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', complnd, mapbilnr, 'one', atm2lnd_map) + call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', compocn, mapbilnr, 'one', atm2ocn_map) call addmrg(fldListTo(complnd)%flds, 'Sa_co2prog', & mrg_from=compatm, mrg_fld='Sa_co2prog', mrg_type='copy') @@ -1861,8 +3058,8 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListTo(complnd)%flds, 'Sa_co2diag') call addfld(fldListTo(compocn)%flds, 'Sa_co2diag') else - call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', complnd, mapbilnr, 'one', atm2lnd_smap) - call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', compocn, mapbilnr, 'one', atm2ocn_smap) + call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', complnd, mapbilnr, 'one', atm2lnd_map) + call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', compocn, mapbilnr, 'one', atm2ocn_map) call addmrg(fldListTo(complnd)%flds, 'Sa_co2diag', & mrg_from=compatm, mrg_fld='Sa_co2diag', mrg_type='copy') @@ -1879,7 +3076,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListFr(compatm)%flds, 'Sa_co2prog') call addfld(fldListTo(complnd)%flds, 'Sa_co2prog') else - call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', complnd, mapbilnr, 'one', atm2lnd_smap) + call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', complnd, mapbilnr, 'one', atm2lnd_map) call addmrg(fldListTo(complnd)%flds, 'Sa_co2prog', & mrg_from=compatm, mrg_fld='Sa_co2prog', mrg_type='copy') end if @@ -1891,7 +3088,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListFr(compatm)%flds, 'Sa_co2diag') call addfld(fldListTo(complnd)%flds, 'Sa_co2diag') else - call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', complnd, mapbilnr, 'one', atm2lnd_smap) + call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', complnd, mapbilnr, 'one', atm2lnd_map) call addmrg(fldListTo(complnd)%flds, 'Sa_co2diag', & mrg_from=compatm, mrg_fld='Sa_co2diag', mrg_type='copy') end if @@ -1903,7 +3100,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', lnd2atm_fmap) + call addmap(fldListFr(complnd)%flds, 'Fall_fco2_lnd', compatm, mapconsf, 'one', lnd2atm_map) call addmrg(fldListTo(compatm)%flds, 'Fall_fco2_lnd', & mrg_from=complnd, mrg_fld='Fall_fco2_lnd', mrg_type='copy_with_weights', mrg_fracname='lfrac') end if @@ -1918,8 +3115,8 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListTo(complnd)%flds, 'Sa_co2prog') call addfld(fldListTo(compocn)%flds, 'Sa_co2prog') else - call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', complnd, mapbilnr, 'one', atm2lnd_smap) - call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', compocn, mapbilnr, 'one', atm2ocn_smap) + call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', complnd, mapbilnr, 'one', atm2lnd_map) + call addmap(fldListFr(compatm)%flds, 'Sa_co2prog', compocn, mapbilnr, 'one', atm2ocn_map) call addmrg(fldListTo(complnd)%flds, 'Sa_co2prog', & mrg_from=compatm, mrg_fld='Sa_co2prog', mrg_type='copy') @@ -1935,8 +3132,8 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListTo(complnd)%flds, 'Sa_co2diag') call addfld(fldListTo(compocn)%flds, 'Sa_co2diag') else - call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', complnd, mapbilnr, 'one', atm2lnd_smap) - call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', compocn, mapbilnr, 'one', atm2ocn_smap) + call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', complnd, mapbilnr, 'one', atm2lnd_map) + call addmap(fldListFr(compatm)%flds, 'Sa_co2diag', compocn, mapbilnr, 'one', atm2ocn_map) call addmrg(fldListTo(complnd)%flds, 'Sa_co2diag', & mrg_from=compatm, mrg_fld='Sa_co2diag', mrg_type='copy') @@ -1951,7 +3148,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', lnd2atm_fmap) + call addmap(fldListFr(complnd)%flds, 'Fall_fco2_lnd', compatm, mapconsf, 'one', lnd2atm_map) call addmrg(fldListTo(compatm)%flds, 'Fall_fco2_lnd', & mrg_from=complnd, mrg_fld='Fall_fco2_lnd', mrg_type='copy_with_weights', mrg_fracname='lfrac') end if @@ -1963,7 +3160,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, mapconsd, 'one', ocn2atm_fmap) + call addmap(fldListFr(compocn)%flds, 'Faoo_fco2_ocn', compatm, mapconsd, 'one', ocn2atm_map) ! custom merge in med_phases_prep_atm end if endif @@ -1971,14 +3168,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) !----------------------------------------------------------------------------- ! CARMA fields (volumetric soil water) !----------------------------------------------------------------------------- - ! TODO: add this - ! if (carma_flds /= ' ') then - ! do n = 1,)number_of_fields in carm_flds) - ! call addfld(fldListFr(complnd)%flds, trim(fldname)) - ! call addmap(fldListFr(complnd)%flds, trim(fldname), compatm, mapconsf, 'one',lnd2atm_smap) - ! call addfld(fldListTo(compatm)%flds, trim(fldname), mrg_from=complnd, mrg_fld=trim(fldname), mrg_type='copy') - ! enddo - ! endif + ! TODO (mvertens, 2021-07-25): add this end subroutine esmFldsExchange_cesm diff --git a/mediator/esmFldsExchange_hafs_mod.F90 b/mediator/esmFldsExchange_hafs_mod.F90 index e88da9261..5f8537221 100644 --- a/mediator/esmFldsExchange_hafs_mod.F90 +++ b/mediator/esmFldsExchange_hafs_mod.F90 @@ -230,7 +230,7 @@ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) !===================================================================== ! --------------------------------------------------------------------- - ! to wav: 10-m wind components + ! to wav: 10-m wind components ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%wav_present) then allocate(S_flds(2)) @@ -510,7 +510,7 @@ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------- - ! Component active or not? + ! Component active or not? !---------------------------------------------------------- call NUOPC_CompAttributeGet(gcomp, name='ATM_model', & diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index 1a4889bc0..b4a407a06 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -318,6 +318,10 @@ canonical_units: 1e-6 mol/mol description: atmosphere export - prognostic CO2 at the lowest model level # + - standard_name: Sa_o3 + canonical_units: mol/mol + description: atmosphere export - O3 in the lowest model layer (prognosed or prescribed) + # - standard_name: Sa_topo alias: inst_surface_height canonical_units: m @@ -948,6 +952,14 @@ canonical_units: m description: river export to land - river channel main channel water volume from 16O, 18O, HDO # + - standard_name: Sr_tdepth + canonical_units: m + description: river export to land - tributary channel water depth + # + - standard_name: Sr_tdepth_max + canonical_units: m + description: river export to land - tributary channel bankfull depth + # - standard_name: Forr_rofi canonical_units: kg m-2 s-1 description: river export to ocean - water flux due to runoff (frozen) diff --git a/mediator/med.F90 b/mediator/med.F90 index 00cada949..7f2b323af 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -1,8 +1,23 @@ module MED !----------------------------------------------------------------------------- - ! Mediator Component. + ! Mediator Initialization + ! + ! Note on time management: + ! Each time loop has its own associated clock object. NUOPC manages + ! these clock objects, i.e. their creation and destruction, as well as + ! startTime, endTime, timeStep adjustments during the execution. The + ! outer most time loop of the run sequence is a special case. It uses + ! the driver clock itself. If a single outer most loop is defined in + ! the run sequence provided by freeFormat, this loop becomes the driver + ! loop level directly. Therefore, setting the timeStep or runDuration + ! for the outer most time loop results in modifying the driver clock + ! itself. However, for cases with cocnatenated loops on the upper level + ! of the run sequence in freeFormat, a single outer loop is added + ! automatically during ingestion, and the driver clock is used for this + ! loop instead. !----------------------------------------------------------------------------- + use ESMF , only : ESMF_VMLogMemInfo use NUOPC_Model , only : SetVM use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 @@ -24,8 +39,8 @@ module MED 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 + use med_time_mod , only : med_time_alarmInit use med_internalstate_mod , only : InternalState use med_internalstate_mod , only : med_coupling_allowed, logunit, mastertask use med_phases_profile_mod , only : med_phases_profile_finalize @@ -33,8 +48,9 @@ module MED use esmFlds , only : fldListFr, fldListTo, med_fldList_Realize use esmFlds , only : ncomps, compname, ncomps use esmFlds , only : compmed, compatm, compocn, compice, complnd, comprof, compwav ! not arrays - use esmFlds , only : num_icesheets, max_icesheets, compglc, ocn2glc_coupling ! compglc is an array - use esmFlds , only : fldListMed_ocnalb, fldListMed_aoflux + use esmFlds , only : num_icesheets, max_icesheets, compglc ! compglc is an array + use esmFlds , only : ocn2glc_coupling, lnd2glc_coupling, accum_lnd2glc + use esmFlds , only : fldListMed_ocnalb use esmFlds , only : med_fldList_GetNumFlds, med_fldList_GetFldNames, med_fldList_GetFldInfo use esmFlds , only : med_fldList_Document_Mapping, med_fldList_Document_Merging use esmFlds , only : coupling_mode @@ -122,7 +138,7 @@ subroutine SetServices(gcomp, rc) integer, intent(out) :: rc ! local variables - character(len=*),parameter :: subname=' (module_MED:SetServices) ' + character(len=*),parameter :: subname=' (SetServices) ' !----------------------------------------------------------- rc = ESMF_SUCCESS @@ -190,7 +206,7 @@ subroutine SetServices(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ - ! setup mediator history phase + ! setup mediator history phases for all output variables !------------------ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & @@ -199,9 +215,6 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_history_write", specRoutine=med_phases_history_write, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_history_write", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ ! setup mediator restart phase @@ -276,9 +289,6 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_post_ocn", specRoutine=med_phases_post_ocn, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_post_ocn", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ ! prep and post routines for ice @@ -298,12 +308,9 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_post_ice", specRoutine=med_phases_post_ice, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_post_ice", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ - ! prep routines for lnd + ! prep/post routines for lnd !------------------ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & @@ -319,12 +326,9 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_post_lnd", specRoutine=med_phases_post_lnd, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_post_lnd", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ - ! prep and post routines for rof + ! prep/post routines for rof !------------------ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & @@ -341,12 +345,9 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_post_rof", specRoutine=med_phases_post_rof, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_post_rof", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ - ! prep and post routines for wav + ! prep/post routines for wav !------------------ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & @@ -362,12 +363,9 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_post_wav", specRoutine=med_phases_post_wav, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_post_wav", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ - ! prep and post routines for glc + ! prep/post routines for glc !------------------ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & @@ -384,9 +382,6 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_post_glc", specRoutine=med_phases_post_glc, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_post_glc", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ ! phase routine for ocean albedo computation @@ -398,9 +393,6 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_ocnalb_run", specRoutine=med_phases_ocnalb_run, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_ocnalb_run", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ ! phase routine for ocn/atm flux computation @@ -412,9 +404,6 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & specPhaseLabel="med_phases_aofluxes_run", specRoutine=med_phases_aofluxes_run, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & - specPhaselabel="med_phases_aofluxes_run", specRoutine=NUOPC_NoOp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------ ! phase routine for updating fractions @@ -529,6 +518,7 @@ subroutine SetServices(gcomp, rc) ! attach specializing method(s) ! -> NUOPC specializes by default --->>> first need to remove the default !------------------ + ! This is called every time you enter a mediator phase call ESMF_MethodRemove(gcomp, mediator_label_SetRunClock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -575,7 +565,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) character(len=CX) :: logfile character(len=CX) :: diagfile character(len=CX) :: do_budgets - character(len=*),parameter :: subname=' (module_MED:InitializeP0) ' + character(len=*),parameter :: subname=' (InitializeP0) ' !----------------------------------------------------------- rc = ESMF_SUCCESS @@ -686,7 +676,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) type(InternalState) :: is_local integer :: stat character(len=CS) :: attrList(8) - character(len=*),parameter :: subname=' (module_MED:InitializeIPDv03p1) ' + character(len=*),parameter :: subname=' (InitializeIPDv03p1) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -763,6 +753,14 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end do + ! Determine aoflux grid + call NUOPC_CompAttributeGet(gcomp, name='aoflux_grid', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (.not. isPresent .and. .not. isSet) then + cvalue = 'ogrid' + end if + is_local%wrap%aoflux_grid = trim(cvalue) + !------------------ ! Initialize mediator flds !------------------ @@ -954,7 +952,8 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) else transferOffer = 'cannot provide' end if - call NUOPC_Advertise(is_local%wrap%NStateImp(ncomp), standardName=stdname, shortname=shortname, name=shortname, & + call NUOPC_Advertise(is_local%wrap%NStateImp(ncomp), & + standardName=stdname, shortname=shortname, name=shortname, & TransferOfferGeomObject=transferOffer, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(subname//':Fr_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) @@ -972,7 +971,8 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) else transferOffer = 'cannot provide' end if - call NUOPC_Advertise(is_local%wrap%NStateExp(ncomp), standardName=stdname, shortname=shortname, name=shortname, & + call NUOPC_Advertise(is_local%wrap%NStateExp(ncomp), & + standardName=stdname, shortname=shortname, name=shortname, & TransferOfferGeomObject=transferOffer, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(subname//':To_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) @@ -1008,7 +1008,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=' (InitializeIPDv03p3) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1069,7 +1069,7 @@ subroutine InitializeIPDv03p4(gcomp, importState, exportState, clock, rc) ! local variables type(InternalState) :: is_local integer :: n1,n2 - character(len=*),parameter :: subname=' (module_MED:InitalizeIPDv03p4) ' + character(len=*),parameter :: subname=' (InitalizeIPDv03p4) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1114,57 +1114,49 @@ subroutine realizeConnectedGrid(State,string,rc) use ESMF , only : ESMF_FieldStatus_Empty, ESMF_FieldStatus_Complete, ESMF_FieldStatus_GridSet use ESMF , only : ESMF_GeomType_Mesh, ESMF_MeshGet, ESMF_Mesh, ESMF_MeshEmptyCreate + ! input/output variables type(ESMF_State) , intent(inout) :: State character(len=*) , intent(in) :: string integer , intent(out) :: rc ! local variables type(ESMF_Field) :: field - type(ESMF_Grid) :: grid + type(ESMF_Grid) :: grid, newgrid type(ESMF_Mesh) :: mesh, newmesh - integer :: localDeCount - type(ESMF_DistGrid) :: distgrid - type(ESMF_DistGrid) :: nodaldistgrid, newnodaldistgrid type(ESMF_DistGrid) :: elemdistgrid, newelemdistgrid - type(ESMF_DistGridConnection), allocatable :: connectionList(:) integer :: arbDimCount - integer :: dimCount, tileCount, petCount + integer :: dimCount, tileCount integer :: connectionCount - integer :: deCountPTile, extraDEs - integer, allocatable :: minIndexPTile(:,:), maxIndexPTile(:,:) - integer, allocatable :: regDecompPTile(:,:) - integer :: i, j, n, n1, fieldCount, nxg, i1, i2 + integer :: fieldCount + integer :: i, j, n, n1, i1, i2 type(ESMF_GeomType_Flag) :: geomtype - character(ESMF_MAXSTR),allocatable :: fieldNameList(:) type(ESMF_FieldStatus_Flag) :: fieldStatus character(len=CX) :: msgString - character(len=*),parameter :: subname=' (module_MED:realizeConnectedGrid) ' + integer , allocatable :: minIndexPTile(:,:), maxIndexPTile(:,:) + character(ESMF_MAXSTR) , allocatable :: fieldNameList(:) + type(ESMF_DistGridConnection) , allocatable :: connectionList(:) + character(len=*),parameter :: subname=' (realizeConnectedGrid) ' !----------------------------------------------------------- - !NOTE: All of the Fields that set their TransferOfferGeomObject Attribute - !NOTE: to "cannot provide" should now have the accepted Grid available. - !NOTE: Go and pull out this Grid for one of a representative Field and - !NOTE: modify the decomposition and distribution of the Grid to match the - !NOTE: Mediator PETs. - - !TODO: quick implementation, do it for each field one by one - !TODO: commented out below are application to other fields + ! All of the Fields that set their TransferOfferGeomObject Attribute + ! to "cannot provide" should now have the accepted Grid available. + ! Go and pull out this Grid for one of a representative Field and + ! modify the decomposition and distribution of the Grid to match the Mediator PETs. + ! On exit from this phase, the connector will transfer the full Grid/Mesh/LocStream + ! objects (with coordinates) for Field pairs that have a provider and an acceptor side. call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) rc = ESMF_Success - if (profile_memory) call ESMF_VMLogMemInfo("Entering "//trim(subname)) - + if (profile_memory) then + call ESMF_VMLogMemInfo("Entering "//trim(subname)) + end if call ESMF_StateGet(State, itemCount=fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(fieldNameList(fieldCount)) call ESMF_StateGet(State, itemNameList=fieldNameList, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridCompGet(gcomp, petCount=petCount, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! do not loop here, assuming that all fields share the ! same grid/mesh and because it is more efficient - if ! a component has fields on multiple grids/meshes, this @@ -1173,34 +1165,22 @@ subroutine realizeConnectedGrid(State,string,rc) call ESMF_StateGet(State, field=field, itemName=fieldNameList(n), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(field, status=fieldStatus, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !call NUOPC_GetAttribute(field, name="TransferActionGeomObject", & - ! value=transferAction, rc=rc) - !if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (fieldStatus==ESMF_FIELDSTATUS_GRIDSET) then ! The Mediator is accepting a Grid/Mesh passed to it ! through the Connector - ! While this is still an empty field, it does now hold a Grid/Mesh with DistGrid call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (geomtype == ESMF_GEOMTYPE_GRID) then - !if (dbug_flag > 1) then - ! call Field_GeomPrint(field,trim(fieldNameList(n))//'_orig',rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - !end if - call ESMF_AttributeGet(field, name="ArbDimCount", value=arbDimCount, & convention="NUOPC", purpose="Instance", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//": geomtype is ESMF_GEOMTYPE_GRID for "//trim(fieldnameList(n)), & ESMF_LOGMSG_INFO) write(msgString,'(A,i8)') trim(subname)//':arbdimcount =',arbdimcount @@ -1208,171 +1188,85 @@ subroutine realizeConnectedGrid(State,string,rc) ! make decision on whether the incoming Grid is arbDistr or not if (arbDimCount>0) then - ! The provider defined an arbDistr grid - ! - ! Need to make a choice here to either represent the grid as a - ! regDecomp grid on the acceptor side, or to stay with arbDistr grid: - ! - ! Setting the PRECIP_REGDECOMP macro will set up a regDecomp grid on the - ! acceptor side. - ! - ! Not setting the PRECIP_REGDECOMP macro will default into keeping the - ! original arbDistr Grid. - - if (grid_arbopt == "grid_reg") then - - call ESMF_LogWrite(trim(subname)//trim(string)//": accept arb2reg grid for "//trim(fieldNameList(n)), & - ESMF_LOGMSG_INFO) - - ! Use a regDecomp representation for the grid - ! first get tile min/max, only single tile supported for arbDistr Grid - allocate(minIndexPTile(arbDimCount,1),maxIndexPTile(arbDimCount,1)) - call ESMF_AttributeGet(field, name="MinIndex", & - valueList=minIndexPTile(:,1), & - convention="NUOPC", purpose="Instance", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_AttributeGet(field, name="MaxIndex", & - valueList=maxIndexPTile(:,1), & - convention="NUOPC", purpose="Instance", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! create default regDecomp DistGrid - distgrid = ESMF_DistGridCreate(minIndexPTile=minIndexPTile, & - maxIndexPTile=maxIndexPTile, connectionList=connectionList, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Create default regDecomp Grid - grid = ESMF_GridCreate(distgrid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! swap out the transferred grid for the newly created one - call ESMF_FieldEmptySet(field, grid=grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - do i1 = 1,arbDimCount - write(msgString,'(A,3i8)') trim(subname)//':PTile =',i1,minIndexPTile(i1,1),maxIndexPTile(i1,1) - call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) - enddo - deallocate(minIndexPTile,maxIndexPTile) - - elseif (grid_arbopt == "grid_arb") then - - ! Stick with the arbDistr representation of the grid: - ! There is nothing to do here if the same number of DEs is kept on the - ! acceptor side. Alternatively, the acceptor side could set up a more - ! natural number of DEs (maybe same number as acceptor PETs), and then - ! redistribute the arbSeqIndexList. Here simply keep the DEs of the - ! provider Grid. - call ESMF_LogWrite(trim(subname)//trim(string)//": accept arb2arb grid for "//trim(fieldNameList(n)), & - ESMF_LOGMSG_INFO) - - else ! grid_arbopt - - call ESMF_LogWrite(trim(subname)//trim(string)//": ERROR grid_arbopt setting = "//trim(grid_arbopt), & - ESMF_LOGMSG_INFO) - rc = ESMF_FAILURE - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - endif ! grid_arbopt + ! The provider defined an arbDistr grid + ! - use a regDecomp representation for the grid + ! - first get tile min/max, only single tile supported for arbDistr Grid + ! - create default regDecomp DistGrid + ! - create default regDecomp Grid with just a distgrid + call ESMF_LogWrite(trim(subname)//trim(string)//": accept arb2reg grid for "//trim(fieldNameList(n)), & + ESMF_LOGMSG_INFO) + allocate(minIndexPTile(arbDimCount,1),maxIndexPTile(arbDimCount,1)) + call ESMF_AttributeGet(field, name="MinIndex", & + valueList=minIndexPTile(:,1), & + convention="NUOPC", purpose="Instance", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_AttributeGet(field, name="MaxIndex", & + valueList=maxIndexPTile(:,1), convention="NUOPC", purpose="Instance", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + distgrid = ESMF_DistGridCreate(minIndexPTile=minIndexPTile, maxIndexPTile=maxIndexPTile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + newgrid = ESMF_GridCreate(distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do i1 = 1,arbDimCount + write(msgString,'(A,3i8)') trim(subname)//':PTile =',i1,minIndexPTile(i1,1),maxIndexPTile(i1,1) + call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) + enddo else ! arbdimcount <= 0 - ! The provider defined as non arb grid + ! The provider sends a non arb grid + ! Create a custom DistGrid, based on the minIndex, maxIndex of the accepted DistGrid, + ! but with a default regDecomp for the current VM that leads to 1DE/PET. + ! - get dimCount and tileCount + ! - allocate minIndexPTile and maxIndexPTile according to dimCount and tileCount + ! - get minIndex and maxIndex arrays and connectionList + ! - create the new DistGrid with the same minIndexPTile and maxIndexPTile + ! - create a new Grid on the new DistGrid - ! access localDeCount to show this is a real Grid call ESMF_LogWrite(trim(subname)//trim(string)//": accept reg2reg grid for "//& trim(fieldNameList(n)), ESMF_LOGMSG_INFO) - call ESMF_FieldGet(field, grid=grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGet(grid, localDeCount=localDeCount, distgrid=distgrid, rc=rc) + call ESMF_GridGet(grid, distgrid=distgrid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Create a custom DistGrid, based on the minIndex, maxIndex of the - ! accepted DistGrid, but with a default regDecomp for the current VM - ! that leads to 1DE/PET. - - ! get dimCount and tileCount - call ESMF_DistGridGet(distgrid, dimCount=dimCount, tileCount=tileCount, & - connectionCount=connectionCount, rc=rc) + call ESMF_DistGridGet(distgrid, dimCount=dimCount, tileCount=tileCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! allocate minIndexPTile and maxIndexPTile accord. to dimCount and tileCount - allocate(minIndexPTile(dimCount, tileCount), maxIndexPTile(dimCount, tileCount)) - allocate(connectionList(connectionCount)) - - ! get minIndex and maxIndex arrays, and connectionList + allocate(minIndexPTile(dimCount, tileCount)) + allocate(maxIndexPTile(dimCount, tileCount)) call ESMF_DistGridGet(distgrid, minIndexPTile=minIndexPTile, & - maxIndexPTile=maxIndexPTile, connectionList=connectionList, rc=rc) + maxIndexPTile=maxIndexPTile, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! construct a default regDecompPTile -> TODO: move this into ESMF as default - - allocate(regDecompPTile(dimCount, tileCount)) - deCountPTile = petCount/tileCount - extraDEs = max(0, petCount-deCountPTile) - do i=1, tileCount - if (i<=extraDEs) then - regDecompPTile(1, i) = deCountPTile + 1 - else - regDecompPTile(1, i) = deCountPTile - endif - do j=2, dimCount - regDecompPTile(j, i) = 1 - enddo - enddo - do i2 = 1,tileCount do i1 = 1,dimCount - write(msgString,'(A,5i8)') trim(subname)//':PTile =',i2,i1,minIndexPTile(i1,i2),& - maxIndexPTile(i1,i2),regDecompPTile(i1,i2) + write(msgString,'(A,4i8)') trim(subname)//':PTile =',i2,i1,minIndexPTile(i1,i2),& + maxIndexPTile(i1,i2) call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) enddo enddo - - !--- tcraig, hardwire i direction wraparound, temporary - !--- tcraig, now getting info from model distgrid, see above - ! allocate(connectionList(1)) - ! nxg = maxIndexPTile(1,1) - minIndexPTile(1,1) + 1 - ! write(msgstring,*) trim(subname)//trim(string),': connlist nxg = ',nxg - ! call ESMF_LogWrite(trim(msgstring), ESMF_LOGMSG_INFO) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & - ! tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! create the new DistGrid with the same minIndexPTile and maxIndexPTile, - ! but with a default regDecompPTile - ! tcraig, force connectionlist and gridEdge arguments to fix wraparound - ! need ESMF fixes to implement properly. if (dimcount == 2) then + call ESMF_DistGridGet(distgrid, connectionCount=connectionCount, rc=rc) + allocate(connectionList(connectionCount)) + call ESMF_DistGridGet(distgrid, connectionList=connectionList, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return distgrid = ESMF_DistGridCreate(minIndexPTile=minIndexPTile, & - maxIndexPTile=maxIndexPTile, regDecompPTile=regDecompPTile, & - connectionList=connectionList, rc=rc) + maxIndexPTile=maxIndexPTile, connectionList=connectionList, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//trim(string)//': distgrid with dimcount=2', ESMF_LOGMSG_INFO) - - ! Create a new Grid on the new DistGrid and swap it in the Field - grid = ESMF_GridCreate(distgrid, gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), rc=rc) + newgrid = ESMF_GridCreate(distgrid, gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + deallocate(connectionList) else distgrid = ESMF_DistGridCreate(minIndexPTile=minIndexPTile, & - maxIndexPTile=maxIndexPTile, regDecompPTile=regDecompPTile, rc=rc) + maxIndexPTile=maxIndexPTile, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//trim(string)//': distgrid with dimcount=1', ESMF_LOGMSG_INFO) - - ! Create a new Grid on the new DistGrid and swap it in the Field - grid = ESMF_GridCreate(distgrid, gridEdgeLWidth=(/0/), gridEdgeUWidth=(/0/), rc=rc) + newgrid = ESMF_GridCreate(distgrid, gridEdgeLWidth=(/0/), gridEdgeUWidth=(/0/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! local clean-up - deallocate(connectionList) - deallocate(minIndexPTile, maxIndexPTile, regDecompPTile) + deallocate(minIndexPTile, maxIndexPTile) endif ! arbdimCount @@ -1381,17 +1275,13 @@ subroutine realizeConnectedGrid(State,string,rc) ! access a field in the State and set the Grid call ESMF_StateGet(State, field=field, itemName=fieldNameList(n1), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(field, status=fieldStatus, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (fieldStatus==ESMF_FIELDSTATUS_EMPTY .or. fieldStatus==ESMF_FIELDSTATUS_GRIDSET) then - call ESMF_FieldEmptySet(field, grid=grid, rc=rc) + call ESMF_FieldEmptySet(field, grid=newgrid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//trim(string)//": attach grid for "//trim(fieldNameList(n1)), & ESMF_LOGMSG_INFO) - if (dbug_flag > 1) then call Field_GeomPrint(field,trim(fieldNameList(n1))//'_new',rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1402,7 +1292,6 @@ subroutine realizeConnectedGrid(State,string,rc) endif enddo - elseif (geomtype == ESMF_GEOMTYPE_MESH) then call ESMF_LogWrite(trim(subname)//": geomtype is ESMF_GEOMTYPE_MESH for "//trim(fieldnameList(n)), & @@ -1412,26 +1301,12 @@ subroutine realizeConnectedGrid(State,string,rc) call Field_GeomPrint(field,trim(fieldNameList(n))//'_orig',rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - call ESMF_FieldGet(field, mesh=mesh, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(mesh, elementDistGrid=elemDistGrid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - newelemDistGrid = ESMF_DistGridCreate(elemDistGrid, balanceflag=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! call ESMF_MeshGet(mesh, nodalDistGrid=nodalDistGrid, rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! newnodalDistGrid = ESMF_DistGridCreate(nodalDistGrid, balanceflag=.true., rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Create a new Grid on the new DistGrid and swap it in the Field - ! newmesh = ESMF_MeshEmptyCreate(elementDistGrid=newelemDistGrid, nodalDistGrid=newnodalDistGrid, rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - newmesh = ESMF_MeshEmptyCreate(elementDistGrid=newelemDistGrid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1443,14 +1318,11 @@ subroutine realizeConnectedGrid(State,string,rc) call ESMF_FieldGet(field, status=fieldStatus, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (fieldStatus==ESMF_FIELDSTATUS_EMPTY .or. fieldStatus==ESMF_FIELDSTATUS_GRIDSET) then call ESMF_FieldEmptySet(field, mesh=newmesh, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//trim(string)//": attach mesh for "//& trim(fieldNameList(n1)), ESMF_LOGMSG_INFO) - if (dbug_flag > 1) then call Field_GeomPrint(field,trim(fieldNameList(n1))//'_new',rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1507,6 +1379,14 @@ subroutine InitializeIPDv03p5(gcomp, importState, exportState, clock, rc) !---------------------------------------------------------- ! realize all Fields with transfer action "accept" + ! Finish initializing the State Fields + ! - Fields are partially created when this routine is called. + ! - Fields contain a geombase object internally created and the geombase object + ! associates with either a ESMF_Grid, or a ESMF_Mesh, or an or an ESMF_XGrid, + ! or a ESMF_LocStream. + ! - Fields containing grids will be transferred! to a Mesh and Realized; + ! - Fields containg meshes are completed with space allocated internally + ! for an ESMF_Array based on arrayspec !---------------------------------------------------------- type(ESMF_GridComp) :: gcomp @@ -1530,30 +1410,25 @@ subroutine InitializeIPDv03p5(gcomp, importState, exportState, clock, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--- Finish initializing the State Fields - !--- Write out grid information - do n1 = 1,ncomps - + ! Finish initializing import states and reset state data to spval_init if (ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then call ESMF_LogWrite(trim(subname)//": calling completeFieldInitialize import states from "//trim(compname(n1)), & ESMF_LOGMSG_INFO) call completeFieldInitialization(is_local%wrap%NStateImp(n1), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_reset(is_local%wrap%NStateImp(n1), value=spval_init, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + ! Finish initializing mediator export states and reset state data to spval_init if (ESMF_StateIsCreated(is_local%wrap%NStateExp(n1),rc=rc)) then call ESMF_LogWrite(trim(subname)//": calling completeFieldInitialize export states to "//trim(compname(n1)), & ESMF_LOGMSG_INFO) call completeFieldInitialization(is_local%wrap%NStateExp(n1), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_reset(is_local%wrap%NStateExp(n1), value=spval_init, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - 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 @@ -1570,10 +1445,10 @@ subroutine completeFieldInitialization(State,rc) use ESMF , only : operator(==) use ESMF , only : ESMF_State, ESMF_MAXSTR, ESMF_Grid, ESMF_Mesh, ESMF_Field, ESMF_FieldStatus_Flag - use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FieldGet, ESMF_FieldEmptyComplete + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FieldGet use ESMF , only : ESMF_GeomType_Flag, ESMF_FieldCreate, ESMF_MeshCreate, ESMF_GEOMTYPE_GRID use ESMF , only : ESMF_MeshLoc_Element, ESMF_TYPEKIND_R8, ESMF_FIELDSTATUS_GRIDSET - use ESMF , only : ESMF_AttributeGet, ESMF_MeshWrite + use ESMF , only : ESMF_AttributeGet, ESMF_MeshWrite, ESMF_FAILURE use NUOPC , only : NUOPC_getStateMemberLists, NUOPC_Realize ! input/output variables @@ -1586,7 +1461,7 @@ subroutine completeFieldInitialization(State,rc) type(ESMF_Grid) :: grid type(ESMF_Mesh) :: mesh type(ESMF_Field) :: meshField - type(ESMF_Field),pointer :: fieldList(:) => null() + type(ESMF_Field),pointer :: fieldList(:) type(ESMF_FieldStatus_Flag) :: fieldStatus type(ESMF_GeomType_Flag) :: geomtype integer :: gridToFieldMapCount, ungriddedCount @@ -1605,89 +1480,99 @@ subroutine completeFieldInitialization(State,rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (fieldCount > 0) then - nullify(fieldList) - call NUOPC_getStateMemberLists(State, fieldList=fieldList, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + nullify(fieldList) + call NUOPC_getStateMemberLists(State, fieldList=fieldList, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - meshcreated = .false. - do n=1, fieldCount + meshcreated = .false. + do n=1, fieldCount - call ESMF_FieldGet(fieldList(n), status=fieldStatus, name=fieldName, & - geomtype=geomtype, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (geomtype == ESMF_GEOMTYPE_GRID .and. fieldName /= is_local%wrap%flds_scalar_name) then - ! Grab grid - if (dbug_flag > 1) then - call Field_GeomPrint(fieldList(n),trim(fieldName)//'_premesh',rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - call ESMF_FieldGet(fieldList(n), grid=grid, rc=rc) + call ESMF_FieldGet(fieldList(n), status=fieldStatus, name=fieldName, geomtype=geomtype, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Convert grid to mesh - if (.not. meshcreated) then - if (dbug_flag > 20) then - call med_grid_write(grid, trim(fieldName)//'_premesh.nc', rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + ! Input fields contains grid - need to convert to mesh + if (geomtype == ESMF_GEOMTYPE_GRID .and. fieldName /= is_local%wrap%flds_scalar_name) then - mesh = ESMF_MeshCreate(grid, rc=rc) + ! Grab grid + if (dbug_flag > 1) then + call Field_GeomPrint(fieldList(n),trim(fieldName)//'_premesh',rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call ESMF_FieldGet(fieldList(n), grid=grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - meshcreated = .true. - if (dbug_flag > 20) then - call ESMF_MeshWrite(mesh, filename=trim(fieldName)//'_postmesh', rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Convert grid to mesh + if (.not. meshcreated) then + if (dbug_flag > 20) then + call med_grid_write(grid, trim(fieldName)//'_premesh.nc', rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + mesh = ESMF_MeshCreate(grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + meshcreated = .true. + if (dbug_flag > 20) then + call ESMF_MeshWrite(mesh, filename=trim(fieldName)//'_postmesh', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if end if - end if - meshField = ESMF_FieldCreate(mesh, typekind=ESMF_TYPEKIND_R8, & - meshloc=ESMF_MESHLOC_ELEMENT, name=fieldName, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Swap grid for mesh, at this point, only connected fields are in the state - call NUOPC_Realize(State, field=meshField, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - - if (fieldStatus==ESMF_FIELDSTATUS_GRIDSET) then - call ESMF_LogWrite(subname//" is allocating field memory for field "//trim(fieldName), & - ESMF_LOGMSG_INFO) + ! Create field on mesh + meshField = ESMF_FieldCreate(mesh, typekind=ESMF_TYPEKIND_R8, & + meshloc=ESMF_MESHLOC_ELEMENT, name=fieldName, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_AttributeGet(fieldList(n), name="GridToFieldMap", convention="NUOPC", & - purpose="Instance", itemCount=gridToFieldMapCount, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(gridToFieldMap(gridToFieldMapCount)) - call ESMF_AttributeGet(fieldList(n), name="GridToFieldMap", convention="NUOPC", & - purpose="Instance", valueList=gridToFieldMap, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Swap grid for mesh, at this point, only connected fields are in the state + call NUOPC_Realize(State, field=meshField, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ungriddedCount=0 ! initialize in case it was not set - call ESMF_AttributeGet(fieldList(n), name="UngriddedLBound", convention="NUOPC", & - purpose="Instance", itemCount=ungriddedCount, isPresent=isPresent, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(ungriddedLBound(ungriddedCount), ungriddedUBound(ungriddedCount)) + call ESMF_FieldGet(meshField, status=fieldStatus, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (fieldStatus == ESMF_FIELDSTATUS_GRIDSET ) then + call ESMF_LogWrite(trim(subname)//": ERROR fieldStatus not complete ", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + end if + call Field_GeomPrint(meshField, trim(subname)//':'//trim(fieldName), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ungriddedCount > 0) then - call ESMF_AttributeGet(fieldList(n), name="UngriddedLBound", convention="NUOPC", & - purpose="Instance", valueList=ungriddedLBound, rc=rc) - call ESMF_AttributeGet(fieldList(n), name="UngriddedUBound", convention="NUOPC", & - purpose="Instance", valueList=ungriddedUBound, rc=rc) - endif + else - call ESMF_FieldEmptyComplete(fieldList(n), typekind=ESMF_TYPEKIND_R8, gridToFieldMap=gridToFieldMap, & - ungriddedLbound=ungriddedLbound, ungriddedUbound=ungriddedUbound, rc=rc) + ! Input fields contain mesh + if (fieldStatus==ESMF_FIELDSTATUS_GRIDSET) then + call ESMF_AttributeGet(fieldList(n), name="GridToFieldMap", convention="NUOPC", & + purpose="Instance", itemCount=gridToFieldMapCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(gridToFieldMap(gridToFieldMapCount)) + call ESMF_AttributeGet(fieldList(n), name="GridToFieldMap", convention="NUOPC", & + purpose="Instance", valueList=gridToFieldMap, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ungriddedCount=0 ! initialize in case it was not set + call ESMF_AttributeGet(fieldList(n), name="UngriddedLBound", convention="NUOPC", & + purpose="Instance", itemCount=ungriddedCount, isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ungriddedLBound(ungriddedCount), ungriddedUBound(ungriddedCount)) + if (ungriddedCount > 0) then + call ESMF_AttributeGet(fieldList(n), name="UngriddedLBound", convention="NUOPC", & + purpose="Instance", valueList=ungriddedLBound, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_AttributeGet(fieldList(n), name="UngriddedUBound", convention="NUOPC", & + purpose="Instance", valueList=ungriddedUBound, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + call NUOPC_Realize(State, fieldName, typekind=ESMF_TYPEKIND_R8, gridToFieldMap=gridToFieldMap, & + ungriddedLbound=ungriddedLbound, ungriddedUbound=ungriddedUbound, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + deallocate(gridToFieldMap, ungriddedLbound, ungriddedUbound) + end if ! fieldStatus + call Field_GeomPrint(fieldlist(n), trim(subname)//':'//trim(fieldName), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - deallocate(gridToFieldMap, ungriddedLbound, ungriddedUbound) - endif ! fieldStatus + end if - call Field_GeomPrint(fieldList(n), trim(subname)//':'//trim(fieldName), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo ! end of loop over fields + deallocate(fieldList) - enddo - deallocate(fieldList) - endif + endif ! end of fieldcount< 0 if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) @@ -1707,12 +1592,10 @@ subroutine DataInitialize(gcomp, rc) ! Do not assume any import fields are connected, just allocate space and such ! -- Check present flags ! -- Check for active coupling interactions - ! -- Create FBs: FBImp, FBExp, FBExpAccum + ! -- Create FBs: FBImp, FBExp ! -- Create mediator specific field bundles (not part of import/export states) - ! -- Initialize FBExpAccums (to zero), and FBImp (from NStateImp) ! -- Read mediator restarts - ! -- Initialize route handles - ! -- Initialize field bundles for normalization + ! -- Initialize route handles field bundles for normalization ! -- return! ! For second loop: ! -- Copy import fields to local FBs @@ -1735,20 +1618,24 @@ subroutine DataInitialize(gcomp, rc) use NUOPC , only : NUOPC_CompAttributeGet use med_fraction_mod , only : med_fraction_init, med_fraction_set use med_phases_restart_mod , only : med_phases_restart_read + use med_phases_prep_ocn_mod , only : med_phases_prep_ocn_init + use med_phases_prep_rof_mod , only : med_phases_prep_rof_init + use med_phases_prep_glc_mod , only : med_phases_prep_glc_init use med_phases_prep_atm_mod , only : med_phases_prep_atm use med_phases_post_atm_mod , only : med_phases_post_atm use med_phases_post_ice_mod , only : med_phases_post_ice - use med_phases_post_lnd_mod , only : med_phases_post_lnd_init + use med_phases_post_lnd_mod , only : med_phases_post_lnd use med_phases_post_glc_mod , only : med_phases_post_glc use med_phases_post_ocn_mod , only : med_phases_post_ocn use med_phases_post_rof_mod , only : med_phases_post_rof use med_phases_post_wav_mod , only : med_phases_post_wav use med_phases_ocnalb_mod , only : med_phases_ocnalb_run - use med_phases_aofluxes_mod , only : med_phases_aofluxes_run + use med_phases_aofluxes_mod , only : med_phases_aofluxes_init_fldbuns use med_phases_profile_mod , only : med_phases_profile 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_map_mod , only : med_map_routehandles_init, med_map_packed_field_create use med_io_mod , only : med_io_init + use esmFlds , only : fldListMed_aoflux ! input/output variables type(ESMF_GridComp) :: gcomp @@ -1763,23 +1650,23 @@ subroutine DataInitialize(gcomp, rc) type(ESMF_Field) :: field type(ESMF_StateItem_Flag) :: itemType logical :: atCorrectTime, connected - logical :: isPresent, isSet integer :: n1,n2,n,ns integer :: nsrc,ndst integer :: cntn1, cntn2 integer :: fieldCount character(ESMF_MAXSTR),allocatable :: fieldNameList(:) - character(CL), pointer :: fldnames(:) => null() + character(CL), pointer :: fldnames(:) character(CL) :: cvalue character(CL) :: cname character(CL) :: start_type logical :: read_restart + logical :: isPresent, isSet logical :: allDone = .false. logical,save :: compDone(ncomps) 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=' (DataInitialize) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1932,7 +1819,7 @@ subroutine DataInitialize(gcomp, rc) endif enddo - ! Reset ocn2glc coupling based in input attribute + ! Reset ocn2glc active coupling based in input attribute if (.not. ocn2glc_coupling) then do ns = 1,num_icesheets is_local%wrap%med_coupling_active(compocn,compglc(ns)) = .false. @@ -1972,7 +1859,7 @@ subroutine DataInitialize(gcomp, rc) endif !---------------------------------------------------------- - ! Create field bundles FBImp, FBExp, FBImpAccum, FBExpAccum + ! Create field bundles FBImp, FBExp !---------------------------------------------------------- if (mastertask) then @@ -1998,27 +1885,11 @@ subroutine DataInitialize(gcomp, rc) is_local%wrap%flds_scalar_name, name='FBExp'//trim(compname(n1)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Create import accumulation field bundles - call FB_init(is_local%wrap%FBImpAccum(n1,n1), is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateImp(n1), STflds=is_local%wrap%NStateImp(n1), & - name='FBImpAccum'//trim(compname(n1)), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_reset(is_local%wrap%FBImpAccum(n1,n1), value=czero, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Create export accumulation field bundles - call FB_init(is_local%wrap%FBExpAccum(n1), is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateExp(n1), STflds=is_local%wrap%NStateExp(n1), & - name='FBExpAccum'//trim(compname(n1)), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_reset(is_local%wrap%FBExpAccum(n1), value=czero, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Create mesh info data - call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n1), fieldCount=fieldCount, rc=rc) + call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n1), fieldCount=fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (fieldCount == 0) then + if (fieldCount == 0) then if (mastertask) then write(logunit,*) trim(subname)//' '//trim(compname(n1))//' import FB field count is = ', fieldCount write(logunit,*) trim(subname)//' '//trim(compname(n1))//' trying to use export FB' @@ -2035,9 +1906,7 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! The following are FBImp and FBImpAccum mapped to different grids. - ! FBImp(n1,n1) and FBImpAccum(n1,n1) are handled above - + ! The following is FBImp mapped to different grids. FBImp(n1,n1) is handled above do n2 = 1,ncomps if (n1 /= n2 .and. & is_local%wrap%med_coupling_active(n1,n2) .and. & @@ -2053,7 +1922,7 @@ subroutine DataInitialize(gcomp, rc) ! to provide mesh information call State_GetNumFields(is_local%wrap%NStateImp(n2), fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (fieldCount == 0) then + if (fieldCount == 0) then call FB_init(is_local%wrap%FBImp(n1,n2), is_local%wrap%flds_scalar_name, & STgeom=is_local%wrap%NStateExp(n2), & STflds=is_local%wrap%NStateImp(n1), & @@ -2065,23 +1934,12 @@ subroutine DataInitialize(gcomp, rc) name='FBImp'//trim(compname(n1))//'_'//trim(compname(n2)), rc=rc) end if if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call FB_init(is_local%wrap%FBImpAccum(n1,n2), is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateImp(n2), & - STflds=is_local%wrap%NStateImp(n1), & - name='FBImpAccum'//trim(compname(n1))//'_'//trim(compname(n2)), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call FB_reset(is_local%wrap%FBImpAccum(n1,n2), value=czero, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif enddo ! loop over n2 - enddo ! loop over n1 !--------------------------------------- - ! Initialize field bundles needed for ocn albedo and ocn/atm flux calculations + ! Initialize field bundles needed for ocn albedo calculation !--------------------------------------- ! NOTE: the NStateImp(compocn) or NStateImp(compatm) used below @@ -2089,29 +1947,22 @@ subroutine DataInitialize(gcomp, rc) ! contain control data and no grid information if if the target ! component (n2) is not prognostic only receives control data back - ! NOTE: this section must be done BEFORE the call to esmFldsExchange + ! NOTE: this section must be done BEFORE the second call to esmFldsExchange ! Create field bundles for mediator ocean albedo computation if ( is_local%wrap%med_coupling_active(compocn,compatm) .or. is_local%wrap%med_coupling_active(compatm,compocn)) then - ! Create field bundles for mediator ocean albedo computation fieldCount = med_fldList_GetNumFlds(fldListMed_ocnalb) if (fieldCount > 0) then - if (.not. is_local%wrap%med_coupling_active(compatm,compocn)) then - is_local%wrap%med_coupling_active(compatm,compocn) = .true. - end if - allocate(fldnames(fieldCount)) call med_fldList_getfldnames(fldListMed_ocnalb%flds, fldnames, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_init(is_local%wrap%FBMed_ocnalb_a, is_local%wrap%flds_scalar_name, & STgeom=is_local%wrap%NStateImp(compatm), fieldnamelist=fldnames, name='FBMed_ocnalb_a', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (mastertask) then write(logunit,'(a)') trim(subname)//' initializing FB FBMed_ocnalb_a' end if - call FB_init(is_local%wrap%FBMed_ocnalb_o, is_local%wrap%flds_scalar_name, & STgeom=is_local%wrap%NStateImp(compocn), fieldnamelist=fldnames, name='FBMed_ocnalb_o', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2119,49 +1970,35 @@ subroutine DataInitialize(gcomp, rc) write(logunit,'(a)') trim(subname)//' initializing FB FBMed_ocnalb_o' end if deallocate(fldnames) - - ! The following assumes that the mediator atm/ocn flux calculation will be done on the ocean grid - if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compatm,compocn), rc=rc)) then - if (mastertask) then - write(logunit,'(a)') trim(subname)//' creating field bundle FBImp(compatm,compocn)' - end if - call FB_init(is_local%wrap%FBImp(compatm,compocn), is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateImp(compocn), & - STflds=is_local%wrap%NStateImp(compatm), & - name='FBImp'//trim(compname(compatm))//'_'//trim(compname(compocn)), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - if (mastertask) then - write(logunit,'(a)') trim(subname)//' initializing FBs for '// & - trim(compname(compatm))//'_'//trim(compname(compocn)) - end if end if + end if - ! Create field bundles for mediator ocean/atmosphere flux computation - fieldCount = med_fldList_GetNumFlds(fldListMed_aoflux) - if (fieldCount > 0) then - allocate(fldnames(fieldCount)) - call med_fldList_getfldnames(fldListMed_aoflux%flds, fldnames, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------------------------------- + ! Initialize field bundles needed for atm/ocn flux computation: + ! is_local%wrap%FBMed_aoflux_a and is_local%wrap%FBMed_aoflux_o + !--------------------------------------- - call FB_init(is_local%wrap%FBMed_aoflux_a, is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateImp(compatm), fieldnamelist=fldnames, name='FBMed_aoflux_a', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(logunit,'(a)') trim(subname)//' initializing FB FBMed_aoflux_a' - end if + ! NOTE: this section must be done BEFORE the second call to esmFldsExchange + ! Create field bundles for mediator ocean albedo computation - call FB_init(is_local%wrap%FBMed_aoflux_o, is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateImp(compocn), fieldnamelist=fldnames, name='FBMed_aoflux_o', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(logunit,'(a)') trim(subname)//' initializing FB FBMed_aoflux_o' + fieldCount = med_fldList_GetNumFlds(fldListMed_aoflux) + if ( fieldCount > 0 ) then + if ( is_local%wrap%med_coupling_active(compocn,compatm) .or. & + is_local%wrap%med_coupling_active(compatm,compocn)) then + if ( is_local%wrap%aoflux_grid == 'ogrid' .and. .not. & + is_local%wrap%med_coupling_active(compatm,compocn)) then + is_local%wrap%med_coupling_active(compatm,compocn) = .true. end if - deallocate(fldnames) + if ( is_local%wrap%aoflux_grid == 'agrid' .and. .not. & + is_local%wrap%med_coupling_active(compocn,compatm)) then + is_local%wrap%med_coupling_active(compocn,compatm) = .true. + end if + call med_phases_aofluxes_init_fldbuns(gcomp, rc=rc) end if end if !--------------------------------------- + ! Second call to esmFldsExchange_xxx ! Determine mapping and merging info for field exchanges in mediator !--------------------------------------- @@ -2180,19 +2017,15 @@ subroutine DataInitialize(gcomp, rc) !--------------------------------------- ! Initialize route handles and required normalization field bunds - ! Initialized packed field data structures !--------------------------------------- - call ESMF_LogWrite("before med_map_RouteHandles_init", ESMF_LOGMSG_INFO) call med_map_RouteHandles_init(gcomp, is_local%wrap%flds_scalar_name, logunit, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite("after med_map_RouteHandles_init", ESMF_LOGMSG_INFO) - call ESMF_LogWrite("before med_map_mapnorm_init", ESMF_LOGMSG_INFO) - call med_map_mapnorm_init(gcomp, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite("after med_map_mapnorm_init", ESMF_LOGMSG_INFO) - + !--------------------------------------- + ! Initialized packed field data structures + !--------------------------------------- do ndst = 1,ncomps do nsrc = 1,ncomps if (is_local%wrap%med_coupling_active(nsrc,ndst)) then @@ -2206,16 +2039,6 @@ subroutine DataInitialize(gcomp, rc) 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, & @@ -2227,6 +2050,52 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if + !--------------------------------------- + ! Initialize ocn export accumulation field bundle + !--------------------------------------- + if ( is_local%wrap%comp_present(compocn) .and. & + ESMF_StateIsCreated(is_local%wrap%NStateImp(compocn),rc=rc) .and. & + ESMF_StateIsCreated(is_local%wrap%NStateExp(compocn),rc=rc)) then + call med_phases_prep_ocn_init(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !--------------------------------------- + ! Initialize glc module field bundles here if appropriate + !--------------------------------------- + do ns = 1,num_icesheets + if (is_local%wrap%med_coupling_active(complnd,compglc(ns))) then + lnd2glc_coupling = .true. + exit + end if + end do + if (lnd2glc_coupling) then + accum_lnd2glc = .true. + else + ! Determine if will create auxiliary history file that contains + ! lnd2glc data averaged over the year + call NUOPC_CompAttributeGet(gcomp, name="histaux_l2x1yrg", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) accum_lnd2glc + else + accum_lnd2glc = .false. + end if + end if + if (lnd2glc_coupling .or. ocn2glc_coupling .or. accum_lnd2glc) then + call med_phases_prep_glc_init(gcomp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !--------------------------------------- + ! Initialize rof module field bundles here if appropriate + !--------------------------------------- + if (is_local%wrap%med_coupling_active(comprof,complnd)) then + call med_phases_prep_rof_init(gcomp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + !--------------------------------------- ! Set the data initialize flag to false !--------------------------------------- @@ -2351,7 +2220,7 @@ subroutine DataInitialize(gcomp, rc) if (.not. compDone(compatm)) then ! atmdone is not true if (trim(lnd_present) == 'true') then ! map initial lnd->atm - call med_phases_post_lnd_init(gcomp, rc) + call med_phases_post_lnd(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if ! do the merge to the atmospheric component @@ -2427,8 +2296,8 @@ subroutine DataInitialize(gcomp, rc) end if do n1 = 1,ncomps if (mastertask) then - write(logunit,*) - write(logunit,'(a)') trim(subname)//" "//trim(compname(n1)) + write(logunit,*) + write(logunit,'(a)') trim(subname)//" "//trim(compname(n1)) end if if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then call State_GetScalar(scalar_value=real_nx, & @@ -2447,7 +2316,7 @@ subroutine DataInitialize(gcomp, rc) is_local%wrap%ny(n1) = nint(real_ny) write(msgString,'(2i8,2l4)') is_local%wrap%nx(n1), is_local%wrap%ny(n1) if (mastertask) then - write(logunit,*) 'global nx,ny sizes for '//trim(compname(n1))//":"//trim(msgString) + write(logunit,'(a)') 'global nx,ny sizes for '//trim(compname(n1))//":"//trim(msgString) end if call ESMF_LogWrite(trim(subname)//":"//trim(compname(n1))//":"//trim(msgString), ESMF_LOGMSG_INFO) end if @@ -2463,17 +2332,10 @@ subroutine DataInitialize(gcomp, rc) !--------------------------------------- ! Initialize mediator water/heat budget diags !--------------------------------------- - call NUOPC_CompAttributeGet(gcomp, name="do_budgets", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) .eq. '.true.') then - call med_diag_init(gcomp, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_diag_zero(mode='all', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - endif + call med_diag_init(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_diag_zero(mode='all', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------------------------------- ! read mediator restarts @@ -2481,6 +2343,7 @@ subroutine DataInitialize(gcomp, rc) call NUOPC_CompAttributeGet(gcomp, name="read_restart", value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (mastertask) then + write(logunit,*) write(logunit,'(a)') trim(subname)//' read_restart = '//trim(cvalue) end if read(cvalue,*) read_restart @@ -2509,7 +2372,7 @@ subroutine DataInitialize(gcomp, rc) end if if (trim(lnd_present) == 'true') then ! map initial lnd->atm - call med_phases_post_lnd_init(gcomp, rc) + call med_phases_post_lnd(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (trim(ocn_present) == 'true') then @@ -2545,7 +2408,6 @@ subroutine DataInitialize(gcomp, rc) end subroutine DataInitialize !----------------------------------------------------------------------------- - subroutine SetRunClock(gcomp, rc) use ESMF , only : ESMF_GridComp, ESMF_CLOCK, ESMF_Time, ESMF_TimeInterval @@ -2553,6 +2415,7 @@ subroutine SetRunClock(gcomp, rc) use ESMF , only : ESMF_Success, ESMF_Failure use ESMF , only : ESMF_Alarm, ESMF_ALARMLIST_ALL, ESMF_ClockGetAlarmList use ESMF , only : ESMF_AlarmCreate, ESMF_AlarmSet, ESMF_ClockAdvance + use ESMF , only : ESMF_ClockGetAlarmList use NUOPC , only : NUOPC_CompCheckSetClock, NUOPC_CompAttributeGet use NUOPC_Mediator , only : NUOPC_MediatorGet @@ -2561,11 +2424,18 @@ subroutine SetRunClock(gcomp, rc) integer, intent(out) :: rc ! local variables - type(ESMF_Clock) :: mediatorClock, driverClock + type(ESMF_Clock) :: mClock ! mediator clock + type(ESMF_CLock) :: dClock ! driver clock type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: timeStep + type(ESMF_Alarm) :: stop_alarm character(len=CL) :: cvalue + character(len=CL) :: name, stop_option + integer :: stop_n, stop_ymd logical :: first_time = .true. + logical, save :: stopalarmcreated=.false. + integer :: alarmcount + character(len=*),parameter :: subname=' (module_MED:SetRunClock) ' !----------------------------------------------------------- @@ -2576,37 +2446,48 @@ subroutine SetRunClock(gcomp, rc) endif ! query the Mediator for clocks - call NUOPC_MediatorGet(gcomp, mediatorClock=mediatorClock, driverClock=driverClock, rc=rc) + call NUOPC_MediatorGet(gcomp, mediatorClock=mClock, driverClock=dClock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 1) then - call Clock_TimePrint(driverClock ,trim(subname)//'driver clock1',rc) - call Clock_TimePrint(mediatorClock,trim(subname)//'mediat clock1',rc) + call Clock_TimePrint(dClock, trim(subname)//'driver clock1',rc) + call Clock_TimePrint(mClock, trim(subname)//'mediat clock1',rc) endif ! set the mediatorClock to have the current start time as the driverClock - call ESMF_ClockGet(driverClock, currTime=currTime, timeStep=timeStep, rc=rc) + call ESMF_ClockGet(dClock, currTime=currTime, timeStep=timeStep, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockSet(mediatorClock, currTime=currTime, timeStep=timeStep, rc=rc) + call ESMF_ClockSet(mClock, currTime=currTime, timeStep=timeStep, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 1) then - call Clock_TimePrint(driverClock ,trim(subname)//'driver clock2',rc) - call Clock_TimePrint(mediatorClock,trim(subname)//'mediat clock2',rc) + call Clock_TimePrint(dClock, trim(subname)//'driver clock2',rc) + call Clock_TimePrint(mClock, trim(subname)//'mediat clock2',rc) endif ! check and set the component clock against the driver clock - call NUOPC_CompCheckSetClock(gcomp, driverClock, rc=rc) + call NUOPC_CompCheckSetClock(gcomp, dClock, checkTimeStep=.false., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !-------------------------------- - ! Advance med clock to trigger alarms then reset model clock back to currtime - !-------------------------------- + if (.not. stopalarmcreated) then + 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 med_time_alarmInit(mclock, 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 + stopalarmcreated = .true. + end if - call ESMF_ClockAdvance(mediatorClock,rc=rc) + ! Advance med clock to trigger alarms then reset model clock back to currtime + call ESMF_ClockAdvance(mClock,rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_ClockSet(mediatorClock, currTime=currtime, timeStep=timestep, rc=rc) + call ESMF_ClockSet(mClock, currTime=currtime, timeStep=timestep, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 5) then @@ -2638,7 +2519,7 @@ subroutine med_meshinfo_create(FB, mesh_info, FBArea, rc) integer :: numOwnedElements integer :: spatialDim real(r8), allocatable :: ownedElemCoords(:) - real(r8), pointer :: dataptr(:) => null() + real(r8), pointer :: dataptr(:) integer :: n, dimcount, fieldcount character(len=*),parameter :: subname=' (module_MED:med_meshinfo_create) ' !------------------------------------------------------------------------------- @@ -2733,43 +2614,33 @@ subroutine med_grid_write(grid, fileName, rc) call ESMF_GridGetCoord(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, & isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent) then 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="lon_center", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - 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="lat_center", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif - ! 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="mask_center", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif @@ -2778,15 +2649,12 @@ subroutine med_grid_write(grid, fileName, rc) 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="area_center", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif @@ -2801,20 +2669,15 @@ subroutine med_grid_write(grid, fileName, rc) call ESMF_GridGetCoord(grid, coordDim=1, & staggerLoc=ESMF_STAGGERLOC_CORNER, array=array, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArraySet(array, name="lon_corner", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridGetCoord(grid, coordDim=2, & staggerLoc=ESMF_STAGGERLOC_CORNER, array=array, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArraySet(array, name="lat_corner", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif @@ -2823,15 +2686,12 @@ subroutine med_grid_write(grid, fileName, rc) call ESMF_GridGetItem(grid, itemflag=ESMF_GRIDITEM_MASK, & staggerLoc=ESMF_STAGGERLOC_CORNER, isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent) then call ESMF_GridGetItem(grid, staggerLoc=ESMF_STAGGERLOC_CORNER, & itemflag=ESMF_GRIDITEM_MASK, array=array, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArraySet(array, name="mask_corner", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif @@ -2840,15 +2700,12 @@ subroutine med_grid_write(grid, fileName, rc) call ESMF_GridGetItem(grid, itemflag=ESMF_GRIDITEM_AREA, & staggerLoc=ESMF_STAGGERLOC_CORNER, isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent) then call ESMF_GridGetItem(grid, staggerLoc=ESMF_STAGGERLOC_CORNER, & itemflag=ESMF_GRIDITEM_AREA, array=array, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArraySet(array, name="area_corner", rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_ArrayBundleAdd(arrayBundle, (/array/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index c996f4354..c8bb304e4 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -31,7 +31,6 @@ module med_diag_mod use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_fldChk => med_methods_FB_FldChk - use med_time_mod , only : alarmInit => med_time_alarmInit use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf @@ -381,22 +380,6 @@ subroutine med_diag_init(gcomp, rc) 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 - 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 end subroutine med_diag_init integer function get_diag_attribute(gcomp, name, rc) @@ -601,12 +584,12 @@ subroutine med_phases_diag_atm(gcomp, 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() + real(r8), pointer :: afrac(:) + real(r8), pointer :: lfrac(:) + real(r8), pointer :: ifrac(:) + real(r8), pointer :: ofrac(:) + real(r8), pointer :: areas(:) + real(r8), pointer :: lats(:) type(ESMF_Field) :: lfield character(*), parameter :: subName = '(med_phases_diag_atm) ' !------------------------------------------------------------------------------- @@ -739,7 +722,7 @@ subroutine diag_atm_recv(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifra ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -775,7 +758,7 @@ subroutine diag_atm_send(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifra ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -814,7 +797,7 @@ subroutine diag_atm_wiso_recv(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ! local variables integer :: n, ip type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() + real(r8), pointer :: data(:,:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -871,7 +854,7 @@ subroutine diag_atm_wiso_send(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ! local variables integer :: n, ip type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() + real(r8), pointer :: data(:,:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -924,9 +907,9 @@ subroutine med_phases_diag_lnd( gcomp, rc) ! local variables type(InternalState) :: is_local - real(r8), pointer :: lfrac(:) => null() + real(r8), pointer :: lfrac(:) integer :: n,ip, ic - real(r8), pointer :: areas(:) => null() + real(r8), pointer :: areas(:) type(ESMF_Field) :: lfield character(*), parameter :: subName = '(med_phases_diag_lnd) ' ! ------------------------------------------------------------------ @@ -966,8 +949,6 @@ subroutine med_phases_diag_lnd( gcomp, rc) 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,& @@ -1029,7 +1010,7 @@ subroutine diag_lnd(FB, fldname, nf, ic, areas, lfrac, budget, minus, rc) ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS @@ -1063,7 +1044,7 @@ subroutine diag_lnd_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, lfrac, ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:,:) => null() + real(r8), pointer :: data(:,:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS @@ -1101,7 +1082,7 @@ subroutine med_phases_diag_rof( gcomp, rc) ! local variables type(InternalState) :: is_local integer :: ic, ip, n - real(r8), pointer :: areas(:) => null() + real(r8), pointer :: areas(:) character(*), parameter :: subName = '(med_phases_diag_rof) ' ! ------------------------------------------------------------------ @@ -1145,7 +1126,6 @@ subroutine med_phases_diag_rof( gcomp, rc) 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) @@ -1173,7 +1153,7 @@ subroutine diag_rof(FB, fldname, nf, ic, areas, budget, minus, rc) ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS @@ -1207,7 +1187,7 @@ subroutine diag_rof_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, budget, ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:,:) => null() + real(r8), pointer :: data(:,:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS @@ -1245,7 +1225,7 @@ subroutine med_phases_diag_glc( gcomp, rc) ! local variables type(InternalState) :: is_local integer :: ic, ip, ns - real(r8), pointer :: areas(:) => null() + real(r8), pointer :: areas(:) character(*), parameter :: subName = '(med_phases_diag_glc) ' ! ------------------------------------------------------------------ @@ -1290,7 +1270,7 @@ subroutine diag_glc(FB, fldname, nf, ic, areas, budget, minus, rc) ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -1314,7 +1294,7 @@ subroutine med_phases_diag_ocn( gcomp, rc) ! Compute global ocn input from mediator ! ------------------------------------------------------------------ - use esmFlds, only : compocn + use esmFlds, only : compocn, compatm ! input/output variables type(ESMF_GridComp) :: gcomp @@ -1324,11 +1304,12 @@ subroutine med_phases_diag_ocn( gcomp, rc) 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() + real(r8), pointer :: ifrac(:) ! ice fraction in ocean grid cell + real(r8), pointer :: ofrac(:) ! non-ice fraction nin ocean grid cell + real(r8), pointer :: sfrac(:) ! sum of ifrac and ofrac + real(r8), pointer :: sfrac_x_ofrac(:) + real(r8), pointer :: areas(:) + real(r8), pointer :: data(:) type(ESMF_field) :: lfield character(*), parameter :: subName = '(med_phases_diag_ocn) ' ! ------------------------------------------------------------------ @@ -1346,6 +1327,8 @@ subroutine med_phases_diag_ocn( gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(sfrac(size(ofrac))) sfrac(:) = ifrac(:) + ofrac(:) + allocate(sfrac_x_ofrac(size(ofrac))) + sfrac_x_ofrac(:) = sfrac(:) * ofrac(:) areas => is_local%wrap%mesh_info(compocn)%areas @@ -1390,8 +1373,20 @@ subroutine med_phases_diag_ocn( gcomp, rc) budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*ofrac(n) end do - 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) + if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lwnet', rc=rc)) then + call diag_ocn(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup', f_heat_lwup, ic, areas, sfrac_x_ofrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBImp(compatm,compocn), 'Faxa_lwdn', f_heat_lwdn, ic, areas, sfrac_x_ofrac, budget_local, rc=rc) + else + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lwup' , f_heat_lwup , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_lwdn' , f_heat_lwdn , ic, areas, sfrac, budget_local, rc=rc) + end if + + if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lat', rc=rc)) then + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lat' , f_heat_latvap , ic, areas, sfrac, budget_local, rc=rc) + else + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_lat' , f_heat_latvap , ic, areas, sfrac_x_ofrac, budget_local, rc=rc) + end if + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_sen' , f_heat_sen , ic, areas, sfrac, budget_local, rc=rc) call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_evap' , f_watr_evap , ic, areas, sfrac, budget_local, rc=rc) call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_meltw', f_watr_melt , ic, areas, sfrac, budget_local, rc=rc) @@ -1400,8 +1395,19 @@ subroutine med_phases_diag_ocn( gcomp, 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, & scale=SFLXtoWFLX, 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) + + if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet', rc=rc)) then + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + else if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', rc=rc) .and. & + fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', rc=rc) .and. & + fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', rc=rc) .and. & + fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', rc=rc)) then + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + end if + 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) @@ -1440,7 +1446,7 @@ subroutine diag_ocn(FB, fldname, nf, ic, areas, frac, budget, scale, rc) ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -1473,7 +1479,7 @@ subroutine diag_ocn_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, frac, b ! local variables integer :: n, ip type(ESMF_field) :: lfield - real(r8), pointer :: data(:,:) => null() + real(r8), pointer :: data(:,:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -1504,10 +1510,10 @@ subroutine med_phases_diag_ice_ice2med( gcomp, 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() + real(r8), pointer :: ofrac(:) + real(r8), pointer :: ifrac(:) + real(r8), pointer :: areas(:) + real(r8), pointer :: lats(:) type(ESMF_field) :: lfield character(*), parameter :: subName = '(med_phases_diag_ice_ice2med) ' ! ------------------------------------------------------------------ @@ -1544,10 +1550,26 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) areas, lats, ifrac, budget_local, minus=.true., rc=rc) call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_salt', f_watr_salt, & areas, lats, ifrac, budget_local, minus=.true., scale=SFLXtoWFLX, rc=rc) - call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen', f_heat_swnet, & - areas, lats, ifrac, budget_local, minus=.true., rc=rc) + + if ( fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', rc=rc) .and. & + fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdf', rc=rc) .and. & + fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idr', rc=rc) .and. & + fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idf', rc=rc)) then + call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', f_heat_swnet, & + areas, lats, ifrac, budget_local, minus=.true., rc=rc) + call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdf', f_heat_swnet, & + areas, lats, ifrac, budget_local, minus=.true., rc=rc) + call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idr', f_heat_swnet, & + areas, lats, ifrac, budget_local, minus=.true., rc=rc) + call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idf', f_heat_swnet, & + areas, lats, ifrac, budget_local, minus=.true., rc=rc) + else + call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen', f_heat_swnet, & + areas, lats, ifrac, budget_local, minus=.true., rc=rc) + end if call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_swnet', f_heat_swnet, & areas, lats, ifrac, budget_local, rc=rc) + call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_lwup', f_heat_lwup, & areas, lats, ifrac, budget_local, rc=rc) call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_lat', f_heat_latvap, & @@ -1580,7 +1602,7 @@ subroutine diag_ice_recv(FB, fldname, nf, areas, lats, ifrac, budget, minus, sca ! local variables integer :: n, ic, ip type(ESMF_Field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -1626,7 +1648,7 @@ subroutine diag_ice_recv_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ! local variables integer :: n, ic, ip type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() + real(r8), pointer :: data(:,:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS @@ -1670,11 +1692,11 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) 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() + real(r8), pointer :: ofrac(:) + real(r8), pointer :: ifrac(:) + real(r8), pointer :: data(:) + real(r8), pointer :: areas(:) + real(r8), pointer :: lats(:) type(ESMF_Field) :: lfield character(*), parameter :: subName = '(med_phases_diag_ice_med2ice) ' ! ------------------------------------------------------------------ @@ -1756,7 +1778,7 @@ subroutine diag_ice_send(FB, fldname, nf, areas, lats, ifrac, budget, rc) ! local variables integer :: n, ic, ip type(ESMF_Field) :: lfield - real(r8), pointer :: data(:) => null() + real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS ip = period_inst @@ -1790,7 +1812,7 @@ subroutine diag_ice_send_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ! local variables integer :: n, ic, ip type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() + real(r8), pointer :: data(:,:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then @@ -2479,7 +2501,7 @@ subroutine add_to_budget_diag(entries, index, name) integer :: n integer :: oldsize logical :: found - type(budget_diag_type), pointer :: new_entries(:) => null() + type(budget_diag_type), pointer :: new_entries(:) character(len=*), parameter :: subname='(add_to_budget_diag)' !---------------------------------------------------------------------- diff --git a/mediator/med_fraction_mod.F90 b/mediator/med_fraction_mod.F90 index 312d1faff..7b7b7ca4d 100644 --- a/mediator/med_fraction_mod.F90 +++ b/mediator/med_fraction_mod.F90 @@ -166,18 +166,18 @@ subroutine med_fraction_init(gcomp, rc) 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 :: aofrac(:) => 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() - real(R8), pointer :: Sa_ofrac(:) => null() + real(R8), pointer :: frac(:) + real(R8), pointer :: ofrac(:) + real(R8), pointer :: aofrac(:) + real(R8), pointer :: lfrac(:) + real(R8), pointer :: ifrac(:) + real(R8), pointer :: gfrac(:) + real(R8), pointer :: rfrac(:) + real(R8), pointer :: wfrac(:) + real(R8), pointer :: Sl_lfrin(:) + real(R8), pointer :: Si_imask(:) + real(R8), pointer :: So_omask(:) + real(R8), pointer :: Sa_ofrac(:) integer :: i,j,n,n1,ns integer :: maptype integer :: fieldCount @@ -224,7 +224,7 @@ subroutine med_fraction_init(gcomp, rc) (ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc) .or. & ESMF_StateIsCreated(is_local%wrap%NStateExp(n1),rc=rc))) then ! Check number of fields in the state - call State_GetNumFields(is_local%wrap%NStateImp(n1), fieldCount, rc=rc) + call State_GetNumFields(is_local%wrap%NStateImp(n1), fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! create FBFrac @@ -656,13 +656,13 @@ subroutine med_fraction_set(gcomp, rc) ! local variables type(InternalState) :: is_local - real(r8), pointer :: lfrac(:) => null() - real(r8), pointer :: ifrac(:) => null() - real(r8), pointer :: ofrac(:) => null() - real(r8), pointer :: aofrac(:) => null() - real(r8), pointer :: Si_ifrac(:) => null() - real(r8), pointer :: Si_imask(:) => null() - real(r8), pointer :: Sa_ofrac(:) => null() + real(r8), pointer :: lfrac(:) + real(r8), pointer :: ifrac(:) + real(r8), pointer :: ofrac(:) + real(r8), pointer :: aofrac(:) + real(r8), pointer :: Si_ifrac(:) + real(r8), pointer :: Si_imask(:) + real(r8), pointer :: Sa_ofrac(:) type(ESMF_Field) :: lfield type(ESMF_Field) :: field_src type(ESMF_Field) :: field_dst diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index da21c30f5..bc5287a61 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -71,13 +71,16 @@ module med_internalstate_mod type(ESMF_FieldBundle) :: FBImp(ncomps,ncomps) ! Import data from various components interpolated to various grids type(ESMF_FieldBundle) :: FBExp(ncomps) ! Export data for various components, on their grid - ! Mediator field bundles + ! Mediator field bundles for ocean albedo 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 + + ! Mediator field bundles and other info for atm/ocn flux computation + type(ESMF_FieldBundle) :: FBMed_aoflux_a ! Ocn/Atm flux output fields on atm grid + type(ESMF_FieldBundle) :: FBMed_aoflux_o ! Ocn/Atm flux output fields on ocn grid type(packed_data_type) :: packed_data_aoflux_o2a(nmappers) ! packed data for mapping ocn->atm + character(len=CS) :: aoflux_grid ! 'ogrid', 'agrid' or 'xgrid' ! Mapping type(ESMF_RouteHandle) :: RH(ncomps,ncomps,nmappers) ! Routehandles for pairs of components and different mappers @@ -85,20 +88,15 @@ module med_internalstate_mod 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 + type(ESMF_FieldBundle) :: FBfrac(ncomps) ! Fraction data for various components, on their grid ! Accumulators for export field bundles - type(ESMF_FieldBundle) :: FBExpAccum(ncomps) ! Accumulator for various components export on their grid - integer :: FBExpAccumCnt(ncomps) = 0 ! Accumulator counter for each FBExpAccum - logical :: FBExpAccumFlag(ncomps) = .false. ! Accumulator flag, if true accumulation was done - - ! Accumulators for import field bundles - type(ESMF_FieldBundle) :: FBImpAccum(ncomps,ncomps) ! Accumulator for various components import - integer :: FBImpAccumCnt(ncomps) = 0 ! Accumulator counter for each FBImpAccum + type(ESMF_FieldBundle) :: FBExpAccumOcn ! Accumulator for various components export on their grid + integer :: ExpAccumOcnCnt = 0 ! Accumulator counter for each FBExpAccum ! Component Mesh info type(mesh_info_type) :: mesh_info(ncomps) - type(ESMF_FieldBundle) :: FBArea(ncomps) ! needed for mediator history writes + type(ESMF_FieldBundle) :: FBArea(ncomps) ! needed for mediator history writes end type InternalStateStruct diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90 index bb156258e..e26748b8f 100644 --- a/mediator/med_io_mod.F90 +++ b/mediator/med_io_mod.F90 @@ -7,9 +7,9 @@ module med_io_mod use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, I8=>SHR_KIND_I8, R8=>SHR_KIND_R8 use med_kind_mod , only : R4=>SHR_KIND_R4 use shr_const_mod , only : fillvalue => SHR_CONST_SPVAL - use ESMF , only : ESMF_VM, ESMF_LogWrite, ESMF_LOGMSG_INFO - use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE - use ESMF , only : ESMF_VMGetCurrent, ESMF_VMGet, ESMF_VMBroadCast, ESMF_GridComp + use ESMF , only : ESMF_VM, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LogFoundError + use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_END_ABORT, ESMF_LOGERR_PASSTHRU + use ESMF , only : ESMF_VMGetCurrent, ESMF_VMGet, ESMF_VMBroadCast, ESMF_Finalize use NUOPC , only : NUOPC_FieldDictionaryGetEntry use NUOPC , only : NUOPC_FieldDictionaryHasEntry use pio , only : file_desc_t, iosystem_desc_t @@ -30,6 +30,8 @@ module med_io_mod public :: med_io_enddef public :: med_io_sec2hms public :: med_io_read + public :: med_io_define_time + public :: med_io_write_time public :: med_io_write public :: med_io_init public :: med_io_date2yyyymmdd @@ -55,7 +57,6 @@ module med_io_mod module procedure med_io_write_r8 module procedure med_io_write_r81d module procedure med_io_write_char - module procedure med_io_write_time end interface med_io_write interface med_io_date2ymd module procedure med_io_date2ymd_int @@ -70,16 +71,13 @@ module med_io_mod module procedure med_io_ymd2date_long end interface med_io_ymd2date - !------------------------------------------------------------------------------- ! module data - !------------------------------------------------------------------------------- - character(*),parameter :: prefix = "med_io_" character(*),parameter :: modName = "(med_io_mod) " character(*),parameter :: version = "cmeps0" + integer , parameter :: number_strlen = 8 integer , parameter :: file_desc_t_cnt = 20 ! Note - this is hard-wired for now - integer , parameter :: number_strlen = 2 - character(CL) :: wfilename = '' + character(CL) :: wfilename(0:file_desc_t_cnt) = '' type(file_desc_t) :: io_file(0:file_desc_t_cnt) integer :: pio_iotype integer :: pio_ioformat @@ -91,7 +89,7 @@ module med_io_mod contains !================================================================================= - logical function med_io_file_exists(vm, iam, filename) + logical function med_io_file_exists(vm, filename) !--------------- ! inquire if i/o file exists @@ -99,19 +97,24 @@ logical function med_io_file_exists(vm, iam, filename) ! input/output variables type(ESMF_VM) :: vm - integer, intent(in) :: iam character(len=*), intent(in) :: filename ! local variables integer :: tmp(1) + integer :: iam integer :: rc !------------------------------------------------------------------------------- tmp(1) = 0 - med_io_file_exists = .false. - if (iam==0) inquire(file=trim(filename),exist=med_io_file_exists) - if (med_io_file_exists) tmp(1) = 1 + call ESMF_VMGet(vm, localPet=iam, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + med_io_file_exists = .false. + if (iam==0) then + inquire(file=trim(filename),exist=med_io_file_exists) + if (med_io_file_exists) tmp(1) = 1 + end if call ESMF_VMBroadCast(vm, tmp, 1, 0, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -126,6 +129,7 @@ subroutine med_io_init(gcomp, rc) ! initialize pio !--------------- + use ESMF , only : ESMF_GridComp, ESMF_UtilStringUpperCase #ifdef CESMCOUPLED use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat #else @@ -136,13 +140,12 @@ subroutine med_io_init(gcomp, rc) use pio , only : PIO_REARR_COMM_P2P, PIO_REARR_COMM_COLL use pio , only : PIO_REARR_COMM_FC_2D_ENABLE, PIO_REARR_COMM_FC_2D_DISABLE use pio , only : PIO_REARR_COMM_FC_1D_COMP2IO, PIO_REARR_COMM_FC_1D_IO2COMP - use ESMF , only : ESMF_GridComp, ESMF_UtilStringUpperCase use NUOPC, only : NUOPC_CompAttributeGet #endif ! input/output arguments - type(ESMF_GridComp), intent(in) :: gcomp - integer , intent(out) :: rc + type(ESMF_GridComp), intent(in) :: gcomp + integer , intent(out) :: rc #ifndef CESMCOUPLED ! local variables @@ -495,7 +498,7 @@ subroutine med_io_init(gcomp, rc) end subroutine med_io_init !=============================================================================== - subroutine med_io_wopen(filename, vm, iam, clobber, file_ind, model_doi_url) + subroutine med_io_wopen(filename, vm, clobber, file_ind, model_doi_url) !--------------- ! open netcdf file @@ -509,7 +512,6 @@ subroutine med_io_wopen(filename, vm, iam, clobber, file_ind, model_doi_url) ! input/output arguments character(*), intent(in) :: filename type(ESMF_VM) :: vm - integer, intent(in) :: iam logical, optional, intent(in) :: clobber integer, optional, intent(in) :: file_ind character(CL), optional, intent(in) :: model_doi_url @@ -520,6 +522,7 @@ subroutine med_io_wopen(filename, vm, iam, clobber, file_ind, model_doi_url) integer :: nmode integer :: lfile_ind integer :: rc + integer :: iam character(CL) :: lversion character(CL) :: lmodel_doi_url character(*),parameter :: subName = '(med_io_wopen) ' @@ -538,10 +541,13 @@ subroutine med_io_wopen(filename, vm, iam, clobber, file_ind, model_doi_url) if (.not. pio_file_is_open(io_file(lfile_ind))) then + call ESMF_VMGet(vm, localPet=iam, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! filename not open - wfilename = filename + wfilename(lfile_ind) = trim(filename) - if (med_io_file_exists(vm, iam, filename)) then + if (med_io_file_exists(vm, filename)) then if (lclobber) then nmode = pio_clobber ! only applies to classic NETCDF files. @@ -549,14 +555,12 @@ subroutine med_io_wopen(filename, vm, iam, clobber, file_ind, model_doi_url) nmode = ior(nmode,pio_ioformat) endif rcode = pio_createfile(io_subsystem, io_file(lfile_ind), pio_iotype, trim(filename), nmode) - if(iam==0) write(logunit,*) subname,' create file ',trim(filename) + if(iam==0) write(logunit,'(a)') trim(subname)//' creating file '//trim(filename) rcode = pio_put_att(io_file(lfile_ind),pio_global,"file_version",version) rcode = pio_put_att(io_file(lfile_ind),pio_global,"model_doi_url",lmodel_doi_url) else rcode = pio_openfile(io_subsystem, io_file(lfile_ind), pio_iotype, trim(filename), pio_write) - if (iam==0) then - write(logunit,*) subname,' open file ',trim(filename) - end if + if (iam==0) write(logunit,'(a)') trim(subname)//' opening file '//trim(filename) call pio_seterrorhandling(io_file(lfile_ind),PIO_BCAST_ERROR) rcode = pio_get_att(io_file(lfile_ind),pio_global,"file_version",lversion) call pio_seterrorhandling(io_file(lfile_ind),PIO_INTERNAL_ERROR) @@ -573,19 +577,21 @@ subroutine med_io_wopen(filename, vm, iam, clobber, file_ind, model_doi_url) nmode = ior(nmode,pio_ioformat) endif rcode = pio_createfile(io_subsystem, io_file(lfile_ind), pio_iotype, trim(filename), nmode) - if (iam==0) then - write(logunit,*) subname,' create file ',trim(filename) - end if + if (iam==0) write(logunit,'(a)') trim(subname) //' creating file '// trim(filename) rcode = pio_put_att(io_file(lfile_ind),pio_global,"file_version",version) rcode = pio_put_att(io_file(lfile_ind),pio_global,"model_doi_url",lmodel_doi_url) endif - elseif (trim(wfilename) /= trim(filename)) then + + elseif (trim(wfilename(lfile_ind)) /= trim(filename)) then ! filename is open, better match open filename - if(iam==0) write(logunit,*) subname,' different filename currently open ',trim(filename) - if(iam==0) write(logunit,*) subname,' different wfilename currently open ',trim(wfilename) - call ESMF_LogWrite(subname//'different file currently open '//trim(filename), ESMF_LOGMSG_INFO) + if (iam==0) then + write(logunit,'(a)') trim(subname)//' different filename currently open '//trim(filename) + write(logunit,'(a)') trim(subname)//' different wfilename currently open '//trim(wfilename(lfile_ind)) + end if + call ESMF_LogWrite(trim(subname)//'different file currently open '//trim(filename), ESMF_LOGMSG_INFO) rc = ESMF_FAILURE return + else ! filename is already open, just return endif @@ -593,7 +599,7 @@ subroutine med_io_wopen(filename, vm, iam, clobber, file_ind, model_doi_url) end subroutine med_io_wopen !=============================================================================== - subroutine med_io_close(filename, iam, file_ind, rc) + subroutine med_io_close(filename, vm, file_ind, rc) !--------------- ! close netcdf file @@ -602,13 +608,14 @@ subroutine med_io_close(filename, iam, file_ind, rc) use pio, only: pio_file_is_open, pio_closefile ! input/output variables - character(*), intent(in) :: filename - integer, intent(in) :: iam - integer,optional, intent(in) :: file_ind - integer , intent(out) :: rc + character(*) , intent(in) :: filename + type(ESMF_VM) , intent(in) :: vm + integer,optional , intent(in) :: file_ind + integer , intent(out) :: rc ! local variables integer :: lfile_ind + integer :: iam character(*),parameter :: subName = '(med_io_close) ' !------------------------------------------------------------------------------- @@ -619,18 +626,28 @@ subroutine med_io_close(filename, iam, file_ind, rc) if (.not. pio_file_is_open(io_file(lfile_ind))) then ! filename not open, just return - elseif (trim(wfilename) == trim(filename)) then + elseif (trim(wfilename(lfile_ind)) == trim(filename)) then ! filename matches, close it call pio_closefile(io_file(lfile_ind)) + !wfilename(lfile_ind) = '' else + call ESMF_VMGet(vm, localPet=iam, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! different filename is open, abort - if (iam==0) write(logunit,*) subname,' different filename currently open, aborting ',trim(filename) - if (iam==0) write(logunit,*) subname,' different wfilename currently open, aborting ',trim(wfilename) + if (iam==0) then + write(logunit,*) subname,' different wfilename and filename currently open, aborting ' + write(logunit,'(a)') 'filename = ',trim(filename) + write(logunit,'(a)') 'wfilename = ',trim(wfilename(lfile_ind)) + write(logunit,'(i6)')'lfile_ind = ',lfile_ind + end if call ESMF_LogWrite(subname//'different file currently open, aborting '//trim(filename), ESMF_LOGMSG_INFO) rc = ESMF_FAILURE - return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) then + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if endif - wfilename = '' + end subroutine med_io_close !=============================================================================== @@ -669,8 +686,8 @@ subroutine med_io_enddef(filename,file_ind) lfile_ind = 0 if (present(file_ind)) lfile_ind=file_ind - rcode = pio_enddef(io_file(lfile_ind)) + end subroutine med_io_enddef !=============================================================================== @@ -728,8 +745,8 @@ character(len=8) function med_io_sec2hms (seconds, rc) end function med_io_sec2hms !=============================================================================== - subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & - fillval, pre, tavg, use_float, file_ind, rc) + subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & + fillval, pre, flds, tavg, use_float, file_ind, rc) !--------------- ! Write FB to netcdf file @@ -745,20 +762,20 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & use pio , only : pio_syncfile ! input/output variables - character(len=*), intent(in) :: filename ! file - integer, intent(in) :: iam ! local pet - type(ESMF_FieldBundle), intent(in) :: FB ! data to be written - logical, optional, intent(in) :: whead ! write header - logical, optional, intent(in) :: wdata ! write data - integer , optional, intent(in) :: nx ! 2d grid size if available - integer , optional, intent(in) :: ny ! 2d grid size if available - integer , optional, intent(in) :: nt ! time sample - real(r8), optional, intent(in) :: fillval ! fill value - character(len=*), optional, intent(in) :: pre ! prefix to variable name - logical, optional, intent(in) :: tavg ! is this a tavg - logical, optional, intent(in) :: use_float ! write output as float rather than double - integer, optional, intent(in) :: file_ind - integer, intent(out):: rc + character(len=*) , intent(in) :: filename ! file + type(ESMF_FieldBundle) , intent(in) :: FB ! data to be written + logical , intent(in) :: whead ! write header + logical , intent(in) :: wdata ! write data + integer , intent(in) :: nx ! 2d grid size if available + integer , intent(in) :: ny ! 2d grid size if available + integer , optional , intent(in) :: nt ! time sample + real(r8), optional , intent(in) :: fillval ! fill value + character(len=*), optional , intent(in) :: pre ! prefix to variable name + character(len=*), optional , intent(in) :: flds(:) ! specific fields to write out + logical, optional , intent(in) :: tavg ! is this a tavg + logical, optional , intent(in) :: use_float ! write output as float rather than double + integer, optional , intent(in) :: file_ind + integer , intent(out):: rc ! local variables type(ESMF_Field) :: field @@ -782,9 +799,8 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & character(CL) :: lname ! long name character(CL) :: sname ! standard name character(CL) :: lpre ! local prefix - logical :: lwhead, lwdata - logical :: luse_float integer :: lnx,lny + logical :: luse_float real(r8) :: lfillvalue integer, pointer :: minIndexPTile(:,:) integer, pointer :: maxIndexPTile(:,:) @@ -801,57 +817,24 @@ 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), allocatable :: fieldNameList(:) character(*),parameter :: subName = '(med_io_write_FB) ' !------------------------------------------------------------------------------- - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) - endif rc = ESMF_Success lfillvalue = fillvalue - if (present(fillval)) then - lfillvalue = fillval - endif - + if (present(fillval)) lfillvalue = fillval lpre = ' ' - if (present(pre)) then - lpre = trim(pre) - endif - - if (.not. ESMF_FieldBundleIsCreated(FB, rc=rc)) then - call ESMF_LogWrite(trim(subname)//" FB "//trim(lpre)//" not created", ESMF_LOGMSG_INFO) - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) - endif - rc = ESMF_Success - return - endif - - lwhead = .true. - lwdata = .true. - if (present(whead)) lwhead = whead - if (present(wdata)) lwdata = wdata - - if (.not.lwhead .and. .not.lwdata) then - ! should we write a warning? - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) - endif - return - endif - + if (present(pre)) lpre = trim(pre) 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) - write(tmpstr,*) subname//' field count = '//trim(lpre),nf - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - if (nf < 1) then - call ESMF_LogWrite(trim(subname)//" FB "//trim(lpre)//" empty", ESMF_LOGMSG_INFO) + ! Error check + if (.not. ESMF_FieldBundleIsCreated(FB, rc=rc)) then + call ESMF_LogWrite(trim(subname)//" FB "//trim(lpre)//" not created", ESMF_LOGMSG_INFO) if (dbug_flag > 5) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) endif @@ -859,43 +842,60 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & return endif + ! Get number of fields + if (present(flds)) then + nf = size(flds) + else + call ESMF_FieldBundleGet(FB, fieldCount=nf, rc=rc) + write(tmpstr,*) subname//' field count = '//trim(lpre), nf + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + if (nf < 1) then + call ESMF_LogWrite(trim(subname)//" FB "//trim(lpre)//" empty", ESMF_LOGMSG_INFO) + if (dbug_flag > 5) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + endif + rc = ESMF_Success + return + endif + allocate(fieldNameList(nf)) + call ESMF_FieldBundleGet(FB, fieldNameList=fieldNameList, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! Get field bundle mesh from first field call FB_getFieldN(FB, 1, field, 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 + ! Get mesh distgrid and number of elements 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) + ! Set element coordinates if (.not. allocated(ownedElemCoords) .and. ndims > 0 .and. nelements > 0) then 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 + ! Get tile info 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 ! write(tmpstr,*) subname,' counts = ',dimcount,tilecount,minindexptile,maxindexptile ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - ! TODO: this is not getting the global size correct for a FB coming in that does not have ! all the global grid values in the distgrid - e.g. CTSM @@ -903,44 +903,40 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & lnx = ng lny = 1 deallocate(minIndexPTile, maxIndexPTile) - - frame = -1 - if (present(nt)) then - frame = nt - endif - if (present(nx)) then - if (nx > 0) lnx = nx - endif - if (present(ny)) then - if (ny > 0) lny = ny - endif + if (nx > 0) lnx = nx + if (ny > 0) lny = ny if (lnx*lny /= ng) then - write(tmpstr,*) subname,' ERROR: grid2d size not consistent ',ng,lnx,lny + write(tmpstr,*) subname,' WARNING: grid2d size not consistent ',ng,lnx,lny call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - !TODO: this should not be an error for say CTSM which does not send a global grid - !rc = ESMF_FAILURE - !return endif - if (lwhead) then - rcode = pio_def_dim(io_file(lfile_ind),trim(lpre)//'_nx',lnx,dimid2(1)) - rcode = pio_def_dim(io_file(lfile_ind),trim(lpre)//'_ny',lny,dimid2(2)) + if (present(nt)) then + frame = nt + else + frame = -1 + end if + ! Write header + if (whead) then + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_nx', lnx, dimid2(1)) + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_ny', lny, dimid2(2)) if (present(nt)) then dimid3(1:2) = dimid2 - rcode = pio_inq_dimid(io_file(lfile_ind),'time',dimid3(3)) + rcode = pio_inq_dimid(io_file(lfile_ind), 'time', dimid3(3)) dimid => dimid3 else dimid => dimid2 endif - write(tmpstr,*) subname,' dimid = ',dimid call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) do k = 1,nf - call FB_getNameN(FB, k, itemc, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Determine field name + if (present(flds)) then + itemc = trim(flds(k)) + else + itemc = trim(fieldNameList(k)) + end if ! Determine rank of field with name itemc call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc) @@ -1028,14 +1024,9 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & rcode = pio_put_att(io_file(lfile_ind), varid, "long_name", "latitude") rcode = pio_put_att(io_file(lfile_ind), varid, "units", "degrees_north") rcode = pio_put_att(io_file(lfile_ind), varid, "standard_name", "latitude") - - ! Finish define mode - if (lwdata) call med_io_enddef(filename, file_ind=lfile_ind) - end if - if (lwdata) then - + if (wdata) 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 @@ -1043,16 +1034,17 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & call ESMF_DistGridGet(distgrid, localDE=0, seqIndexList=dof, rc=rc) write(tmpstr,*) subname,' dof = ',ns,size(dof),dof(1),dof(ns) !,minval(dof),maxval(dof) call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call pio_initdecomp(io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) - ! call pio_writedof(lpre, (/lnx,lny/), int(dof,kind=PIO_OFFSET_KIND), mpicom) - deallocate(dof) do k = 1,nf - call FB_getNameN(FB, k, itemc, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Determine field name + if (present(flds)) then + itemc = trim(flds(k)) + else + itemc = trim(fieldNameList(k)) + end if call FB_getFldPtr(FB, itemc, & fldptr1=fldptr1, fldptr2=fldptr2, rank=rank, rc=rc) @@ -1091,7 +1083,7 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & end if ! end if not "hgt" end do ! end loop over fields in FB - ! Fill coordinate variables + ! Fill coordinate variables - why is this being done each time? name1 = trim(lpre)//'_lon' rcode = pio_inq_varid(io_file(lfile_ind), trim(name1), varid) call pio_setframe(io_file(lfile_ind),varid,frame) @@ -1113,7 +1105,7 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & end subroutine med_io_write_FB !=============================================================================== - subroutine med_io_write_int(filename, iam, idata, dname, whead, wdata, file_ind, rc) + subroutine med_io_write_int(filename, idata, dname, whead, wdata, file_ind, rc) use pio, only : var_desc_t, pio_def_var, pio_put_att, pio_int, pio_inq_varid, pio_put_var @@ -1123,11 +1115,10 @@ subroutine med_io_write_int(filename, iam, idata, dname, whead, wdata, file_ind, ! intput/output variables character(len=*) ,intent(in) :: filename ! file - integer ,intent(in) :: iam ! local pet integer ,intent(in) :: idata ! data to be written character(len=*) ,intent(in) :: dname ! name of data - logical,optional ,intent(in) :: whead ! write header - logical,optional ,intent(in) :: wdata ! write data + logical ,intent(in) :: whead ! write header + logical ,intent(in) :: wdata ! write data integer,optional ,intent(in) :: file_ind integer ,intent(out):: rc @@ -1135,27 +1126,16 @@ subroutine med_io_write_int(filename, iam, idata, dname, whead, wdata, file_ind, integer :: rcode type(var_desc_t) :: varid character(CL) :: cunit ! var units - logical :: lwhead, lwdata integer :: lfile_ind character(*),parameter :: subName = '(med_io_write_int) ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS - lwhead = .true. - lwdata = .true. - if (present(whead)) lwhead = whead - if (present(wdata)) lwdata = wdata - - if (.not.lwhead .and. .not.lwdata) then - ! should we write a warning? - return - endif - lfile_ind = 0 if (present(file_ind)) lfile_ind=file_ind - if (lwhead) then + if (whead) then if (NUOPC_FieldDictionaryHasEntry(trim(dname))) then call NUOPC_FieldDictionaryGetEntry(dname, canonicalUnits=cunit, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -1163,19 +1143,16 @@ subroutine med_io_write_int(filename, iam, idata, dname, whead, wdata, file_ind, end if rcode = pio_def_var(io_file(lfile_ind),trim(dname),PIO_INT,varid) rcode = pio_put_att(io_file(lfile_ind),varid,"standard_name",trim(dname)) - if (lwdata) call med_io_enddef(filename, file_ind=lfile_ind) endif - - if (lwdata) then + if (wdata) then rcode = pio_inq_varid(io_file(lfile_ind),trim(dname),varid) rcode = pio_put_var(io_file(lfile_ind),varid,idata) - ! write(logunit,*) subname,' wrote AV ',trim(dname),lwhead,lwdata endif end subroutine med_io_write_int !=============================================================================== - subroutine med_io_write_int1d(filename, iam, idata, dname, whead, wdata, file_ind, rc) + subroutine med_io_write_int1d(filename, idata, dname, whead, wdata, file_ind, rc) !--------------- ! Write 1d integer array to netcdf file @@ -1186,14 +1163,13 @@ subroutine med_io_write_int1d(filename, iam, idata, dname, whead, wdata, file_in use pio , only : pio_int, pio_def_var ! input/output arguments - character(len=*),intent(in) :: filename ! file - integer ,intent(in) :: iam ! local pet - integer ,intent(in) :: idata(:) ! data to be written - character(len=*),intent(in) :: dname ! name of data - logical,optional,intent(in) :: whead ! write header - logical,optional,intent(in) :: wdata ! write data - integer,optional,intent(in) :: file_ind - integer , intent(out) :: rc + character(len=*) ,intent(in) :: filename ! file + integer ,intent(in) :: idata(:) ! data to be written + character(len=*) ,intent(in) :: dname ! name of data + logical ,intent(in) :: whead ! write header + logical ,intent(in) :: wdata ! write data + integer,optional ,intent(in) :: file_ind + integer , intent(out):: rc ! local variables integer :: rcode @@ -1203,50 +1179,34 @@ subroutine med_io_write_int1d(filename, iam, idata, dname, whead, wdata, file_in character(CL) :: lname ! long name character(CL) :: sname ! standard name integer :: lnx - logical :: lwhead, lwdata integer :: lfile_ind character(*),parameter :: subName = '(med_io_write_int1d) ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS - lwhead = .true. - lwdata = .true. - if (present(whead)) lwhead = whead - if (present(wdata)) lwdata = wdata - - if (.not.lwhead .and. .not.lwdata) then - ! should we write a warning? - return - endif - lfile_ind = 0 if (present(file_ind)) lfile_ind=file_ind - if (lwhead) then + if (whead) then if (NUOPC_FieldDictionaryHasEntry(trim(dname))) then call NUOPC_FieldDictionaryGetEntry(dname, 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 lnx = size(idata) - rcode = pio_def_dim(io_file(lfile_ind),trim(dname)//'_nx',lnx,dimid(1)) + rcode = pio_def_dim(io_file(lfile_ind),trim(dname),lnx,dimid(1)) rcode = pio_def_var(io_file(lfile_ind),trim(dname),PIO_INT,dimid,varid) rcode = pio_put_att(io_file(lfile_ind),varid,"standard_name",trim(dname)) - if (lwdata) call med_io_enddef(filename, file_ind=lfile_ind) - endif - - if (lwdata) then + else if (wdata) then rcode = pio_inq_varid(io_file(lfile_ind),trim(dname),varid) rcode = pio_put_var(io_file(lfile_ind),varid,idata) endif - ! write(logunit,*) subname,' wrote AV ',trim(dname),lwhead,lwdata - end subroutine med_io_write_int1d !=============================================================================== - subroutine med_io_write_r8(filename, iam, rdata, dname, whead, wdata, file_ind, rc) + subroutine med_io_write_r8(filename, rdata, dname, whead, wdata, file_ind, rc) !--------------- ! Write scalar double to netcdf file @@ -1256,39 +1216,25 @@ subroutine med_io_write_r8(filename, iam, rdata, dname, whead, wdata, file_ind, use pio , only : pio_double, pio_noerr, pio_inq_varid, pio_put_var ! input/output arguments - character(len=*),intent(in) :: filename ! file - integer ,intent(in) :: iam ! local pet - real(r8) ,intent(in) :: rdata ! data to be written - character(len=*),intent(in) :: dname ! name of data - logical,optional,intent(in) :: whead ! write header - logical,optional,intent(in) :: wdata ! write data - integer,optional,intent(in) :: file_ind - integer ,intent(out):: rc + character(len=*) ,intent(in) :: filename ! file + real(r8) ,intent(in) :: rdata ! data to be written + character(len=*) ,intent(in) :: dname ! name of data + logical ,intent(in) :: whead ! write header + logical ,intent(in) :: wdata ! write data + integer,optional ,intent(in) :: file_ind + integer ,intent(out):: rc ! local variables integer :: rcode type(var_desc_t) :: varid character(CL) :: cunit ! var units - logical :: lwhead, lwdata integer :: lfile_ind character(*),parameter :: subName = '(med_io_write_r8) ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS - lwhead = .true. - if (present(whead)) lwhead = whead - lwdata = .true. - if (present(wdata)) lwdata = wdata - lfile_ind = 0 - if (present(file_ind)) lfile_ind=file_ind - - if (.not.lwhead .and. .not.lwdata) then - ! should we write a warning? - return - endif - - if (lwhead) then + if (whead) then rcode = pio_def_var(io_file(lfile_ind),trim(dname),PIO_DOUBLE,varid) if (rcode==PIO_NOERR) then if (NUOPC_FieldDictionaryHasEntry(trim(dname))) then @@ -1297,11 +1243,8 @@ subroutine med_io_write_r8(filename, iam, rdata, dname, whead, wdata, file_ind, 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(dname)) - if (lwdata) call med_io_enddef(filename, file_ind=lfile_ind) end if - endif - - if (lwdata) then + else if (wdata) then rcode = pio_inq_varid(io_file(lfile_ind),trim(dname),varid) rcode = pio_put_var(io_file(lfile_ind),varid,rdata) endif @@ -1309,7 +1252,7 @@ subroutine med_io_write_r8(filename, iam, rdata, dname, whead, wdata, file_ind, end subroutine med_io_write_r8 !=============================================================================== - subroutine med_io_write_r81d(filename, iam, rdata, dname, whead, wdata, file_ind, rc) + subroutine med_io_write_r81d(filename, rdata, dname, whead, wdata, file_ind, rc) !--------------- ! Write 1d double array to netcdf file @@ -1319,14 +1262,13 @@ subroutine med_io_write_r81d(filename, iam, rdata, dname, whead, wdata, file_ind use pio , only : pio_inq_varid, pio_put_var, pio_double, pio_put_att ! !INPUT/OUTPUT PARAMETERS: - character(len=*),intent(in) :: filename ! file - integer ,intent(in) :: iam - real(r8) ,intent(in) :: rdata(:) ! data to be written - character(len=*),intent(in) :: dname ! name of data - logical,optional,intent(in) :: whead ! write header - logical,optional,intent(in) :: wdata ! write data - integer,optional,intent(in) :: file_ind - integer ,intent(out):: rc + character(len=*) ,intent(in) :: filename ! file + real(r8) ,intent(in) :: rdata(:) ! data to be written + character(len=*) ,intent(in) :: dname ! name of data + logical ,intent(in) :: whead ! write header + logical ,intent(in) :: wdata ! write data + integer,optional ,intent(in) :: file_ind + integer ,intent(out):: rc ! local variables integer :: rcode @@ -1334,26 +1276,13 @@ subroutine med_io_write_r81d(filename, iam, rdata, dname, whead, wdata, file_ind type(var_desc_t) :: varid character(CL) :: cunit ! var units integer :: lnx - logical :: lwhead, lwdata integer :: lfile_ind character(*),parameter :: subName = '(med_io_write_r81d) ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS - lwhead = .true. - if (present(whead)) lwhead = whead - lwdata = .true. - if (present(wdata)) lwdata = wdata - lfile_ind = 0 - if (present(file_ind)) lfile_ind=file_ind - - if (.not.lwhead .and. .not.lwdata) then - ! should we write a warning? - return - endif - - if (lwhead) then + if (whead) then lnx = size(rdata) rcode = pio_def_dim(io_file(lfile_ind),trim(dname)//'_nx',lnx,dimid(1)) rcode = pio_def_var(io_file(lfile_ind),trim(dname),PIO_DOUBLE,dimid,varid) @@ -1363,10 +1292,9 @@ subroutine med_io_write_r81d(filename, iam, rdata, dname, whead, wdata, file_ind 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(dname)) - if (lwdata) call med_io_enddef(filename, file_ind=lfile_ind) endif - if (lwdata) then + if (wdata) then rcode = pio_inq_varid(io_file(lfile_ind),trim(dname),varid) rcode = pio_put_var(io_file(lfile_ind),varid,rdata) endif @@ -1374,7 +1302,7 @@ subroutine med_io_write_r81d(filename, iam, rdata, dname, whead, wdata, file_ind end subroutine med_io_write_r81d !=============================================================================== - subroutine med_io_write_char(filename, iam, rdata, dname, whead, wdata, file_ind, rc) + subroutine med_io_write_char(filename, rdata, dname, whead, wdata, file_ind, rc) !--------------- ! Write char string to netcdf file @@ -1384,14 +1312,13 @@ subroutine med_io_write_char(filename, iam, rdata, dname, whead, wdata, file_ind use pio , only : pio_char, pio_put_var ! input/output arguments - character(len=*),intent(in) :: filename ! file - integer ,intent(in) :: iam ! local pet - character(len=*),intent(in) :: rdata ! data to be written - character(len=*),intent(in) :: dname ! name of data - logical,optional,intent(in) :: whead ! write header - logical,optional,intent(in) :: wdata ! write data - integer,optional,intent(in) :: file_ind - integer ,intent(out):: rc + character(len=*) ,intent(in) :: filename ! file + character(len=*) ,intent(in) :: rdata ! data to be written + character(len=*) ,intent(in) :: dname ! name of data + logical ,intent(in) :: whead ! write header + logical ,intent(in) :: wdata ! write data + integer,optional ,intent(in) :: file_ind + integer ,intent(out):: rc ! local variables integer :: rcode @@ -1401,7 +1328,6 @@ subroutine med_io_write_char(filename, iam, rdata, dname, whead, wdata, file_ind character(CL) :: lname ! long name character(CL) :: sname ! standard name integer :: lnx - logical :: lwhead, lwdata integer :: lfile_ind character(CL) :: charvar ! buffer for string read/write character(*),parameter :: subName = '(med_io_write_char) ' @@ -1409,18 +1335,7 @@ subroutine med_io_write_char(filename, iam, rdata, dname, whead, wdata, file_ind rc = ESMF_SUCCESS - lwhead = .true. - if (present(whead)) lwhead = whead - lwdata = .true. - if (present(wdata)) lwdata = wdata - lfile_ind = 0 - if (present(file_ind)) lfile_ind=file_ind - if (.not.lwhead .and. .not.lwdata) then - ! should we write a warning? - return - endif - - if (lwhead) then + if (whead) then lnx = len(charvar) rcode = pio_def_dim(io_file(lfile_ind),trim(dname)//'_len',lnx,dimid(1)) rcode = pio_def_var(io_file(lfile_ind),trim(dname),PIO_CHAR,dimid,varid) @@ -1429,9 +1344,7 @@ subroutine med_io_write_char(filename, iam, rdata, dname, whead, wdata, file_ind if (chkerr(rc,__LINE__,u_FILE_u)) return end if rcode = pio_put_att(io_file(lfile_ind),varid,"standard_name",trim(dname)) - if (lwdata) call med_io_enddef(filename, file_ind=lfile_ind) - endif - if (lwdata) then + else if (wdata) then charvar = '' charvar = trim(rdata) rcode = pio_inq_varid(io_file(lfile_ind),trim(dname),varid) @@ -1441,119 +1354,119 @@ subroutine med_io_write_char(filename, iam, rdata, dname, whead, wdata, file_ind end subroutine med_io_write_char !=============================================================================== - subroutine med_io_write_time(filename, iam, time_units, calendar, time_val, nt,& - whead, wdata, tbnds, file_ind, rc) + subroutine med_io_define_time(time_units, calendar, file_ind, rc) - !--------------- - ! Write time variable to netcdf file - !--------------- - - use ESMF, only : operator(==) - use ESMF, only : ESMF_Calendar + use ESMF, only : operator(==), operator(/=) + use ESMF, only : ESMF_Calendar, ESMF_CalendarIsCreated use ESMF, only : ESMF_CALKIND_360DAY, ESMF_CALKIND_GREGORIAN use ESMF, only : ESMF_CALKIND_JULIAN, ESMF_CALKIND_JULIANDAY, ESMF_CALKIND_MODJULIANDAY use ESMF, only : ESMF_CALKIND_NOCALENDAR, ESMF_CALKIND_NOLEAP + use ESMF, only : ESMF_LOGMSG_ERROR, ESMF_FAILURE use pio , only : var_desc_t, PIO_UNLIMITED use pio , only : pio_double, pio_def_dim, pio_def_var, pio_put_att use pio , only : pio_inq_varid, pio_put_var ! input/output variables - character(len=*) , intent(in) :: filename ! file - integer , intent(in) :: iam ! local pet - character(len=*) , intent(in) :: time_units ! units of time - type(ESMF_Calendar) , intent(in) :: calendar ! calendar - real(r8) , intent(in) :: time_val ! data to be written - integer , optional, intent(in) :: nt - logical , optional, intent(in) :: whead ! write header - logical , optional, intent(in) :: wdata ! write data - real(r8) , optional, intent(in) :: tbnds(2) ! time bounds - integer , optional, intent(in) :: file_ind - integer , intent(out):: rc + character(len=*) , intent(in) :: time_units ! units of time + type(ESMF_Calendar) , intent(in) :: calendar ! calendar + integer, optional , intent(in) :: file_ind + integer , intent(out):: rc ! local variables integer :: rcode integer :: dimid(1) integer :: dimid2(2) type(var_desc_t) :: varid - logical :: lwhead, lwdata - integer :: start(4),count(4) - real(r8) :: time_val_1d(1) integer :: lfile_ind character(CL) :: calname ! calendar name - character(*),parameter :: subName = '(med_io_write_time) ' + character(*),parameter :: subName = '(med_io_define_time) ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS - lwhead = .true. - if (present(whead)) lwhead = whead - lwdata = .true. - if (present(wdata)) lwdata = wdata lfile_ind = 0 if (present(file_ind)) lfile_ind=file_ind - if (.not.lwhead .and. .not.lwdata) then - ! should we write a warning? + + if (.not. ESMF_CalendarIsCreated(calendar)) then + call ESMF_LogWrite(trim(subname)//' ERROR: calendar is not created ', & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE return - endif + end if - ! Write out header - if (lwhead) then - rcode = pio_def_dim(io_file(lfile_ind),'time',PIO_UNLIMITED,dimid(1)) - rcode = pio_def_var(io_file(lfile_ind),'time',PIO_DOUBLE,dimid,varid) - rcode = pio_put_att(io_file(lfile_ind),varid,'units',trim(time_units)) - - if (calendar == ESMF_CALKIND_360DAY) then - calname = '360_day' - else if (calendar == ESMF_CALKIND_GREGORIAN) then - calname = 'gregorian' - else if (calendar == ESMF_CALKIND_JULIAN) then - calname = 'julian' - else if (calendar == ESMF_CALKIND_JULIANDAY) then - calname = 'ESMF_CALKIND_JULIANDAY' - else if (calendar == ESMF_CALKIND_MODJULIANDAY) then - calname = 'ESMF_CALKIND_MODJULIANDAY' - else if (calendar == ESMF_CALKIND_NOCALENDAR) then - calname = 'none' - else if (calendar == ESMF_CALKIND_NOLEAP) then - calname = 'noleap' - end if - rcode = pio_put_att(io_file(lfile_ind),varid,'calendar',trim(calname)) + ! define time and add calendar attribute + rcode = pio_def_dim(io_file(lfile_ind), 'time', PIO_UNLIMITED, dimid(1)) + rcode = pio_def_var(io_file(lfile_ind), 'time', PIO_DOUBLE, dimid, varid) + rcode = pio_put_att(io_file(lfile_ind), varid, 'units', trim(time_units)) + if (calendar == ESMF_CALKIND_360DAY) then + calname = '360_day' + else if (calendar == ESMF_CALKIND_GREGORIAN) then + calname = 'gregorian' + else if (calendar == ESMF_CALKIND_JULIAN) then + calname = 'julian' + else if (calendar == ESMF_CALKIND_JULIANDAY) then + calname = 'ESMF_CALKIND_JULIANDAY' + else if (calendar == ESMF_CALKIND_MODJULIANDAY) then + calname = 'ESMF_CALKIND_MODJULIANDAY' + else if (calendar == ESMF_CALKIND_NOCALENDAR) then + calname = 'none' + else if (calendar == ESMF_CALKIND_NOLEAP) then + calname = 'noleap' + end if + rcode = pio_put_att(io_file(lfile_ind), varid, 'calendar', trim(calname)) - if (present(tbnds)) then - dimid2(2) = dimid(1) - rcode = pio_put_att(io_file(lfile_ind),varid,'bounds','time_bnds') - rcode = pio_def_dim(io_file(lfile_ind),'ntb',2,dimid2(1)) - rcode = pio_def_var(io_file(lfile_ind),'time_bnds',PIO_DOUBLE,dimid2,varid) - endif - if (lwdata) call med_io_enddef(filename, file_ind=lfile_ind) - endif + ! define time bounds + dimid2(2) = dimid(1) + rcode = pio_def_dim(io_file(lfile_ind), 'ntb', 2, dimid2(1)) + rcode = pio_def_var(io_file(lfile_ind), 'time_bnds', PIO_DOUBLE, dimid2, varid) + rcode = pio_put_att(io_file(lfile_ind), varid, 'bounds', 'time_bnds') - ! Write out data - if (lwdata) then - start = 1 - count = 1 - if (present(nt)) then - start(1) = nt - endif - time_val_1d(1) = time_val - rcode = pio_inq_varid(io_file(lfile_ind),'time',varid) - rcode = pio_put_var(io_file(lfile_ind),varid,start,count,time_val_1d) - if (present(tbnds)) then - rcode = pio_inq_varid(io_file(lfile_ind),'time_bnds',varid) - start = 1 - count = 1 - if (present(nt)) then - start(2) = nt - endif - count(1) = 2 - rcode = pio_put_var(io_file(lfile_ind),varid,start,count,tbnds) - endif - endif + end subroutine med_io_define_time + + !=============================================================================== + subroutine med_io_write_time(time_val, tbnds, nt, file_ind, rc) + + !--------------- + ! Write time variable to netcdf file + !--------------- + + use pio, only : pio_put_att, pio_inq_varid, pio_put_var + + ! input/output variables + real(r8) , intent(in) :: time_val ! data to be written + real(r8) , intent(in) :: tbnds(2) ! time bounds + integer , intent(in) :: nt + integer , optional, intent(in) :: file_ind + integer , intent(out):: rc + + ! local variables + integer :: rcode + integer :: lfile_ind + integer :: varid + integer :: start(2),count(2) + character(*),parameter :: subName = '(med_io_write_time) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + lfile_ind = 0 + if (present(file_ind)) lfile_ind=file_ind + + ! write time + count = 1; start = nt + rcode = pio_inq_varid(io_file(lfile_ind), 'time', varid) + rcode = pio_put_var(io_file(lfile_ind), varid, start(1:1), count(1:1), (/time_val/)) + + ! write time bounds + rcode = pio_inq_varid(io_file(lfile_ind), 'time_bnds', varid) + start(1) = 1; start(2) = nt + count(1) = 2; count(2) = 1 + rcode = pio_put_var(io_file(lfile_ind), varid, start(1:2), count(1:2), tbnds) end subroutine med_io_write_time !=============================================================================== - subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc) + subroutine med_io_read_FB(filename, vm, FB, pre, frame, rc) !--------------- ! Read FB from netcdf file @@ -1573,7 +1486,6 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc) ! input/output arguments character(len=*) ,intent(in) :: filename ! file type(ESMF_VM) ,intent(in) :: vm - integer ,intent(in) :: iam type(ESMF_FieldBundle) ,intent(in) :: FB ! data to be read character(len=*) ,optional ,intent(in) :: pre ! prefix to variable name integer(kind=PIO_OFFSET_KIND) ,optional ,intent(in) :: frame @@ -1640,13 +1552,13 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc) return endif - if (med_io_file_exists(vm, iam, trim(filename))) then + if (med_io_file_exists(vm, 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) if (chkerr(rc,__LINE__,u_FILE_u)) return else call ESMF_LogWrite(trim(subname)//' ERROR: file invalid '//trim(filename), & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE return endif @@ -1826,16 +1738,12 @@ subroutine med_io_read_init_iodesc(FB, name1, pioid, iodesc, rc) write(tmpstr,*) trim(subname),' lny = ',lny call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) ng = lnx * lny - call FB_getFieldN(FB, 1, field, 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_DistGridGet(distgrid, dimCount=dimCount, tileCount=tileCount, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -1843,8 +1751,6 @@ subroutine med_io_read_init_iodesc(FB, name1, pioid, iodesc, rc) call ESMF_DistGridGet(distgrid, minIndexPTile=minIndexPTile, & maxIndexPTile=maxIndexPTile, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - !write(tmpstr,*) subname,' counts = ',dimcount,tilecount,minindexptile,maxindexptile - !call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) if (ng > maxval(maxIndexPTile)) then write(tmpstr,*) subname,' WARNING: dimensions do not match', lnx, lny, maxval(maxIndexPTile) @@ -1872,7 +1778,7 @@ subroutine med_io_read_init_iodesc(FB, name1, pioid, iodesc, rc) end subroutine med_io_read_init_iodesc !=============================================================================== - subroutine med_io_read_int(filename, vm, iam, idata, dname, rc) + subroutine med_io_read_int(filename, vm, idata, dname, rc) !--------------- ! Read scalar integer from netcdf file @@ -1881,7 +1787,6 @@ subroutine med_io_read_int(filename, vm, iam, idata, dname, rc) ! input/output arguments character(len=*) , intent(in) :: filename ! file type(ESMF_VM) :: vm - integer , intent(in) :: iam integer , intent(inout) :: idata ! integer data character(len=*) , intent(in) :: dname ! name of data integer , intent(out) :: rc @@ -1892,14 +1797,14 @@ subroutine med_io_read_int(filename, vm, iam, idata, dname, rc) !------------------------------------------------------------------------------- rc = ESMF_SUCCESS - call med_io_read_int1d(filename, vm, iam, i1d, dname, rc) + call med_io_read_int1d(filename, vm, i1d, dname, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return idata = i1d(1) end subroutine med_io_read_int !=============================================================================== - subroutine med_io_read_int1d(filename, vm, iam, idata, dname, rc) + subroutine med_io_read_int1d(filename, vm, idata, dname, rc) !--------------- ! Read 1d integer array from netcdf file @@ -1913,7 +1818,6 @@ subroutine med_io_read_int1d(filename, vm, iam, idata, dname, rc) ! input/output arguments character(len=*), intent(in) :: filename ! file type(ESMF_VM) :: vm - integer, intent(in) :: iam integer , intent(inout) :: idata(:) ! integer data character(len=*), intent(in) :: dname ! name of data integer , intent(out) :: rc @@ -1924,6 +1828,7 @@ subroutine med_io_read_int1d(filename, vm, iam, idata, dname, rc) type(var_desc_t) :: varid character(CL) :: lversion character(CL) :: name1 + integer :: iam character(*),parameter :: subName = '(med_io_read_int1d) ' !------------------------------------------------------------------------------- @@ -1931,7 +1836,10 @@ subroutine med_io_read_int1d(filename, vm, iam, idata, dname, rc) lversion=trim(version) - if (med_io_file_exists(vm, iam, filename)) then + call ESMF_VMGet(vm, localPet=iam, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (med_io_file_exists(vm, filename)) then rcode = pio_openfile(io_subsystem, pioid, pio_iotype, trim(filename),pio_nowrite) call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) rcode = pio_get_att(pioid,pio_global,"file_version",lversion) @@ -1955,7 +1863,7 @@ subroutine med_io_read_int1d(filename, vm, iam, idata, dname, rc) end subroutine med_io_read_int1d !=============================================================================== - subroutine med_io_read_r8(filename, vm, iam, rdata, dname, rc) + subroutine med_io_read_r8(filename, vm, rdata, dname, rc) !--------------- ! Read scalar double from netcdf file @@ -1964,7 +1872,6 @@ subroutine med_io_read_r8(filename, vm, iam, rdata, dname, rc) ! input/output arguments character(len=*) , intent(in) :: filename ! file type(ESMF_VM) :: vm - integer , intent(in) :: iam real(r8) , intent(inout) :: rdata ! real data character(len=*) , intent(in) :: dname ! name of data integer , intent(out) :: rc @@ -1975,7 +1882,7 @@ subroutine med_io_read_r8(filename, vm, iam, rdata, dname, rc) !------------------------------------------------------------------------------- rc = ESMF_SUCCESS - call med_io_read_r81d(filename, vm, iam, r1d,dname, rc) + call med_io_read_r81d(filename, vm, r1d,dname, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return rdata = r1d(1) @@ -1983,7 +1890,7 @@ subroutine med_io_read_r8(filename, vm, iam, rdata, dname, rc) end subroutine med_io_read_r8 !=============================================================================== - subroutine med_io_read_r81d(filename, vm, iam, rdata, dname, rc) + subroutine med_io_read_r81d(filename, vm, rdata, dname, rc) !--------------- ! Read 1d double array from netcdf file @@ -1996,7 +1903,6 @@ subroutine med_io_read_r81d(filename, vm, iam, rdata, dname, rc) ! input/output arguments character(len=*), intent(in) :: filename ! file type(ESMF_VM) :: vm - integer , intent(in) :: iam real(r8) , intent(inout) :: rdata(:) ! real data character(len=*), intent(in) :: dname ! name of data integer , intent(out) :: rc @@ -2007,6 +1913,7 @@ subroutine med_io_read_r81d(filename, vm, iam, rdata, dname, rc) type(var_desc_t) :: varid character(CL) :: lversion character(CL) :: name1 + integer :: iam character(*),parameter :: subName = '(med_io_read_r81d) ' !------------------------------------------------------------------------------- @@ -2014,7 +1921,10 @@ subroutine med_io_read_r81d(filename, vm, iam, rdata, dname, rc) lversion=trim(version) - if (med_io_file_exists(vm, iam, filename)) then + call ESMF_VMGet(vm, localPet=iam, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (med_io_file_exists(vm, filename)) then rcode = pio_openfile(io_subsystem, pioid, pio_iotype, trim(filename),pio_nowrite) call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) rcode = pio_get_att(pioid,pio_global,"file_version",lversion) @@ -2038,7 +1948,7 @@ subroutine med_io_read_r81d(filename, vm, iam, rdata, dname, rc) end subroutine med_io_read_r81d !=============================================================================== - subroutine med_io_read_char(filename, vm, iam, rdata, dname, rc) + subroutine med_io_read_char(filename, vm, rdata, dname, rc) !--------------- ! Read char string from netcdf file @@ -2051,7 +1961,6 @@ subroutine med_io_read_char(filename, vm, iam, rdata, dname, rc) ! input/output arguments character(len=*), intent(in) :: filename ! file type(ESMF_VM) :: vm - integer, intent(in) :: iam character(len=*), intent(inout) :: rdata ! character data character(len=*), intent(in) :: dname ! name of data integer , intent(out) :: rc @@ -2062,6 +1971,7 @@ subroutine med_io_read_char(filename, vm, iam, rdata, dname, rc) type(var_desc_t) :: varid character(CL) :: lversion character(CL) :: name1 + integer :: iam character(CL) :: charvar ! buffer for string read/write character(*),parameter :: subName = '(med_io_read_char) ' !------------------------------------------------------------------------------- @@ -2070,7 +1980,10 @@ subroutine med_io_read_char(filename, vm, iam, rdata, dname, rc) lversion=trim(version) - if (med_io_file_exists(vm, iam, filename)) then + call ESMF_VMGet(vm, localPet=iam, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (med_io_file_exists(vm, filename)) then rcode = pio_openfile(io_subsystem, pioid, pio_iotype, trim(filename),pio_nowrite) ! write(logunit,*) subname,' open file ',trim(filename) call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 897341956..41b1931f2 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -16,14 +16,13 @@ module med_map_mod ! public routines 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_esmflds ! called from med.F90 module procedure med_map_routehandles_initfrom_fieldbundle module procedure med_map_routehandles_initfrom_field end interface @@ -47,15 +46,17 @@ module med_map_mod subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogunit, rc) !--------------------------------------------- - ! Initialize route handles in the mediator + ! Initialize route handles in the mediator and also + ! initialize unity normalization fields and do the mapping for + ! unity normalization up front + ! ! Assumptions: ! - Route handles are created per target field bundles NOT ! per individual fields in the bundle ! - ALL fields in the bundle are on identical grids ! - MULTIPLE route handles are going to be generated for ! given field bundle source and destination grids - ! - Route handles will ONLY be created if coupling is active - ! between n1 and n2 + ! - Route handles will ONLY be created if coupling_active is true between n1 and n2 ! Algorithm ! n1=source component index ! n2=destination component index @@ -74,11 +75,16 @@ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogun ! for the field !--------------------------------------------- - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush - use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_Field - use ESMF , only : ESMF_FieldBundleGet - use esmFlds , only : fldListFr, ncomps, mapunset, compname - use med_methods_mod , only : med_methods_FB_getFieldN, med_methods_FB_getNameN + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_Field + 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 ESMF , only : ESMF_Mesh, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT + use med_methods_mod , only : med_methods_FB_getFieldN, med_methods_FB_getNameN + use med_constants_mod , only : czero => med_constants_czero + use esmFlds , only : fldListFr, ncomps, mapunset, compname, compocn, compatm + use esmFlds , only : ncomps, nmappers, compname, mapnames, mapfcopy ! input/output variables type(ESMF_GridComp) :: gcomp @@ -87,15 +93,21 @@ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogun integer, intent(out) :: rc ! local variables - type(InternalState) :: is_local - type(ESMF_Field) :: fldsrc - type(ESMF_Field) :: flddst - integer :: n,n1,n2,m,nf,id,nflds - integer :: fieldCount - character(len=CX) :: mapfile - integer :: mapindex - logical :: mapexists = .false. - character(len=CX) :: fieldname + type(InternalState) :: is_local + type(ESMF_Field) :: fldsrc + type(ESMF_Field) :: flddst + integer :: n1,n2 + integer :: n,m,nf,id,nflds + integer :: fieldCount + character(len=CL) :: fieldname + type(ESMF_Field), pointer :: fieldlist(:) + type(ESMF_Field) :: field_src + character(len=CX) :: mapfile + integer :: mapindex + logical :: mapexists = .false. + real(R8), pointer :: dataptr(:) + type(ESMF_Mesh) :: mesh_src + type(ESMF_Mesh) :: mesh_dst character(len=*), parameter :: subname=' (module_med_map: RouteHandles_init) ' !----------------------------------------------------------- @@ -111,7 +123,10 @@ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogun call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ! -------------------------------------------------------------- ! Create the necessary route handles + ! -------------------------------------------------------------- + ! First loop over source and destination components components if (mastertask) write(logunit,*) ' ' do n1 = 1, ncomps @@ -122,15 +137,22 @@ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogun call med_methods_FB_getFieldN(is_local%wrap%FBImp(n1,n1), 1, fldsrc, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Check number of fields in FB and get destination field + ! Check number of fields in source FB on destination mesh and get destination field + if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(n1,n2))) then + call ESMF_LogWrite(trim(subname)//'FBImp('//trim(compname(n1))//','//trim(compname(n2))//')'// & + ' has not been created', ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + end if call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n2), fieldCount=fieldCount, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (fieldCount == 0) then call med_methods_FB_getFieldN(is_local%wrap%FBExp(n2), 1, flddst, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return else call med_methods_FB_getFieldN(is_local%wrap%FBImp(n1,n2), 1, flddst, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return end if - if (chkerr(rc,__LINE__,u_FILE_u)) return ! Loop over fields do nf = 1,size(fldListFr(n1)%flds) @@ -154,11 +176,96 @@ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogun 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 coupling active end if ! if n1 not equal to n2 end do ! loop over n2 end do ! loop over n1 + ! -------------------------------------------------------------- + ! Initialize unity normalization fields and do the mapping for + ! unity normalization up front + ! -------------------------------------------------------------- + + if (mastertask) then + write(logunit,*) + write(logunit,'(a)') trim(subname)//"Initializing unity map normalizations" + endif + + ! Create the destination normalization field + do n1 = 1,ncomps + + ! Since coupling could be uni-directional, the import FB could be + ! available but number of fields could be zero, so it is better to + ! check export FB if this is the case + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(n1,n1)) .or. & + ESMF_FieldBundleIsCreated(is_local%wrap%FBExp(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 + if (fieldCount == 0) then + if (mastertask) then + write(logunit,*) trim(subname)//' '//trim(compname(n1))//' import FB field count is = ', fieldCount + write(logunit,*) trim(subname)//' '//trim(compname(n1))//' trying to use export FB' + end if + call ESMF_FieldBundleGet(is_local%wrap%FBExp(n1), fieldCount=fieldCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(fieldlist(fieldcount)) + call ESMF_FieldBundleGet(is_local%wrap%FBExp(n1), fieldlist=fieldlist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + allocate(fieldlist(fieldcount)) + call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n1), fieldlist=fieldlist, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + 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 + + ! Loop over destination components + 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 + + ! 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 + + ! Create is_local%wrap%field_NormOne(n1,n2,mapindex) if appropriate (don't create if mapping is redist) + do mapindex = 1,nmappers + if (mapindex /= mapfcopy .and. med_map_RH_is_created(is_local%wrap%RH,n1,n2,mapindex,rc=rc)) then + is_local%wrap%field_NormOne(n1,n2,mapindex) = ESMF_FieldCreate(mesh_dst, & + ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(is_local%wrap%field_NormOne(n1,n2,mapindex), 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,mapindex), & + routehandles=is_local%wrap%RH(n1,n2,:), maptype=mapindex, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,'(a)') trim(subname)//' created field_NormOne for '& + //compname(n1)//'->'//compname(n2)//' with mapping '//trim(mapnames(mapindex)) + end if + end if + end do ! end of loop over map_indiex 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 @@ -257,9 +364,9 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, integer :: srcMaskValue integer :: dstMaskValue character(len=ESMF_MAXSTR) :: lmapfile - logical :: rhprint = .false. + logical :: rhprint = .false., ldstprint = .false. integer :: ns - integer(I4), pointer :: dof(:) => null() + integer(I4), pointer :: dof(:) 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) ' @@ -278,6 +385,8 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, if (chkerr(rc,__LINE__,u_FILE_u)) return dststatusfield = ESMF_FieldCreate(dstmesh, ESMF_TYPEKIND_I4, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ! set local flag to false + ldstprint = .false. if (trim(coupling_mode) == 'cesm') then dstMaskValue = ispval_mask @@ -357,6 +466,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. end if else if (mapindex == mapfillv_bilnr) then if (mastertask) then @@ -372,6 +482,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mapbilnr_nstod) then if (mastertask) then write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string) @@ -387,6 +498,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mapconsf .or. mapindex == mapnstod_consf) then if (mastertask) then write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string) @@ -402,6 +514,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mapconsf_aofrac) then if (.not. ESMF_RouteHandleIsCreated(routehandles(mapconsf))) then if (mastertask) then @@ -418,6 +531,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else ! Copy existing consf RH if (mastertask) then @@ -441,6 +555,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. else if (mapindex == mappatch .or. mapindex == mappatch_uv3d) then if (.not. ESMF_RouteHandleIsCreated(routehandles(mappatch))) then if (mastertask) then @@ -456,6 +571,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstStatusField=dststatusfield, & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. end if else if (mastertask) then @@ -468,30 +584,28 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, end if ! Output destination status field to file if requested - if (dststatus_print) then - if (mapindex /= mapfcopy .or. lmapfile /= 'unset') then - fname = 'dststatus.'//trim(compname(n1))//'.'//trim(compname(n2))//'.'//trim(mapname)//'.nc' - call ESMF_LogWrite(trim(subname)//": writing dstStatusField to "//trim(fname), ESMF_LOGMSG_INFO) - - call ESMF_FieldWrite(dststatusfield, filename=trim(fname), variableName='dststatus', & - overwrite=.true., rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! the sequence index in order to sort the dststatus field - call ESMF_MeshGet(dstmesh, elementDistgrid=distgrid, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_DistGridGet(distgrid, localDE=0, elementCount=ns, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(dof(ns)) - call ESMF_DistGridGet(distgrid, localDE=0, seqIndexList=dof, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - doffield = ESMF_FieldCreate(dstmesh, dof, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldWrite(doffield, fileName='dof.'//trim(compname(n2))//'.nc', variableName='dof', & - overwrite=.true., rc=rc) - deallocate(dof) - call ESMF_FieldDestroy(doffield, rc=rc, noGarbage=.true.) - end if + if (dststatus_print .and. ldstprint) then + fname = 'dststatus.'//trim(compname(n1))//'.'//trim(compname(n2))//'.'//trim(mapname)//'.nc' + call ESMF_LogWrite(trim(subname)//": writing dstStatusField to "//trim(fname), ESMF_LOGMSG_INFO) + + call ESMF_FieldWrite(dststatusfield, filename=trim(fname), variableName='dststatus', & + overwrite=.true., rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the sequence index in order to sort the dststatus field + call ESMF_MeshGet(dstmesh, elementDistgrid=distgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_DistGridGet(distgrid, localDE=0, elementCount=ns, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(dof(ns)) + call ESMF_DistGridGet(distgrid, localDE=0, seqIndexList=dof, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + doffield = ESMF_FieldCreate(dstmesh, dof, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldWrite(doffield, fileName='dof.'//trim(compname(n2))//'.nc', variableName='dof', & + overwrite=.true., rc=rc) + deallocate(dof) + call ESMF_FieldDestroy(doffield, rc=rc, noGarbage=.true.) end if ! consd_nstod method requires a second routehandle @@ -506,9 +620,10 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ldstprint = .true. ! Output destination status field to file if requested - if (dststatus_print) then + if (dststatus_print .and. ldstprint) then fname = 'dststatus.'//trim(compname(n1))//'.'//trim(compname(n2))//'.'//trim(mapname)//'_2.nc' call ESMF_LogWrite(trim(subname)//": writing dstStatusField to "//trim(fname), ESMF_LOGMSG_INFO) @@ -517,14 +632,6 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, end if 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 @@ -610,140 +717,6 @@ logical function med_map_RH_is_created_RH1d(RHs,mapindex,rc) end function med_map_RH_is_created_RH1d - !================================================================================ - subroutine med_map_mapnorm_init(gcomp, rc) - - !--------------------------------------- - ! 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 - 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(out) :: rc - - ! local variables - type(InternalState) :: is_local - integer :: n1, n2, m - 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(trim(subname)//": start", ESMF_LOGMSG_INFO) - endif - if (mastertask) then - write(logunit,*) - write(logunit,'(a)') trim(subname)//"Initializing unity map normalizations" - endif - - ! 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 destination normalization field - do n1 = 1,ncomps - - ! Since coupling could be uni-directional, the import FB could be - ! available but number of fields could be zero, so it is better to - ! check export FB if this is the case - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(n1,n1)) .or. & - ESMF_FieldBundleIsCreated(is_local%wrap%FBExp(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 - - if (fieldCount == 0) then - if (mastertask) then - write(logunit,*) trim(subname)//' '//trim(compname(n1))//' import FB field count is = ', fieldCount - write(logunit,*) trim(subname)//' '//trim(compname(n1))//' trying to use export FB' - end if - call ESMF_FieldBundleGet(is_local%wrap%FBExp(n1), fieldCount=fieldCount, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(fieldlist(fieldcount)) - call ESMF_FieldBundleGet(is_local%wrap%FBExp(n1), fieldlist=fieldlist, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - allocate(fieldlist(fieldcount)) - call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n1), fieldlist=fieldlist, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - - 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 - - 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 - - ! 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 - - ! Create is_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 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(logunit,'(a)') trim(subname)//' created field_NormOne for '& - //compname(n1)//'->'//compname(n2)//' with mapping '//trim(mapnames(m)) - endif - end if - 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 - !================================================================================ subroutine med_map_packed_field_create(destcomp, flds_scalar_name, & fldsSrc, FBSrc, FBDst, packed_data, rc) @@ -768,15 +741,15 @@ subroutine med_map_packed_field_create(destcomp, flds_scalar_name, & 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() + real(r8), pointer :: ptrsrc_packed(:,:) + real(r8), pointer :: ptrdst_packed(:,:) 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() + type(ESMF_Field), pointer :: fieldlist_src(:) + type(ESMF_Field), pointer :: fieldlist_dst(:) character(CL), allocatable :: fieldNameList(:) character(CS) :: mapnorm_mapindex character(len=CX) :: tmpstr @@ -928,8 +901,10 @@ subroutine med_map_packed_field_create(destcomp, flds_scalar_name, & packed_data(mapindex)%field_fracsrc = ESMF_FieldCreate(lmesh_src, ESMF_TYPEKIND_R8, & meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return packed_data(mapindex)%field_fracdst = ESMF_FieldCreate(lmesh_dst, ESMF_TYPEKIND_R8, & meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return end if end do ! end loop over mapindex @@ -968,17 +943,17 @@ subroutine med_map_field_packed(FBSrc, FBDst, FBFracSrc, field_normOne, packed_d integer :: fieldcount integer :: mapindex integer :: ungriddedUBound(1) - real(r8), pointer :: dataptr1d(:) => null() - real(r8), pointer :: dataptr2d(:,:) => null() - real(r8), pointer :: dataptr2d_packed(:,:) => null() + real(r8), pointer :: dataptr1d(:) + real(r8), pointer :: dataptr2d(:,:) + real(r8), pointer :: dataptr2d_packed(:,:) 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), pointer :: fieldlist_src(:) + type(ESMF_Field), pointer :: fieldlist_dst(:) 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() + real(r8), pointer :: data_norm(:) + real(r8), pointer :: data_dst(:,:) character(len=*), parameter :: subname=' (module_MED_map:med_map_field_packed) ' !----------------------------------------------------------- @@ -1082,6 +1057,7 @@ subroutine med_map_field_packed(FBSrc, FBDst, FBFracSrc, field_normOne, packed_d maptype=mapindex, & field_normsrc=field_fracsrc, & field_normdst=packed_data(mapindex)%field_fracdst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return else if ( trim(packed_data(mapindex)%mapnorm) == 'one' .or. trim(packed_data(mapindex)%mapnorm) == 'none') then @@ -1179,14 +1155,14 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, ! 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() + real(r8), pointer :: data_src2d(:,:) + real(r8), pointer :: data_dst2d(:,:) + real(r8), pointer :: data_srctmp2d(:,:) + real(r8), pointer :: data_src1d(:) + real(r8), pointer :: data_dst1d(:) + real(r8), pointer :: data_srctmp1d(:) + real(r8), pointer :: data_normsrc(:) + real(r8), pointer :: data_normdst(:) integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields integer :: lsize_src integer :: lsize_dst @@ -1394,14 +1370,14 @@ subroutine med_map_uv_cart3d(FBsrc, FBdst, routehandles, mapindex, rc) real(r8) :: ux,uy,uz type(ESMF_Mesh) :: lmesh_src type(ESMF_Mesh) :: lmesh_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() + 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(:) integer :: numOwnedElements integer :: spatialDim real(r8), parameter :: deg2rad = shr_const_pi/180.0_R8 ! deg to rads diff --git a/mediator/med_merge_mod.F90 b/mediator/med_merge_mod.F90 index 3d0d6bbd4..c226b1ab9 100644 --- a/mediator/med_merge_mod.F90 +++ b/mediator/med_merge_mod.F90 @@ -7,8 +7,6 @@ module med_merge_mod 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 : logunit use med_constants_mod , only : dbug_flag => med_constants_dbug_flag - use med_constants_mod , only : spval_init => med_constants_spval_init - use med_constants_mod , only : spval => med_constants_spval 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 @@ -25,6 +23,11 @@ module med_merge_mod public :: med_merge_auto public :: med_merge_field + interface med_merge_auto ; module procedure & + med_merge_auto_single_fldbun, & + med_merge_auto_multi_fldbuns + end interface + interface med_merge_field ; module procedure & med_merge_field_1D end interface @@ -38,25 +41,22 @@ module med_merge_mod contains !=============================================================================== - subroutine med_merge_auto(compout, coupling_active, FBOut, FBfrac, FBImp, fldListTo, & - FBMed1, FBMed2, rc) + subroutine med_merge_auto_multi_fldbuns(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 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 + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR, ESMF_LogSetError ! ---------------------------------------------- ! Auto merge based on fldListTo info ! ---------------------------------------------- ! input/output variables - 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(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 @@ -75,13 +75,11 @@ subroutine med_merge_auto(compout, coupling_active, FBOut, FBfrac, FBImp, fldLis 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(CL) , pointer :: fieldnamelist(:) + type(ESMF_Field), pointer :: fieldlist(:) + real(r8), pointer :: dataptr1d(:) + real(r8), pointer :: dataptr2d(:,:) logical :: zero_output - character(CL) :: fldname character(len=*),parameter :: subname=' (module_med_merge_mod: med_merge_auto)' !--------------------------------------- @@ -136,12 +134,10 @@ subroutine med_merge_auto(compout, coupling_active, FBOut, FBfrac, FBImp, fldLis 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) @@ -207,7 +203,139 @@ subroutine med_merge_auto(compout, coupling_active, FBOut, FBfrac, FBImp, fldLis call t_stopf('MED:'//subname) - end subroutine med_merge_auto + end subroutine med_merge_auto_multi_fldbuns + + !=============================================================================== + subroutine med_merge_auto_single_fldbun(compsrc, FBOut, FBfrac, FBIn, fldListTo, rc) + + ! ---------------------------------------------- + ! Auto merge from one import field bundle based on fldListTo info. + ! Want to loop over all of the fields in FBout here - and find the + ! corresponding index in fldListTo for that field name - then call + ! the corresponding merge routine below appropriately. + ! ---------------------------------------------- + + 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 + + ! input/output variables + integer , intent(in) :: compsrc + 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) :: FBIn ! Single field bundle to merge to the FBOut mesh + type(med_fldList_type) , intent(in) :: fldListTo ! Information for merging + integer , intent(out) :: rc + + ! local variables + integer :: nfld_out,nfld_in,nm + 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(:) + integer :: ungriddedUBound_out(1) ! size of ungridded dimension + integer :: fieldcount + character(CL) , pointer :: fieldnamelist(:) + type(ESMF_Field), pointer :: fieldlist(:) + real(r8), pointer :: dataptr1d(:) + real(r8), pointer :: dataptr2d(:,:) + logical :: zero_output + character(len=*),parameter :: subname=' (module_med_merge_mod: med_merge_auto)' + !--------------------------------------- + + call t_startf('MED:'//subname) + + rc = ESMF_SUCCESS + + 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 + + ! Loop over all fields in output field bundle FBOut + do nfld_out = 1,fieldcount + zero_output = .true. + + ! Loop over the field in fldListTo to get fieldname and merging type + do nfld_in = 1,med_fldList_GetNumFlds(fldListTo) + + 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 + + ! 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 + + ! Initialize initial output field data to zero before doing merge + if (zero_output) then + 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 + zero_output = .false. + end if + + ! Perform merge + call med_merge_auto_field(trim(merge_type), fieldlist(nfld_out), ungriddedUBound_out, & + FB=FBIn, FBFld=merge_field, FBw=FBfrac, fldw=trim(merge_fracname), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end do ! end of nm loop + end if ! end of check of merge_type and merge_field not unset + 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 + + deallocate(fieldnamelist) + deallocate(fieldlist) + + if (dbug_flag > 1) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + end if + + call t_stopf('MED:'//subname) + + end subroutine med_merge_auto_single_fldbun !=============================================================================== subroutine med_merge_auto_field(merge_type, field_out, ungriddedUBound_out, & @@ -232,11 +360,11 @@ subroutine med_merge_auto_field(merge_type, field_out, ungriddedUBound_out, & integer :: n type(ESMF_Field) :: field_wgt type(ESMF_Field) :: field_in - real(R8), pointer :: dp1 (:) => null() - real(R8), pointer :: dp2(:,:) => null() ! output pointers to 1d and 2d fields - real(R8), pointer :: dpf1(:) => null() - real(R8), pointer :: dpf2(:,:) => null() ! intput pointers to 1d and 2d fields - real(R8), pointer :: dpw1(:) => null() ! weight pointer + real(R8), pointer :: dp1 (:) + real(R8), pointer :: dp2(:,:) ! output pointers to 1d and 2d fields + real(R8), pointer :: dpf1(:) + real(R8), pointer :: dpf2(:,:) ! intput pointers to 1d and 2d fields + real(R8), pointer :: dpw1(:) ! weight pointer character(len=*),parameter :: subname=' (med_merge_mod: med_merge_auto_field)' !--------------------------------------- @@ -439,9 +567,9 @@ subroutine med_merge_field_1D(FBout, fnameout, & integer , intent(out) :: rc ! local variables - real(R8), pointer :: dataOut(:) => null() - real(R8), pointer :: dataPtr(:) => null() - real(R8), pointer :: wgt(:) => null() + real(R8), pointer :: dataOut(:) + real(R8), pointer :: dataPtr(:) + real(R8), pointer :: wgt(:) integer :: lb1,ub1,i,j,n logical :: wgtfound, FBinfound integer :: dbrc diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index fc9e55e97..f25b024cd 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -19,14 +19,6 @@ module med_methods_mod implicit none private - interface med_methods_FB_accum ; module procedure & - med_methods_FB_accumFB2FB - end interface - - interface med_methods_FB_copy ; module procedure & - med_methods_FB_copyFB2FB - end interface - interface med_methods_FieldPtr_compare ; module procedure & med_methods_FieldPtr_compare1, & med_methods_FieldPtr_compare2 @@ -76,8 +68,6 @@ module med_methods_mod private med_methods_Mesh_Print private med_methods_Grid_Print private med_methods_Field_GetFldPtr - private med_methods_FB_copyFB2FB - private med_methods_FB_accumFB2FB private med_methods_Array_diagnose !----------------------------------------------------------------------------- @@ -116,8 +106,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(:) => null() - real(R8), pointer :: dataptr2d(:,:) => null() + real(R8), pointer :: dataptr1d(:) + real(R8), pointer :: dataptr2d(:,:) character(ESMF_MAXSTR), allocatable :: lfieldNameList(:) character(len=*), parameter :: subname='(med_methods_FB_init_pointer)' ! ---------------------------------------------- @@ -178,8 +168,10 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r ! set ungridded dimensions and GridToFieldMap for field call ESMF_AttributeGet(lfield, name="UngriddedLBound", convention="NUOPC", & purpose="Instance", valueList=ungriddedLBound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_AttributeGet(lfield, name="UngriddedUBound", convention="NUOPC", & purpose="Instance", valueList=ungriddedUBound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_AttributeGet(lfield, name="GridToFieldMap", convention="NUOPC", & purpose="Instance", valueList=gridToFieldMap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -474,8 +466,10 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S allocate(ungriddedLBound(ungriddedCount), ungriddedUBound(ungriddedCount)) call ESMF_AttributeGet(lfield, name="UngriddedLBound", convention="NUOPC", & purpose="Instance", valueList=ungriddedLBound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_AttributeGet(lfield, name="UngriddedUBound", convention="NUOPC", & purpose="Instance", valueList=ungriddedUBound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_AttributeGet(lfield, name="GridToFieldMap", convention="NUOPC", & purpose="Instance", itemCount=gridToFieldMapCount, rc=rc) @@ -545,7 +539,7 @@ subroutine med_methods_FB_getNameN(FB, fieldnum, fieldname, rc) ! local variables integer :: fieldCount - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) character(len=*),parameter :: subname='(med_methods_FB_getNameN)' ! ---------------------------------------------- @@ -629,7 +623,7 @@ subroutine med_methods_State_getNameN(State, fieldnum, fieldname, rc) ! local variables integer :: fieldCount - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) character(len=*),parameter :: subname='(med_methods_State_getNameN)' ! ---------------------------------------------- @@ -676,8 +670,7 @@ subroutine med_methods_State_getNumFields(State, fieldnum, rc) ! local variables integer :: n,itemCount - type(ESMF_Field), pointer :: fieldList(:) => null() - type(ESMF_StateItem_Flag), pointer :: itemTypeList(:) => null() + type(ESMF_Field), pointer :: fieldList(:) character(len=*),parameter :: subname='(med_methods_State_getNumFields)' ! ---------------------------------------------- @@ -719,12 +712,12 @@ subroutine med_methods_FB_reset(FB, value, rc) ! local variables integer :: i,j,n integer :: fieldCount - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) real(R8) :: lvalue type(ESMF_Field) :: lfield integer :: lrank - real(R8), pointer :: fldptr1(:) => null() - real(R8), pointer :: fldptr2(:,:) => null() + real(R8), pointer :: fldptr1(:) + real(R8), pointer :: fldptr2(:,:) character(len=*),parameter :: subname='(med_methods_FB_reset)' ! ---------------------------------------------- @@ -797,12 +790,12 @@ subroutine med_methods_State_reset(State, value, rc) ! local variables integer :: i,j,n integer :: fieldCount - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) real(R8) :: lvalue type(ESMF_Field) :: lfield integer :: lrank - real(R8), pointer :: fldptr1(:) => null() - real(R8), pointer :: fldptr2(:,:) => null() + real(R8), pointer :: fldptr1(:) + real(R8), pointer :: fldptr2(:,:) character(len=*),parameter :: subname='(med_methods_State_reset)' ! ---------------------------------------------- @@ -865,9 +858,9 @@ subroutine med_methods_FB_average(FB, count, rc) ! local variables integer :: i,j,n integer :: fieldCount, lrank - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() - real(R8), pointer :: dataPtr1(:) => null() - real(R8), pointer :: dataPtr2(:,:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(R8), pointer :: dataPtr1(:) + real(R8), pointer :: dataPtr2(:,:) type(ESMF_Field) :: lfield character(len=*),parameter :: subname='(med_methods_FB_average)' ! ---------------------------------------------- @@ -943,10 +936,10 @@ subroutine med_methods_FB_diagnose(FB, string, rc) ! local variables integer :: i,j,n integer :: fieldCount, lrank - character(ESMF_MAXSTR), pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR), pointer :: lfieldnamelist(:) character(len=CL) :: lstring - real(R8), pointer :: dataPtr1d(:) => null() - real(R8), pointer :: dataPtr2d(:,:) => null() + real(R8), pointer :: dataPtr1d(:) + real(R8), pointer :: dataPtr2d(:,:) type(ESMF_Field) :: lfield character(len=*), parameter :: subname='(med_methods_FB_diagnose)' ! ---------------------------------------------- @@ -1027,7 +1020,7 @@ subroutine med_methods_Array_diagnose(array, string, rc) ! local variables character(len=CS) :: lstring - real(R8), pointer :: dataPtr3d(:,:,:) => null() + real(R8), pointer :: dataPtr3d(:,:,:) character(len=*),parameter :: subname='(med_methods_Array_diagnose)' ! ---------------------------------------------- @@ -1077,10 +1070,10 @@ subroutine med_methods_State_diagnose(State, string, rc) ! local variables integer :: i,j,n integer :: fieldCount, lrank - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) character(len=CS) :: lstring - real(R8), pointer :: dataPtr1d(:) => null() - real(R8), pointer :: dataPtr2d(:,:) => null() + real(R8), pointer :: dataPtr1d(:) + real(R8), pointer :: dataPtr2d(:,:) type(ESMF_Field) :: lfield character(len=*),parameter :: subname='(med_methods_State_diagnose)' ! ---------------------------------------------- @@ -1160,8 +1153,8 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc) ! local variables integer :: lrank character(len=CS) :: lstring - real(R8), pointer :: dataPtr1d(:) => null() - real(R8), pointer :: dataPtr2d(:,:) => null() + real(R8), pointer :: dataPtr1d(:) + real(R8), pointer :: dataPtr2d(:,:) type(ESMF_Field) :: lfield integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields character(len=*),parameter :: subname='(med_methods_FB_Field_diagnose)' @@ -1227,8 +1220,8 @@ subroutine med_methods_Field_diagnose(field, fieldname, string, rc) ! local variables integer :: lrank character(len=CS) :: lstring - real(R8), pointer :: dataPtr1d(:) => null() - real(R8), pointer :: dataPtr2d(:,:) => null() + real(R8), pointer :: dataPtr1d(:) + real(R8), pointer :: dataPtr2d(:,:) character(len=*),parameter :: subname='(med_methods_Field_diagnose)' ! ---------------------------------------------- @@ -1280,7 +1273,7 @@ end subroutine med_methods_Field_diagnose !----------------------------------------------------------------------------- - subroutine med_methods_FB_copyFB2FB(FBout, FBin, rc) + subroutine med_methods_FB_copy(FBout, FBin, rc) ! ---------------------------------------------- ! Copy common field names from FBin to FBout @@ -1291,7 +1284,7 @@ subroutine med_methods_FB_copyFB2FB(FBout, FBin, rc) type(ESMF_FieldBundle), intent(inout) :: FBout type(ESMF_FieldBundle), intent(in) :: FBin integer , intent(out) :: rc - character(len=*), parameter :: subname='(med_methods_FB_copyFB2FB)' + character(len=*), parameter :: subname='(med_methods_FB_copy)' ! ---------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1304,11 +1297,11 @@ subroutine med_methods_FB_copyFB2FB(FBout, FBin, rc) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) endif - end subroutine med_methods_FB_copyFB2FB + end subroutine med_methods_FB_copy !----------------------------------------------------------------------------- - subroutine med_methods_FB_accumFB2FB(FBout, FBin, copy, rc) + subroutine med_methods_FB_accum(FBout, FBin, copy, rc) ! ---------------------------------------------- ! Accumulate common field names from FBin to FBout @@ -1326,15 +1319,15 @@ subroutine med_methods_FB_accumFB2FB(FBout, FBin, copy, rc) ! local variables integer :: i,j,n integer :: fieldCount, lranki, lranko - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) logical :: exists logical :: lcopy - real(R8), pointer :: dataPtri1(:) => null() - real(R8), pointer :: dataPtro1(:) => null() - real(R8), pointer :: dataPtri2(:,:) => null() - real(R8), pointer :: dataPtro2(:,:) => null() + real(R8), pointer :: dataPtri1(:) + real(R8), pointer :: dataPtro1(:) + real(R8), pointer :: dataPtri2(:,:) + real(R8), pointer :: dataPtro2(:,:) type(ESMF_Field) :: lfield - character(len=*), parameter :: subname='(med_methods_FB_accumFB2FB)' + character(len=*), parameter :: subname='(med_methods_FB_accum)' ! ---------------------------------------------- if (dbug_flag > 10) then @@ -1427,7 +1420,7 @@ subroutine med_methods_FB_accumFB2FB(FBout, FBin, copy, rc) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) endif - end subroutine med_methods_FB_accumFB2FB + end subroutine med_methods_FB_accum !----------------------------------------------------------------------------- @@ -1755,7 +1748,7 @@ subroutine med_methods_State_GeomPrint(state, string, rc) ! local variables type(ESMF_Field) :: lfield integer :: fieldcount - character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null() + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) character(ESMF_MAXSTR) :: name character(len=*),parameter :: subname='(med_methods_State_GeomPrint)' ! ---------------------------------------------- @@ -1840,8 +1833,8 @@ subroutine med_methods_Field_GeomPrint(field, string, rc) type(ESMF_Grid) :: lgrid type(ESMF_Mesh) :: lmesh integer :: lrank - real(R8), pointer :: dataPtr1(:) => null() - real(R8), pointer :: dataPtr2(:,:) => null() + real(R8), pointer :: dataPtr1(:) + real(R8), pointer :: dataPtr2(:,:) type(ESMF_GeomType_Flag) :: geomtype character(len=*),parameter :: subname='(med_methods_Field_GeomPrint)' ! ---------------------------------------------- @@ -2084,10 +2077,10 @@ subroutine med_methods_Grid_Print(grid, string, rc) type(ESMF_TypeKind_Flag) :: coordTypeKind character(len=32) :: staggerstr integer, allocatable :: minIndexPTile(:,:), maxIndexPTile(:,:) - real, pointer :: fldptrR41D(:) => null() - real, pointer :: fldptrR42D(:,:) => null() - real(R8), pointer :: fldptrR81D(:) => null() - real(R8), pointer :: fldptrR82D(:,:) => null() + real, pointer :: fldptrR41D(:) + real, pointer :: fldptrR42D(:,:) + real(R8), pointer :: fldptrR81D(:) + real(R8), pointer :: fldptrR82D(:,:) integer :: n1,n2,n3 character(len=*),parameter :: subname='(med_methods_Grid_Print)' ! ---------------------------------------------- @@ -2286,7 +2279,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(:,:) => null() + real(R8), pointer :: farrayptr(:,:) real(r8) :: tmp(1) character(len=*), parameter :: subname='(med_methods_State_GetScalar)' ! ---------------------------------------------- @@ -2350,7 +2343,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(:,:) => null() + real(R8), pointer :: farrayptr(:,:) character(len=*), parameter :: subname='(med_methods_State_SetScalar)' ! ---------------------------------------------- @@ -2504,7 +2497,7 @@ subroutine med_methods_FB_getmesh(FB, mesh, rc) ! local variables integer :: fieldCount - type(ESMF_Field), pointer :: fieldlist(:) => null() + type(ESMF_Field), pointer :: fieldlist(:) ! ---------------------------------------------- rc = ESMF_SUCCESS diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index e967cbf9b..42382d3d9 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -1,15 +1,33 @@ module med_phases_aofluxes_mod + ! -------------------------------------------------------------------------- + ! Determine atm/ocn flux calculation in mediator - for one of 3 cases: + ! if aoflux grid is ocn + ! - map atm attributes of aoflux_in to ocn and map aoflux_out back to atm + ! if aoflux grid is atm + ! - map ocn attributes of oaflux_in to atm and map aoflux_out back to ocn + ! if aoflux grid is exchange + ! - map both atm and ocn attributes of aoflux_in to xgrid and then + ! map aoflux_out from xgrid to both atm and ocn grid + ! -------------------------------------------------------------------------- + + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet + use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate, ESMF_FieldIsCreated, ESMF_FieldDestroy + use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet + use ESMF , only : ESMF_FieldBundleCreate, ESMF_FieldBundleAdd + use ESMF , only : ESMF_RouteHandle, ESMF_FieldRegrid, ESMF_FieldRegridStore + use ESMF , only : ESMF_REGRIDMETHOD_CONSERVE_2ND + use ESMF , only : ESMF_TERMORDER_SRCSEQ, ESMF_REGION_TOTAL, ESMF_MESHLOC_ELEMENT, ESMF_MAXSTR + use ESMF , only : ESMF_XGRIDSIDE_B, ESMF_XGRIDSIDE_A, ESMF_END_ABORT, ESMF_LOGERR_PASSTHRU + use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_XGrid, ESMF_XGridCreate, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LOGMSG_ERROR, ESMF_FAILURE + use ESMF , only : ESMF_Finalize, ESMF_LogFoundError 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 - use med_internalstate_mod , only : mastertask, logunit + use med_internalstate_mod , only : InternalState, mastertask, logunit 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_map_mod , only : med_map_field_packed + use esmFlds , only : compatm, compocn, coupling_mode, mapconsd, mapconsf, mapfcopy use perf_mod , only : t_startf, t_stopf implicit none @@ -19,43 +37,78 @@ module med_phases_aofluxes_mod ! Public routines !-------------------------------------------------------------------------- - public :: med_phases_aofluxes_run + public :: med_phases_aofluxes_init_fldbuns + public :: med_phases_aofluxes_run !-------------------------------------------------------------------------- ! Private routines !-------------------------------------------------------------------------- private :: med_aofluxes_init - private :: med_aofluxes_run + private :: med_aofluxes_init_ogrid + private :: med_aofluxes_init_agrid + private :: med_aofluxes_init_xgrid + private :: med_aofluxes_update + private :: set_aoflux_in_pointers + private :: set_aoflux_out_pointers + private :: fldbun_getfldptr !-------------------------------------------------------------------------- ! Private data !-------------------------------------------------------------------------- - type aoflux_type - ! input - 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) + logical :: flds_wiso ! use case + logical :: compute_atm_dens + logical :: compute_atm_thbot + integer :: ocn_surface_flux_scheme ! use case + + character(len=CS), pointer :: fldnames_ocn_in(:) + character(len=CS), pointer :: fldnames_atm_in(:) + character(len=CS), pointer :: fldnames_aof_out(:) + + ! following is needed for atm/ocn fluxes on atm grid + type(ESMF_FieldBundle) :: FBocn_a ! ocean fields need for aoflux calc on atm grid + + ! following is needed for atm/ocn fluxes on the exchange grid + type(ESMF_FieldBundle) :: FBocn_x ! input ocn fields + type(ESMF_FieldBundle) :: FBatm_x ! input atm fields + type(ESMF_FieldBundle) :: FBaof_x ! output aoflux fields + type(ESMF_RouteHandle) :: rh_ogrid2xgrid ! ocn->xgrid mapping + type(ESMF_RouteHandle) :: rh_agrid2xgrid ! atm->xgrid mapping + type(ESMF_RouteHandle) :: rh_xgrid2ogrid ! xgrid->ocn mapping + type(ESMF_RouteHandle) :: rh_xgrid2agrid ! xgrid->atm mapping + type(ESMF_RouteHandle) :: rh_ogrid2xgrid_2ndord ! ocn->xgrid mapping 2nd order conservative + type(ESMF_RouteHandle) :: rh_agrid2xgrid_2ndord ! atm->xgrid mapping 2nd order conservative + type(ESMF_Field) :: field_ogrid2xgrid_normone + type(ESMF_Field) :: field_xgrid2agrid_normone + + type aoflux_in_type + ! input: ocn 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 :: roce_16O (:) => null() ! ocn H2O ratio + real(R8) , pointer :: roce_HDO (:) => null() ! ocn HDO ratio + real(R8) , pointer :: roce_18O (:) => null() ! ocn H218O ratio + ! input: atm 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 - ! output + 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 + ! local size and computational mask: on aoflux grid + integer :: lsize ! local size + integer , pointer :: mask (:) => null() ! integer ocn domain mask: 0 <=> inactive cell + real(R8) , pointer :: rmask (:) => null() ! real ocn domain mask: 0 <=> inactive cell + end type aoflux_in_type + + type aoflux_out_type real(R8) , pointer :: sen (:) => null() ! heat flux: sensible real(R8) , pointer :: lat (:) => null() ! heat flux: latent real(R8) , pointer :: lwup (:) => null() ! lwup over ocean @@ -65,21 +118,17 @@ module med_phases_aofluxes_mod 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 :: 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 :: 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 - - ! The following three variables are obtained as attributes from gcomp - logical :: flds_wiso ! use case - logical :: compute_atm_dens - logical :: compute_atm_thbot - integer :: ocn_surface_flux_scheme ! use case + end type aoflux_out_type + + character(len=CS) :: aoflux_grid + character(*), parameter :: u_FILE_u = & __FILE__ @@ -87,29 +136,119 @@ module med_phases_aofluxes_mod contains !================================================================================ - subroutine med_phases_aofluxes_run(gcomp, rc) + subroutine med_phases_aofluxes_init_fldbuns(gcomp, rc) + + use ESMF , only : ESMF_FieldBundleIsCreated + use esmFlds , only : med_fldList_GetNumFlds, med_fldList_GetFldNames, compname + use esmFlds , only : fldListMed_aoflux + use med_methods_mod , only : FB_init => med_methods_FB_init + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + integer :: n + integer :: fieldcount + type(InternalState) :: is_local + character(len=*),parameter :: subname=' (med_phases_aofluxes_init_fldbuns) ' + !--------------------------------------- + + ! Create field bundles for mediator ocean/atmosphere flux computation + ! This is needed regardless of the grid on which the atm/ocn flux computation is done on + + ! Get the internal state from the mediator Component. + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Set module variable fldnames_aof_out + fieldCount = med_fldList_GetNumFlds(fldListMed_aoflux) + allocate(fldnames_aof_out(fieldCount)) + call med_fldList_getfldnames(fldListMed_aoflux%flds, fldnames_aof_out, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Initialize FBMed_aoflux_a + call FB_init(is_local%wrap%FBMed_aoflux_a, is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateImp(compatm), fieldnamelist=fldnames_aof_out, name='FBMed_aoflux_a', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,*) + write(logunit,'(a)') trim(subname)//' initialized FB FBMed_aoflux_a' + end if + + ! Initialize FBMed_aoflux_o + call FB_init(is_local%wrap%FBMed_aoflux_o, is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateImp(compocn), fieldnamelist=fldnames_aof_out, name='FBMed_aoflux_o', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,'(a)') trim(subname)//' initialized FB FBMed_aoflux_o' + write(logunit,'(a)') trim(subname)//' following are the fields in FBMed_aoflux_o and FBMed_aoflux_a' + do n = 1,fieldcount + write(logunit,'(a)')' FBmed_aoflux fieldname = '//trim(fldnames_aof_out(n)) + end do + end if - use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_GridCompGet - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_FieldBundleIsCreated - 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 + ! Create required field bundles + if (is_local%wrap%aoflux_grid == 'ogrid' .or. is_local%wrap%aoflux_grid == 'agrid') then + + ! Create the field bundle is_local%wrap%FBImp(compatm,compocn) if needed + if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compatm,compocn), rc=rc)) then + if (mastertask) then + write(logunit,'(a)') trim(subname)//' creating field bundle FBImp(compatm,compocn)' + end if + call FB_init(is_local%wrap%FBImp(compatm,compocn), is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateImp(compocn), STflds=is_local%wrap%NStateImp(compatm), & + name='FBImp'//trim(compname(compatm))//'_'//trim(compname(compocn)), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (mastertask) then + write(logunit,'(a)') trim(subname)//' initializing FB for '// & + trim(compname(compatm))//'_'//trim(compname(compocn)) + end if + + ! Create the field bundle is_local%wrap%FBImp(compocn,compatm) if needed + if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compocn,compatm), rc=rc)) then + if (mastertask) then + write(logunit,'(a)') trim(subname)//' creating field bundle FBImp(compocn,compatm)' + end if + call FB_init(is_local%wrap%FBImp(compocn,compatm), is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateImp(compatm), STflds=is_local%wrap%NStateImp(compocn), & + name='FBImp'//trim(compname(compocn))//'_'//trim(compname(compatm)), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (mastertask) then + write(logunit,'(a)') trim(subname)//' initializing FB for '// & + trim(compname(compocn))//'_'//trim(compname(compatm)) + end if + + end if + + end subroutine med_phases_aofluxes_init_fldbuns + + !================================================================================ + subroutine med_phases_aofluxes_run(gcomp, rc) !----------------------------------------------------------------------- ! Compute atm/ocn fluxes !----------------------------------------------------------------------- + use NUOPC , only : NUOPC_CompAttributeGet + use ESMF , only : ESMF_FieldBundleIsCreated + use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose + use med_phases_history_mod, only : med_phases_history_write_med + ! input/output variables type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc ! local variables - type(InternalState) :: is_local - type(aoflux_type), save :: aoflux - logical, save :: first_call = .true. - character(len=*),parameter :: subname='(med_phases_aofluxes_run)' + type(InternalState) :: is_local + type(aoflux_in_type) , save :: aoflux_in + type(aoflux_out_type) , save :: aoflux_out + logical , save :: aoflux_created + logical , save :: first_call = .true. + character(len=*),parameter :: subname=' (med_phases_aofluxes_run) ' !--------------------------------------- rc = ESMF_SUCCESS @@ -124,87 +263,76 @@ subroutine med_phases_aofluxes_run(gcomp, rc) if ( ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_a, rc=rc) .and. & ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_o, rc=rc)) then - ! Allocate memoroy for the aoflux module data type (mediator atm/ocn field bundle on the ocean grid) - call med_aofluxes_init(gcomp, aoflux, & - FBAtm=is_local%wrap%FBImp(compatm,compocn), & - FBOcn=is_local%wrap%FBImp(compocn,compocn), & - FBFrac=is_local%wrap%FBfrac(compocn), & - FBMed_aoflux=is_local%wrap%FBMed_aoflux_o, rc=rc) + ! Allocate memroy for the aoflux module data type (mediator atm/ocn field bundle on the ocean grid) + call med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - aoflux%created = .true. + + aoflux_created = .true. else - aoflux%created = .false. + aoflux_created = .false. end if - ! Now set first_call to .false. first_call = .false. end if ! Return if there is no aoflux has not been created - if (.not. aoflux%created) then - RETURN - end if - - ! Start time timer - call t_startf('MED:'//subname) - - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) - endif - - call memcheck(subname, 5, mastertask) + if ( aoflux_created) then + ! Start time timer + call t_startf('MED:'//subname) + if (dbug_flag > 5) then + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + endif + call memcheck(subname, 5, mastertask) + + ! Calculate atm/ocn fluxes on the destination grid + call med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Calculate atm/ocn fluxes on the destination grid - call med_aofluxes_run(gcomp, aoflux, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Write mediator aofluxes + call med_phases_history_write_med(gcomp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 1) then - call FB_diagnose(is_local%wrap%FBMed_aoflux_o, & - string=trim(subname) //' FBAMed_aoflux_o' , rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (dbug_flag > 1) then + call FB_diagnose(is_local%wrap%FBMed_aoflux_o, & + string=trim(subname) //' FBAMed_aoflux_o' , rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + call t_stopf('MED:'//subname) end if - call t_stopf('MED:'//subname) - end subroutine med_phases_aofluxes_run -!================================================================================ + !================================================================================ + subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) - subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux, rc) + use NUOPC , only : NUOPC_CompAttributeGet + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LogFoundError + use ESMF , only : ESMF_SUCCESS, ESMF_LOGERR_PASSTHRU + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet + use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldBundle + use esmFlds , only : coupling_mode + use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk + use shr_flux_mod , only : shr_flux_adjust_constants - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LogFoundError - use ESMF , only : ESMF_SUCCESS, ESMF_LOGERR_PASSTHRU - 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 - use esmFlds , only : coupling_mode !----------------------------------------------------------------------- ! Initialize pointers to the module variables !----------------------------------------------------------------------- ! input/output variables - type(ESMF_GridComp) :: gcomp - type(aoflux_type) , intent(inout) :: aoflux - type(ESMF_FieldBundle) , intent(in) :: FBAtm ! Atm Import fields on aoflux grid - type(ESMF_FieldBundle) , intent(in) :: FBOcn ! Ocn Import fields on aoflux grid - type(ESMF_FieldBundle) , intent(in) :: FBfrac ! Fraction data for various components, on their grid - type(ESMF_FieldBundle) , intent(inout) :: FBMed_aoflux ! Ocn albedos computed in mediator - integer , intent(out) :: rc + type(ESMF_GridComp) , intent(inout) :: gcomp + type(aoflux_in_type) , intent(inout) :: aoflux_in + type(aoflux_out_type) , intent(inout) :: aoflux_out + integer , intent(out) :: rc ! local variables - integer :: iam - integer :: n - integer :: lsize - 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 implicit 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 + type(InternalState) :: is_local + integer :: n + character(CL) :: cvalue + character(len=CX) :: tmpstr + real(R8) :: flux_convergence ! convergence criteria for implicit 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) ' !----------------------------------------------------------------------- @@ -216,8 +344,13 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux, call t_startf('MED:'//subname) + ! Get the internal state from the mediator Component. + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + !---------------------------------- - ! get attributes that are set as module variables + ! Initialize module variables !---------------------------------- call NUOPC_CompAttributeGet(gcomp, name='flds_wiso', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) @@ -227,6 +360,45 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux, else flds_wiso = .false. end if + call NUOPC_CompAttributeGet(gcomp, name='ocn_surface_flux_scheme', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) ocn_surface_flux_scheme + else + ocn_surface_flux_scheme = 0 + end if + + ! bottom level potential temperature and/or botom level density + ! will need to be computed if not received from the atm + if (FB_fldchk(is_local%Wrap%FBImp(Compatm,Compatm), 'Sa_ptem', rc=rc)) then + compute_atm_thbot = .false. + else + compute_atm_thbot = .true. + end if + if (FB_fldchk(is_local%Wrap%FBImp(Compatm,Compatm), 'Sa_dens', rc=rc)) then + compute_atm_dens = .false. + else + compute_atm_dens = .true. + end if + + !---------------------------------- + ! Initialize aoflux + !---------------------------------- + + if (is_local%wrap%aoflux_grid == 'ogrid') then ! aoflux_grid is ocn + call med_aofluxes_init_ogrid(gcomp, aoflux_in, aoflux_out, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else if (is_local%wrap%aoflux_grid == 'agrid') then ! aoflux_grid is atm + call med_aofluxes_init_agrid(gcomp, aoflux_in, aoflux_out, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else if (is_local%wrap%aoflux_grid == 'xgrid') then ! aoflux_grid is exchange grid + call med_aofluxes_init_xgrid(gcomp, aoflux_in, aoflux_out, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + !---------------------------------- + ! Initialize shr_flux_adjust_constants + !---------------------------------- call NUOPC_CompAttributeGet(gcomp, name='coldair_outbreak_mod', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -235,7 +407,6 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux, 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 @@ -243,7 +414,6 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux, 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 @@ -251,325 +421,877 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux, else flux_convergence = 0.0_r8 end if - - call NUOPC_CompAttributeGet(gcomp, name='ocn_surface_flux_scheme', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) ocn_surface_flux_scheme - else - ocn_surface_flux_scheme = 0 - 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) - !---------------------------------- - ! atm/ocn fields - !---------------------------------- + if (dbug_flag > 5) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + endif + call t_stopf('MED:'//subname) - call FB_GetFldPtr(FBMed_aoflux, fldname='So_tref', fldptr1=aoflux%tref, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='So_qref', fldptr1=aoflux%qref, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='So_ustar', fldptr1=aoflux%ustar, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='So_re', fldptr1=aoflux%re, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='So_ssq', fldptr1=aoflux%ssq, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='So_u10', fldptr1=aoflux%u10, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='So_duu10n', fldptr1=aoflux%duu10n, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + end subroutine med_aofluxes_init - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_taux', fldptr1=aoflux%taux, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_tauy', fldptr1=aoflux%tauy, rc=rc) + !=============================================================================== + subroutine med_aofluxes_init_ogrid(gcomp, aoflux_in, aoflux_out, rc) + + ! -------------------------------------------- + ! Initialize aoflux data type and compute mask + ! for computations on ocn grid + ! -------------------------------------------- + + use ESMF , only : ESMF_FieldBundleIsCreated + use esmFlds , only : fldListMed_aoflux + use med_map_mod , only : med_map_packed_field_create + + ! Arguments + type(ESMF_GridComp) , intent(inout) :: gcomp + type(aoflux_in_type) , intent(inout) :: aoflux_in + type(aoflux_out_type) , intent(inout) :: aoflux_out + integer , intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + character(len=CX) :: tmpstr + integer :: lsize + integer :: fieldcount + character(len=*),parameter :: subname=' (med_aofluxes_init_ocngrid) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Get the internal state from the mediator Component. + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_lat', fldptr1=aoflux%lat, rc=rc) + + ! ------------------------ + ! input fields from atm and ocn on aofluxgrid + ! ------------------------ + call set_aoflux_in_pointers(is_local%wrap%FBImp(compatm,compocn), is_local%wrap%FBImp(compocn,compocn), & + aoflux_in, lsize, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_sen', fldptr1=aoflux%sen, rc=rc) + + ! ------------------------ + ! output fields from aoflux calculation + ! ------------------------ + call set_aoflux_out_pointers(is_local%wrap%FBMed_aoflux_o, lsize, aoflux_out, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_evap', fldptr1=aoflux%evap, rc=rc) + + ! ------------------------ + ! set aoflux computational mask on ocn grid + ! ------------------------ + ! default compute everywhere, then "turn off" gridcells + allocate(aoflux_in%mask(lsize)) + aoflux_in%mask(:) = 1 + write(tmpstr,'(i12,g22.12,i12)') lsize,sum(aoflux_in%rmask),sum(aoflux_in%mask) + call ESMF_LogWrite(trim(subname)//" : maskA= "//trim(tmpstr), ESMF_LOGMSG_INFO) + where (aoflux_in%rmask(:) == 0._R8) aoflux_in%mask(:) = 0 ! like nint + write(tmpstr,'(i12,g22.12,i12)') lsize,sum(aoflux_in%rmask),sum(aoflux_in%mask) + call ESMF_LogWrite(trim(subname)//" : maskB= "//trim(tmpstr), ESMF_LOGMSG_INFO) + + ! ------------------------ + ! create packed mapping from ocn->atm if aoflux_grid is ocn + ! ------------------------ + if (is_local%wrap%aoflux_grid == 'ogrid') then + 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(destcomp=compatm, & + flds_scalar_name=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 + end if + + end subroutine med_aofluxes_init_ogrid + + !=============================================================================== + subroutine med_aofluxes_init_agrid(gcomp, aoflux_in, aoflux_out, rc) + + ! -------------------------------------------- + ! Initialize aoflux data type and compute mask for computations on atm grid + ! - all aoflux fields are on the atm mesh + ! - input atm aoflux attributes are just pointers into is_local%wrap%FBImp(compatm,compatm) + ! - input ocn aoflux attributes are just pointers into is_local%wrap%FBImp(compocn,compatm) + ! - output aoflux attributes are on the atm mesh + ! -------------------------------------------- + + use med_methods_mod, only : FB_init => med_methods_FB_init + use med_map_mod , only : med_map_rh_is_created, med_map_field + + ! Arguments + type(ESMF_GridComp) , intent(inout) :: gcomp + type(aoflux_in_type) , intent(inout) :: aoflux_in + type(aoflux_out_type) , intent(inout) :: aoflux_out + integer , intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + integer :: lsize,n + integer :: fieldcount + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + real(r8), pointer :: dataptr1d(:) + type(ESMF_Mesh) :: mesh_src + type(ESMF_Mesh) :: mesh_dst + integer :: maptype + character(len=*),parameter :: subname=' (med_aofluxes_init_atmgrid) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - lsize = size(aoflux%evap) + ! ------------------------ + ! input fields from atm and ocn on atm grid + ! ------------------------ + if (flds_wiso) then - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_evap_16O', fldptr1=aoflux%evap_16O, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_evap_18O', fldptr1=aoflux%evap_18O, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_evap_HDO', fldptr1=aoflux%evap_HDO, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(fldnames_ocn_in(5)) + fldnames_ocn_in = (/'So_omask ','So_t ','So_u ','So_v ','So_roce_wiso' /) else - allocate(aoflux%evap_16O(lsize)); aoflux%evap_16O(:) = 0._R8 - allocate(aoflux%evap_18O(lsize)); aoflux%evap_18O(:) = 0._R8 - allocate(aoflux%evap_HDO(lsize)); aoflux%evap_HDO(:) = 0._R8 + allocate(fldnames_ocn_in(4)) + fldnames_ocn_in = (/'So_omask','So_t ','So_u ','So_v '/) end if + call FB_init(FBocn_a, is_local%wrap%flds_scalar_name, & + FBgeom=is_local%wrap%FBImp(compatm,compatm), fieldnamelist=fldnames_ocn_in, name='FBocn_a', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBMed_aoflux, fldname='Faox_lwup', fldptr1=aoflux%lwup, rc=rc) + call set_aoflux_in_pointers(is_local%wrap%FBImp(compatm,compatm), FBocn_a, aoflux_in, lsize, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - !---------------------------------- - ! Ocn import fields - !---------------------------------- + ! ------------------------ + ! output fields from aoflux calculation on atm grid + ! ------------------------ - call FB_GetFldPtr(FBOcn, fldname='So_omask', fldptr1=aoflux%rmask, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBOcn, fldname='So_t', fldptr1=aoflux%tocn, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBOcn, fldname='So_u', fldptr1=aoflux%uocn, rc=rc) + call set_aoflux_out_pointers(is_local%wrap%FBMed_aoflux_a, lsize, aoflux_out, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBOcn, fldname='So_v', fldptr1=aoflux%vocn, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (flds_wiso) then - call FB_GetFldPtr(FBOcn, fldname='So_roce_16O', fldptr1=aoflux%roce_16O, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBOcn, fldname='So_roce_18O', fldptr1=aoflux%roce_18O, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBOcn, fldname='So_roce_HDO', fldptr1=aoflux%roce_HDO, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! ------------------------ + ! Determine maptype for ocn->atm mapping + ! ------------------------ + + if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapfcopy, rc=rc)) then + maptype = mapfcopy + else if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapconsd, rc=rc)) then + maptype = mapconsd else - allocate(aoflux%roce_16O(lsize)); aoflux%roce_16O(:) = 0._R8 - allocate(aoflux%roce_18O(lsize)); aoflux%roce_18O(:) = 0._R8 - allocate(aoflux%roce_HDO(lsize)); aoflux%roce_HDO(:) = 0._R8 + call ESMF_LogWrite(trim(subname)//& + ": maptype for atm->ocn mapping of So_mask must be either mapfcopy or mapconsd", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return end if - !---------------------------------- - ! Atm import fields - !---------------------------------- + ! ------------------------ + ! set aoflux computational mask on atm grid + ! ------------------------ - call FB_GetFldPtr(FBAtm, fldname='Sa_z', fldptr1=aoflux%zbot, rc=rc) + ! Compute mask is the ocean mask mapped to atm grid (conservatively without fractions) + ! This computes So_omask in FBocn_a - but the assumption is that it already is there + ! Compute mask is the ocean mask mapped to atm grid (conservatively without fractions) + ! This computes So_omask in FBocn_a - but the assumption is that it already is there + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), 'So_omask', field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(FBocn_a, 'So_omask', field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call med_map_field( field_src=field_src, field_dst=field_dst, & + routehandles=is_local%wrap%RH(compocn,compatm,:), maptype=maptype, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_dst, farrayptr=dataptr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(aoflux_in%mask(lsize)) + do n = 1,lsize + if (dataptr1d(n) == 0._r8) then + aoflux_in%mask(n) = 0 + else + aoflux_in%mask(n) = 1 + end if + enddo - ! bulk formula quantities for nems_orig_data - if (trim(coupling_mode) == 'nems_orig_data' .and. ocn_surface_flux_scheme == -1) then - call FB_GetFldPtr(FBAtm, fldname='Sa_u10m', fldptr1=aoflux%ubot, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_v10m', fldptr1=aoflux%vbot, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_t2m', fldptr1=aoflux%tbot, rc=rc) + ! ------------------------ + ! set one normalization for ocn-atm mapping if needed + ! ------------------------ + + if (.not. ESMF_FieldIsCreated(is_local%wrap%field_NormOne(compocn,compatm,maptype))) then + ! Get source mesh + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), 'So_omask', field=field_src, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_src, mesh=mesh_src, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_q2m', fldptr1=aoflux%shum, rc=rc) + field_src = ESMF_FieldCreate(mesh_src, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - else - call FB_GetFldPtr(FBAtm, fldname='Sa_u', fldptr1=aoflux%ubot, rc=rc) + call ESMF_FieldGet(field_src, farrayptr=dataPtr1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_v', fldptr1=aoflux%vbot, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_tbot', fldptr1=aoflux%tbot, rc=rc) + dataptr1d(:) = 1.0_R8 + + ! Create field is_local%wrap%field_NormOne(compocn,compatm,maptype) and fill in its values + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compatm), 'So_omask', field=field_dst, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_dst, mesh=mesh_dst, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_shum', fldptr1=aoflux%shum, rc=rc) + is_local%wrap%field_NormOne(compocn,compatm,maptype) = ESMF_FieldCreate(mesh_dst, & + ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + call med_map_field( field_src=field_src, field_dst=is_local%wrap%field_NormOne(compocn,compatm,maptype), & + routehandles=is_local%wrap%RH(compocn,compatm,:), maptype=maptype, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - end if - ! bottom level potential temperature will need to be computed if not received from the atm - if (FB_fldchk(FBAtm, 'Sa_ptem', rc=rc)) then - call FB_GetFldPtr(FBAtm, fldname='Sa_ptem', fldptr1=aoflux%thbot, rc=rc) + call ESMF_FieldDestroy(field_src, rc=rc, noGarbage=.true.) if (chkerr(rc,__LINE__,u_FILE_u)) return - compute_atm_thbot = .false. - else - allocate(aoflux%thbot(lsize)) - compute_atm_thbot = .true. end if - ! bottom level density will need to be computed if not received from the atm - if (FB_fldchk(FBAtm, 'Sa_dens', rc=rc)) then - call FB_GetFldPtr(FBAtm, fldname='Sa_dens', fldptr1=aoflux%dens, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - compute_atm_dens = .false. - else - compute_atm_dens = .true. - allocate(aoflux%dens(lsize)) - end if + end subroutine med_aofluxes_init_agrid - ! if either density or potential temperature are computed, will need bottom level pressure - if (compute_atm_dens .or. compute_atm_thbot) then - call FB_GetFldPtr(FBAtm, fldname='Sa_pbot', fldptr1=aoflux%pbot, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end if + !=============================================================================== + subroutine med_aofluxes_init_xgrid(gcomp, aoflux_in, aoflux_out, rc) - if (flds_wiso) then - call FB_GetFldPtr(FBAtm, fldname='Sa_shum_16O', fldptr1=aoflux%shum_16O, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_shum_18O', fldptr1=aoflux%shum_18O, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(FBAtm, fldname='Sa_shum_HDO', fldptr1=aoflux%shum_HDO, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - else - allocate(aoflux%shum_16O(lsize)); aoflux%shum_16O(:) = 0._R8 - allocate(aoflux%shum_18O(lsize)); aoflux%shum_18O(:) = 0._R8 - allocate(aoflux%shum_HDO(lsize)); aoflux%shum_HDO(:) = 0._R8 - end if + ! -------------------------------------------- + ! Initialize aoflux data type and compute mask + ! for computations on exchange grid + ! -------------------------------------------- - !---------------------------------- - ! setup the compute mask. - !---------------------------------- + ! Arguments + type(ESMF_GridComp) , intent(inout) :: gcomp + type(aoflux_in_type) , intent(inout) :: aoflux_in + type(aoflux_out_type) , intent(inout) :: aoflux_out + integer , intent(out) :: rc - ! allocate grid mask fields - ! default compute everywhere, then "turn off" gridcells - allocate(aoflux%mask(lsize)) - aoflux%mask(:) = 1 + ! Local variables + integer :: n + integer :: lsize + type(InternalState) :: is_local + type(ESMF_Field) :: lfield_a + type(ESMF_Field) :: lfield_o + type(ESMF_Field) :: lfield_x + type(ESMF_Field) :: lfield + integer :: elementCount + type(ESMF_Mesh) :: ocn_mesh + type(ESMF_Mesh) :: atm_mesh + integer, allocatable :: ocn_mask(:) + type(ESMF_XGrid) :: xgrid + type(ESMF_Field) :: field_src ! needed for normalization + type(ESMF_Field) :: field_dst ! needed for normalization + type(ESMF_Mesh) :: mesh_src ! needed for normalization + type(ESMF_Mesh) :: mesh_dst ! needed for normalization + real(r8), pointer :: dataptr1d(:) + integer :: fieldcount + character(ESMF_MAXSTR),allocatable :: fieldNameList(:) + character(len=*),parameter :: subname=' (med_aofluxes_init_xgrid) ' + !----------------------------------------------------------------------- - write(tmpstr,'(i12,g22.12,i12)') lsize,sum(aoflux%rmask),sum(aoflux%mask) - call ESMF_LogWrite(trim(subname)//" : maskA= "//trim(tmpstr), ESMF_LOGMSG_INFO) + rc = ESMF_SUCCESS - where (aoflux%rmask(:) == 0._R8) aoflux%mask(:) = 0 ! like nint + ! Get the internal state from the mediator Component. + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - write(tmpstr,'(i12,g22.12,i12)') lsize,sum(aoflux%rmask),sum(aoflux%mask) - call ESMF_LogWrite(trim(subname)//" : maskB= "//trim(tmpstr), ESMF_LOGMSG_INFO) + ! ------------------------ + ! create the aoflux exchange grid + ! ------------------------ - ! TODO: need to check if this logic is correct - ! then check ofrac + ifrac - ! call FB_getFldPtr(FBFrac , fldname='ofrac' , fldptr1=ofrac, rc=rc) - ! if (chkerr(rc,__LINE__,u_FILE_u)) return - ! 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 - !---------------------------------- + ! determine atm mesh + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), fieldname='Sa_z', field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, mesh=atm_mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='coldair_outbreak_mod', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + ! determine ocn mesh + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fieldname='So_t', field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, mesh=ocn_mesh, 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) + ! create exchange grid - assume that atm mask is always 1 + xgrid = ESMF_XGridCreate(sideBMesh=(/ocn_mesh/), sideAMesh=(/atm_mesh/), sideBMaskValues=(/0/), & + storeOverlay=.true., 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) + ! ------------------------ + ! input fields from atm and ocn on xgrid + ! ------------------------ + + ! Create FBatm_x and FBocn_x (module variables) + FBatm_x = ESMF_FieldBundleCreate(rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + FBocn_x = ESMF_FieldBundleCreate(rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call set_aoflux_in_pointers(FBatm_x, FBocn_x, aoflux_in, lsize, xgrid=xgrid, 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) + call ESMF_FieldBundleGet(FBatm_x, fieldCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(fldnames_atm_in(fieldcount)) + call ESMF_FieldBundleGet(FBatm_x, fieldnamelist=fldnames_atm_in, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(FBocn_x, fieldCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(fldnames_ocn_in(fieldcount)) + call ESMF_FieldBundleGet(FBocn_x, fieldnamelist=fldnames_ocn_in, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! ------------------------ + ! output fields from aoflux calculation on exchange grid + ! ------------------------ - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) - endif - call t_stopf('MED:'//subname) + FBaof_x = ESMF_FieldBundleCreate(rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call set_aoflux_out_pointers(FBaof_x, lsize, aoflux_out, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - end subroutine med_aofluxes_init + ! ------------------------ + ! create the routehandles atm->xgrid and xgrid->atm + ! ------------------------ -!=============================================================================== + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), trim(fldnames_atm_in(1)), field=lfield_a, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(FBatm_x, trim(fldnames_atm_in(1)), field=lfield_x, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridStore(xgrid, lfield_a, lfield_x, routehandle=rh_agrid2xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridStore(xgrid, lfield_x, lfield_a, routehandle=rh_xgrid2agrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridStore(xgrid, lfield_a, lfield_x, routehandle=rh_agrid2xgrid_2ndord, & + regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - subroutine med_aofluxes_run(gcomp, aoflux, rc) + ! ------------------------ + ! create the routehandles ocn->xgrid and xgrid->ocn + ! ------------------------ - use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time, ESMF_TimeInterval - use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet, ESMF_TimeIntervalGet - use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info, ESMF_SUCCESS - use NUOPC , only : NUOPC_CompAttributeGet - use shr_flux_mod , only : shr_flux_atmocn + ! TODO: the second order conservative route handle below error out in its creation + + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), trim(fldnames_ocn_in(1)), field=lfield_o, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(FBocn_x, trim(fldnames_ocn_in(1)), field=lfield_x, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridStore(xgrid, lfield_o, lfield_x, routehandle=rh_ogrid2xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridStore(xgrid, lfield_x, lfield_o, routehandle=rh_xgrid2ogrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! call ESMF_FieldRegridStore(xgrid, lfield_o, lfield_x, routehandle=rh_ogrid2xgrid_2ndord, & + ! regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, rc=rc) + ! if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! ------------------------ + ! setup the compute mask - default compute everywhere for exchange grid + ! ------------------------ + + allocate(aoflux_in%mask(lsize)) + aoflux_in%mask(:) = 1 + + ! ------------------------ + ! determine one normalization field for ocn->xgrid + ! ------------------------ + + ! Create temporary source field on ocn mesh and set its value to 1. + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), 'So_t', field=lfield_o, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield_o, mesh=ocn_mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + lfield_o = ESMF_FieldCreate(ocn_mesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield_o, farrayptr=dataPtr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + dataptr1d(:) = 1.0_R8 + + ! Create field_ogrid2xgrid_normone (module variable) + field_ogrid2xgrid_normone = ESMF_FieldCreate(xgrid, ESMF_TYPEKIND_R8, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegrid(lfield_o, field_ogrid2xgrid_normone, routehandle=rh_ogrid2xgrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Destroy temporary field + call ESMF_FieldDestroy(lfield_o, rc=rc, noGarbage=.true.) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! ------------------------ + ! Determine one normalization field for xgrid->atm + ! ------------------------ + + ! Create temporary field on xgrid and set its value to 1. + lfield_x = ESMF_FieldCreate(xgrid, typekind=ESMF_TYPEKIND_R8, name='Sa_z', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield_x, farrayptr=dataPtr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + dataptr1d(:) = 1.0_R8 + + ! Create field_xgrid2agrid_normone (module variable) - on the atm mesh + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), 'Sa_z', field=lfield_a, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield_a, mesh=atm_mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + field_xgrid2agrid_normone = ESMF_FieldCreate(atm_mesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegrid(lfield_x, field_xgrid2agrid_normone, routehandle=rh_xgrid2agrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Destroy temporary field on xgrid + call ESMF_FieldDestroy(lfield_x, rc=rc, noGarbage=.true.) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine med_aofluxes_init_xgrid + + !=============================================================================== + subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) !----------------------------------------------------------------------- - ! Determine atm/ocn fluxes eother on atm or on ocean grid - ! The module arrays are set via pointers the the mediator internal states + ! Determine atm/ocn fluxes eother on atm, ocn or exchange grid + ! The module arrays are set via pointers to the mediator internal states ! in med_ocnatm_init and are used below. + ! 1) Create input on aoflux grid + ! 2) Update atmosphere/ocean surface fluxes + ! 3) Map aoflux output to relevant atm/ocn grid(s) !----------------------------------------------------------------------- + use ESMF , only : ESMF_GridComp + use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info, ESMF_SUCCESS + use med_map_mod , only : med_map_field_packed, med_map_rh_is_created + use shr_flux_mod , only : shr_flux_atmocn + ! Arguments - type(ESMF_GridComp) :: gcomp - type(aoflux_type) , intent(inout) :: aoflux - integer , intent(out) :: rc + type(ESMF_GridComp) :: gcomp + type(aoflux_in_type) , intent(inout) :: aoflux_in + type(aoflux_out_type) , intent(inout) :: aoflux_out + integer , intent(out) :: rc ! ! Local variables - character(CL) :: cvalue - integer :: n,i ! indices - integer :: lsize ! local size - character(len=CX) :: tmpstr - logical :: isPresent, isSet - character(*),parameter :: subName = '(med_aofluxes_run) ' + type(InternalState) :: is_local + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + integer :: n,i,nf ! indices + real(r8), pointer :: data_normdst(:) + real(r8), pointer :: data_dst(:) + integer :: maptype + character(*),parameter :: subName = '(med_aofluxes_update) ' !----------------------------------------------------------------------- rc = ESMF_SUCCESS call t_startf('MED:'//subname) + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + !---------------------------------- - ! Determine the compute mask + ! Create input on aoflux grid !---------------------------------- - ! Prefer to compute just where ocean exists, so setup a mask here. - ! this could be run with either the ocean or atm grid so need to be careful. - ! really want the ocean mask on ocean grid or ocean mask mapped to atm grid, - ! but do not have access to the ocean mask mapped to the atm grid. - ! the dom mask is a good place to start, on ocean grid, it should be what we want, - ! on the atm grid, it's just all 1's so not very useful. - ! next look at ofrac+ifrac in fractions. want to compute on all non-land points. - ! using ofrac alone will exclude points that are currently all sea ice but that later - ! could be less that 100% covered in ice. + if (is_local%wrap%aoflux_grid == 'ogrid') then - lsize = size(aoflux%mask) + ! Do nothing - mapping of input atm to ogrid is in med_phases_post_atm + ! via the call to med_map_field_packed - write(tmpstr,'(i12,g22.12,i12)') lsize,sum(aoflux%rmask),sum(aoflux%mask) - call ESMF_LogWrite(trim(subname)//" : maskA= "//trim(tmpstr), ESMF_LOGMSG_INFO) + else if (is_local%wrap%aoflux_grid == 'agrid') then - aoflux%mask(:) = 1 - where (aoflux%rmask(:) == 0._R8) aoflux%mask(:) = 0 ! like nint + ! Map input ocn to agrid + do nf = 1,size(fldnames_ocn_in) + ! Create source field + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fldnames_ocn_in(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - write(tmpstr,'(i12,g22.12,i12)') lsize,sum(aoflux%rmask),sum(aoflux%mask) - call ESMF_LogWrite(trim(subname)//" : maskB= "//trim(tmpstr), ESMF_LOGMSG_INFO) + ! Create destination field + call ESMF_FieldBundleGet(FBocn_a, fldnames_ocn_in(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - write(tmpstr,'(3i12)') lsize,size(aoflux%mask),sum(aoflux%mask) - call ESMF_LogWrite(trim(subname)//" : mask= "//trim(tmpstr), ESMF_LOGMSG_INFO) + ! Determine maptype from ocn->atm + if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapfcopy, rc=rc)) then + maptype = mapfcopy + else if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapconsd, rc=rc)) then + maptype = mapconsd + else + call ESMF_LogWrite(trim(subname)//& + ": maptype for atm->ocn mapping of aofluxes from atm->ocn either mapfcopy or mapconsd", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + end if + + ! Map ocn->atm conservatively without fractions + call ESMF_FieldRegrid(field_src, field_dst, routehandle=is_local%wrap%RH(compocn,compatm, maptype), & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + + ! Normalization of map by 'one' + if (maptype /= mapfcopy) then + call ESMF_FieldGet(is_local%wrap%field_normOne(compocn,compatm,maptype), farrayPtr=data_normdst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_dst, farrayptr=data_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(data_dst) + if (data_normdst(n) == 0.0_r8) then + data_dst(n) = 0.0_r8 + else + data_dst(n) = data_dst(n)/data_normdst(n) + end if + end do + end if + end do + + else if (is_local%wrap%aoflux_grid == 'xgrid') then + + ! Map input atm to xgrid + do nf = 1,size(fldnames_atm_in) + ! Get the source field + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), fldnames_atm_in(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Get the destination field + call ESMF_FieldBundleGet(FBatm_x, fldnames_atm_in(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Map atm->xgrid conservatively + if (trim(fldnames_atm_in(nf)) == 'Sa_u' .or. (trim(fldnames_atm_in(nf)) == 'Sa_v')) then + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_agrid2xgrid_2ndord, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + else + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_agrid2xgrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end if + end do + + ! map input ocn to xgrid + do nf = 1,size(fldnames_ocn_in) + ! Create source field + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fldnames_ocn_in(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Create destination field + call ESMF_FieldBundleGet(FBocn_x, fldnames_ocn_in(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Map ocn->xgrid conservatively without fractions + if (trim(fldnames_atm_in(nf)) == 'So_u' .or. (trim(fldnames_atm_in(nf)) == 'So_v')) then + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_ogrid2xgrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + else + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_ogrid2xgrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end if + end do + end if !---------------------------------- - ! Update atmosphere/ocean surface fluxes + ! Calculate quantities if they are not defined !---------------------------------- + ! Note pbot, tbot and shum have already been mapped or are available on the aoflux grid if (compute_atm_thbot) then - do n = 1,lsize - if (aoflux%mask(n) /= 0._r8) then - aoflux%thbot(n) = aoflux%tbot(n)*((100000._R8/aoflux%pbot(n))**0.286_R8) + do n = 1,aoflux_in%lsize + if (aoflux_in%mask(n) /= 0._r8) then + aoflux_in%thbot(n) = aoflux_in%tbot(n)*((100000._R8/aoflux_in%pbot(n))**0.286_R8) end if end do end if if (compute_atm_dens) then - do n = 1,lsize - if (aoflux%mask(n) /= 0._r8) then - aoflux%dens(n) = aoflux%pbot(n)/(287.058_R8*(1._R8 + 0.608_R8*aoflux%shum(n))*aoflux%tbot(n)) + do n = 1,aoflux_in%lsize + if (aoflux_in%mask(n) /= 0._r8) then + aoflux_in%dens(n) = aoflux_in%pbot(n)/(287.058_R8*(1._R8 + 0.608_R8*aoflux_in%shum(n))*aoflux_in%tbot(n)) end if end do end if + !---------------------------------- + ! Update atmosphere/ocean surface fluxes + !---------------------------------- + call shr_flux_atmocn (& - nMax=lsize, zbot=aoflux%zbot, ubot=aoflux%ubot, vbot=aoflux%vbot, thbot=aoflux%thbot, & - qbot=aoflux%shum, s16O=aoflux%shum_16O, sHDO=aoflux%shum_HDO, s18O=aoflux%shum_18O, rbot=aoflux%dens, & - tbot=aoflux%tbot, us=aoflux%uocn, vs=aoflux%vocn, & - ts=aoflux%tocn, mask=aoflux%mask, seq_flux_atmocn_minwind=0.5_r8, & - sen=aoflux%sen, lat=aoflux%lat, lwup=aoflux%lwup, & - r16O=aoflux%roce_16O, rhdo=aoflux%roce_HDO, r18O=aoflux%roce_18O, & - evap=aoflux%evap, evap_16O=aoflux%evap_16O, evap_HDO=aoflux%evap_HDO, evap_18O=aoflux%evap_18O, & - taux=aoflux%taux, tauy=aoflux%tauy, tref=aoflux%tref, qref=aoflux%qref, & + nMax=aoflux_in%lsize, & + zbot=aoflux_in%zbot, ubot=aoflux_in%ubot, vbot=aoflux_in%vbot, thbot=aoflux_in%thbot, qbot=aoflux_in%shum, & + s16O=aoflux_in%shum_16O, sHDO=aoflux_in%shum_HDO, s18O=aoflux_in%shum_18O, rbot=aoflux_in%dens, & + tbot=aoflux_in%tbot, us=aoflux_in%uocn, vs=aoflux_in%vocn, ts=aoflux_in%tocn, & + mask=aoflux_in%mask, seq_flux_atmocn_minwind=0.5_r8, & + sen=aoflux_out%sen, lat=aoflux_out%lat, lwup=aoflux_out%lwup, & + r16O=aoflux_in%roce_16O, rhdo=aoflux_in%roce_HDO, r18O=aoflux_in%roce_18O, & + evap=aoflux_out%evap, evap_16O=aoflux_out%evap_16O, evap_HDO=aoflux_out%evap_HDO, evap_18O=aoflux_out%evap_18O, & + taux=aoflux_out%taux, tauy=aoflux_out%tauy, tref=aoflux_out%tref, qref=aoflux_out%qref, & ocn_surface_flux_scheme=ocn_surface_flux_scheme, & - duu10n=aoflux%duu10n, ustar_sv=aoflux%ustar, re_sv=aoflux%re, ssq_sv=aoflux%ssq, & + duu10n=aoflux_out%duu10n, ustar_sv=aoflux_out%ustar, re_sv=aoflux_out%re, ssq_sv=aoflux_out%ssq, & missval = 0.0_r8) - do n = 1,lsize - if (aoflux%mask(n) /= 0) then - aoflux%u10(n) = sqrt(aoflux%duu10n(n)) + do n = 1,aoflux_in%lsize + if (aoflux_in%mask(n) /= 0) then + aoflux_out%u10(n) = sqrt(aoflux_out%duu10n(n)) end if enddo + + !---------------------------------- + ! map aoflux output to relevant atm/ocn grid(s) + !---------------------------------- + + if (is_local%wrap%aoflux_grid == 'ogrid') then + + ! mapping aoflux from ogrid to agrid is done in med_phases_prep_atm using updated ocean fractions + ! on the atm grid + + else if (is_local%wrap%aoflux_grid == 'agrid') then + + if (is_local%wrap%med_coupling_active(compatm,compocn)) then + ! map aoflux from agrid to ogrid + do nf = 1,size(fldnames_aof_out) + ! Create source field + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_a, fldnames_aof_out(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Create destination field + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_o, fldnames_aof_out(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Map atm->ocn conservatively WITHOUT fractions + if (med_map_RH_is_created(is_local%wrap%RH(compatm,compocn,:), mapfcopy, rc=rc)) then + maptype = mapfcopy + else if (med_map_RH_is_created(is_local%wrap%RH(compatm,compocn,:), mapconsf, rc=rc)) then + maptype = mapconsf + else + call ESMF_LogWrite(trim(subname)//& + ": maptype for atm->ocn mapping of aofluxes from atm->ocn either mapfcopy or mapconsf", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + end if + call ESMF_FieldRegrid(field_src, field_dst, & + routehandle=is_local%wrap%RH(compatm, compocn, maptype), & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end do + end if + + else if (is_local%wrap%aoflux_grid == 'xgrid') then + + do nf = 1,size(fldnames_aof_out) + + ! Get the source field + call ESMF_FieldBundleGet(FBaof_x, fldnames_aof_out(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! map aoflux from xgrid to agrid followed by normalization by 'one' + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_a, fldnames_aof_out(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_xgrid2agrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + ! normalization by 'one' + call ESMF_FieldGet(field_xgrid2agrid_normone, farrayPtr=data_normdst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_dst, farrayptr=data_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(data_dst) + if (data_normdst(n) == 0.0_r8) then + data_dst(n) = 0.0_r8 + else + data_dst(n) = data_dst(n)/data_normdst(n) + end if + end do + + ! map aoflx from xgrid->ogrid conservatively + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_o, fldnames_aof_out(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_xgrid2ogrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end do + + end if + call t_stopf('MED:'//subname) - end subroutine med_aofluxes_run + end subroutine med_aofluxes_update + +!================================================================================ + subroutine set_aoflux_in_pointers(fldbun_a, fldbun_o, aoflux_in, lsize, xgrid, rc) + + ! Set pointers for aoflux_in attributes + ! Note that if computation is on the xgrid, fldbun_a and fldbun_o are both fldbun_x + + ! input/output variables + type(ESMF_FieldBundle) , intent(inout) :: fldbun_a + type(ESMF_FieldBundle) , intent(inout) :: fldbun_o + type(aoflux_in_type) , intent(inout) :: aoflux_in + integer , intent(out) :: lsize + type(ESMF_Xgrid), optional , intent(inout) :: xgrid + integer , intent(out) :: rc + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! ------------------------ + ! input fields from atm on aoflux grid + ! ------------------------ + + ! Determine lsize from first field + call fldbun_getfldptr(fldbun_a, 'Sa_z', aoflux_in%zbot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + lsize = size(aoflux_in%zbot) + aoflux_in%lsize = lsize + + ! bulk formula quantities for nems_orig_data + if (trim(coupling_mode) == 'nems_orig_data' .and. ocn_surface_flux_scheme == -1) then + call fldbun_getfldptr(fldbun_a, 'Sa_u10m', aoflux_in%ubot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_v10m', aoflux_in%vbot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_t2m', aoflux_in%tbot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_q2m', aoflux_in%shum, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call fldbun_getfldptr(fldbun_a, 'Sa_u', aoflux_in%ubot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_v', aoflux_in%vbot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_tbot', aoflux_in%tbot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_shum', aoflux_in%shum, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! bottom level potential temperature will need to be computed if not received from the atm + if (compute_atm_thbot) then + allocate(aoflux_in%thbot(lsize)) + else + call fldbun_getfldptr(fldbun_a, 'Sa_ptem', aoflux_in%thbot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! bottom level density will need to be computed if not received from the atm + if (compute_atm_dens) then + allocate(aoflux_in%dens(lsize)) + else + call fldbun_getfldptr(fldbun_a, 'Sa_dens', aoflux_in%dens, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! if either density or potential temperature are computed, will need bottom level pressure + if (compute_atm_dens .or. compute_atm_thbot) then + call fldbun_getfldptr(fldbun_a, 'Sa_pbot', aoflux_in%pbot, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + if (flds_wiso) then + call fldbun_getfldptr(fldbun_a, 'Sa_shum_16O', aoflux_in%shum_16O, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_shum_18O', aoflux_in%shum_18O, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_a, 'Sa_shum_HDO', aoflux_in%shum_HDO, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + allocate(aoflux_in%shum_16O(lsize)); aoflux_in%shum_16O(:) = 0._R8 + allocate(aoflux_in%shum_18O(lsize)); aoflux_in%shum_18O(:) = 0._R8 + allocate(aoflux_in%shum_HDO(lsize)); aoflux_in%shum_HDO(:) = 0._R8 + end if + + ! ------------------------ + ! input fields from ocn on aoflux_grid + ! ------------------------ + + ! point directly into input field bundle from ocean on the ocean grid + call fldbun_getfldptr(fldbun_o, 'So_omask', aoflux_in%rmask, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_o, 'So_t', aoflux_in%tocn, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_o, 'So_u', aoflux_in%uocn, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_o, 'So_v', aoflux_in%vocn, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (flds_wiso) then + call fldbun_getfldptr(fldbun_o, 'So_roce_16O', aoflux_in%roce_16O, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_o, 'So_roce_18O', aoflux_in%roce_18O, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun_o, 'So_roce_HDO', aoflux_in%roce_HDO, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + allocate(aoflux_in%roce_16O(aoflux_in%lsize)); aoflux_in%roce_16O(:) = 0._R8 + allocate(aoflux_in%roce_18O(aoflux_in%lsize)); aoflux_in%roce_18O(:) = 0._R8 + allocate(aoflux_in%roce_HDO(aoflux_in%lsize)); aoflux_in%roce_HDO(:) = 0._R8 + end if + + end subroutine set_aoflux_in_pointers + + !================================================================================ + subroutine set_aoflux_out_pointers(fldbun, lsize, aoflux_out, xgrid, rc) + + ! input/output variables + type(ESMF_FieldBundle) , intent(inout) :: fldbun + integer , intent(in) :: lsize + type(aoflux_out_type) , intent(inout) :: aoflux_out + type(ESMF_Xgrid), optional , intent(inout) :: xgrid + integer , intent(out) :: rc + + rc = ESMF_SUCCESS + !----------------------------------------------------------------------- + + call fldbun_getfldptr(fldbun, 'So_tref', aoflux_out%tref, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'So_qref', aoflux_out%qref, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'So_ustar', aoflux_out%ustar, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'So_re', aoflux_out%re, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'So_ssq', aoflux_out%ssq, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'So_u10', aoflux_out%u10, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'So_duu10n', aoflux_out%duu10n, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_taux', aoflux_out%taux, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_tauy', aoflux_out%tauy, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_lat', aoflux_out%lat, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_sen', aoflux_out%sen, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_evap', aoflux_out%evap, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_lwup', aoflux_out%lwup, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (flds_wiso) then + call fldbun_getfldptr(fldbun, 'Faox_evap_16O', aoflux_out%evap_16O, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_evap_18O', aoflux_out%evap_18O, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getfldptr(fldbun, 'Faox_evap_HDO', aoflux_out%evap_HDO, xgrid=xgrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + allocate(aoflux_out%evap_16O(lsize)); aoflux_out%evap_16O(:) = 0._R8 + allocate(aoflux_out%evap_18O(lsize)); aoflux_out%evap_18O(:) = 0._R8 + allocate(aoflux_out%evap_HDO(lsize)); aoflux_out%evap_HDO(:) = 0._R8 + end if + + end subroutine set_aoflux_out_pointers + + !================================================================================ + subroutine fldbun_getfldptr(fldbun, fldname, fldptr, xgrid, rc) + + ! input/output variables + type(ESMF_FieldBundle) , intent(inout) :: fldbun + character(len=*) , intent(in) :: fldname + real(r8) , pointer :: fldptr(:) + type(ESMF_Xgrid), optional , intent(in) :: xgrid + integer , intent(out) :: rc + + ! local variables + type(ESMF_Field) :: lfield + !----------------------------------------------------------------------- + rc = ESMF_SUCCESS + + if (present(xgrid)) then + lfield = ESMF_FieldCreate(xgrid, typekind=ESMF_TYPEKIND_R8, name=trim(fldname), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleAdd(fldbun, (/lfield/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_FieldBundleGet(fldbun, trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + end subroutine fldbun_getfldptr end module med_phases_aofluxes_mod diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 893393d2c..77496e1d7 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -2,47 +2,121 @@ module med_phases_history_mod !----------------------------------------------------------------------------- ! Mediator History control - ! - ! Each time loop has its own associated clock object. NUOPC manages - ! these clock objects, i.e. their creation and destruction, as well as - ! startTime, endTime, timeStep adjustments during the execution. The - ! outer most time loop of the run sequence is a special case. It uses - ! the driver clock itself. If a single outer most loop is defined in - ! the run sequence provided by freeFormat, this loop becomes the driver - ! loop level directly. Therefore, setting the timeStep or runDuration - ! for the outer most time loop results modifiying the driver clock - ! itself. However, for cases with concatenated loops on the upper level - ! of the run sequence in freeFormat, a single outer loop is added - ! automatically during ingestion, and the driver clock is used for this - ! loop instead. !----------------------------------------------------------------------------- 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_Alarm - use med_constants_mod , only : dbug_flag => med_constants_dbug_flag - use med_constants_mod , only : SecPerDay => med_constants_SecPerDay - 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_accum => med_methods_FB_accum - use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_VM + use ESMF , only : ESMF_Clock, ESMF_ClockGet, ESMF_ClockSet, ESMF_ClockAdvance + use ESMF , only : ESMF_ClockGetNextTime, ESMF_ClockGetAlarm, ESMF_ClockIsCreated + use ESMF , only : ESMF_Calendar, ESMF_Time, ESMF_TimeGet + use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalGet, ESMF_TimeIntervalSet + use ESMF , only : ESMF_Alarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff, ESMF_AlarmGet + use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR, ESMF_LogFoundError + use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_MAXSTR, ESMF_LOGERR_PASSTHRU, ESMF_END_ABORT + use ESMF , only : ESMF_Finalize + use ESMF , only : operator(-), operator(+) + use NUOPC , only : NUOPC_CompAttributeGet + use NUOPC_Model , only : NUOPC_ModelGet + use esmFlds , only : ncomps, compname + use med_utils_mod , only : chkerr => med_utils_ChkErr use med_internalstate_mod , only : InternalState, mastertask, logunit use med_time_mod , only : med_time_alarmInit - use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef - use med_io_mod , only : med_io_close, med_io_date2yyyymmdd, med_io_sec2hms - use med_io_mod , only : med_io_ymd2date + use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef, med_io_close use perf_mod , only : t_startf, t_stopf - use esmFlds , only : ncomps implicit none private - public :: med_phases_history_alarm_init - public :: med_phases_history_write - - ! type(ESMF_Alarm) :: alarm_hist_inst - ! type(ESMF_Alarm) :: alarm_hist_avg - + ! Public routine called from the run sequence + public :: med_phases_history_write ! inst only - for all variables + + ! Public routines called from post phases + public :: med_phases_history_write_comp ! inst, avg, aux for component + public :: med_phases_history_write_med ! inst only, med aoflux and ocn albedoes + public :: med_phases_history_write_lnd2glc ! inst only, yearly average of lnd->glc data on lnd grid + + ! Private routines + private :: med_phases_history_write_comp_inst ! write instantaneous file for a given component + private :: med_phases_history_write_comp_avg ! write averaged file for a given component + private :: med_phases_history_write_comp_aux ! write auxiliary file for a given component + private :: med_phases_history_init_histclock + private :: med_phases_history_query_ifwrite + private :: med_phases_history_set_timeinfo + private :: med_phases_history_fldbun_accum + private :: med_phases_history_fldbun_average + + ! ---------------------------- + ! Instantaneous history files datatypes/variables + ! ---------------------------- + type, public :: instfile_type + logical :: write_inst + character(CS) :: hist_option + integer :: hist_n + type(ESMF_Clock) :: clock + type(ESMF_Alarm) :: alarm + character(CS) :: alarmname + logical :: is_clockset = .false. + logical :: is_active = .false. + end type instfile_type + type(instfile_type) , public :: instfiles(ncomps) + + ! ---------------------------- + ! Time averaging history files + ! ---------------------------- + type, public :: avgfile_type + logical :: write_avg + type(ESMF_FieldBundle) :: FBaccum_import ! field bundle for time averaging + integer :: accumcnt_import ! field bundle accumulation counter + type(ESMF_FieldBundle) :: FBaccum_export ! field bundle for time averaging + integer :: accumcnt_export ! field bundle accumulation counter + character(CS) :: hist_option + integer :: hist_n + type(ESMF_Clock) :: clock + type(ESMF_Alarm) :: alarm + character(CS) :: alarmname + logical :: is_clockset = .false. + logical :: is_active = .false. + end type avgfile_type + type(avgfile_type) :: avgfiles(ncomps) + + ! ---------------------------- + ! Auxiliary history files + ! ---------------------------- + type, public :: auxfile_type + character(CS), allocatable :: flds(:) ! array of aux field names + character(CS) :: auxname ! name for history file creation + character(CL) :: histfile = '' ! current history file name + integer :: ntperfile ! maximum number of time samples per file + integer :: nt = 0 ! time in file + logical :: doavg ! if true, time average, otherwise instantaneous + type(ESMF_FieldBundle) :: FBaccum ! field bundle for time averaging + integer :: accumcnt ! field bundle accumulation counter + type(ESMF_Clock) :: clock ! auxiliary history clock + type(ESMF_Alarm) :: alarm ! auxfile alarm + character(CS) :: alarmname ! name of write alarm + end type auxfile_type + + integer, parameter :: max_auxfiles = 10 + type, public :: auxcomp_type + type(auxfile_type) :: files(max_auxfiles) + integer :: num_auxfiles = 0 ! actual number of auxiliary files + logical :: init_auxfiles = .false. ! if auxfile initial has occured + end type auxcomp_type + type(auxcomp_type) , public :: auxcomp(ncomps) + + !logical :: init_auxfiles(ncomps) = .false. ! if true, auxfiles has been initialized for the component + + ! ---------------------------- + ! Other private module variables + ! ---------------------------- + + logical :: whead(2) = (/.true. , .false./) + logical :: wdata(2) = (/.false., .true. /) + + character(CL) :: case_name = 'unset' ! case name + character(CS) :: inst_tag = 'unset' ! instance tag + logical :: debug_alarms = .true. character(*), parameter :: u_FILE_u = & __FILE__ @@ -50,429 +124,1641 @@ module med_phases_history_mod contains !=============================================================================== - subroutine med_phases_history_alarm_init(gcomp, rc) + subroutine med_phases_history_write(gcomp, rc) ! -------------------------------------- - ! Initialize mediator history file alarms (module variables) + ! Write instantaneous mediator history file for all variables ! -------------------------------------- - use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_Clock, ESMF_ClockGet, ESMF_ClockAdvance, ESMF_ClockSet - use ESMF , only : ESMF_Time - use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalGet - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR - use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE - use ESMF , only : operator(==), operator(-) - use ESMF , only : ESMF_ALARMLIST_ALL, ESMF_Alarm, ESMF_AlarmSet - use NUOPC , only : NUOPC_CompAttributeGet - use NUOPC_Model, only : NUOPC_ModelGet + use med_io_mod, only : med_io_write_time, med_io_define_time + use ESMF , only : ESMF_Alarm, ESMF_AlarmSet + use ESMF , only : ESMF_FieldBundleIsCreated + use esmflds , only : compocn, compatm ! input/output variables type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc ! local variables + type(InternalState) :: is_local + type(ESMF_Clock) :: mclock type(ESMF_Alarm) :: alarm - type(ESMF_Clock) :: mclock, dclock - type(ESMF_TimeInterval) :: mtimestep, dtimestep - type(ESMF_Time) :: mCurrTime - type(ESMF_Time) :: mStartTime - type(ESMF_TimeInterval) :: timestep - integer :: alarmcount - integer :: timestep_length - character(CL) :: cvalue ! attribute string - character(CL) :: histinst_option ! freq_option setting (ndays, nsteps, etc) - character(CL) :: histavg_option ! freq_option setting (ndays, nsteps, etc) - integer :: histinst_n ! freq_n setting relative to freq_option - integer :: histavg_n ! freq_n setting relative to freq_option - character(len=*), parameter :: subname='(med_phases_history_alarm_init)' + character(CS) :: alarmname + character(CL) :: hist_option ! freq_option setting (ndays, nsteps, etc) + integer :: hist_n ! freq_n setting relative to freq_option + character(CL) :: cvalue ! attribute string + logical :: isPresent + logical :: isSet + type(ESMF_VM) :: vm + type(ESMF_Calendar) :: calendar ! calendar type + integer :: i,m,n ! indices + integer :: nx,ny ! global grid size + character(CL) :: time_units ! units of time variable + character(CL) :: hist_file ! history file name + real(r8) :: time_val ! time coordinate output + real(r8) :: time_bnds(2) ! time bounds output + logical :: write_now ! true => write to history type + real(r8) :: tbnds(2) ! CF1.0 time bounds + type(ESMF_Time) :: starttime + type(ESMF_Time) :: currtime + type(ESMF_Time) :: nexttime + character(len=CS) :: currtimestr + character(len=CS) :: nexttimestr + integer :: yr,mon,day,sec ! time units + type(ESMF_TimeInterval) :: ringInterval + integer :: ringInterval_length + logical :: first_time = .true. + character(len=*), parameter :: subname='(med_phases_history_write)' !--------------------------------------- rc = ESMF_SUCCESS + call t_startf('MED:'//subname) - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) - endif + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! ----------------------------- - ! Get model clock - ! ----------------------------- + alarmname='alarm_history_inst_all' - call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (first_time) then + call NUOPC_CompAttributeGet(gcomp, name='history_option', isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name='history_option', value=hist_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='history_n', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_n + else + ! If attribute is not present - don't write history output + hist_option = 'none' + hist_n = -999 + end if - ! get start time - call ESMF_ClockGet(mclock, startTime=mStartTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Set alarm name and initialize clock and alarm for instantaneous history output + ! The alarm for the full history write is set on the mediator clock not as a separate alarm + if (hist_option /= 'none' .and. hist_option /= 'never') then + + ! Initialize alarm on mediator clock for instantaneous mediator history output for all variables + call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(mclock, startTime=starttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_time_alarmInit(mclock, alarm, option=hist_option, opt_n=hist_n, & + reftime=starttime, alarmname=alarmname, rc=rc) + call ESMF_AlarmSet(alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Advance model clock to trigger alarms then reset model clock back to currtime + call ESMF_ClockGet(mclock, currTime=CurrTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockAdvance(mclock,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockSet(mclock, currTime=currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Write diagnostic info + if (mastertask) then + write(logunit,'(a,2x,i8)') trim(subname) // " initialized history alarm "//& + trim(alarmname)//" with option "//trim(hist_option)//" and frequency ",hist_n + end if + end if + first_time = .false. + end if - ! ----------------------------- - ! Set alarm for instantaneous mediator history output - ! ----------------------------- + write_now = .false. + if (hist_option /= 'none' .and. hist_option /= 'never') then + call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(mclock, alarmname=trim(alarmname), alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='history_option', value=histinst_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='history_n', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) histinst_n + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Set write flag to .true. and turn ringer off + write_now = .true. + call ESMF_AlarmRingerOff( alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_time_alarmInit(mclock, alarm, option=histinst_option, opt_n=histinst_n, & - reftime=mStartTime, alarmname='alarm_history_inst', rc=rc) + ! Write diagnostic info if appropriate + if (mastertask .and. debug_alarms) then + call ESMF_AlarmGet(alarm, ringInterval=ringInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalGet(ringInterval, s=ringinterval_length, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_AlarmSet(alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(mclock, currtime=currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(currtime,yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec - ! ----------------------------- - ! Set alarm for averaged mediator history output - ! ----------------------------- + call ESMF_ClockGetNextTime(mclock, nextTime=nexttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nexttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(nexttimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + + if (mastertask) then + write(logunit,*) + write(logunit,'(a,i8)') trim(subname)//" : history alarmname "//trim(alarmname)//& + ' is ringing, interval length is ', ringInterval_length + write(logunit,'(a)') trim(subname)//" : mclock currtime = "//trim(currtimestr)//& + " mclock nexttime = "//trim(nexttimestr) + end if + end if + end if - !TODO: add isSet and isPresent flags to reading these and other config attributes - !call NUOPC_CompAttributeGet(gcomp, name='histavg_option', value=histavg_option, rc=rc) - !if (ChkErr(rc,__LINE__,u_FILE_u)) return - !call NUOPC_CompAttributeGet(gcomp, name='histavg_n', value=cvalue, rc=rc) - !if (ChkErr(rc,__LINE__,u_FILE_u)) return - !read(cvalue,*) histavg_n + ! If write now flag is true + if (write_now) then - !call med_time_alarmInit(mclock, alarm, option=histavg_option, opt_n=histavg_n, & - ! reftime=mStartTime, alarmname='alarm_history_avg', rc=rc) - !if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Determine time_val and tbnds data for history as well as history file name + call med_phases_history_set_timeinfo(gcomp, mclock, alarmname, & + time_val, time_bnds, time_units, hist_file, doavg=.false., compname='all', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !call ESMF_AlarmSet(alarm, clock=mclock, rc=rc) - !if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Create history file + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_wopen(hist_file, vm, clobber=.true.) - !-------------------------------- - ! Advance model clock to trigger alarms then reset model clock back to currtime - !-------------------------------- + ! Loop over whead/wdata phases + do m = 1,2 + if (m == 2) then + call med_io_enddef(hist_file) + end if - call ESMF_ClockGet(mclock, currTime=mCurrTime, timeStep=mtimestep, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeIntervalGet(mtimestep, s=timestep_length, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Write time values + if (whead(m)) then + call ESMF_ClockGet(mclock, calendar=calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_define_time(time_units, calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call med_io_write_time(time_val, time_bnds, nt=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - call ESMF_ClockAdvance(mclock,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 2,ncomps ! skip the mediator here + ! Write import and export field bundles + if (is_local%wrap%comp_present(n)) then + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(n,n),rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBimp(n,n), whead(m), wdata(m), & + is_local%wrap%nx(n), is_local%wrap%ny(n), nt=1, pre=trim(compname(n))//'Imp', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(n),rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBexp(n), whead(m), wdata(m), & + is_local%wrap%nx(n), is_local%wrap%ny(n), nt=1, pre=trim(compname(n))//'Exp', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + end if + ! Write mediator fraction field bundles + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBFrac(n),rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBFrac(n), whead(m), wdata(m), & + is_local%wrap%nx(n), is_local%wrap%ny(n), nt=1, pre='Med_frac_'//trim(compname(n)), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + ! Write component mediator area field bundles + call med_io_write(hist_file, is_local%wrap%FBArea(n), whead(m), wdata(m), & + is_local%wrap%nx(n), is_local%wrap%ny(n), nt=1, pre='MED_'//trim(compname(n)), rc=rc) + end do + + ! Write atm/ocn fluxes and ocean albedoes if field bundles are created + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_o,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_ocnalb_o, whead(m), wdata(m), & + is_local%wrap%nx(compocn), is_local%wrap%ny(compocn), nt=1, pre='Med_alb_ocn', rc=rc) + end if + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_o,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_aoflux_o, whead(m), wdata(m), & + is_local%wrap%nx(compocn), is_local%wrap%ny(compocn), nt=1, pre='Med_aoflux_ocn', rc=rc) + end if + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_a,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_ocnalb_a, whead(m), wdata(m), & + is_local%wrap%nx(compatm), is_local%wrap%ny(compatm), nt=1, pre='Med_alb_atm', rc=rc) + end if + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_a,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_aoflux_a, whead(m), wdata(m), & + is_local%wrap%nx(compatm), is_local%wrap%ny(compatm), nt=1, pre='Med_aoflux_atm', rc=rc) + end if - call ESMF_ClockSet(mclock, currTime=mcurrtime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + end do ! end of loop over whead/wdata m index phases - ! ----------------------------- - ! Write mediator diagnostic output - ! ----------------------------- + ! Close file + call med_io_close(hist_file, vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(logunit,*) - write(logunit,100) trim(subname)//" history clock timestep = ",timestep_length - write(logunit,100) trim(subname)//" set instantaneous mediator history alarm with option "//& - trim(histinst_option)//" and frequency ",histinst_n - !write(logunit,100) trim(subname)//" set averaged mediator history alarm with option "//& - ! trim(histavg_option)//" and frequency ",histavg_n -100 format(a,2x,i8) - write(logunit,*) + end if ! end of write_now if-block end if - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": exited", ESMF_LOGMSG_INFO) - endif + call t_stopf('MED:'//subname) - end subroutine med_phases_history_alarm_init + end subroutine med_phases_history_write !=============================================================================== + subroutine med_phases_history_write_med(gcomp, rc) - subroutine med_phases_history_write(gcomp, rc) + ! Write mediator history file for med variables - only instantaneous files are written + ! This writes out ocean albedoes and atm/ocean fluxes computed by the mediator + ! along with the fractions computed by the mediator - ! -------------------------------------- - ! Write mediator history file - ! -------------------------------------- - - use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_VM, ESMF_VMGet - use ESMF , only : ESMF_Clock, ESMF_ClockGet, ESMF_ClockGetNextTime, ESMF_ClockGetAlarm - use ESMF , only : ESMF_Calendar - use ESMF , only : ESMF_Time, ESMF_TimeGet - use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalGet - use ESMF , only : ESMF_Alarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff, ESMF_AlarmGet - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR - use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE - use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_MAXSTR, ESMF_ClockPrint, ESMF_AlarmIsCreated - use ESMF , only : operator(==), operator(-) - use ESMF , only : ESMF_ALARMLIST_ALL, ESMF_ClockGetAlarmList - use NUOPC , only : NUOPC_CompAttributeGet - use esmFlds , only : compatm, compocn, ncomps, compname - use esmFlds , only : fldListFr, fldListTo - use NUOPC_Model, only : NUOPC_ModelGet + use ESMF , only : ESMF_FieldBundleIsCreated + use med_io_mod, only : med_io_write_time, med_io_define_time + use esmFlds , only : compmed, compocn, compatm ! input/output variables type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc ! local variables - type(ESMF_Clock) :: mclock, dclock - type(ESMF_TimeInterval) :: mtimestep, dtimestep - integer :: timestep_length - type(ESMF_Alarm) :: alarm - integer :: alarmCount + type(InternalState) :: is_local + type(ESMF_VM) :: vm + type(ESMF_Calendar) :: calendar ! calendar type + integer :: i,m,n ! indices + integer :: nx,ny ! global grid size + character(CL) :: time_units ! units of time variable + character(CL) :: hist_file ! history file name + real(r8) :: time_val ! time coordinate output + real(r8) :: time_bnds(2) ! time bounds output + logical :: write_now ! true => write to history type + character(CL) :: cvalue ! attribute string + character(CL) :: hist_option ! freq_option setting (ndays, nsteps, etc) + integer :: hist_n ! freq_n setting relative to freq_option + character(CL) :: hist_option_in + character(CL) :: hist_n_in + logical :: isPresent + logical :: isSet + character(len=*), parameter :: subname='(med_phases_history_write_med)' + !--------------------------------------- + rc = ESMF_SUCCESS + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! alarm is not set determine hist_option and hist_n + if (.not. instfiles(compmed)%is_clockset) then + ! Determine attribute prefix + write(hist_option_in,'(a)') 'history_option_med_inst' + write(hist_n_in,'(a)') 'history_n_med_inst' + + ! Determine instantaneous mediator output frequency and type + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_option_in), isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_option_in), value=hist_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_n_in), value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_n + else + ! If attribute is not present - don't write history output + hist_option = 'none' + hist_n = -999 + end if + + ! Set alarm name and initialize clock and alarm for instantaneous history output + if (hist_option /= 'none' .and. hist_option /= 'never') then + instfiles(compmed)%alarmname = 'alarm_history_inst_med' + call med_phases_history_init_histclock(gcomp, instfiles(compmed)%clock, & + instfiles(compmed)%alarm, instfiles(compmed)%alarmname, hist_option, hist_n, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + instfiles(compmed)%is_active = .true. + instfiles(compmed)%is_clockset = .true. + else + instfiles(compmed)%is_active = .false. + ! this is set to true here even if history file is not active + instfiles(compmed)%is_clockset = .true. + end if + end if + + ! if history file is active and history clock is initialized - process history file + if (instfiles(compmed)%is_active .and. instfiles(compmed)%is_clockset) then + + ! Determine if will write to history file + call med_phases_history_query_ifwrite(gcomp, instfiles(compmed)%clock, instfiles(compmed)%alarmname, & + write_now, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! If write now flag is true + if (write_now) then + + ! Determine time_val and tbnds data for history as well as history file name + call med_phases_history_set_timeinfo(gcomp, instfiles(compmed)%clock, instfiles(compmed)%alarmname, & + time_val, time_bnds, time_units, hist_file, doavg=.false., compname='med', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Create history file + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_wopen(hist_file, vm, clobber=.true.) + do m = 1,2 + ! Write time values + if (whead(m)) then + call ESMF_ClockGet(instfiles(compmed)%clock, calendar=calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_define_time(time_units, calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call med_io_enddef(hist_file) + call med_io_write_time(time_val, time_bnds, nt=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! Write aoflux fields computed in mediator + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_o,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_aoflux_o, whead(m), wdata(m), & + is_local%wrap%nx(compocn), is_local%wrap%ny(compocn), nt=1, pre='Med_aoflux_ocn', rc=rc) + end if + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_a,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_aoflux_a, whead(m), wdata(m), & + is_local%wrap%nx(compatm), is_local%wrap%ny(compatm), nt=1, pre='Med_aoflux_atm', rc=rc) + end if + + ! If appropriate - write ocn albedos computed in mediator + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_o,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_ocnalb_o, whead(m), wdata(m), & + is_local%wrap%nx(compocn), is_local%wrap%ny(compocn), nt=1, pre='Med_alb_ocn', rc=rc) + end if + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_a,rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBMed_ocnalb_a, whead(m), wdata(m), & + is_local%wrap%nx(compatm), is_local%wrap%ny(compatm), nt=1, pre='Med_alb_atm', rc=rc) + end if + end do ! end of loop over m + + ! Close file + call med_io_close(hist_file, vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end if ! end of if-write_now block + end if ! end of if-active block + + end subroutine med_phases_history_write_med + + !=============================================================================== + subroutine med_phases_history_write_lnd2glc(gcomp, fldbun, rc) + + ! Write yearly average of lnd -> glc fields + + use esmFlds , only : complnd + use med_constants_mod , only : SecPerDay => med_constants_SecPerDay + use med_io_mod , only : med_io_write_time, med_io_define_time + use med_io_mod , only : med_io_date2yyyymmdd, med_io_sec2hms, med_io_ymd2date + + ! input/output variables + type(ESMF_GridComp) , intent(in) :: gcomp + type(ESMF_FieldBundle) , intent(in) :: fldbun + integer , intent(out) :: rc + + ! local variables + type(InternalState) :: is_local type(ESMF_VM) :: vm - type(ESMF_Time) :: currtime + type(ESMF_Clock) :: clock type(ESMF_Time) :: starttime + type(ESMF_Time) :: currtime type(ESMF_Time) :: nexttime - type(ESMF_TimeInterval) :: timediff ! Used to calculate curr_time - type(ESMF_Calendar) :: calendar ! calendar type - character(len=64) :: currtimestr - character(len=64) :: nexttimestr - type(InternalState) :: is_local - character(CS) :: histavg_option ! Histavg option units - integer :: i,j,m,n,n1,ncnt - integer :: start_ymd ! Starting date YYYYMMDD - integer :: start_tod ! Starting time-of-day (s) - integer :: nx,ny ! global grid size - integer :: yr,mon,day,sec ! time units - real(r8) :: rval ! real tmp value - real(r8) :: dayssince ! Time interval since reference time - integer :: fk ! index - character(CL) :: time_units ! units of time variable - character(CL) :: case_name ! case name - character(CL) :: hist_file ! Local path to history filename - character(CS) :: cpl_inst_tag ! instance tag - character(CL) :: cvalue ! attribute string - real(r8) :: tbnds(2) ! CF1.0 time bounds - logical :: whead,wdata ! for writing restart/history cdf files - integer :: iam - logical :: isPresent - type(ESMF_TimeInterval) :: RingInterval - integer :: ringInterval_length - logical :: first_time = .true. - character(len=*), parameter :: subname='(med_phases_history_write)' + type(ESMF_Calendar) :: calendar ! calendar type + type(ESMF_TimeInterval) :: timediff(2) ! time bounds upper and lower relative to start + character(len=CS) :: nexttime_str + integer :: yr,mon,day,sec + integer :: start_ymd ! starting date YYYYMMDD + character(CL) :: time_units ! units of time variable + real(r8) :: time_val ! time coordinate output + real(r8) :: time_bnds(2) ! time bounds output + character(len=CL) :: hist_str + character(len=CL) :: hist_file + integer :: m + logical :: isPresent, isSet + character(len=*), parameter :: subname='(med_phases_history_write_lnd2glc)' !--------------------------------------- - 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 communicator and localpet - !--------------------------------------- + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + ! Get the model clock + call NUOPC_ModelGet(gcomp, modelClock=clock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, localPet=iam, rc=rc) + + ! Determine starttime, currtime and nexttime + call ESMF_ClockGet(clock, currtime=currtime, starttime=starttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetNextTime(clock, nextTime=nexttime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! --- Get the internal state - !--------------------------------------- + ! Determine time units + call ESMF_TimeGet(starttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_ymd2date(yr,mon,day,start_ymd) + time_units = 'days since ' // trim(med_io_date2yyyymmdd(start_ymd)) // ' ' // med_io_sec2hms(sec, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - nullify(is_local%wrap) - call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + ! Set time bounds and time coord + timediff(1) = nexttime - starttime + call ESMF_TimeIntervalGet(timediff(1), d=day, s=sec, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='case_name', value=case_name, rc=rc) + time_val = day + sec/real(SecPerDay,R8) + time_bnds(1) = time_val + time_bnds(2) = time_val + + ! Determine history file name + if (trim(case_name) == 'unset') then + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=case_name, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if(isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', value=inst_tag, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + inst_tag = "" + endif + end if + call ESMF_TimeGet(nexttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(nexttime_str,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + write(hist_file, "(6a)") trim(case_name),'.cpl',trim(inst_tag),'.hx.1yr2glc.',trim(nexttime_str),'.nc' - call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', isPresent=isPresent, rc=rc) + ! Create history file + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(isPresent) then - call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', value=cpl_inst_tag, rc=rc) + call med_io_wopen(hist_file, vm, clobber=.true.) + + ! Write data to history file + do m = 1,2 + if (whead(m)) then + call ESMF_ClockGet(clock, calendar=calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_define_time(time_units, calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call med_io_enddef(hist_file) + call med_io_write_time(time_val, time_bnds, nt=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call med_io_write(hist_file, fldbun, whead(m), wdata(m), is_local%wrap%nx(complnd), is_local%wrap%ny(complnd), & + nt=1, pre=trim(compname(complnd))//'Imp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - cpl_inst_tag = "" - endif + end do ! end of loop over m - call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) + ! Close history file + call med_io_close(hist_file, vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (first_time) then - call med_phases_history_alarm_init(gcomp, rc) - end if + end subroutine med_phases_history_write_lnd2glc + + !=============================================================================== + subroutine med_phases_history_write_comp(gcomp, compid, rc) + + ! Write mediator history file for atm variables + + ! input/output variables + type(ESMF_GridComp), intent(inout) :: gcomp + integer , intent(in) :: compid + integer , intent(out) :: rc !--------------------------------------- - ! Check if history alarm is ringing - and if so write the mediator history file + rc = ESMF_SUCCESS + + call med_phases_history_write_comp_inst(gcomp, compid, instfiles(compid), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_phases_history_write_comp_avg(gcomp, compid, avgfiles(compid), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_phases_history_write_comp_aux(gcomp, compid, auxcomp(compid), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine med_phases_history_write_comp + + !=============================================================================== + subroutine med_phases_history_write_comp_inst(gcomp, compid, instfile, rc) + + ! Write instantaneous mediator history file for component compid + + use med_io_mod, only : med_io_write_time, med_io_define_time + use ESMF , only : ESMF_FieldBundleIsCreated + + ! input/output variables + type(ESMF_GridComp) , intent(inout) :: gcomp + integer , intent(in) :: compid + type(instfile_type) , intent(inout) :: instfile + integer , intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + character(CL) :: cvalue ! attribute string + character(CL) :: hist_option ! freq_option setting (ndays, nsteps, etc) + integer :: hist_n ! freq_n setting relative to freq_option + character(CL) :: hist_option_in + character(CL) :: hist_n_in + logical :: isPresent + logical :: isSet + type(ESMF_VM) :: vm + type(ESMF_Calendar) :: calendar ! calendar type + integer :: i,m,n ! indices + integer :: nx,ny ! global grid size + character(CL) :: time_units ! units of time variable + character(CL) :: hist_file ! history file name + real(r8) :: time_val ! time coordinate output + real(r8) :: time_bnds(2) ! time bounds output + logical :: write_now ! true => write to history type + real(r8) :: tbnds(2) ! CF1.0 time bounds + character(len=*), parameter :: subname='(med_phases_history_write_inst_comp)' !--------------------------------------- - ! TODO: Add history averaging functionality and Determine if history average alarm is on - ! if (ESMF_AlarmIsRinging(AlarmHistAvg, rc=rc)) then - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! alarmIsOn = .true. - ! call ESMF_AlarmRingerOff( AlarmHist, rc=rc ) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! else - ! alarmisOn = .false. - ! endif + rc = ESMF_SUCCESS + call t_startf('MED:'//subname) - call ESMF_ClockGetAlarm(mclock, alarmname='alarm_history_inst', alarm=alarm, rc=rc) + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 2) then - call ESMF_AlarmGet(alarm, ringInterval=ringInterval, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeIntervalGet(ringInterval, s=ringinterval_length, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGet(mclock, currtime=currtime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(currtime,yy=yr, mm=mon, dd=day, s=sec, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec - call ESMF_ClockGetNextTime(mclock, nextTime=nexttime, rc=rc) + ! alarm is not set determine hist_option and hist_n + if (.not. instfile%is_clockset) then + + ! Determine attribute prefix + write(hist_option_in,'(a)') 'history_option_'//trim(compname(compid))//'_inst' + write(hist_n_in,'(a)') 'history_n_'//trim(compname(compid))//'_inst' + + ! Determine instantaneous mediator output frequency and type + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_option_in), isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(nexttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_option_in), value=hist_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_n_in), value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_n + else + ! If attribute is not present - don't write history output + hist_option = 'none' + hist_n = -999 + end if + + ! Set alarm name and initialize clock and alarm for instantaneous history output + if (hist_option /= 'none' .and. hist_option /= 'never') then + instfile%alarmname = 'alarm_history_inst_'//trim(compname(compid)) + call med_phases_history_init_histclock(gcomp, instfile%clock, & + instfile%alarm, instfile%alarmname, hist_option, hist_n, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + instfile%is_active = .true. + instfile%is_clockset = .true. + else + instfile%is_active = .false. + ! this is set to true here even if history file is not active + instfile%is_clockset = .true. + end if + end if ! end of if-clock set if block + + ! if history file is active and history clock is initialized - process history file + if (instfile%is_active .and. instfile%is_clockset) then + + ! Determine if should write to history file + call med_phases_history_query_ifwrite(gcomp, instfile%clock, instfile%alarmname, write_now, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(nexttimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec - write(logunit,*) - write(logunit,*) trim(subname)//": history alarm ringinterval = ", ringInterval_length - write(logunit,' (a)') trim(subname)//": currtime = "//trim(currtimestr)//" nexttime = "//trim(nexttimestr) - write(logunit,*) trim(subname) //' history alarm is ringing = ', ESMF_AlarmIsRinging(alarm) + + ! If write now flag is true + if (write_now) then + ! Determine time_val and tbnds data for history as well as history file name + call med_phases_history_set_timeinfo(gcomp, instfile%clock, instfile%alarmname, & + time_val, time_bnds, time_units, hist_file, doavg=.false., compname=compname(compid), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Create history file + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_wopen(hist_file, vm, clobber=.true.) + do m = 1,2 + ! Write time values + if (whead(m)) then + call ESMF_ClockGet(instfile%clock, calendar=calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_define_time(time_units, calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call med_io_enddef(hist_file) + call med_io_write_time(time_val, time_bnds, nt=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + nx = is_local%wrap%nx(compid) + ny = is_local%wrap%ny(compid) + ! Define/write import field bundle + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(compid,compid),rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBimp(compid,compid), whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(compid))//'Imp', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + ! Define/write import export bundle + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid),rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBexp(compid), whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(compid))//'Exp', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + ! Define/Write mediator fractions + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBFrac(compid),rc=rc)) then + call med_io_write(hist_file, is_local%wrap%FBFrac(compid), whead(m), wdata(m), nx, ny, & + nt=1, pre='Med_frac_'//trim(compname(compid)), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + end do ! end of loop over m + + ! Close file + call med_io_close(hist_file, vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if end if - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf('MED:'//subname) - ! Turn ringer off - call ESMF_AlarmRingerOff( alarm, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + end subroutine med_phases_history_write_comp_inst - ! Get time info for history file - call ESMF_GridCompGet(gcomp, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !=============================================================================== + subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) - call ESMF_ClockGet(mclock, currtime=currtime, starttime=starttime, calendar=calendar, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Write mediator average history file variables for component compid - call ESMF_ClockGetNextTime(mclock, nextTime=nexttime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + use ESMF , only : ESMF_FieldBundleIsCreated + use med_constants_mod , only : czero => med_constants_czero + use med_methods_mod , only : med_methods_FB_init, med_methods_FB_reset + use med_io_mod , only : med_io_write_time, med_io_define_time - call ESMF_TimeGet(currtime,yy=yr, mm=mon, dd=day, s=sec, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + ! input/output variables + type(ESMF_GridComp) , intent(inout) :: gcomp + integer , intent(in) :: compid + type(avgfile_type) , intent(inout) :: avgfile + integer , intent(out) :: rc - call ESMF_TimeGet(nexttime,yy=yr, mm=mon, dd=day, s=sec, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - write(nexttimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec - timediff = nexttime - starttime - call ESMF_TimeIntervalGet(timediff, d=day, s=sec, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - dayssince = day + sec/real(SecPerDay,R8) + ! local variables + type(InternalState) :: is_local + character(CL) :: cvalue ! attribute string + character(CL) :: hist_option ! freq_option setting (ndays, nsteps, etc) + integer :: hist_n ! freq_n setting relative to freq_option + character(CL) :: hist_option_in + character(CL) :: hist_n_in + logical :: isPresent + logical :: isSet + type(ESMF_VM) :: vm + type(ESMF_Calendar) :: calendar ! calendar type + integer :: i,m,n ! indices + integer :: nx,ny ! global grid size + character(CL) :: time_units ! units of time variable + character(CL) :: hist_file ! history file name + real(r8) :: time_val ! time coordinate output + real(r8) :: time_bnds(2) ! time bounds output + logical :: write_now ! true => write to history type + real(r8) :: tbnds(2) ! CF1.0 time bounds + character(CS) :: scalar_name + character(len=*), parameter :: subname='(med_phases_history_write_comp_avg)' + !--------------------------------------- - call ESMF_TimeGet(starttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_io_ymd2date(yr,mon,day,start_ymd) - start_tod = sec - time_units = 'days since ' // trim(med_io_date2yyyymmdd(start_ymd)) // ' ' // med_io_sec2hms(start_tod, rc) + rc = ESMF_SUCCESS + + call t_startf('MED:'//subname) + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! alarm is not set determine hist_option and hist_n + if (.not. avgfile%is_clockset) then + + ! Determine attribute prefix + write(hist_option_in,'(a)') 'history_option_'//trim(compname(compid))//'_avg' + write(hist_n_in,'(a)') 'history_n_'//trim(compname(compid))//'_avg' + + ! Determine time average mediator output frequency and type + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_option_in), isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_option_in), value=hist_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name=trim(hist_n_in), value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_n + else + hist_option = 'none' + hist_n = -999 + end if + if (hist_option /= 'never' .and. hist_option /= 'none') then + + ! Set alarm name, initialize clock and alarm for average history output and + avgfile%alarmname = 'alarm_history_avg_'//trim(compname(compid)) + call med_phases_history_init_histclock(gcomp, avgfile%clock, & + avgfile%alarm, avgfile%alarmname, hist_option, hist_n, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + avgfile%is_active = .true. + avgfile%is_clockset = .true. + + ! Initialize accumulation import/export field bundles + scalar_name = trim(is_local%wrap%flds_scalar_name) + if ( ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(compid,compid)) .and. .not. & + ESMF_FieldBundleIsCreated(avgfile%FBaccum_import)) then + call med_methods_FB_init(avgfile%FBaccum_import, scalar_name, & + FBgeom=is_local%wrap%FBImp(compid,compid), FBflds=is_local%wrap%FBimp(compid,compid), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call med_methods_FB_reset(avgfile%FBaccum_import, czero, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + avgfile%accumcnt_import = 0 + end if + if ( ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid)) .and. .not. & + ESMF_FieldBundleIsCreated(avgfile%FBaccum_export)) then + call med_methods_FB_init(avgfile%FBaccum_export, scalar_name, & + FBgeom=is_local%wrap%FBExp(compid), FBflds=is_local%wrap%FBexp(compid), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call med_methods_FB_reset(avgfile%FBaccum_export, czero, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + avgfile%accumcnt_export = 0 + end if + + else - ! Use nexttimestr rather than currtimestr here since that is the time at the end of - ! the timestep and is preferred for history file names - write(hist_file,"(6a)") trim(case_name), '.cpl',trim(cpl_inst_tag),'.hi.', trim(nexttimestr),'.nc' + avgfile%is_active = .false. + ! this is set to true here even if history file is not active + avgfile%is_clockset = .true. - if (mastertask) then - write(logunit,*) - write(logunit,' (a)') trim(subname)//": writing mediator history file "//trim(hist_file) - write(logunit,' (a)') trim(subname)//": currtime = "//trim(currtimestr) - write(logunit,' (a)') trim(subname)//": nexttime = "//trim(nexttimestr) end if + end if ! end of if-clock set if block - call med_io_wopen(hist_file, vm, iam, clobber=.true.) - do m = 1,2 - whead=.false. - wdata=.false. - if (m == 1) then - whead=.true. - elseif (m == 2) then - wdata=.true. - call med_io_enddef(hist_file) - endif + ! if history file is active and history clock is initialized - process history file + if (avgfile%is_active .and. avgfile%is_clockset) then - tbnds = dayssince + ! Determine if will write to history file + call med_phases_history_query_ifwrite(gcomp, avgfile%clock, avgfile%alarmname, write_now, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (tbnds(1) >= tbnds(2)) then - call med_io_write(hist_file, iam, time_units=time_units, calendar=calendar, time_val=dayssince, & - whead=whead, wdata=wdata, rc=rc) + ! Accumulate and then average if write_now flag is true + if (ESMF_FieldBundleIsCreated(avgfile%FBaccum_import)) then + call med_phases_history_fldbun_accum(is_local%wrap%FBImp(compid,compid), & + avgfile%FBaccum_import, avgfile%accumcnt_import, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (write_now) then + call med_phases_history_fldbun_average(avgfile%FBaccum_import, avgfile%accumcnt_import, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call med_io_write(hist_file, iam, time_units=time_units, calendar=calendar, time_val=dayssince, & - whead=whead, wdata=wdata, tbnds=tbnds, rc=rc) + end if + end if + if (ESMF_FieldBundleIsCreated(avgfile%FBaccum_export)) then + call med_phases_history_fldbun_accum(is_local%wrap%FBExp(compid), & + avgfile%FBaccum_export, avgfile%accumcnt_export, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (write_now) then + call med_phases_history_fldbun_average(avgfile%FBaccum_export, avgfile%accumcnt_export, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + end if + end if + + ! If write now flag is true + if (write_now) then + + ! Determine time_val and tbnds data for history as well as history file name + call med_phases_history_set_timeinfo(gcomp, avgfile%clock, avgfile%alarmname, & + time_val, time_bnds, time_units, hist_file, doavg=.true., compname=trim(compname(compid)), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Create history file + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_wopen(hist_file, vm, clobber=.true.) + do m = 1,2 + ! Write time values + if (whead(m)) then + call ESMF_ClockGet(avgfile%clock, calendar=calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_define_time(time_units, calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call med_io_enddef(hist_file) + call med_io_write_time(time_val, time_bnds, nt=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - do n = 1,ncomps - if (is_local%wrap%comp_present(n)) then - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(n,n),rc=rc)) then - nx = is_local%wrap%nx(n) - ny = is_local%wrap%ny(n) - call med_io_write(hist_file, iam, is_local%wrap%FBimp(n,n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'Imp', rc=rc) + ! Write import and export field bundles + if (is_local%wrap%comp_present(compid)) then + nx = is_local%wrap%nx(compid) + ny = is_local%wrap%ny(compid) + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(compid,compid),rc=rc)) then + call med_io_write(hist_file, avgfile%FBaccum_import, whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(compid))//'Imp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (wdata(m)) then + call med_methods_FB_reset(avgfile%FBAccum_import, czero, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if endif - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(n),rc=rc)) then - nx = is_local%wrap%nx(n) - ny = is_local%wrap%ny(n) - call med_io_write(hist_file, iam, is_local%wrap%FBexp(n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'Exp', rc=rc) + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid),rc=rc)) then + call med_io_write(hist_file, avgfile%FBaccum_export, whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(compid))//'Exp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (wdata(m)) then + call med_methods_FB_reset(avgfile%FBAccum_export, czero, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if endif - ! write component mediator fractions - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBFrac(n),rc=rc)) then - nx = is_local%wrap%nx(n) - ny = is_local%wrap%ny(n) - call med_io_write(hist_file, iam, is_local%wrap%FBFrac(n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='Med_frac_'//trim(compname(n)), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end do ! end of loop over m + + ! Close file + call med_io_close(hist_file, vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end if ! end of write_now if-block + end if ! end of clock created if-block + + call t_stopf('MED:'//subname) + + end subroutine med_phases_history_write_comp_avg + + !=============================================================================== + subroutine med_phases_history_write_comp_aux(gcomp, compid, auxcomp, rc) + + ! ----------------------------- + ! Write mediator auxiliary history file for auxcomp component + ! Initialize auxiliary history file + ! Each time this routine is called the routine SetRunClock in med.F90 is called + ! at the beginning and the mediator clock current time and time step is set to the + ! driver current time and time step + ! ----------------------------- + + use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_FieldBundleRemove + use med_constants_mod, only : czero => med_constants_czero + use med_io_mod , only : med_io_write_time, med_io_define_time + use med_methods_mod , only : med_methods_FB_init + use med_methods_mod , only : med_methods_FB_reset + use med_methods_mod , only : med_methods_FB_fldchk + + ! input/output variables + type(ESMF_GridComp) , intent(inout) :: gcomp + integer , intent(in) :: compid + type(auxcomp_type) , intent(inout) :: auxcomp + integer , intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + type(ESMF_VM) :: vm + type(ESMF_Calendar) :: calendar ! calendar type + logical :: isPresent ! is attribute present + logical :: isSet ! is attribute set + character(CL) :: hist_option ! freq_option setting (ndays, nsteps, etc) + integer :: hist_n ! freq_n setting relative to freq_option + integer :: nfcnt + integer :: nfile + integer :: nfld + integer :: n,n1,nf + character(CL) :: prefix + character(CL) :: cvalue + character(CL) :: auxflds + integer :: fieldCount + logical :: found + logical :: enable_auxfile + character(CS) :: timestr ! yr-mon-day-sec string + character(CL) :: time_units ! units of time variable + integer :: nx,ny ! global grid size + logical :: write_now ! if true, write time sample to file + integer :: yr,mon,day,sec ! time units + real(r8) :: time_val ! time coordinate output + real(r8) :: time_bnds(2) ! time bounds output + character(CS), allocatable :: fieldNameList(:) + character(len=*), parameter :: subname='(med_phases_history_write_comp_aux)' + !--------------------------------------- + + rc = ESMF_SUCCESS + call t_startf('MED:'//subname) + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (.not. auxcomp%init_auxfiles) then + + ! Initialize number of aux files for this component to zero + nfcnt = 0 + do nfile = 1,max_auxfiles + ! Determine attribute prefix + write(prefix,'(a,i0)') 'histaux_'//trim(compname(compid))//'2med_file',nfile + + ! Determine if will write the file + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_enabled', isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_enabled', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,'(l)') enable_auxfile + else + enable_auxfile = .false. + end if + + ! If file will be written - then initialize auxcomp%files(nfcnt) + if (enable_auxfile) then + ! Increment nfcnt + nfcnt = nfcnt + 1 + + ! Determine number of time samples per file + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_ntperfile', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) auxcomp%files(nfcnt)%ntperfile + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine if will do time average for aux file + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_doavg', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) auxcomp%files(nfcnt)%doavg + + ! Determine the colon delimited field names for this file + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_flds', value=auxflds, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine fields that will be output to auxhist files + if (trim(auxflds) == 'all') then + + ! Output all fields sent to the mediator from ncomp to the auxhist files + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compid,compid), fieldCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(auxcomp%files(nfcnt)%flds(fieldcount)) + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compid,compid), fieldNameList=auxcomp%files(nfcnt)%flds, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + else + + ! Translate the colon deliminted string (auxflds) into a character array (fieldnamelist) + ! Note that the following call allocates the memory for fieldnamelist + call get_auxflds(auxflds, fieldnamelist, rc) + + ! TODO: print warning statement if remove field + ! TODO: if request field that is NOT in the field definition file - then quit + ! Remove all fields from fieldnamelist that are not in FBImp(compid,compid) + fieldCount = size(fieldnamelist) + do n = 1,fieldcount + if (.not. med_methods_FB_fldchk(is_local%wrap%FBImp(compid,compid), trim(fieldnamelist(n)), rc)) then + do n1 = n, fieldCount-1 + fieldnamelist(n1) = fieldnamelist(n1+1) + end do + fieldCount = fieldCount - 1 + end if + end do + + ! Create auxcomp%files(nfcnt)%flds array + allocate(auxcomp%files(nfcnt)%flds(fieldcount)) + do n = 1,fieldcount + auxcomp%files(nfcnt)%flds(n) = trim(fieldnamelist(n)) + end do + + ! Deallocate memory from fieldnamelist + deallocate(fieldnamelist) ! this was allocated in med_phases_history_get_auxflds + + end if ! end of if auxflds is set to 'all' + + if (mastertask) then + write(logunit,*) + write(logunit,'(a,i4,a)') trim(subname) // ' Writing the following fields to auxfile ',nfcnt,& + ' for component '//trim(compname(compid)) + do nfld = 1,size(auxcomp%files(nfcnt)%flds) + write(logunit,'(8x,a)') trim(auxcomp%files(nfcnt)%flds(nfld)) + end do + end if + + ! Create FBaccum if averaging is on + if (auxcomp%files(nfcnt)%doavg) then + + ! First duplicate all fields in FBImp(compid,compid) + call ESMF_LogWrite(trim(subname)// ": initializing FBaccum(compid)", ESMF_LOGMSG_INFO) + if ( ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compid,compid)) .and. .not. & + ESMF_FieldBundleIsCreated(auxcomp%files(nfcnt)%FBaccum)) then + call med_methods_FB_init(auxcomp%files(nfcnt)%FBaccum, is_local%wrap%flds_scalar_name, & + FBgeom=is_local%wrap%FBImp(compid,compid), FBflds=is_local%wrap%FBImp(compid,compid), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call med_methods_FB_reset(auxcomp%files(nfcnt)%FBaccum, czero, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + auxcomp%files(nfcnt)%accumcnt = 0 + end if + + ! Now remove all fields from FBAccum that are not in the input flds list + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compid,compid), fieldCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compid,compid), fieldNameList=fieldNameList, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(fieldnamelist) + found = .false. + do n1 = 1,size(auxcomp%files(nfcnt)%flds) + if (trim(fieldnamelist(n)) == trim(auxcomp%files(nfcnt)%flds(n1))) then + found = .true. + exit + end if + end do + if (.not. found) then + call ESMF_FieldBundleRemove(auxcomp%files(nfcnt)%FBaccum, fieldnamelist(n:n), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + end do + deallocate(fieldnameList) + + ! Check that FBAccum has at least one field left - if not exit + call ESMF_FieldBundleGet(auxcomp%files(nfcnt)%FBAccum, fieldCount=nfld, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (nfld == 0) then + call ESMF_LogWrite(subname//'FBAccum is zero for '//trim(auxcomp%files(nfcnt)%auxname), & + ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) then + call ESMF_Finalize(endflag=ESMF_END_ABORT) + end if end if - ! write component mediator areas - nx = is_local%wrap%nx(n) - ny = is_local%wrap%ny(n) - call med_io_write(hist_file, iam, is_local%wrap%FBArea(n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='MED_'//trim(compname(n)), rc=rc) + end if - enddo - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_o,rc=rc)) then - nx = is_local%wrap%nx(compocn) - ny = is_local%wrap%ny(compocn) - 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) + + ! Determine auxiliary file output frequency and type + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_history_option', value=hist_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_history_n', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_n + + ! Determine alarmname + call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_auxname', value=auxcomp%files(nfcnt)%auxname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(auxcomp%files(nfcnt)%alarmname,'(a,i0)') 'alarm_'//trim(prefix) + + ! Initialize clock and alarm for instantaneous history output + call med_phases_history_init_histclock(gcomp, auxcomp%files(nfcnt)%clock, & + auxcomp%files(nfcnt)%alarm, auxcomp%files(nfcnt)%alarmname, hist_option, hist_n, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end if ! end of isPresent and isSet and if flag is on for file n + end do ! end of loop over nfile + + ! Set number of aux files for this component - this is a module variable + auxcomp%num_auxfiles = nfcnt + + ! Set initialization flags to .true. + auxcomp%init_auxfiles = .true. + + end if ! end of initialization if-block + + ! Write auxiliary history files for component compid + do nf = 1,auxcomp%num_auxfiles + + ! Determine if will write to history file + call med_phases_history_query_ifwrite(gcomp, auxcomp%files(nf)%clock, auxcomp%files(nf)%alarmname, write_now, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Do accumulation and average if required + if (auxcomp%files(nf)%doavg) then + call med_phases_history_fldbun_accum(is_local%wrap%FBImp(compid,compid), & + auxcomp%files(nf)%FBaccum, auxcomp%files(nf)%accumcnt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (write_now) then + call med_phases_history_fldbun_average(auxcomp%files(nf)%FBaccum, auxcomp%files(nf)%accumcnt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + end if + + ! Write time sample to file + if ( write_now ) then + + ! Determine time_val and tbnds data for history as well as history file name + call med_phases_history_set_timeinfo(gcomp, auxcomp%files(nf)%clock, auxcomp%files(nf)%alarmname, & + time_val, time_bnds, time_units, auxcomp%files(nf)%histfile, auxcomp%files(nf)%doavg, & + auxname=auxcomp%files(nf)%auxname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set shorthand variables + nx = is_local%wrap%nx(compid) + ny = is_local%wrap%ny(compid) + + ! Increment number of time samples on file + auxcomp%files(nf)%nt = auxcomp%files(nf)%nt + 1 + + ! Write header + if (auxcomp%files(nf)%nt == 1) then + ! open file + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_wopen(auxcomp%files(nf)%histfile, vm, file_ind=nf, clobber=.true.) + + ! define time variables + call ESMF_ClockGet(auxcomp%files(nf)%clock, calendar=calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_define_time(time_units, calendar, file_ind=nf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! define data variables with a time dimension (include the nt argument below) + call med_io_write(auxcomp%files(nf)%histfile, is_local%wrap%FBimp(compid,compid), & + whead(1), wdata(1), nx, ny, nt=auxcomp%files(nf)%nt, & + pre=trim(compname(compid))//'Imp', flds=auxcomp%files(nf)%flds, & + file_ind=nf, use_float=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! end definition phase + call med_io_enddef(auxcomp%files(nf)%histfile, file_ind=nf) 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) + + ! Write time variables for time nt + call med_io_write_time(time_val, time_bnds, nt=auxcomp%files(nf)%nt, file_ind=nf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Write data variables for time nt + if (auxcomp%files(nf)%doavg) then + call med_io_write(auxcomp%files(nf)%histfile, auxcomp%files(nf)%FBaccum, whead(2), wdata(2), nx, ny, & + nt=auxcomp%files(nf)%nt, pre=trim(compname(compid))//'Imp', flds=auxcomp%files(nf)%flds, file_ind=nf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_methods_FB_reset(auxcomp%files(nf)%FBaccum, value=czero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call med_io_write(auxcomp%files(nf)%histfile, is_local%wrap%FBimp(compid,compid), whead(2), wdata(2), nx, ny, & + nt=auxcomp%files(nf)%nt, pre=trim(compname(compid))//'Imp', flds=auxcomp%files(nf)%flds, file_ind=nf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return 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) - call med_io_write(hist_file, iam, is_local%wrap%FBMed_aoflux_o, & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='Med_aoflux_ocn', rc=rc) + + ! Close file + if (auxcomp%files(nf)%nt == auxcomp%files(nf)%ntperfile) then + call med_io_close(auxcomp%files(nf)%histfile, vm, file_ind=nf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + auxcomp%files(nf)%nt = 0 end if - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_a,rc=rc)) then - nx = is_local%wrap%nx(compatm) - ny = is_local%wrap%ny(compatm) - call med_io_write(hist_file, iam, is_local%wrap%FBMed_ocnalb_a, & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='Med_alb_atm', rc=rc) + + end if ! end of write_now if-block + + end do + call t_stopf('MED:'//subname) + + contains + + subroutine get_auxflds(str, flds, rc) + ! input/output variables + character(len=*) , intent(in) :: str ! colon deliminted string to search + character(len=*) , allocatable , intent(out) :: flds(:) ! memory will be allocate for flds + integer , intent(out) :: rc + ! local variables + integer :: i,k,n ! generic indecies + integer :: nflds ! allocatable size of flds + integer :: count ! counts occurances of char + integer :: kFlds ! number of fields in list + integer :: i0,i1 ! name = list(i0:i1) + integer :: nChar ! temporary + logical :: valid ! check if str is valid + !--------------------------------------- + rc = ESMF_SUCCESS + + ! check that this is a str is a valid colon dlimited list + valid = .true. + nChar = len_trim(str) + if (nChar < 1) then ! list is an empty string + valid = .false. + else if (str(1:1) == ':') then ! first char is delimiter + valid = .false. + else if (str(nChar:nChar) == ':') then ! last char is delimiter + valid = .false. + else if (index(trim(str)," ") > 0) then ! white-space in a field name + valid = .false. + end if + if (.not. valid) then + if (mastertask) write(logunit,*) "ERROR: invalid list = ",trim(str) + call ESMF_LogWrite("ERROR: invalid list = "//trim(str), ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + end if + ! get number of fields in a colon delimited string list + nflds = 0 + if (len_trim(str) > 0) then + count = 0 + do n = 1, len_trim(str) + if (str(n:n) == ':') count = count + 1 + end do + nflds = count + 1 + endif + ! allocate memory for flds) + allocate(flds(nflds)) + do k = 1,nflds + ! start with whole list + i0 = 1 + i1 = len_trim(str) + ! remove field names before kth field + do n = 2,k + i = index(str(i0:i1),':') + i0 = i0 + i + end do + ! remove field names after kth field + if (k < nFlds) then + i = index(str(i0:i1),':') + i1 = i0 + i - 2 + end if + ! set flds(k) + flds(k) = str(i0:i1)//" " + end do + end subroutine get_auxflds + + end subroutine med_phases_history_write_comp_aux + + !=============================================================================== + subroutine med_phases_history_fldbun_accum(fldbun, fldbun_accum, count, rc) + + use ESMF, only : ESMF_Field, ESMF_FieldGet + + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: fldbun + type(ESMF_FieldBundle) , intent(inout) :: fldbun_accum + integer , intent(out) :: count + integer , intent(out) :: rc + + ! local variables + integer :: n + type(ESMF_Field) :: lfield + type(ESMF_Field) :: lfield_accum + integer :: fieldCount + character(CL), pointer :: fieldnames(:) + real(r8), pointer :: dataptr1d(:) + real(r8), pointer :: dataptr2d(:,:) + real(r8), pointer :: dataptr1d_accum(:) + real(r8), pointer :: dataptr2d_accum(:,:) + integer :: ungriddedUBound(1) + !--------------------------------------- + + rc = ESMF_SUCCESS + + ! Accumulate field + call ESMF_FieldBundleGet(fldbun_accum, fieldCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(fieldnames(fieldCount)) + call ESMF_FieldBundleGet(fldbun_accum, fieldNameList=fieldnames, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1, fieldcount + call ESMF_FieldBundleGet(fldbun, fieldName=trim(fieldnames(n)), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(fldbun_accum, fieldName=trim(fieldnames(n)), field=lfield_accum, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + 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 + call ESMF_FieldGet(lfield_accum, farrayptr=dataptr2d_accum, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + dataptr2d_accum(:,:) = dataptr2d_accum(:,:) + dataptr2d(:,:) + else + call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield_accum, farrayptr=dataptr1d_accum, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + dataptr1d_accum(:) = dataptr1d_accum(:) + dataptr1d(:) + end if + end do + deallocate(fieldnames) + + ! Accumulate counter + count = count + 1 + + end subroutine med_phases_history_fldbun_accum + + !=============================================================================== + subroutine med_phases_history_fldbun_average(fldbun_accum, count, rc) + + use ESMF , only : ESMF_Field, ESMF_FieldGet + use med_constants_mod , only : czero => med_constants_czero + + ! input/output variables + type(ESMF_FieldBundle) , intent(inout) :: fldbun_accum + integer , intent(inout) :: count + integer , intent(out) :: rc + + ! local variables + integer :: n,i + type(ESMF_Field) :: lfield_accum + integer :: fieldCount + character(CL), pointer :: fieldnames(:) + real(r8), pointer :: dataptr1d_accum(:) + real(r8), pointer :: dataptr2d_accum(:,:) + integer :: ungriddedUBound(1) + !--------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_FieldBundleGet(fldbun_accum, fieldCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(fieldnames(fieldCount)) + call ESMF_FieldBundleGet(fldbun_accum, fieldNameList=fieldnames, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1, fieldcount + call ESMF_FieldBundleGet(fldbun_accum, fieldName=trim(fieldnames(n)), field=lfield_accum, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield_accum, ungriddedUBound=ungriddedUBound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ungriddedUBound(1) > 0) then + call ESMF_FieldGet(lfield_accum, farrayptr=dataptr2d_accum, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (count == 0) then + dataptr2d_accum(:,:) = czero + else + dataptr2d_accum(:,:) = dataptr2d_accum(:,:) / real(count, r8) end if - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_a,rc=rc)) then - nx = is_local%wrap%nx(compatm) - ny = is_local%wrap%ny(compatm) - call med_io_write(hist_file, iam, is_local%wrap%FBMed_aoflux_a, & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='Med_aoflux_atm', rc=rc) + else + call ESMF_FieldGet(lfield_accum, farrayptr=dataptr1d_accum, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (count == 0) then + dataptr1d_accum(:) = czero + else + dataptr1d_accum(:) = dataptr1d_accum(:) / real(count, r8) end if - enddo + end if + end do + deallocate(fieldnames) + + ! Reset counter + count = 0 + + end subroutine med_phases_history_fldbun_average + + !=============================================================================== + subroutine med_phases_history_init_histclock(gcomp, hclock, alarm, alarmname, hist_option, hist_n, rc) + + use NUOPC_Mediator, only : NUOPC_MediatorGet + use ESMF , only : ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockSet + use med_time_mod , only : med_time_alarmInit + + ! input/output variables + type(ESMF_GridComp) , intent(in) :: gcomp + type(ESMF_Clock) , intent(inout) :: hclock + type(ESMF_Alarm) , intent(inout) :: alarm + character(len=*) , intent(in) :: alarmname + character(len=*) , intent(in) :: hist_option ! freq_option setting (ndays, nsteps, etc) + integer , intent(in) :: hist_n ! freq_n setting relative to freq_option + integer , intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: StartTime + type(ESMF_TimeInterval) :: htimestep + type(ESMF_TimeInterval) :: mtimestep, dtimestep + integer :: msec, dsec + character(len=*), parameter :: subname='(med_phases_history_init_histclock) ' + !--------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_MediatorGet(gcomp, mediatorClock=mClock, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(mclock, timeStep=mtimestep, starttime=starttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalGet(mtimestep, s=msec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(dclock, timeStep=dtimestep, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalGet(dtimestep, s=dsec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (mastertask) then + write(logunit,'(a,2x,i8,2x,i8)') trim(subname) // " mediator, driver timesteps for " & + //trim(alarmname),msec,dsec + end if - call med_io_close(hist_file, iam, rc=rc) + ! Create history clock from mediator clock - THIS CALL DOES NOT COPY ALARMS + hclock = ESMF_ClockCreate(mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Initialize history alarm and advance history clock to trigger + ! alarms then reset history clock back to mcurrtime + call med_time_alarmInit(hclock, alarm, option=hist_option, opt_n=hist_n, & + reftime=StartTime, alarmname=trim(alarmname), advance_clock=.true., rc=rc) + + ! Write diagnostic info + if (mastertask) then + write(logunit,'(a,2x,i8)') trim(subname) // " initialized history alarm "//& + trim(alarmname)//" with option "//trim(hist_option)//" and frequency ",hist_n + end if + + end subroutine med_phases_history_init_histclock + + !=============================================================================== + subroutine med_phases_history_query_ifwrite(gcomp, hclock, alarmname, write_now, rc) + + use NUOPC_Mediator, only : NUOPC_MediatorGet + + ! input/output variables + type(ESMF_GridComp) , intent(in) :: gcomp + type(ESMF_Clock) , intent(inout) :: hclock ! write clock + character(len=*) , intent(in) :: alarmname ! write alarmname + logical , intent(out) :: write_now ! if true => write now + integer , intent(out) :: rc ! error code + + ! local variables + type(ESMF_Clock) :: mclock ! mediator clock + type(ESMF_Alarm) :: alarm ! write alarm + type(ESMF_Time) :: currtime ! current time + character(len=CS) :: currtimestr ! current time string + type(ESMF_Time) :: nexttime ! next time + character(len=CS) :: nexttimestr ! next time string + integer :: yr,mon,day,sec ! time units + type(ESMF_TimeInterval) :: ringInterval + integer :: ringInterval_length + character(len=*), parameter :: subname='(med_phases_history_query_ifwrite) ' + !--------------------------------------- + + rc = ESMF_SUCCESS + + ! Update hclock to trigger alarm + call ESMF_ClockAdvance(hclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Get the history file alarm and determine if alarm is ringing + call ESMF_ClockGetAlarm(hclock, alarmname=trim(alarmname), alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set write_now flag and turn ringer off if appropriate + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_now = .true. + call ESMF_AlarmRingerOff(alarm, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + write_now = .false. + end if + + ! Write diagnostic output + if (write_now) then + if (mastertask .and. debug_alarms) then + ! output alarm info + call ESMF_AlarmGet(alarm, ringInterval=ringInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalGet(ringInterval, s=ringinterval_length, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(hclock, currtime=currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(currtime,yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + call ESMF_ClockGetNextTime(hclock, nextTime=nexttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nexttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(nexttimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec - endif + if (mastertask) then + write(logunit,*) + write(logunit,'(a,i8)') trim(subname)//" : history alarmname "//trim(alarmname)//& + ' is ringing, interval length is ', ringInterval_length + write(logunit,'(a)') trim(subname)//" : hclock currtime = "//trim(currtimestr)//& + " hclock nexttime = "//trim(nexttimestr) + end if - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) - endif - call t_stopf('MED:'//subname) + call NUOPC_MediatorGet(gcomp, mediatorClock=mClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(mclock, currtime=currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(currtime,yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + + call ESMF_ClockGetNextTime(mclock, nextTime=nexttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nexttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(nexttimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec - first_time = .false. + if (mastertask) then + write(logunit,'(a)') trim(subname)//" : mclock currtime = "//trim(currtimestr)//& + " mclock nexttime = "//trim(nexttimestr) + end if - end subroutine med_phases_history_write + end if + end if + + end subroutine med_phases_history_query_ifwrite !=============================================================================== + subroutine med_phases_history_set_timeinfo(gcomp, hclock, alarmname, & + time_val, time_bnds, time_units, histfile, doavg, auxname, compname, rc) + + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Alarm, ESMF_Time, ESMF_TimeInterval + use ESMF , only : ESMF_ClockGet, ESMF_ClockGetNextTime, ESMF_ClockGetAlarm + use ESMF , only : ESMF_AlarmGet, ESMF_TimeIntervalGet, ESMF_TimeGet + use med_constants_mod , only : SecPerDay => med_constants_SecPerDay + use med_io_mod , only : med_io_ymd2date, med_io_date2yyyymmdd, med_io_sec2hms + + ! input/output variables + type(ESMF_GridComp) , intent(in) :: gcomp + type(ESMF_Clock) , intent(in) :: hclock + character(len=*) , intent(in) :: alarmname + real(r8) , intent(out) :: time_val + real(r8) , intent(out) :: time_bnds(2) + character(len=*) , intent(out) :: time_units + character(len=*) , intent(out) :: histfile + logical , intent(in) :: doavg + character(len=*) , optional , intent(in) :: auxname + character(len=*) , optional , intent(in) :: compname + integer , intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: mclock + type(ESMF_Alarm) :: alarm + type(ESMF_Time) :: starttime + type(ESMF_Time) :: currtime + type(ESMF_Time) :: nexttime + type(ESMF_TimeInterval) :: ringInterval ! alarm interval + type(ESMF_TimeInterval) :: timediff(2) ! time bounds upper and lower relative to start + character(len=CL) :: currtime_str + character(len=CL) :: nexttime_str + character(len=CL) :: hist_str + integer :: yr,mon,day,sec ! time units + integer :: start_ymd ! Starting date YYYYMMDD + logical :: isPresent + logical :: isSet + character(len=*), parameter :: subname='(med_phases_history_set_timeinfo) ' + !--------------------------------------- + + rc = ESMF_SUCCESS + + ! Determine starttime, currtime and nexttime from the mediator clock rather than the input history clock + call NUOPC_MediatorGet(gcomp, mediatorClock=mClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(mclock, currtime=currtime, starttime=starttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetNextTime(mclock, nextTime=nexttime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine time units + call ESMF_TimeGet(starttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_ymd2date(yr,mon,day,start_ymd) + time_units = 'days since ' // trim(med_io_date2yyyymmdd(start_ymd)) // ' ' // med_io_sec2hms(sec, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set time bounds and time coord + if (doavg) then + call ESMF_ClockGetAlarm(hclock, alarmname=trim(alarmname), alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_AlarmGet(alarm, ringInterval=ringInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + timediff(2) = nexttime - starttime + timediff(1) = nexttime - starttime - ringinterval + call ESMF_TimeIntervalGet(timediff(2), d_r8=time_bnds(2), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalGet(timediff(1), d_r8=time_bnds(1), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + time_val = 0.5_r8 * (time_bnds(1) + time_bnds(2)) + else + timediff(1) = nexttime - starttime + call ESMF_TimeIntervalGet(timediff(1), d=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + time_val = day + sec/real(SecPerDay,R8) + time_bnds(1) = time_val + time_bnds(2) = time_val + end if + + ! Determine history file name + ! Use nexttime_str rather than currtime_str here since that is the time at the end of + ! the timestep and is preferred for history file names + + call ESMF_TimeGet(nexttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(nexttime_str,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + + if (trim(case_name) == 'unset') then + call NUOPC_CompAttributeGet(gcomp, name='case_name', value=case_name, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', isPresent=isPresent, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if(isPresent) then + call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', value=inst_tag, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + inst_tag = "" + endif + end if + + if (present(auxname)) then + write(histfile, "(8a)") trim(case_name),'.cpl' ,trim(inst_tag),'.hx.',trim(auxname),'.',& + trim(nexttime_str),'.nc' + else if (present(compname)) then + if (doavg) then + hist_str = '.ha.' + else + hist_str = '.hi.' + end if + if (trim(compname) /= 'all') then + hist_str = trim(hist_str) // trim(compname) // '.' + end if + write(histfile, "(6a)") trim(case_name),'.cpl',trim(inst_tag),trim(hist_str),trim(nexttime_str),'.nc' + end if + + if (mastertask) then + call ESMF_TimeGet(currtime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(currtime_str,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec + write(logunit,*) + write(logunit,' (a)') trim(subname) // " writing mediator history file "//trim(histfile) + write(logunit,' (a)') trim(subname) // " currtime = "//trim(currtime_str)//" nexttime = "//trim(nexttime_str) + end if + + end subroutine med_phases_history_set_timeinfo end module med_phases_history_mod diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90 index 1cd819ac8..c9c4d76fe 100644 --- a/mediator/med_phases_ocnalb_mod.F90 +++ b/mediator/med_phases_ocnalb_mod.F90 @@ -94,11 +94,11 @@ subroutine med_phases_ocnalb_init(gcomp, ocnalb, rc) integer :: spatialDim integer :: numOwnedElements type(InternalState) :: is_local - real(R8), pointer :: ownedElemCoords(:) => null() + real(R8), pointer :: ownedElemCoords(:) character(len=CL) :: tempc1,tempc2 logical :: mastertask integer :: fieldCount - type(ESMF_Field), pointer :: fieldlist(:) => null() + type(ESMF_Field), pointer :: fieldlist(:) character(*), parameter :: subname = '(med_phases_ocnalb_init) ' !----------------------------------------------------------------------- @@ -232,10 +232,10 @@ subroutine med_phases_ocnalb_run(gcomp, rc) character(CL) :: runtype ! initial, continue, hybrid, branch logical :: flux_albav ! flux avg option real(R8) :: nextsw_cday ! calendar day of next atm shortwave - real(R8), pointer :: ofrac(:) => null() - real(R8), pointer :: ofrad(:) => null() - real(R8), pointer :: ifrac(:) => null() - real(R8), pointer :: ifrad(:) => null() + real(R8), pointer :: ofrac(:) + real(R8), pointer :: ofrad(:) + real(R8), pointer :: ifrac(:) + real(R8), pointer :: ifrad(:) integer :: lsize ! local size integer :: n,i ! indices real(R8) :: rlat ! gridcell latitude in radians diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index bd6b93230..acf1c2298 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -22,10 +22,13 @@ subroutine med_phases_post_atm(gcomp, rc) ! map atm to ocn and atm to ice and atm to land !--------------------------------------- + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_Clock, ESMF_ClockIsCreated use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_FieldBundleGet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS 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, mastertask, logunit + use med_phases_history_mod, only : med_phases_history_write_comp use med_map_mod , only : med_map_field_packed use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_utils_mod , only : chkerr => med_utils_ChkErr @@ -38,6 +41,7 @@ subroutine med_phases_post_atm(gcomp, rc) ! local variables type(InternalState) :: is_local + type(ESMF_Clock) :: dClock character(len=*), parameter :: subname='(med_phases_post_atm)' !------------------------------------------------------------------------------- @@ -93,6 +97,14 @@ subroutine med_phases_post_atm(gcomp, rc) call t_stopf('MED:'//trim(subname)//' map_atm2lnd') end if + ! Write atm inst, avg or aux if requested in mediator attributes + call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_ClockIsCreated(dclock)) then + call med_phases_history_write_comp(gcomp, compatm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (dbug_flag > 20) then call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end if diff --git a/mediator/med_phases_post_glc_mod.F90 b/mediator/med_phases_post_glc_mod.F90 index e04fc64b4..44e013641 100644 --- a/mediator/med_phases_post_glc_mod.F90 +++ b/mediator/med_phases_post_glc_mod.F90 @@ -85,11 +85,16 @@ module med_phases_post_glc_mod subroutine med_phases_post_glc(gcomp, rc) + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_Clock, ESMF_ClockIsCreated + use med_phases_history_mod, only : med_phases_history_write_comp + ! input/output variables type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc ! local variables + type(ESMF_Clock) :: dClock type(ESMF_StateItem_Flag) :: itemType type(InternalState) :: is_local integer :: n1,ncnt,ns @@ -213,6 +218,16 @@ subroutine med_phases_post_glc(gcomp, rc) ! Reset first call logical first_call = .false. + ! Write glc inst, avg or aux if requested in mediator attributes + call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_ClockIsCreated(dclock)) then + do ns = 1,num_icesheets + call med_phases_history_write_comp(gcomp, compglc(ns), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end do + end if + if (dbug_flag > 20) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if @@ -235,7 +250,7 @@ subroutine map_glc2lnd_init(gcomp, rc) integer :: ungriddedUBound_output(1) integer :: fieldCount integer :: ns,n - type(ESMF_Field), pointer :: fieldlist(:) => null() + type(ESMF_Field), pointer :: fieldlist(:) character(len=*) , parameter :: subname='(map_glc2lnd_init)' !--------------------------------------- @@ -353,22 +368,22 @@ subroutine map_glc2lnd( gcomp, rc) type(ESMF_Field) :: lfield_dst integer :: ec, l, g, ns, n real(r8) :: topo_virtual - 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() ! topo height of each glc cell (no elev classes) - real(r8), pointer :: topo_l_ec(:,:) => null() ! topo height in each land gridcell for each elev 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() - real(r8), pointer :: frac_l_ec_sum(:,:) => null() - real(r8), pointer :: topo_l_ec_sum(:,:) => null() - real(r8), pointer :: dataptr1d_src(:) => null() - real(r8), pointer :: dataptr1d_dst(:) => null() + 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 :: topo_g(:) ! topo height of each glc cell (no elev classes) + real(r8), pointer :: topo_l_ec(:,:) ! topo height in each land gridcell for each elev class + real(r8), pointer :: frac_x_icemask_g_ec(:,:) ! (glc fraction) x (icemask), on the glc grid + real(r8), pointer :: frac_x_icemask_l_ec(:,:) + real(r8), pointer :: topo_x_icemask_g_ec(:,:) + real(r8), pointer :: topo_x_icemask_l_ec(:,:) + real(r8), pointer :: dataptr1d(:) + real(r8), pointer :: dataptr2d(:,:) + real(r8), pointer :: frac_l_ec_sum(:,:) + real(r8), pointer :: topo_l_ec_sum(:,:) + real(r8), pointer :: dataptr1d_src(:) + real(r8), pointer :: dataptr1d_dst(:) character(len=*), parameter :: subname = 'map_glc2lnd' !----------------------------------------------------------------------- diff --git a/mediator/med_phases_post_ice_mod.F90 b/mediator/med_phases_post_ice_mod.F90 index f605006e5..2daa4c358 100644 --- a/mediator/med_phases_post_ice_mod.F90 +++ b/mediator/med_phases_post_ice_mod.F90 @@ -18,15 +18,18 @@ module med_phases_post_ice_mod subroutine med_phases_post_ice(gcomp, rc) - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_Clock, ESMF_ClockIsCreated use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_GridComp + use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 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_map_mod , only : med_map_field_packed use med_fraction_mod , only : med_fraction_set use med_internalstate_mod , only : InternalState, mastertask + use med_phases_history_mod, only : med_phases_history_write_comp use esmFlds , only : compice, compatm, compocn, compwav use perf_mod , only : t_startf, t_stopf @@ -35,7 +38,8 @@ subroutine med_phases_post_ice(gcomp, rc) integer, intent(out) :: rc ! local variables - type(InternalState) :: is_local + type(InternalState) :: is_local + type(ESMF_Clock) :: dClock character(len=*),parameter :: subname='(med_phases_post_ice)' !------------------------------------------------------------------------------- @@ -94,6 +98,14 @@ subroutine med_phases_post_ice(gcomp, rc) call t_stopf('MED:'//trim(subname)//' map_ice2wav') end if + ! Write ice inst, avg or aux if requested in mediator attributes + call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_ClockIsCreated(dclock)) then + call med_phases_history_write_comp(gcomp, compice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call t_stopf('MED:'//subname) if (dbug_flag > 20) then call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) diff --git a/mediator/med_phases_post_lnd_mod.F90 b/mediator/med_phases_post_lnd_mod.F90 index 21f4f243e..1bd416c77 100644 --- a/mediator/med_phases_post_lnd_mod.F90 +++ b/mediator/med_phases_post_lnd_mod.F90 @@ -3,11 +3,8 @@ module med_phases_post_lnd_mod implicit none private - public :: med_phases_post_lnd_init ! does not accumulate input to rof public :: med_phases_post_lnd - logical :: lnd2glc_coupling - character(*), parameter :: u_FILE_u = & __FILE__ @@ -17,17 +14,21 @@ module med_phases_post_lnd_mod subroutine med_phases_post_lnd(gcomp, rc) - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_Clock, ESMF_ClockIsCreated use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_GridComp + use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 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_map_mod , only : med_map_field_packed use med_internalstate_mod , only : InternalState, mastertask use med_phases_prep_rof_mod , only : med_phases_prep_rof_accum - use med_phases_prep_glc_mod , only : med_phases_prep_glc_accum_lnd + use med_phases_prep_glc_mod , only : med_phases_prep_glc_accum_lnd, med_phases_prep_glc_avg + use med_phases_history_mod , only : med_phases_history_write_comp use esmFlds , only : complnd, compatm, comprof, compglc, num_icesheets + use esmFlds , only : lnd2glc_coupling, accum_lnd2glc use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -36,8 +37,7 @@ subroutine med_phases_post_lnd(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: ns - logical :: first_call = .true. + type(ESMF_Clock) :: dClock character(len=*),parameter :: subname='(med_phases_post_lnd)' !------------------------------------------------------------------------------- @@ -53,93 +53,61 @@ subroutine med_phases_post_lnd(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map lnd to atm - if (is_local%wrap%med_coupling_active(complnd,compatm)) then - call med_map_field_packed( & - FBSrc=is_local%wrap%FBImp(complnd,complnd), & - FBDst=is_local%wrap%FBImp(complnd,compatm), & - FBFracSrc=is_local%wrap%FBFrac(complnd), & - field_NormOne=is_local%wrap%field_normOne(complnd,compatm,:), & - packed_data=is_local%wrap%packed_data(complnd,compatm,:), & - routehandles=is_local%wrap%RH(complnd,compatm,:), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! accumulate lnd input for rof - if (is_local%wrap%med_coupling_active(complnd,comprof)) then - call med_phases_prep_rof_accum(gcomp, rc) + ! If driver clock is created then are in the run phase otherwise are in the initialization phase + if (ESMF_ClockIsCreated(dclock)) then + + ! map lnd to atm + if (is_local%wrap%med_coupling_active(complnd,compatm)) then + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(complnd,complnd), & + FBDst=is_local%wrap%FBImp(complnd,compatm), & + FBFracSrc=is_local%wrap%FBFrac(complnd), & + field_NormOne=is_local%wrap%field_normOne(complnd,compatm,:), & + packed_data=is_local%wrap%packed_data(complnd,compatm,:), & + routehandles=is_local%wrap%RH(complnd,compatm,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! accumulate lnd input for rof + if (is_local%wrap%med_coupling_active(complnd,comprof)) then + call med_phases_prep_rof_accum(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! accumulate lnd input for glc (note that lnd2glc_coupling and accum_lnd2glc is determined in med.F90) + if (lnd2glc_coupling) then + call med_phases_prep_glc_accum_lnd(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Note that in this case med_phases_prep_glc_avg is called + ! from med_phases_prep_glc in the run sequence + else if (accum_lnd2glc) then + call med_phases_prep_glc_accum_lnd(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_phases_prep_glc_avg(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! Write lnd inst, avg or aux if requested in mediator attributes + call med_phases_history_write_comp(gcomp, complnd, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - ! first determine if there will be any lnd to glc coupling - if (first_call) then - do ns = 1,num_icesheets - if (is_local%wrap%med_coupling_active(complnd,compglc(ns))) then - lnd2glc_coupling = .true. - exit - end if - end do - first_call = .false. - end if + else - ! accumulate lnd input for glc - if (lnd2glc_coupling) then - call med_phases_prep_glc_accum_lnd(gcomp, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + ! initialization phase - map lnd to atm + if (is_local%wrap%med_coupling_active(complnd,compatm)) then + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(complnd,complnd), & + FBDst=is_local%wrap%FBImp(complnd,compatm), & + FBFracSrc=is_local%wrap%FBFrac(complnd), & + field_NormOne=is_local%wrap%field_normOne(complnd,compatm,:), & + packed_data=is_local%wrap%packed_data(complnd,compatm,:), & + routehandles=is_local%wrap%RH(complnd,compatm,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - if (dbug_flag > 20) then - call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) - end if - call t_stopf('MED:'//subname) - - end subroutine med_phases_post_lnd - - !=============================================================================== - subroutine med_phases_post_lnd_init(gcomp, rc) - - 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_GridComp - 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_map_mod , only : med_map_field_packed - use med_internalstate_mod , only : InternalState, mastertask - use esmFlds , only : complnd, compatm - use perf_mod , only : t_startf, t_stopf - - ! input/output variables - type(ESMF_GridComp) :: gcomp - integer, intent(out) :: rc - - ! local variables - type(InternalState) :: is_local - character(len=*),parameter :: subname='(med_phases_post_lnd)' - !------------------------------------------------------------------------------- - - call t_startf('MED:'//subname) - rc = ESMF_SUCCESS - - if (dbug_flag > 20) then - call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) - end if - - ! Get the internal state - nullify(is_local%wrap) - call ESMF_GridCompGetInternalState(gcomp, is_local, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! map lnd to atm - if (is_local%wrap%med_coupling_active(complnd,compatm)) then - call med_map_field_packed( & - FBSrc=is_local%wrap%FBImp(complnd,complnd), & - FBDst=is_local%wrap%FBImp(complnd,compatm), & - FBFracSrc=is_local%wrap%FBFrac(complnd), & - field_NormOne=is_local%wrap%field_normOne(complnd,compatm,:), & - packed_data=is_local%wrap%packed_data(complnd,compatm,:), & - routehandles=is_local%wrap%RH(complnd,compatm,:), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (dbug_flag > 20) then @@ -147,6 +115,6 @@ subroutine med_phases_post_lnd_init(gcomp, rc) end if call t_stopf('MED:'//subname) - end subroutine med_phases_post_lnd_init + end subroutine med_phases_post_lnd end module med_phases_post_lnd_mod diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index d0d00b970..c51f9eecf 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -20,13 +20,16 @@ module med_phases_post_ocn_mod subroutine med_phases_post_ocn(gcomp, rc) - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_Clock, ESMF_ClockIsCreated use ESMF , only : ESMF_GridComp use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS + 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_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_map_mod , only : med_map_field_packed use med_internalstate_mod , only : InternalState, logunit, mastertask + use med_phases_history_mod , only : med_phases_history_write_comp use med_phases_prep_glc_mod , only : med_phases_prep_glc_accum_ocn use esmFlds , only : compice, compglc, compocn, num_icesheets use perf_mod , only : t_startf, t_stopf @@ -38,6 +41,7 @@ subroutine med_phases_post_ocn(gcomp, rc) ! local variables type(InternalState) :: is_local integer :: ns + type(ESMF_Clock) :: dClock logical :: first_call = .true. character(len=*),parameter :: subname='(med_phases_post_ocn)' !--------------------------------------- @@ -83,6 +87,14 @@ subroutine med_phases_post_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if + ! Write ocn inst, avg or aux if requested in mediator attributes + call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_ClockIsCreated(dclock)) then + call med_phases_history_write_comp(gcomp, compocn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (dbug_flag > 20) then call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end if diff --git a/mediator/med_phases_post_rof_mod.F90 b/mediator/med_phases_post_rof_mod.F90 index 93e73ac3e..10ca7bfc7 100644 --- a/mediator/med_phases_post_rof_mod.F90 +++ b/mediator/med_phases_post_rof_mod.F90 @@ -16,13 +16,16 @@ module med_phases_post_rof_mod subroutine med_phases_post_rof(gcomp, rc) - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_Clock, ESMF_ClockIsCreated use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR, ESMF_SUCCESS, ESMF_FAILURE use ESMF , only : ESMF_GridComp, ESMF_GridCompGet + use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 use esmFlds , only : complnd, compocn, compice, compatm, comprof, ncomps, compname 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, mastertask, logunit + use med_phases_history_mod, only : med_phases_history_write_comp use med_map_mod , only : med_map_field_packed use perf_mod , only : t_startf, t_stopf @@ -32,6 +35,7 @@ subroutine med_phases_post_rof(gcomp, rc) ! local variables type(InternalState) :: is_local + type(ESMF_Clock) :: dClock character(len=*), parameter :: subname='(med_phases_post_rof)' !--------------------------------------- @@ -86,6 +90,14 @@ subroutine med_phases_post_rof(gcomp, rc) call t_stopf('MED:'//trim(subname)//' map_rof2ice') end if + ! Write rof inst, avg or aux if requested in mediator attributes + call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_ClockIsCreated(dclock)) then + call med_phases_history_write_comp(gcomp, comprof, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (dbug_flag > 20) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if diff --git a/mediator/med_phases_post_wav_mod.F90 b/mediator/med_phases_post_wav_mod.F90 index feb1c8515..a1bf805ef 100644 --- a/mediator/med_phases_post_wav_mod.F90 +++ b/mediator/med_phases_post_wav_mod.F90 @@ -14,14 +14,17 @@ module med_phases_post_wav_mod subroutine med_phases_post_wav(gcomp, rc) - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + use NUOPC_Mediator , only : NUOPC_MediatorGet + use ESMF , only : ESMF_Clock, ESMF_ClockIsCreated use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_GridComp + use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 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_map_mod , only : med_map_field_packed use med_internalstate_mod , only : InternalState, mastertask + use med_phases_history_mod, only : med_phases_history_write_comp use esmFlds , only : compwav, compatm, compocn, compice use perf_mod , only : t_startf, t_stopf @@ -30,7 +33,8 @@ subroutine med_phases_post_wav(gcomp, rc) integer, intent(out) :: rc ! local variables - type(InternalState) :: is_local + type(InternalState) :: is_local + type(ESMF_Clock) :: dClock character(len=*),parameter :: subname='(med_phases_post_wav)' !------------------------------------------------------------------------------- @@ -80,6 +84,14 @@ subroutine med_phases_post_wav(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if + ! Write atm inst, avg or aux if requested in mediator attributes + call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_ClockIsCreated(dclock)) then + call med_phases_history_write_comp(gcomp, compwav, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call t_stopf('MED:'//subname) if (dbug_flag > 20) then call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) diff --git a/mediator/med_phases_prep_atm_mod.F90 b/mediator/med_phases_prep_atm_mod.F90 index e26f3b5f1..76c8b1e83 100644 --- a/mediator/med_phases_prep_atm_mod.F90 +++ b/mediator/med_phases_prep_atm_mod.F90 @@ -42,10 +42,10 @@ subroutine med_phases_prep_atm(gcomp, rc) type(ESMF_Field) :: lfield character(len=64) :: timestr type(InternalState) :: is_local - real(R8), pointer :: dataPtr1(:) => null() - real(R8), pointer :: dataPtr2(:) => null() - real(R8), pointer :: ifrac(:) => null() - real(R8), pointer :: ofrac(:) => null() + real(R8), pointer :: dataPtr1(:) + real(R8), pointer :: dataPtr2(:) + real(R8), pointer :: ifrac(:) + real(R8), pointer :: ofrac(:) integer :: i, j, n, n1, ncnt character(len=*),parameter :: subname='(med_phases_prep_atm)' !------------------------------------------------------------------------------- @@ -108,22 +108,27 @@ subroutine med_phases_prep_atm(gcomp, rc) !--- map atm/ocn fluxes from ocn to atm grid if appropriate !--------------------------------------- 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), & - 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 + if (is_local%wrap%aoflux_grid == 'ogrid') then + 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), & + 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 + else if (is_local%wrap%aoflux_grid == 'agrid') then + ! do nothing - is_local%wrap%FBMed_aoflux_a has been computed in med_aofluxes_init_agrid + else if (is_local%wrap%aoflux_grid == 'xgrid') then + ! do nothing - is_local%wrap%FBMed_aoflux_a has been computed in med_aofluxes_init_agrid + end if endif !--------------------------------------- !--- merge all fields to atm !--------------------------------------- if (trim(coupling_mode) == 'cesm' .or. trim(coupling_mode) == 'hafs') then - call med_merge_auto(compatm, & + call med_merge_auto(& is_local%wrap%med_coupling_active(:,compatm), & is_local%wrap%FBExp(compatm), & is_local%wrap%FBFrac(compatm), & @@ -133,7 +138,7 @@ subroutine med_phases_prep_atm(gcomp, rc) 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(compatm, & + call med_merge_auto(& is_local%wrap%med_coupling_active(:,compatm), & is_local%wrap%FBExp(compatm), & is_local%wrap%FBFrac(compatm), & @@ -193,7 +198,7 @@ subroutine med_phases_prep_atm(gcomp, rc) end if ! Note - the following needs a custom merge since Faoo_fco2_ocn is scaled by (ifrac+ofrac) - ! in the merge to the atm + ! in the merge to the atm if ( FB_FldChk(is_local%wrap%FBExp(compatm) , 'Faoo_fco2_ocn', rc=rc) .and. & FB_FldChk(is_local%wrap%FBImp(compocn,compocn), 'Faoo_fco2_ocn', rc=rc)) then call ESMF_FieldGet(lfield, farrayPtr=dataptr1, rc=rc) diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index 4c0879a2c..890bb5501 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -11,7 +11,8 @@ module med_phases_prep_glc_mod use NUOPC_Model , only : NUOPC_ModelGet 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, ESMF_REDUCE_MAX - use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockGetAlarm, ESMF_ClockAdvance, ESMF_ClockGet + use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockIsCreated + use ESMF , only : ESMF_ClockGetAlarm, ESMF_ClockAdvance, ESMF_ClockGet use ESMF , only : ESMF_Time, ESMF_TimeGet use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmSet, ESMF_AlarmGet use ESMF , only : ESMF_AlarmIsRinging, ESMF_AlarmRingerOff @@ -23,7 +24,8 @@ module med_phases_prep_glc_mod use ESMF , only : ESMF_DYNAMICMASK, ESMF_DynamicMaskSetR8R8R8, ESMF_DYNAMICMASKELEMENTR8R8R8 use ESMF , only : ESMF_FieldRegrid use esmFlds , only : complnd, compocn, mapbilnr, mapconsd, compname - use esmFlds , only : max_icesheets, num_icesheets, compglc, ocn2glc_coupling + use esmFlds , only : max_icesheets, num_icesheets, compglc + use esmFlds , only : ocn2glc_coupling, lnd2glc_coupling, accum_lnd2glc use med_internalstate_mod , only : InternalState, mastertask, logunit 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 @@ -34,6 +36,7 @@ module med_phases_prep_glc_mod use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_diagnose => med_methods_FB_diagnose use med_methods_mod , only : fldbun_reset => med_methods_FB_reset + use med_methods_mod , only : fldbun_init => med_methods_FB_init use med_methods_mod , only : field_getdata2d => med_methods_Field_getdata2d use med_methods_mod , only : field_getdata1d => med_methods_Field_getdata1d use med_utils_mod , only : chkerr => med_utils_ChkErr @@ -48,11 +51,12 @@ module med_phases_prep_glc_mod implicit none private + public :: med_phases_prep_glc_init ! called from med.F90 + public :: med_phases_prep_glc_accum_lnd ! called from med_phases_post_lnd_mod.F90 + public :: med_phases_prep_glc_accum_ocn ! called from med_phases_post_ocn_mod.F90 + public :: med_phases_prep_glc_avg ! called either from med_phases_post_lnd_mod.F90 or med_phases_prep_glc public :: med_phases_prep_glc ! called from nuopc run sequence - public :: med_phases_prep_glc_accum_lnd ! called from med_phases_post_lnd - public :: med_phases_prep_glc_accum_ocn ! called from med_phases_post_ocn - private :: med_phases_prep_glc_init private :: med_phases_prep_glc_map_lnd2glc private :: med_phases_prep_glc_renormalize_smb @@ -70,49 +74,48 @@ module med_phases_prep_glc_mod ! Does not need to be true for 1-way coupling. logical :: smb_renormalize - type(ESMF_FieldBundle) :: FBlndAccum_l - integer :: FBlndAccumCnt - 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 '/) - + type(ESMF_FieldBundle), public :: FBlndAccum2glc_l + integer , public :: lndAccum2glc_cnt + + 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 '/) + type, public :: toglc_frlnd_type character(CS) :: name - type(ESMF_FieldBundle) :: FBlndAccum_g + type(ESMF_FieldBundle) :: FBlndAccum2glc_g type(ESMF_Field) :: field_icemask_g type(ESMF_Field) :: field_frac_g type(ESMF_Field) :: field_frac_g_ec type(ESMF_Field) :: field_lfrac_g type(ESMF_Mesh) :: mesh_g end type toglc_frlnd_type - type(toglc_frlnd_type) :: toglc_frlnd(max_icesheets) ! TODO: make this allocatable for number of actual ice sheets + type(toglc_frlnd_type) :: toglc_frlnd(max_icesheets) ! TODO: make this allocatable for number of actual ice sheets - type(ESMF_Field) :: field_normdst_l - type(ESMF_Field) :: field_icemask_l - type(ESMF_Field) :: field_frac_l - type(ESMF_Field) :: field_frac_l_ec - type(ESMF_Field) :: field_lnd_icemask_l - real(r8) , pointer :: aream_l(:) => null() ! cell areas on land grid, for mapping + type(ESMF_Field) :: field_normdst_l + type(ESMF_Field) :: field_icemask_l + type(ESMF_Field) :: field_frac_l + type(ESMF_Field) :: field_frac_l_ec + type(ESMF_Field) :: field_lnd_icemask_l + real(r8) , pointer :: aream_l(:) ! cell areas on land grid, for mapping - character(len=*), parameter :: qice_fieldname = 'Flgl_qice' ! Name of flux field giving surface mass balance - 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' - integer :: ungriddedCount ! this equals the number of elevation classes + 1 (for bare land) + character(len=*), parameter :: qice_fieldname = 'Flgl_qice' ! Name of flux field giving surface mass balance + 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' + integer :: ungriddedCount ! this equals the number of elevation classes + 1 (for bare land) ! ----------------- ! ocn -> glc ! ----------------- - type(ESMF_FieldBundle) :: FBocnAccum_o - integer :: FBocnAccumCnt - character(len=14) :: fldnames_fr_ocn(2) = (/'So_t_depth','So_s_depth'/) ! TODO: what else needs to be added here - type(ESMF_DynamicMask) :: dynamicOcnMask - integer, parameter :: num_ocndepths = 7 - logical :: ocn_sends_depths = .false. + type(ESMF_FieldBundle), public :: FBocnAccum2glc_o + integer , public :: ocnAccum2glc_cnt + character(len=14) :: fldnames_fr_ocn(2) = (/'So_t_depth','So_s_depth'/) ! TODO: what else needs to be added here + type(ESMF_DynamicMask) :: dynamicOcnMask + integer, parameter :: num_ocndepths = 7 + logical :: ocn_sends_depths = .false. - logical :: lnd2glc_coupling = .false. - logical :: init_prep_glc = .false. - type(ESMF_Clock) :: prepglc_clock + type(ESMF_Clock) :: prepglc_clock character(*), parameter :: u_FILE_u = & __FILE__ @@ -132,22 +135,22 @@ subroutine med_phases_prep_glc_init(gcomp, rc) integer, intent(out) :: rc ! local variables - type(InternalState) :: is_local - integer :: i,n,ns,nf - type(ESMF_Mesh) :: mesh_l - type(ESMF_Mesh) :: mesh_o - type(ESMF_Field) :: lfield - real(r8), pointer :: data2d_in(:,:) => null() - real(r8), pointer :: data2d_out(:,:) => null() - character(len=CS) :: glc_renormalize_smb - logical :: glc_coupled_fluxes - integer :: ungriddedUBound_output(1) ! currently the size must equal 1 for rank 2 fieldds - type(ESMF_Clock) :: med_clock - type(ESMF_ALARM) :: glc_avg_alarm - logical :: glc_present - character(len=CS) :: glc_avg_period - integer :: glc_cpl_dt - character(len=CS) :: cvalue + type(InternalState) :: is_local + type(ESMF_Clock) :: med_clock + type(ESMF_ALARM) :: glc_avg_alarm + character(len=CS) :: glc_avg_period + type(ESMF_Time) :: starttime + integer :: glc_cpl_dt + integer :: i,n,ns,nf + type(ESMF_Mesh) :: mesh_l + type(ESMF_Mesh) :: mesh_o + type(ESMF_Field) :: lfield + character(len=CS) :: cvalue + real(r8), pointer :: data2d_in(:,:) + real(r8), pointer :: data2d_out(:,:) + character(len=CS) :: glc_renormalize_smb + logical :: glc_coupled_fluxes + integer :: ungriddedUBound_output(1) ! currently the size must equal 1 for rank 2 fieldds character(len=*),parameter :: subname=' (med_phases_prep_glc_init) ' !--------------------------------------- @@ -162,90 +165,12 @@ subroutine med_phases_prep_glc_init(gcomp, rc) nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - - ! ------------------------------- - ! Initialize prepglc_clock - ! ------------------------------- - - ! Initialize prepglc_clock from mclock - THIS CALL DOES NOT COPY ALARMS - call NUOPC_ModelGet(gcomp, modelClock=med_clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - prepglc_clock = ESMF_ClockCreate(med_clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Set alarm glc averaging interval - call NUOPC_CompAttributeGet(gcomp, name="glc_avg_period", value=glc_avg_period, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (trim(glc_avg_period) == 'yearly') then - call med_time_alarmInit(prepglc_clock, glc_avg_alarm, 'nyears', opt_n=1, alarmname='alarm_glc_avg', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(logunit,'(a,i10)') trim(subname)//& - ' created alarm with averaging period for export to glc is yearly' - end if - else if (trim(glc_avg_period) == 'glc_coupling_period') then - call NUOPC_CompAttributeGet(gcomp, name="glc_cpl_dt", value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) glc_cpl_dt - call med_time_alarmInit(prepglc_clock, glc_avg_alarm, 'nseconds', opt_n=glc_cpl_dt, alarmname='alarm_glc_avg', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(logunit,'(a,i10)') trim(subname)//& - ' created alarm with averaging period for export to glc (in seconds) ',glc_cpl_dt - end if - else - call ESMF_LogWrite(trim(subname)// ": ERROR glc_avg_period = "//trim(glc_avg_period)//" not supported", & - ESMF_LOGMSG_INFO) - rc = ESMF_FAILURE - RETURN - end if - call ESMF_AlarmSet(glc_avg_alarm, clock=prepglc_clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------------------------------- - ! If lnd->glc couplng is active + ! If will accumulate lnd2glc input on land grid ! ------------------------------- - do ns = 1,num_icesheets - if (is_local%wrap%med_coupling_active(complnd,compglc(ns))) then - lnd2glc_coupling = .true. - exit - end if - end do - if (lnd2glc_coupling) then - - ! Determine if renormalize smb - call NUOPC_CompAttributeGet(gcomp, name='glc_renormalize_smb', value=glc_renormalize_smb, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! TODO: talk to Bill Sacks to determine if this is the correct logic - glc_coupled_fluxes = is_local%wrap%med_coupling_active(compglc(1),complnd) - - ! Note glc_coupled_fluxes should be false in the no_evolve cases - ! Goes back to the zero-gcm fluxes variable - if zero-gcm fluxes is true than do not renormalize - ! The user can set this to true in an evolve cases - - select case (glc_renormalize_smb) - case ('on') - smb_renormalize = .true. - case ('off') - smb_renormalize = .false. - case ('on_if_glc_coupled_fluxes') - if (.not. glc_coupled_fluxes) then - ! Do not renormalize if med_coupling_active is not true for compglc->complnd - ! In this case, conservation is not important - smb_renormalize = .false. - else - smb_renormalize = .true. - end if - case default - write(logunit,*) subname,' ERROR: unknown value for glc_renormalize_smb: ', trim(glc_renormalize_smb) - call ESMF_LogWrite(trim(subname)//' ERROR: unknown value for glc_renormalize_smb: '// trim(glc_renormalize_smb), & - ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) - rc = ESMF_FAILURE - return - end select - + if (accum_lnd2glc) then ! Create field bundles for the fldnames_fr_lnd that have an ! undistributed dimension corresponding to elevation classes (including bare land) call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fldnames_fr_lnd(1), field=lfield, rc=rc) @@ -259,41 +184,47 @@ subroutine med_phases_prep_glc_init(gcomp, rc) call fldbun_getmesh(is_local%wrap%FBImp(complnd,complnd), mesh_l, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - FBlndAccum_l = ESMF_FieldBundleCreate(name='FBlndAccum_l', rc=rc) + FBlndAccum2glc_l = ESMF_FieldBundleCreate(name='FBlndAccum2glc_l', rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return do n = 1,size(fldnames_fr_lnd) lfield = ESMF_FieldCreate(mesh_l, ESMF_TYPEKIND_R8, name=fldnames_fr_lnd(n), & meshloc=ESMF_MESHLOC_ELEMENT, & ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldBundleAdd(FBlndAccum_l, (/lfield/), rc=rc) + call ESMF_FieldBundleAdd(FBlndAccum2glc_l, (/lfield/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(trim(subname)//' adding field '//trim(fldnames_fr_lnd(n))//' to FBLndAccum_l', & ESMF_LOGMSG_INFO) end do - call fldbun_reset(FBlndAccum_l, value=0.0_r8, rc=rc) + call fldbun_reset(FBlndAccum2glc_l, value=0.0_r8, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! ------------------------------- + ! If lnd->glc couplng is active + ! ------------------------------- + if (lnd2glc_coupling) then ! Create accumulation field bundles from land on each glc ice sheet mesh ! Determine glc mesh from the mesh from the first export field to glc - ! However FBlndAccum_g has the fields fldnames_fr_lnd BUT ON the glc grid + ! However FBlndAccum2glc_g has the fields fldnames_fr_lnd BUT ON the glc grid do ns = 1,num_icesheets ! get mesh on glc grid call fldbun_getmesh(is_local%wrap%FBExp(compglc(ns)), toglc_frlnd(ns)%mesh_g, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! create accumulation field bundle on glc grid - toglc_frlnd(ns)%FBlndAccum_g = ESMF_FieldBundleCreate(rc=rc) + toglc_frlnd(ns)%FBlndAccum2glc_g = ESMF_FieldBundleCreate(rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return do nf = 1,size(fldnames_fr_lnd) lfield = ESMF_FieldCreate(toglc_frlnd(ns)%mesh_g, ESMF_TYPEKIND_R8, name=fldnames_fr_lnd(nf), & meshloc=ESMF_MESHLOC_ELEMENT, & ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldBundleAdd(toglc_frlnd(ns)%FBlndAccum_g, (/lfield/), rc=rc) + call ESMF_FieldBundleAdd(toglc_frlnd(ns)%FBlndAccum2glc_g, (/lfield/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end do - call fldbun_reset(toglc_frlnd(ns)%FBlndAccum_g, value=0.0_r8, rc=rc) + call fldbun_reset(toglc_frlnd(ns)%FBlndAccum2glc_g, value=0.0_r8, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! create land fraction field on glc mesh (this is just needed for normalization mapping) @@ -310,9 +241,7 @@ subroutine med_phases_prep_glc_init(gcomp, rc) end if end do - ! ------------------------------- ! Determine if renormalize smb - ! ------------------------------- call NUOPC_CompAttributeGet(gcomp, name='glc_renormalize_smb', value=glc_renormalize_smb, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -384,6 +313,12 @@ subroutine med_phases_prep_glc_init(gcomp, rc) ! 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(ns),complnd,:),mapconsd, rc=rc)) then + if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compglc(ns),complnd))) then + call fldbun_init(is_local%wrap%FBImp(compglc(ns),complnd), is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateImp(complnd), & + STflds=is_local%wrap%NStateImp(compglc(ns)), & + name='FBImp'//trim(compname(compglc(ns)))//'_'//trim(compname(complnd)), rc=rc) + end if call med_map_routehandles_init( compglc(ns), complnd, & FBSrc=is_local%wrap%FBImp(compglc(ns),compglc(ns)), & FBDst=is_local%wrap%FBImp(compglc(ns),complnd), & @@ -404,19 +339,19 @@ subroutine med_phases_prep_glc_init(gcomp, rc) call fldbun_getmesh(is_local%wrap%FBImp(compocn,compocn), mesh_o, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - FBocnAccum_o = ESMF_FieldBundleCreate(name='FBocnAccum_o', rc=rc) + FBocnAccum2glc_o = ESMF_FieldBundleCreate(name='FBocnAccum2glc_o', rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return do n = 1,size(fldnames_fr_ocn) lfield = ESMF_FieldCreate(mesh_o, ESMF_TYPEKIND_R8, name=fldnames_fr_ocn(n), & meshloc=ESMF_MESHLOC_ELEMENT, & ungriddedLbound=(/1/), ungriddedUbound=(/num_ocndepths/), gridToFieldMap=(/2/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldBundleAdd(FBocnAccum_o, (/lfield/), rc=rc) + call ESMF_FieldBundleAdd(FBocnAccum2glc_o, (/lfield/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//' adding field '//trim(fldnames_fr_ocn(n))//' to FBOcnAccum_o', & + call ESMF_LogWrite(trim(subname)//' adding field '//trim(fldnames_fr_ocn(n))//' to FBOcnAccum2glc_o', & ESMF_LOGMSG_INFO) end do - call fldbun_reset(FBocnAccum_o, value=czero, rc=rc) + call fldbun_reset(FBocnAccum2glc_o, value=czero, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! create route handle if it has not been created @@ -465,9 +400,9 @@ subroutine med_phases_prep_glc_accum_lnd(gcomp, rc) type(InternalState) :: is_local type(ESMF_Field) :: lfield integer :: i,n - real(r8), pointer :: data2d_in(:,:) => null() - real(r8), pointer :: data2d_out(:,:) => null() - character(len=*),parameter :: subname=' (med_phases_prep_glc_accum) ' + real(r8), pointer :: data2d_in(:,:) + real(r8), pointer :: data2d_out(:,:) + character(len=*),parameter :: subname=' (med_phases_prep_glc_accum) ' !--------------------------------------- call t_startf('MED:'//subname) @@ -477,17 +412,6 @@ subroutine med_phases_prep_glc_accum_lnd(gcomp, rc) rc = ESMF_SUCCESS - if (.not. init_prep_glc) then - call med_phases_prep_glc_init(gcomp, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - init_prep_glc = .true. - end if - - ! Advance prepglc_clock - this will make the prepglc_clock in sync with the mediator clock - ! TODO: this assumes that the land is in the fast time loop - call ESMF_ClockAdvance(prepglc_clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Get the internal state nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) @@ -497,15 +421,15 @@ subroutine med_phases_prep_glc_accum_lnd(gcomp, rc) do n = 1, size(fldnames_fr_lnd) call fldbun_getdata2d(is_local%wrap%FBImp(complnd,complnd), fldnames_fr_lnd(n), data2d_in, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call fldbun_getdata2d(FBlndAccum_l, fldnames_fr_lnd(n), data2d_out, rc) + call fldbun_getdata2d(FBlndAccum2glc_l, fldnames_fr_lnd(n), data2d_out, 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) end do end do - FBlndAccumCnt = FBlndAccumCnt + 1 + lndAccum2glc_cnt = lndAccum2glc_cnt + 1 if (dbug_flag > 1) then - call fldbun_diagnose(FBlndAccum_l, string=trim(subname)// ' FBlndAccum_l ', rc=rc) + call fldbun_diagnose(FBlndAccum2glc_l, string=trim(subname)// ' FBlndAccum2glc_l ', rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if if (dbug_flag > 5) then @@ -534,8 +458,8 @@ subroutine med_phases_prep_glc_accum_ocn(gcomp, rc) type(InternalState) :: is_local type(ESMF_Field) :: lfield integer :: i,n - real(r8), pointer :: data2d_in(:,:) => null() - real(r8), pointer :: data2d_out(:,:) => null() + real(r8), pointer :: data2d_in(:,:) + real(r8), pointer :: data2d_out(:,:) character(len=*),parameter :: subname=' (med_phases_prep_glc_accum) ' !--------------------------------------- @@ -547,35 +471,24 @@ subroutine med_phases_prep_glc_accum_ocn(gcomp, rc) rc = ESMF_SUCCESS - if (.not. init_prep_glc) then - call med_phases_prep_glc_init(gcomp, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - init_prep_glc = .true. - end if - ! Get the internal state nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - ! Advance prepglc_clock - this will make the prepglc_clock in sync with the mediator clock - ! TODO: do we need 2 clocks? one for the lnd and one for the ocean? - ! call ESMF_ClockAdvance(prepglc_clock, rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Accumulate fields from ocean on ocean mesh that will be sent to glc do n = 1, size(fldnames_fr_ocn) call fldbun_getdata2d(is_local%wrap%FBImp(compocn,compocn), fldnames_fr_ocn(n), data2d_in, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call fldbun_getdata2d(FBocnAccum_o, fldnames_fr_ocn(n), data2d_out, rc) + call fldbun_getdata2d(FBocnAccum2glc_o, fldnames_fr_ocn(n), data2d_out, 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) end do end do - FBocnAccumCnt = FBocnAccumCnt + 1 + ocnAccum2glc_cnt = ocnAccum2glc_cnt + 1 if (dbug_flag > 1) then - call fldbun_diagnose(FBocnAccum_o, string=trim(subname)// ' FBocnAccum_o ', rc=rc) + call fldbun_diagnose(FBocnAccum2glc_o, string=trim(subname)// ' FBocnAccum2glc_o ', rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if @@ -587,13 +500,15 @@ subroutine med_phases_prep_glc_accum_ocn(gcomp, rc) end subroutine med_phases_prep_glc_accum_ocn !================================================================================================ - subroutine med_phases_prep_glc(gcomp, rc) + subroutine med_phases_prep_glc_avg(gcomp, rc) !--------------------------------------- ! Create module clock (prepglc_clock) ! Prepare the GLC export Fields from the mediator !--------------------------------------- + use med_phases_history_mod, only : med_phases_history_write_lnd2glc + ! input/output variables type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc @@ -612,8 +527,12 @@ subroutine med_phases_prep_glc(gcomp, rc) integer :: yr_prepglc, mon_prepglc, day_prepglc, sec_prepglc type(ESMF_Alarm) :: alarm integer :: i, n, ns - real(r8), pointer :: data2d(:,:) => null() - real(r8), pointer :: data2d_import(:,:) => null() + real(r8), pointer :: data2d(:,:) + real(r8), pointer :: data2d_import(:,:) + character(len=CS) :: cvalue + logical :: do_avg + logical :: isPresent, isSet + logical :: write_histaux_l2x1yrg character(len=*) , parameter :: subname=' (med_phases_prep_glc) ' !--------------------------------------- @@ -624,58 +543,100 @@ subroutine med_phases_prep_glc(gcomp, rc) end if rc = ESMF_SUCCESS - if (.not. init_prep_glc) then - call med_phases_prep_glc_init(gcomp, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - init_prep_glc = .true. - end if - ! Get the internal state nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - ! Check time - call NUOPC_ModelGet(gcomp, modelClock=med_clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGet(med_clock, currtime=med_currtime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(med_currtime,yy=yr_med, mm=mon_med, dd=day_med, s=sec_med, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGet(prepglc_clock, currtime=prepglc_currtime, rc=rc) + if (.not. ESMF_ClockIsCreated(prepglc_clock)) then + ! Initialize prepglc_clock from mclock - THIS CALL DOES NOT COPY ALARMS + call NUOPC_ModelGet(gcomp, modelClock=med_clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + prepglc_clock = ESMF_ClockCreate(med_clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Set alarm glc averaging interval + call NUOPC_CompAttributeGet(gcomp, name="glc_avg_period", value=glc_avg_period, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (trim(glc_avg_period) == 'yearly') then + call med_time_alarmInit(prepglc_clock, glc_avg_alarm, 'yearly', alarmname='alarm_glc_avg', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,'(a,i10)') trim(subname)//& + ' created alarm with averaging period for export to glc is yearly' + end if + else if (trim(glc_avg_period) == 'glc_coupling_period') then + call NUOPC_CompAttributeGet(gcomp, name="glc_cpl_dt", value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) glc_cpl_dt + call med_time_alarmInit(prepglc_clock, glc_avg_alarm, 'nseconds', opt_n=glc_cpl_dt, alarmname='alarm_glc_avg', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,'(a,i10)') trim(subname)//& + ' created alarm with averaging period for export to glc (in seconds) ',glc_cpl_dt + end if + else + call ESMF_LogWrite(trim(subname)// ": ERROR glc_avg_period = "//trim(glc_avg_period)//" not supported", & + ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + RETURN + end if + call ESMF_AlarmSet(glc_avg_alarm, clock=prepglc_clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! Advance prepglc_clock - this will make the prepglc_clock in sync with the mediator clock + call ESMF_ClockAdvance(prepglc_clock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(prepglc_currtime,yy=yr_prepglc, mm=mon_prepglc, dd=day_prepglc, s=sec_prepglc, rc=rc) - if (mastertask) then - write(logunit,'(a,4(i8,2x))') trim(subname)//'med clock yr, mon, day, sec = ',& - yr_med,mon_med,day_med,sec_med - write(logunit,'(a,4(i8,2x))') trim(subname)//'prep glc clock yr, mon, day, sec = ',& - yr_prepglc,mon_prepglc,day_prepglc,sec_prepglc + + ! Check time + if (dbug_flag > 5) then + if (mastertask) then + call NUOPC_ModelGet(gcomp, modelClock=med_clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(med_clock, currtime=med_currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(med_currtime,yy=yr_med, mm=mon_med, dd=day_med, s=sec_med, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGet(prepglc_clock, currtime=prepglc_currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(prepglc_currtime,yy=yr_prepglc, mm=mon_prepglc, dd=day_prepglc, s=sec_prepglc, rc=rc) + if (mastertask) then + write(logunit,'(a,4(i8,2x))') trim(subname)//'med clock yr, mon, day, sec = ',& + yr_med,mon_med,day_med,sec_med + write(logunit,'(a,4(i8,2x))') trim(subname)//'prep glc clock yr, mon, day, sec = ',& + yr_prepglc,mon_prepglc,day_prepglc,sec_prepglc + end if + end if end if ! Determine if the alarm is ringing call ESMF_ClockGetAlarm(prepglc_clock, alarmname='alarm_glc_avg', alarm=alarm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (.not. ESMF_AlarmIsRinging(alarm, rc=rc)) then - ! Do nothing if the alarm is not ringing - call ESMF_LogWrite(trim(subname)//": glc_avg alarm is not ringing - returning", ESMF_LOGMSG_INFO) - else - call ESMF_LogWrite(trim(subname)//": glc_avg alarm is ringing - averaging input from lnd and ocn to glc", & + if (ESMF_AlarmIsRinging(alarm, rc=rc)) then + do_avg = .true. + call ESMF_LogWrite(trim(subname)//": glc_avg alarm is ringing - average input from lnd and ocn to glc", & ESMF_LOGMSG_INFO) if (mastertask) then write(logunit,'(a)') trim(subname)//"glc_avg alarm is ringing - averaging input from lnd and ocn to glc" end if - ! Turn off the alarm call ESMF_AlarmRingerOff( alarm, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + do_avg = .false. + call ESMF_LogWrite(trim(subname)//": glc_avg alarm is not ringing - returning", ESMF_LOGMSG_INFO) + end if - ! Average import from accumulated land import data + ! Average and map data from land (and possibly ocean) + if (do_avg) then + ! Always average import from accumulated land import data do n = 1, size(fldnames_fr_lnd) - call fldbun_getdata2d(FBlndAccum_l, fldnames_fr_lnd(n), data2d, rc) + call fldbun_getdata2d(FBlndAccum2glc_l, fldnames_fr_lnd(n), data2d, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (FBlndAccumCnt > 0) then + if (lndAccum2glc_cnt > 0) then ! If accumulation count is greater than 0, do the averaging - data2d(:,:) = data2d(:,:) / real(FBlndAccumCnt) + data2d(:,:) = data2d(:,:) / real(lndAccum2glc_cnt) else ! If accumulation count is 0, then simply set the averaged field bundle values from the land ! to the import field bundle values @@ -685,14 +646,30 @@ subroutine med_phases_prep_glc(gcomp, rc) end if end do + ! Write auxiliary history file if flag is set and accumulation is being done + if (lndAccum2glc_cnt > 0) then + call NUOPC_CompAttributeGet(gcomp, name="histaux_l2x1yrg", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) write_histaux_l2x1yrg + else + write_histaux_l2x1yrg = .false. + end if + if (write_histaux_l2x1yrg) then + call med_phases_history_write_lnd2glc(gcomp, FBlndAccum2glc_l, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + if (ocn2glc_coupling) then ! Average import from accumulated ocn import data do n = 1, size(fldnames_fr_ocn) - call fldbun_getdata2d(FBocnAccum_o, fldnames_fr_ocn(n), data2d, rc) + call fldbun_getdata2d(FBocnAccum2glc_o, fldnames_fr_ocn(n), data2d, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (FBocnAccumCnt > 0) then + if (ocnAccum2glc_cnt > 0) then ! If accumulation count is greater than 0, do the averaging - data2d(:,:) = data2d(:,:) / real(FBocnAccumCnt) + data2d(:,:) = data2d(:,:) / real(ocnAccum2glc_cnt) else ! If accumulation count is 0, then simply set the averaged field bundle values from the ocn ! to the import field bundle values @@ -702,14 +679,14 @@ subroutine med_phases_prep_glc(gcomp, rc) end if end do if (dbug_flag > 1) then - call fldbun_diagnose(FBocnAccum_o, string=trim(subname)//' FBocnAccum for after avg for field bundle ', rc=rc) + call fldbun_diagnose(FBocnAccum2glc_o, string=trim(subname)//' FBocnAccum for after avg for field bundle ', rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if ! Map accumulated ocean field from ocean mesh to land mesh and set FBExp(compglc(ns)) data ! Zero land accumulator and accumulated field bundles on ocean grid do n = 1,size(fldnames_fr_ocn) - call ESMF_FieldBundleGet(FBocnAccum_o, fldnames_fr_ocn(n), field=lfield_src, rc=rc) + call ESMF_FieldBundleGet(FBocnAccum2glc_o, fldnames_fr_ocn(n), field=lfield_src, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return do ns = 1,num_icesheets call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc(ns)), fldnames_fr_ocn(n), field=lfield_dst, rc=rc) @@ -720,8 +697,8 @@ subroutine med_phases_prep_glc(gcomp, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end do end do - FBocnAccumCnt = 0 - call fldbun_reset(FBocnAccum_o, value=czero, rc=rc) + ocnAccum2glc_cnt = 0 + call fldbun_reset(FBocnAccum2glc_o, value=czero, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if @@ -731,8 +708,8 @@ subroutine med_phases_prep_glc(gcomp, rc) ! Zero land accumulator and accumulated field bundles on land grid call med_phases_prep_glc_map_lnd2glc(gcomp, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - FBlndAccumCnt = 0 - call fldbun_reset(FBlndAccum_l, value=czero, rc=rc) + lndAccum2glc_cnt = 0 + call fldbun_reset(FBlndAccum2glc_l, value=czero, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if @@ -749,6 +726,18 @@ subroutine med_phases_prep_glc(gcomp, rc) endif call t_stopf('MED:'//subname) + end subroutine med_phases_prep_glc_avg + + !================================================================================================ + subroutine med_phases_prep_glc(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + call med_phases_prep_glc_avg(gcomp, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return + end subroutine med_phases_prep_glc !================================================================================================ @@ -764,17 +753,17 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! local variables type(InternalState) :: is_local - 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 + 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 :: ice_covered_g(:) ! if points on the glc grid is ice-covered (1) or ice-free (0) + integer , pointer :: elevclass_g(:) ! 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 integer :: nfld, ec integer :: i,j,n,g,lsize_g,ns integer :: ungriddedUBound_output(1) @@ -782,8 +771,8 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) type(ESMF_Field) :: field_lfrac_l integer :: fieldCount character(len=3) :: cnum - type(ESMF_Field), pointer :: fieldlist_lnd(:) => null() - type(ESMF_Field), pointer :: fieldlist_glc(:) => null() + type(ESMF_Field), pointer :: fieldlist_lnd(:) + type(ESMF_Field), pointer :: fieldlist_glc(:) character(len=*) , parameter :: subname=' (med_phases_prep_glc_map_lnd2glc) ' !--------------------------------------- @@ -799,7 +788,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! Initialize accumulated field bundle on the glc grid to zero before doing the mapping do ns = 1,num_icesheets - call fldbun_reset(toglc_frlnd(ns)%FBlndAccum_g, value=0.0_r8, rc=rc) + call fldbun_reset(toglc_frlnd(ns)%FBlndAccum2glc_g, value=0.0_r8, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end do @@ -809,27 +798,25 @@ 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_l - call ESMF_FieldBundleGet(FBlndAccum_l, fieldCount=fieldCount, rc=rc) + ! get fieldlist from FBlndAccum2glc_l + call ESMF_FieldBundleGet(FBlndAccum2glc_l, fieldCount=fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(fieldlist_lnd(fieldcount)) allocate(fieldlist_glc(fieldcount)) - call ESMF_FieldBundleGet(FBlndAccum_l, fieldlist=fieldlist_lnd, rc=rc) + call ESMF_FieldBundleGet(FBlndAccum2glc_l, fieldlist=fieldlist_lnd, 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), 'lfrac', field=field_lfrac_l, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! TODO: is this needed? + ! map accumlated land fields to each ice sheet (normalize by the land fraction in the mapping) do ns = 1,num_icesheets - call fldbun_reset(toglc_frlnd(ns)%FBlndAccum_g, value=0.0_r8, rc=rc) + call fldbun_reset(toglc_frlnd(ns)%FBlndAccum2glc_g, value=0.0_r8, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end do - - ! map accumlated land fields to each ice sheet (normalize by the land fraction in the mapping) do ns = 1,num_icesheets - call ESMF_FieldBundleGet(toglc_frlnd(ns)%FBlndAccum_g, fieldlist=fieldlist_glc, rc=rc) + call ESMF_FieldBundleGet(toglc_frlnd(ns)%FBlndAccum2glc_g, fieldlist=fieldlist_glc, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do nfld = 1,fieldcount call med_map_field_normalized( & @@ -847,13 +834,13 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) deallocate(fieldlist_glc) if (dbug_flag > 1) then - call fldbun_diagnose(FBlndAccum_l, string=trim(subname)//' FBlndAccum_l ', rc=rc) + call fldbun_diagnose(FBlndAccum2glc_l, string=trim(subname)//' FBlndAccum2glc_l ', rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return call fldbun_diagnose(is_local%wrap%FBfrac(complnd), string=trim(subname)//' FBFrac ', rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return do ns = 1,num_icesheets - call fldbun_diagnose(toglc_frlnd(ns)%FBlndAccum_g, string=trim(subname)//& - ' FBlndAccum_glc '//compname(compglc(ns)), rc=rc) + call fldbun_diagnose(toglc_frlnd(ns)%FBlndAccum2glc_g, string=trim(subname)//& + ' FBlndAccum2glc_glc '//compname(compglc(ns)), rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end do endif @@ -883,7 +870,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) 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 fldbun_getdata2d(toglc_frlnd(ns)%FBlndAccum_g, 'Sl_topo_elev', topolnd_g_ec, rc=rc) + call fldbun_getdata2d(toglc_frlnd(ns)%FBlndAccum2glc_g, 'Sl_topo_elev', topolnd_g_ec, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return ! ------------------------------------------------------------------------ @@ -901,7 +888,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) do nfld = 1, size(fldnames_to_glc) ! Get a pointer to the land data in multiple elevation classes on the glc grid - call fldbun_getdata2d(toglc_frlnd(ns)%FBlndAccum_g, fldnames_fr_lnd(nfld), dataptr2d, rc) + call fldbun_getdata2d(toglc_frlnd(ns)%FBlndAccum2glc_g, fldnames_fr_lnd(nfld), dataptr2d, 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) @@ -968,12 +955,12 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! Renormalize surface mass balance (smb, here named dataexp_g) so that the global ! integral on the glc grid is equal to the global integral on the land grid. ! ------------------------------------------------------------------------ - + ! No longer need to make a preemptive adjustment to qice_g to account for area differences ! between CISM and the coupler. In NUOPC, the area correction is done in! the cap not in the ! mediator, so to preserve the bilinear mapping values, do not need to do any area correction ! scaling in the CISM NUOPC cap - + if (smb_renormalize) then call med_phases_prep_glc_renormalize_smb(gcomp, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return @@ -1052,18 +1039,18 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) type(InternalState) :: is_local type(ESMF_VM) :: vm type(ESMF_Field) :: lfield - 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 :: topo_g(:) => null() ! ice topographic height on the glc grid cell - real(r8) , pointer :: frac_g(:) => null() ! total ice fraction in each glc cell - real(r8) , pointer :: frac_g_ec(:,:) => null() ! total ice fraction in each glc cell - real(r8) , pointer :: frac_l_ec(:,:) => null() ! EC fractions (Sg_ice_covered) on land grid - real(r8) , pointer :: icemask_g(:) => null() ! icemask on glc grid - real(r8) , pointer :: 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 + real(r8) , pointer :: qice_g(:) ! SMB (Flgl_qice) on glc grid without elev classes + real(r8) , pointer :: qice_l_ec(:,:) ! SMB (Flgl_qice) on land grid with elev classes + real(r8) , pointer :: topo_g(:) ! ice topographic height on the glc grid cell + real(r8) , pointer :: frac_g(:) ! total ice fraction in each glc cell + real(r8) , pointer :: frac_g_ec(:,:) ! total ice fraction in each glc cell + real(r8) , pointer :: frac_l_ec(:,:) ! EC fractions (Sg_ice_covered) on land grid + real(r8) , pointer :: icemask_g(:) ! icemask on glc grid + real(r8) , pointer :: 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 integer :: n, ns ! local and global sums of accumulation and ablation; used to compute renormalization factors @@ -1076,7 +1063,7 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) real(r8) :: accum_renorm_factor ! ratio between global accumulation on the two grids real(r8) :: ablat_renorm_factor ! ratio between global ablation on the two grids real(r8) :: effective_area ! grid cell area multiplied by min(lfrac,icemask_l). - real(r8), pointer :: area_g(:) ! areas on glc grid + real(r8), pointer :: area_g(:) ! areas on glc grid character(len=*), parameter :: subname=' (renormalize_smb) ' !--------------------------------------------------------------- @@ -1100,7 +1087,7 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) !--------------------------------------- ! Map icemask_g from the glc grid to the land grid. !--------------------------------------- - + ! determine icemask_g and set as contents of field_icemask_g call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_icemask_fieldname, dataptr1d, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -1129,10 +1116,8 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! get frac_g(:), the total ice fraction in each glc gridcell - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_frac_fieldname, dataptr1d, rc) + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_frac_fieldname, frac_g, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata1d(toglc_frlnd(ns)%field_lfrac_g, frac_g, rc) ! module field - frac_g(:) = dataptr1d(:) ! get frac_g_ec - the glc_elevclass gives the elevation class of each ! glc grid cell, assuming that the grid cell is ice-covered, spans [1 -> ungriddedcount] @@ -1164,7 +1149,7 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return ! get qice_l_ec - call fldbun_getdata2d(FBlndAccum_l, trim(qice_fieldname)//'_elev', qice_l_ec, rc) + call fldbun_getdata2d(FBlndAccum2glc_l, trim(qice_fieldname)//'_elev', qice_l_ec, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return local_accum_lnd(1) = 0.0_r8 @@ -1302,4 +1287,3 @@ subroutine dynOcnMaskProc(dynamicMaskList, dynamicSrcMaskValue, dynamicDstMaskVa end subroutine DynOcnMaskProc end module med_phases_prep_glc_mod - diff --git a/mediator/med_phases_prep_ice_mod.F90 b/mediator/med_phases_prep_ice_mod.F90 index 4f12f97ad..1f6424bf1 100644 --- a/mediator/med_phases_prep_ice_mod.F90 +++ b/mediator/med_phases_prep_ice_mod.F90 @@ -29,7 +29,7 @@ subroutine med_phases_prep_ice(gcomp, rc) 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 ESMF , only : ESMF_VMBroadCast + use ESMF , only : ESMF_VMBroadCast 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_diagnose => med_methods_FB_diagnose @@ -50,8 +50,8 @@ subroutine med_phases_prep_ice(gcomp, rc) type(InternalState) :: is_local type(ESMF_Field) :: lfield integer :: i,n - real(R8), pointer :: dataptr(:) => null() - real(R8), pointer :: dataptr_scalar_ocn(:,:) => null() + real(R8), pointer :: dataptr(:) + real(R8), pointer :: dataptr_scalar_ocn(:,:) real(R8) :: precip_fact(1) character(len=CS) :: cvalue character(len=64), allocatable :: fldnames(:) @@ -80,7 +80,7 @@ subroutine med_phases_prep_ice(gcomp, rc) ! ocn->ice is mapped in med_phases_post_ocn ! auto merges to create FBExp(compice) - call med_merge_auto(compice, & + call med_merge_auto(& is_local%wrap%med_coupling_active(:,compice), & is_local%wrap%FBExp(compice), & is_local%wrap%FBFrac(compice), & @@ -91,12 +91,12 @@ subroutine med_phases_prep_ice(gcomp, rc) ! Apply precipitation factor from ocean (that scales atm rain and snow to ice) if appropriate if (trim(coupling_mode) == 'cesm' .and. is_local%wrap%flds_scalar_index_precip_factor /= 0) then - ! Note that in med_internal_mod.F90 all is_local%wrap%flds_scalar_index_precip_factor + ! Note that in med_internal_mod.F90 all is_local%wrap%flds_scalar_index_precip_factor ! is initialized to 0. - ! In addition, in med.F90, if this attribute is not present as a mediator component attribute, - ! it is set to 0. + ! In addition, in med.F90, if this attribute is not present as a mediator component attribute, + ! it is set to 0. if (mastertask) then - call ESMF_StateGet(is_local%wrap%NstateImp(compocn), & + call ESMF_StateGet(is_local%wrap%NstateImp(compocn), & itemName=trim(is_local%wrap%flds_scalar_name), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldGet(lfield, farrayPtr=dataptr_scalar_ocn, rc=rc) @@ -111,7 +111,7 @@ subroutine med_phases_prep_ice(gcomp, rc) end if call ESMF_VMBroadCast(is_local%wrap%vm, precip_fact, 1, 0, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - is_local%wrap%flds_scalar_precip_factor = precip_fact(1) + is_local%wrap%flds_scalar_precip_factor = precip_fact(1) if (dbug_flag > 5) then write(cvalue,*) precip_fact(1) call ESMF_LogWrite(trim(subname)//" precip_fact is "//trim(cvalue), ESMF_LOGMSG_INFO) diff --git a/mediator/med_phases_prep_lnd_mod.F90 b/mediator/med_phases_prep_lnd_mod.F90 index ca1ed38d5..d60ac6dcf 100644 --- a/mediator/med_phases_prep_lnd_mod.F90 +++ b/mediator/med_phases_prep_lnd_mod.F90 @@ -47,10 +47,10 @@ subroutine med_phases_prep_lnd(gcomp, rc) real(r8) :: nextsw_cday integer :: scalar_id real(r8) :: tmp(1) - real(r8), pointer :: dataptr2d(:,:) => null() + real(r8), pointer :: dataptr2d(:,:) logical :: first_call = .true. - real(r8), pointer :: dataptr_scalar_lnd(:,:) => null() - real(r8), pointer :: dataptr_scalar_atm(:,:) => null() + real(r8), pointer :: dataptr_scalar_lnd(:,:) + real(r8), pointer :: dataptr_scalar_atm(:,:) character(len=*), parameter :: subname='(med_phases_prep_lnd)' !--------------------------------------- @@ -82,7 +82,7 @@ subroutine med_phases_prep_lnd(gcomp, rc) ! auto merges to create FBExp(complnd) - other than glc->lnd ! The following will merge all fields in fldsSrc call t_startf('MED:'//trim(subname)//' merge') - call med_merge_auto(complnd, & + call med_merge_auto(& is_local%wrap%med_coupling_active(:,complnd), & is_local%wrap%FBExp(complnd), & is_local%wrap%FBFrac(complnd), & diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90 index 705d8a595..ffa029b37 100644 --- a/mediator/med_phases_prep_ocn_mod.F90 +++ b/mediator/med_phases_prep_ocn_mod.F90 @@ -27,8 +27,9 @@ module med_phases_prep_ocn_mod implicit none private - public :: med_phases_prep_ocn_accum - public :: med_phases_prep_ocn_avg + public :: med_phases_prep_ocn_init ! called from med.F90 + public :: med_phases_prep_ocn_accum ! called from run sequence + public :: med_phases_prep_ocn_avg ! called from run sequence private :: med_phases_prep_ocn_custom_cesm private :: med_phases_prep_ocn_custom_nems @@ -40,6 +41,41 @@ module med_phases_prep_ocn_mod contains !----------------------------------------------------------------------------- + subroutine med_phases_prep_ocn_init(gcomp, rc) + + use ESMF , only : ESMF_GridComp, ESMF_SUCCESS + use med_methods_mod , only : FB_Init => med_methods_FB_init + use med_methods_mod , only : FB_Reset => med_methods_FB_Reset + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + character(len=*),parameter :: subname=' (med_phases_prep_ocn_init) ' + !--------------------------------------- + + rc = ESMF_SUCCESS + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return + + if (mastertask) then + write(logunit,'(a)') trim(subname)//' initializing ocean export accumulation FB for ' + end if + call FB_init(is_local%wrap%FBExpAccumOcn, is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateExp(compocn), STflds=is_local%wrap%NStateExp(compocn), & + name='FBExpAccumOcn', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_reset(is_local%wrap%FBExpAccumOcn, value=czero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine med_phases_prep_ocn_init + + !----------------------------------------------------------------------------- subroutine med_phases_prep_ocn_accum(gcomp, rc) use ESMF , only : ESMF_GridComp, ESMF_FieldBundleGet @@ -72,7 +108,7 @@ subroutine med_phases_prep_ocn_accum(gcomp, rc) if ( trim(coupling_mode) == 'cesm' .or. & trim(coupling_mode) == 'nems_orig_data' .or. & trim(coupling_mode) == 'hafs') then - call med_merge_auto(compocn, & + call med_merge_auto(& is_local%wrap%med_coupling_active(:,compocn), & is_local%wrap%FBExp(compocn), & is_local%wrap%FBFrac(compocn), & @@ -81,7 +117,7 @@ subroutine med_phases_prep_ocn_accum(gcomp, rc) 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(compocn, & + call med_merge_auto(& is_local%wrap%med_coupling_active(:,compocn), & is_local%wrap%FBExp(compocn), & is_local%wrap%FBFrac(compocn), & @@ -100,13 +136,13 @@ subroutine med_phases_prep_ocn_accum(gcomp, rc) end if ! ocean accumulator - call FB_accum(is_local%wrap%FBExpAccum(compocn), is_local%wrap%FBExp(compocn), rc=rc) + call FB_accum(is_local%wrap%FBExpAccumOcn, is_local%wrap%FBExp(compocn), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - is_local%wrap%FBExpAccumCnt(compocn) = is_local%wrap%FBExpAccumCnt(compocn) + 1 + is_local%wrap%ExpAccumOcnCnt = is_local%wrap%ExpAccumOcnCnt + 1 ! diagnose output if (dbug_flag > 1) then - call FB_diagnose(is_local%wrap%FBExpAccum(compocn), string=trim(subname)//' FBExpAccum accumulation ', rc=rc) + call FB_diagnose(is_local%wrap%FBExpAccumOcn, string=trim(subname)//' FBExpAccumOcn accumulation ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (dbug_flag > 20) then @@ -147,34 +183,32 @@ subroutine med_phases_prep_ocn_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 ESMF_FieldBundleGet(is_local%wrap%FBExpAccum(compocn), fieldCount=ncnt, rc=rc) + call ESMF_FieldBundleGet(is_local%wrap%FBExpAccumOcn, fieldCount=ncnt, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (ncnt > 0) then ! average ocn accumulator if (dbug_flag > 1) then - call FB_diagnose(is_local%wrap%FBExpAccum(compocn), & - string=trim(subname)//' FBExpAccum(compocn) before avg ', rc=rc) + call FB_diagnose(is_local%wrap%FBExpAccumOcn, & + string=trim(subname)//' FBExpAccumOcn before avg ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - call FB_average(is_local%wrap%FBExpAccum(compocn), & - is_local%wrap%FBExpAccumCnt(compocn), rc=rc) + call FB_average(is_local%wrap%FBExpAccumOcn, is_local%wrap%ExpAccumOcnCnt, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 1) then - call FB_diagnose(is_local%wrap%FBExpAccum(compocn), & - string=trim(subname)//' FBExpAccum(compocn) after avg ', rc=rc) + call FB_diagnose(is_local%wrap%FBExpAccumOcn, & + string=trim(subname)//' FBExpAccumOcn after avg ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if ! copy to FBExp(compocn) - call FB_copy(is_local%wrap%FBExp(compocn), is_local%wrap%FBExpAccum(compocn), rc=rc) + call FB_copy(is_local%wrap%FBExp(compocn), is_local%wrap%FBExpAccumOcn, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! zero accumulator - is_local%wrap%FBExpAccumFlag(compocn) = .true. - is_local%wrap%FBExpAccumCnt(compocn) = 0 - call FB_reset(is_local%wrap%FBExpAccum(compocn), value=czero, rc=rc) + is_local%wrap%ExpAccumOcnCnt = 0 + call FB_reset(is_local%wrap%FBExpAccumOcn, value=czero, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -205,31 +239,31 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) ! local variables type(InternalState) :: is_local type(ESMF_Field) :: lfield - real(R8), pointer :: ifrac(:) => null() - real(R8), pointer :: ofrac(:) => null() - real(R8), pointer :: ifracr(:) => null() - real(R8), pointer :: ofracr(:) => null() - real(R8), pointer :: avsdr(:) => null() - real(R8), pointer :: avsdf(:) => null() - real(R8), pointer :: anidr(:) => null() - real(R8), pointer :: anidf(:) => null() - real(R8), pointer :: Faxa_swvdf(:) => null() - real(R8), pointer :: Faxa_swndf(:) => null() - real(R8), pointer :: Faxa_swvdr(:) => null() - real(R8), pointer :: Faxa_swndr(:) => null() - real(R8), pointer :: Foxx_swnet(:) => null() - real(R8), pointer :: Foxx_swnet_afracr(:) => null() - real(R8), pointer :: Foxx_swnet_vdr(:) => null() - real(R8), pointer :: Foxx_swnet_vdf(:) => null() - real(R8), pointer :: Foxx_swnet_idr(:) => null() - real(R8), pointer :: Foxx_swnet_idf(:) => null() - real(R8), pointer :: Fioi_swpen_vdr(:) => null() - real(R8), pointer :: Fioi_swpen_vdf(:) => null() - real(R8), pointer :: Fioi_swpen_idr(:) => null() - real(R8), pointer :: Fioi_swpen_idf(:) => null() - real(R8), pointer :: Fioi_swpen(:) => null() - real(R8), pointer :: dataptr(:) => null() - real(R8), pointer :: dataptr_scalar_ocn(:,:) => null() + real(R8), pointer :: ifrac(:) + real(R8), pointer :: ofrac(:) + real(R8), pointer :: ifracr(:) + real(R8), pointer :: ofracr(:) + real(R8), pointer :: avsdr(:) + real(R8), pointer :: avsdf(:) + real(R8), pointer :: anidr(:) + real(R8), pointer :: anidf(:) + real(R8), pointer :: Faxa_swvdf(:) + real(R8), pointer :: Faxa_swndf(:) + real(R8), pointer :: Faxa_swvdr(:) + real(R8), pointer :: Faxa_swndr(:) + real(R8), pointer :: Foxx_swnet(:) + real(R8), pointer :: Foxx_swnet_afracr(:) + real(R8), pointer :: Foxx_swnet_vdr(:) + real(R8), pointer :: Foxx_swnet_vdf(:) + real(R8), pointer :: Foxx_swnet_idr(:) + real(R8), pointer :: Foxx_swnet_idf(:) + real(R8), pointer :: Fioi_swpen_vdr(:) + real(R8), pointer :: Fioi_swpen_vdf(:) + real(R8), pointer :: Fioi_swpen_idr(:) + real(R8), pointer :: Fioi_swpen_idf(:) + real(R8), pointer :: Fioi_swpen(:) + real(R8), pointer :: dataptr(:) + real(R8), pointer :: dataptr_scalar_ocn(:,:) real(R8) :: frac_sum real(R8) :: ifrac_scaled, ofrac_scaled real(R8) :: ifracr_scaled, ofracr_scaled @@ -438,12 +472,12 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) ! Apply precipitation factor from ocean (that scales atm rain and snow back to ocn ) if appropriate if (trim(coupling_mode) == 'cesm' .and. is_local%wrap%flds_scalar_index_precip_factor /= 0) then - ! Note that in med_internal_mod.F90 all is_local%wrap%flds_scalar_index_precip_factor + ! Note that in med_internal_mod.F90 all is_local%wrap%flds_scalar_index_precip_factor ! is initialized to 0. - ! In addition, in med.F90, if this attribute is not present as a mediator component attribute, - ! it is set to 0. + ! In addition, in med.F90, if this attribute is not present as a mediator component attribute, + ! it is set to 0. if (mastertask) then - call ESMF_StateGet(is_local%wrap%NstateImp(compocn), & + call ESMF_StateGet(is_local%wrap%NstateImp(compocn), & itemName=trim(is_local%wrap%flds_scalar_name), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldGet(lfield, farrayPtr=dataptr_scalar_ocn, rc=rc) @@ -458,7 +492,7 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) end if call ESMF_VMBroadCast(is_local%wrap%vm, precip_fact, 1, 0, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - is_local%wrap%flds_scalar_precip_factor = precip_fact(1) + is_local%wrap%flds_scalar_precip_factor = precip_fact(1) if (dbug_flag > 5) then write(cvalue,*) precip_fact(1) call ESMF_LogWrite(trim(subname)//" precip_fact is "//trim(cvalue), ESMF_LOGMSG_INFO) @@ -501,13 +535,13 @@ subroutine med_phases_prep_ocn_custom_nems(gcomp, rc) ! local variables type(InternalState) :: is_local - 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() + 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(:) 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 41625bcfb..f54da223b 100644 --- a/mediator/med_phases_prep_rof_mod.F90 +++ b/mediator/med_phases_prep_rof_mod.F90 @@ -3,11 +3,11 @@ module med_phases_prep_rof_mod !----------------------------------------------------------------------------- ! Create rof export fields ! - 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 - ! merge the mapped lnd fields to create FBExp(comprof) - ! this will be done in med_phases_prep_rof_avg + ! - done in med_phases_prep_rof_accum + ! - time avergage accumulated import lnd fields on lnd grid when necessary and + ! then map the time averaged accumulated lnd fields to the rof grid + ! and then merge the mapped lnd fields to create FBExp(comprof) + ! - done in med_phases_prep_rof_avg !----------------------------------------------------------------------------- use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 @@ -18,20 +18,19 @@ module med_phases_prep_rof_mod use med_constants_mod , only : czero => med_constants_czero use med_utils_mod , only : chkerr => med_utils_chkerr use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh - use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_diagnose => med_methods_FB_diagnose use med_methods_mod , only : fldbun_reset => med_methods_FB_reset use med_methods_mod , only : fldbun_average => med_methods_FB_average - use med_methods_mod , only : field_getdata2d => med_methods_Field_getdata2d use med_methods_mod , only : field_getdata1d => med_methods_Field_getdata1d use perf_mod , only : t_startf, t_stopf implicit none private + public :: med_phases_prep_rof_init ! called from med.F90 + public :: med_phases_prep_rof_accum ! called by med_phases_post_lnd.F90 public :: med_phases_prep_rof ! called by run sequence - public :: med_phases_prep_rof_accum ! called by med_phases_post_lnd private :: med_phases_prep_rof_irrig @@ -49,13 +48,18 @@ module med_phases_prep_rof_mod character(len=*), parameter :: irrig_normalized_field = 'Flrl_irrig_normalized' character(len=*), parameter :: irrig_volr0_field = 'Flrl_irrig_volr0 ' - ! the following are the fields that will be accumulated from the land - character(CS) :: lnd2rof_flds(6) = (/'Flrl_rofsur','Flrl_rofgwl','Flrl_rofsub', & - 'Flrl_rofdto','Flrl_rofi ','Flrl_irrig '/) + ! the following are the fields that will be accumulated from the land and are derived from fldlistTo(comprof) + character(CS), allocatable :: lnd2rof_flds(:) integer :: maptype_lnd2rof integer :: maptype_rof2lnd + ! Accumulation to river field bundles - accumulation is done on the land mesh and then averaged and mapped to the + ! rof mesh + integer , public :: lndAccum2rof_cnt + type(ESMF_FieldBundle), public :: FBlndAccum2rof_l + type(ESMF_FieldBundle), public :: FBlndAccum2rof_r + character(*) , parameter :: u_FILE_u = & __FILE__ @@ -63,6 +67,108 @@ module med_phases_prep_rof_mod contains !=============================================================================== + subroutine med_phases_prep_rof_init(gcomp, rc) + + !--------------------------------------- + ! Create module field bundles FBlndAccum2rof_l and FBlndAccum2rof_r + ! land accumulation on both complnd and comprof meshes + !--------------------------------------- + + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet + use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate + use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT + use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleCreate, ESMF_FieldBundleGet, ESMF_FieldBundleAdd + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_TYPEKIND_R8 + use esmFlds , only : fldListFr, fldlistTo, med_fldlist_GetNumFlds, med_fldlist_getFldInfo + use med_map_mod , only : med_map_packed_field_create + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + integer :: n, n1, nflds + type(ESMF_Mesh) :: mesh_l + type(ESMF_Mesh) :: mesh_r + type(ESMF_Field) :: lfield + character(len=CS), allocatable :: fldnames_temp(:) + character(len=*),parameter :: subname=' (med_phases_prep_rof_init) ' + !--------------------------------------- + + rc = ESMF_SUCCESS + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine lnd2rof_flds (module variable) - note that fldListTo is set in esmFldsExchange_cesm.F90 + ! Remove scalar field from lnd2rof_flds + nflds = med_fldlist_getnumflds(fldlistTo(comprof)) + allocate(fldnames_temp(nflds)) + do n = 1,nflds + call med_fldList_GetFldInfo(fldListTo(comprof), n, fldnames_temp(n)) + end do + do n = 1,nflds + if (trim(fldnames_temp(n)) == trim(is_local%wrap%flds_scalar_name)) then + do n1 = n, nflds-1 + fldnames_temp(n1) = fldnames_temp(n1+1) + enddo + nflds = nflds - 1 + endif + enddo + allocate(lnd2rof_flds(nflds)) + do n = 1,nflds + lnd2rof_flds(n) = trim(fldnames_temp(n)) + end do + deallocate(fldnames_temp) + + ! Get lnd and rof meshes + call fldbun_getmesh(is_local%wrap%FBImp(complnd,complnd), mesh_l, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_getmesh(is_local%wrap%FBImp(complnd,comprof), mesh_r, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create module field bundle FBlndAccum2rof_l on land mesh and FBlndAccum2rof_r on rof mesh + FBlndAccum2rof_l = ESMF_FieldBundleCreate(name='FBlndAccum2rof_l', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + FBlndAccum2rof_r = ESMF_FieldBundleCreate(name='FBlndAccum2rof_r', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(lnd2rof_flds) + lfield = ESMF_FieldCreate(mesh_l, ESMF_TYPEKIND_R8, name=lnd2rof_flds(n), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleAdd(FBlndAccum2rof_l, (/lfield/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(trim(subname)//' adding field '//trim(lnd2rof_flds(n))//' to FBLndAccum2rof_l', & + ESMF_LOGMSG_INFO) + lfield = ESMF_FieldCreate(mesh_r, ESMF_TYPEKIND_R8, name=lnd2rof_flds(n), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleAdd(FBlndAccum2rof_r, (/lfield/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(trim(subname)//' adding field '//trim(lnd2rof_flds(n))//' to FBLndAccum2rof_r', & + ESMF_LOGMSG_INFO) + end do + + ! Initialize field bundles and accumulation count + call fldbun_reset(FBlndAccum2rof_l, value=0.0_r8, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call fldbun_reset(FBlndAccum2rof_r, value=0.0_r8, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + lndAccum2rof_cnt = 0 + + ! Create packed mapping from rof->lnd + call med_map_packed_field_create(destcomp=comprof, & + flds_scalar_name=is_local%wrap%flds_scalar_name, & + fldsSrc=fldListFr(complnd)%flds, & + FBSrc=FBLndAccum2rof_l, FBDst=FBLndAccum2rof_r, & + packed_data=is_local%wrap%packed_data(complnd,comprof,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine med_phases_prep_rof_init + + !=============================================================================== subroutine med_phases_prep_rof_accum(gcomp, rc) !------------------------------------ @@ -80,7 +186,6 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) ! input/output variables type(ESMF_GridComp) :: gcomp - integer, intent(out) :: rc ! local variables @@ -89,15 +194,10 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) integer :: fieldCount integer :: ungriddedUBound(1) logical :: exists - real(r8), pointer :: dataptr1d(:) => null() - real(r8), pointer :: dataptr2d(:,:) => null() - real(r8), pointer :: dataptr1d_accum(:) => null() - real(r8), pointer :: dataptr2d_accum(:,:) => null() + real(r8), pointer :: dataptr1d(:) + real(r8), pointer :: dataptr1d_accum(:) type(ESMF_Field) :: lfield type(ESMF_Field) :: lfield_accum - type(ESMF_Field), pointer :: fieldlist(:) => null() - type(ESMF_Field), pointer :: fieldlist_accum(:) => null() - character(CL), pointer :: lfieldnamelist(:) => null() character(len=*), parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof_accum)' !--------------------------------------- @@ -119,36 +219,25 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) isPresent=exists, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (exists) then + call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), & + field=lfield_accum, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldBundleGet(is_local%wrap%FBImpaccum(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & - field=lfield_accum, rc=rc) + call field_getdata1d(lfield, dataptr1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) + call field_getdata1d(lfield_accum, dataptr1d_accum, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (ungriddedUBound(1) > 0) then - call field_getdata2d(lfield, dataptr2d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata2d(lfield_accum, dataptr2d_accum, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr2d_accum(:,:) = dataptr2d_accum(:,:) + dataptr2d(:,:) - else - call field_getdata1d(lfield, dataptr1d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata1d(lfield_accum, dataptr1d_accum, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr1d_accum(:) = dataptr1d_accum(:) + dataptr1d(:) - end if + dataptr1d_accum(:) = dataptr1d_accum(:) + dataptr1d(:) end if end do ! Accumulate counter - is_local%wrap%FBImpAccumCnt(complnd) = is_local%wrap%FBImpAccumCnt(complnd) + 1 + lndAccum2rof_cnt = lndAccum2rof_cnt + 1 if (dbug_flag > 1) then - call fldbun_diagnose(is_local%wrap%FBImpAccum(complnd,complnd), & - string=trim(subname)//' FBImpAccum(complnd,complnd) ', rc=rc) + call fldbun_diagnose(FBlndAccum2rof_l, string=trim(subname)//' FBlndAccum2rof_l accum', rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if @@ -184,15 +273,14 @@ subroutine med_phases_prep_rof(gcomp, rc) integer :: i,j,n,n1,ncnt integer :: count logical :: exists - real(r8), pointer :: dataptr(:) => null() - real(r8), pointer :: dataptr1d(:) => null() - real(r8), pointer :: dataptr2d(:,:) => null() + real(r8), pointer :: dataptr(:) + real(r8), pointer :: dataptr1d(:) type(ESMF_Field) :: field_irrig_flux - integer :: fieldcount type(ESMF_Field) :: lfield - type(ESMF_Field), pointer :: fieldlist(:) => null() - integer :: ungriddedUBound(1) - character(CL), pointer :: lfieldnamelist(:) => null() + type(ESMF_Field) :: lfield_src + type(ESMF_Field) :: lfield_dst + type(ESMF_Field) :: field_lfrac_lnd + character(CL), pointer :: lfieldnamelist(:) character(len=*),parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof)' !--------------------------------------- @@ -214,7 +302,7 @@ subroutine med_phases_prep_rof(gcomp, rc) ! Average import from land accumuled FB !--------------------------------------- - count = is_local%wrap%FBImpAccumCnt(complnd) + count = lndAccum2rof_cnt if (count == 0) then if (mastertask) then write(logunit,'(a)')trim(subname)//'accumulation count for land input averging to river is 0 '// & @@ -223,77 +311,57 @@ subroutine med_phases_prep_rof(gcomp, rc) end if do n = 1,size(lnd2rof_flds) - call ESMF_FieldBundleGet(is_local%wrap%FBImpAccum(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & - isPresent=exists, rc=rc) + call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), isPresent=exists, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (exists) then - call ESMF_FieldBundleGet(is_local%wrap%FBImpAccum(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & - field=lfield, rc=rc) + call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) + call field_getdata1d(lfield, dataptr1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (ungriddedUBound(1) > 0) then - call field_getdata2d(lfield, dataptr2d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (count == 0) then - dataptr2d(:,:) = czero - else - dataptr2d(:,:) = dataptr2d(:,:) / real(count, r8) - end if + if (count == 0) then + dataptr1d(:) = czero else - call field_getdata1d(lfield, dataptr1d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (count == 0) then - dataptr1d(:) = czero - else - dataptr1d(:) = dataptr1d(:) / real(count, r8) - end if + dataptr1d(:) = dataptr1d(:) / real(count, r8) end if end if end do if (dbug_flag > 1) then - call fldbun_diagnose(is_local%wrap%FBImpAccum(complnd,complnd), & - string=trim(subname)//' FBImpAccum(complnd,complnd) after avg ', rc=rc) + call fldbun_diagnose(FBlndAccum2rof_l, string=trim(subname)//' FBlndAccum2rof_l after avg ', rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if !--------------------------------------- - ! Map to create FBImpAccum(complnd,comprof) + ! Map to create FBlndAccum2rof_r !--------------------------------------- ! 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_field_packed( & - FBSrc=is_local%wrap%FBImpAccum(complnd,complnd), & - FBDst=is_local%wrap%FBImpAccum(complnd,comprof), & - FBFracSrc=is_local%wrap%FBFrac(complnd), & - 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 fldbun_diagnose(is_local%wrap%FBImpAccum(complnd,comprof), & - string=trim(subname)//' FBImpAccum(complnd,comprof) after map ', rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end if + call med_map_field_packed( FBSrc=FBlndAccum2rof_l, FBDst=FBlndAccum2rof_r, & + FBFracSrc=is_local%wrap%FBFrac(complnd), & + 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 - ! Reset the irrig_flux_field with the map_lnd2rof_irrig calculation below if appropriate - if ( NUOPC_IsConnected(is_local%wrap%NStateImp(complnd), fieldname=trim(irrig_flux_field))) then - call med_phases_prep_rof_irrig( gcomp, rc=rc ) - if (chkerr(rc,__LINE__,u_FILE_u)) return - else - ! This will ensure that no irrig is sent from the land - call fldbun_getdata1d(is_local%wrap%FBImpAccum(complnd,comprof), irrig_flux_field, dataptr, rc) - dataptr(:) = czero - end if - endif + if (dbug_flag > 1) then + call fldbun_diagnose(FBlndAccum2rof_r, string=trim(subname)//' FBlndAccum2rof_r after map ', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + ! Reset the irrig_flux_field with the map_lnd2rof_irrig calculation below if appropriate + if ( NUOPC_IsConnected(is_local%wrap%NStateImp(complnd), fieldname=trim(irrig_flux_field))) then + call med_phases_prep_rof_irrig( gcomp, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + ! This will ensure that no irrig is sent from the land + call fldbun_getdata1d(FBlndAccum2rof_r, irrig_flux_field, dataptr, rc) + dataptr(:) = czero + end if !--------------------------------------- - ! auto merges to create FBExp(comprof) + ! auto merges to create FBExp(comprof) - assumes that all data is coming from FBlndAccum2rof_r !--------------------------------------- if (dbug_flag > 1) then @@ -302,12 +370,8 @@ subroutine med_phases_prep_rof(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if - 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), & - fldListTo(comprof), rc=rc) + call med_merge_auto(compsrc=complnd, FBout=is_local%wrap%FBExp(comprof), & + FBfrac=is_local%wrap%FBFrac(comprof), FBin=FBlndAccum2rof_r, fldListTo=fldListTo(comprof), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 1) then @@ -321,28 +385,19 @@ subroutine med_phases_prep_rof(gcomp, rc) !--------------------------------------- ! zero counter - is_local%wrap%FBImpAccumCnt(complnd) = 0 + lndAccum2rof_cnt = 0 - ! zero lnd2rof fields in FBImpAccum + ! zero lnd2rof fields in FBlndAccum2rof_l do n = 1,size(lnd2rof_flds) call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & isPresent=exists, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (exists) then - call ESMF_FieldBundleGet(is_local%wrap%FBImpaccum(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & - field=lfield, rc=rc) + call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) + call field_getdata1d(lfield, dataptr1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (ungriddedUBound(1) > 0) then - call field_getdata2d(lfield, dataptr2d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr2d(:,:) = czero - else - call field_getdata1d(lfield, dataptr1d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr1d(:) = czero - end if + dataptr1d(:) = czero end if end do @@ -396,19 +451,17 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc) 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(:) => null() - real(r8), pointer :: 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() + real(r8), pointer :: volr_l(:) + real(r8), pointer :: volr_r(:) + real(r8), pointer :: 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(:) character(len=*), parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof_irrig)' !--------------------------------------------------------------- @@ -539,7 +592,7 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc) ! flux on the rof grid. ! First extract accumulated irrigation flux from land - call fldbun_getdata1d(is_local%wrap%FBImpAccum(complnd,complnd), trim(irrig_flux_field), irrig_flux_l, rc) + call fldbun_getdata1d(FBlndAccum2rof_l, trim(irrig_flux_field), irrig_flux_l, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Fill in values for irrig_normalized_l and irrig_volr0_l @@ -584,12 +637,12 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc) field_normdst=field_lfrac_rof, 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) + ! Convert to a total irrigation flux on the ROF grid, and put this in the pre-merge FBlndAccum2rof_r call field_getdata1d(field_rofIrrig, irrig_normalized_r, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call field_getdata1d(field_rofIrrig0, irrig_volr0_r, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call fldbun_getdata1d(is_local%wrap%FBImpAccum(complnd,comprof), trim(irrig_flux_field), irrig_flux_r, rc) + call fldbun_getdata1d(FBlndAccum2rof_r, trim(irrig_flux_field), irrig_flux_r, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call field_getdata1d(field_rofIrrig0, irrig_volr0_r, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 9d5e51f54..8ff29e432 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -80,7 +80,7 @@ subroutine med_phases_prep_wav(gcomp, rc) end do ! auto merges to create FBExp(compwav) - call med_merge_auto(compwav, & + call med_merge_auto(& is_local%wrap%med_coupling_active(:,compwav), & is_local%wrap%FBExp(compwav), & is_local%wrap%FBFrac(compwav), & diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index 642816420..e2e00c474 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -4,14 +4,15 @@ module med_phases_restart_mod ! Write/Read mediator restart files !----------------------------------------------------------------------------- - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 - use med_constants_mod , only : dbug_flag => med_constants_dbug_flag - use med_constants_mod , only : SecPerDay => med_constants_SecPerDay - use med_utils_mod , only : chkerr => med_utils_ChkErr - use med_internalstate_mod , only : mastertask, logunit, InternalState - use med_time_mod , only : med_time_AlarmInit - use esmFlds , only : ncomps, compname, compocn - use perf_mod , only : t_startf, t_stopf + use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + 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 : mastertask, logunit, InternalState + use esmFlds , only : ncomps, compname, compocn, complnd + use perf_mod , only : t_startf, t_stopf + use med_phases_prep_glc_mod , only : FBlndAccum2glc_l, lndAccum2glc_cnt + use med_phases_prep_glc_mod , only : FBocnAccum2glc_o, ocnAccum2glc_cnt + use med_phases_prep_rof_mod , only : FBlndAccum2rof_l, lndAccum2rof_cnt implicit none private @@ -21,6 +22,10 @@ module med_phases_restart_mod private :: med_phases_restart_alarm_init + logical :: write_restart_at_endofrun = .false. + logical :: whead(2) = (/.true. , .false./) + logical :: wdata(2) = (/.false., .true. /) + character(*), parameter :: u_FILE_u = & __FILE__ @@ -34,16 +39,15 @@ subroutine med_phases_restart_alarm_init(gcomp, rc) ! Initialize mediator restart file alarms (module variables) ! -------------------------------------- - use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_Clock, ESMF_ClockGet, ESMF_ClockAdvance, ESMF_ClockSet - use ESMF , only : ESMF_Time - use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalGet - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR - use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE - use ESMF , only : operator(==), operator(-) - use ESMF , only : ESMF_ALARMLIST_ALL, ESMF_Alarm, ESMF_AlarmSet - use NUOPC , only : NUOPC_CompAttributeGet - use NUOPC_Model, only : NUOPC_ModelGet + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet + use ESMF , only : ESMF_Clock, ESMF_ClockGet, ESMF_ClockAdvance, ESMF_ClockSet + use ESMF , only : ESMF_Time, ESMF_TimeInterval, ESMF_TimeIntervalGet + use ESMF , only : ESMF_Alarm, ESMF_AlarmSet + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR + use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE + use NUOPC , only : NUOPC_CompAttributeGet + use NUOPC_Model , only : NUOPC_ModelGet + use med_time_mod , only : med_time_AlarmInit ! input/output variables type(ESMF_GridComp) :: gcomp @@ -60,42 +64,33 @@ subroutine med_phases_restart_alarm_init(gcomp, rc) character(CL) :: cvalue ! attribute string character(CL) :: restart_option ! freq_option setting (ndays, nsteps, etc) integer :: restart_n ! freq_n setting relative to freq_option + logical :: isPresent + logical :: isSet character(len=*), parameter :: subname='(med_phases_restart_alarm_init)' !--------------------------------------- rc = ESMF_SUCCESS - ! ----------------------------- ! Get model clock - ! ----------------------------- - call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! get current time - call ESMF_ClockGet(mclock, currTime=mCurrTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! ----------------------------- - ! Set alarm for instantaneous mediator restart output - ! ----------------------------- - + ! Determine restart frequency call NUOPC_CompAttributeGet(gcomp, name='restart_option', value=restart_option, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name='restart_n', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) restart_n + ! Set alarm for instantaneous mediator restart output + call ESMF_ClockGet(mclock, currTime=mCurrTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call med_time_alarmInit(mclock, alarm, option=restart_option, opt_n=restart_n, & reftime=mcurrTime, alarmname='alarm_restart', rc=rc) - call ESMF_AlarmSet(alarm, clock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !-------------------------------- - ! Advance model clock to trigger alarms then reset model clock back to currtime - !-------------------------------- - + ! Advance model clock to trigger alarm then reset model clock back to currtime call ESMF_ClockGet(mclock, currTime=mCurrTime, timeStep=mtimestep, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeIntervalGet(mtimestep, s=timestep_length, rc=rc) @@ -105,23 +100,26 @@ subroutine med_phases_restart_alarm_init(gcomp, rc) call ESMF_ClockSet(mclock, currTime=mcurrtime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! ----------------------------- - ! Write mediator diagnostic output - ! ----------------------------- + ! Handle end of run restart + call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(cvalue) .eq. '.true.') write_restart_at_endofrun = .true. + end if + ! Write mediator diagnostic output if (mastertask) then write(logunit,*) - write(logunit,100) trim(subname)//" restart clock timestep = ",timestep_length - write(logunit,100) trim(subname)//" set restart alarm with option "//& + write(logunit,'(a,2x,i8)') trim(subname)//" restart clock timestep = ",timestep_length + write(logunit,'(a,2x,i8)') trim(subname)//" set restart alarm with option "//& trim(restart_option)//" and frequency ",restart_n -100 format(a,2x,i8) + write(logunit,'(a)') trim(subname)//" write_restart_at_endofrun : ", write_restart_at_endofrun write(logunit,*) end if end subroutine med_phases_restart_alarm_init !=============================================================================== - subroutine med_phases_restart_write(gcomp, rc) ! Write mediator restart @@ -130,14 +128,17 @@ subroutine med_phases_restart_write(gcomp, rc) use ESMF , only : ESMF_TimeInterval, ESMF_CalKind_Flag, ESMF_MAXSTR use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE use ESMF , only : ESMF_LOGMSG_ERROR, operator(==), operator(-) - use ESMF , only : ESMF_GridCompGet, ESMF_VMGet, ESMF_ClockGet, ESMF_ClockGetNextTime + use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_ClockGetNextTime use ESMF , only : ESMF_TimeGet, ESMF_ClockGetAlarm, ESMF_ClockPrint, ESMF_TimeIntervalGet use ESMF , only : ESMF_AlarmIsRinging, ESMF_AlarmRingerOff, ESMF_FieldBundleIsCreated use ESMF , only : ESMF_Calendar use NUOPC , only : NUOPC_CompAttributeGet use NUOPC_Model, only : NUOPC_ModelGet + use med_io_mod , only : med_io_define_time, med_io_write_time use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef use med_io_mod , only : med_io_close, med_io_date2yyyymmdd, med_io_sec2hms + use med_phases_history_mod, only : auxcomp + use med_constants_mod , only : SecPerDay => med_constants_SecPerDay ! Input/output variables type(ESMF_GridComp) :: gcomp @@ -149,13 +150,14 @@ subroutine med_phases_restart_write(gcomp, rc) type(ESMF_Time) :: starttime type(ESMF_Time) :: currtime type(ESMF_Time) :: nexttime + type(ESMF_Time), save :: lasttimewritten type(ESMF_TimeInterval) :: timediff ! Used to calculate curr_time type(ESMF_Alarm) :: alarm type(ESMF_Calendar) :: calendar character(len=CS) :: currtimestr character(len=CS) :: nexttimestr type(InternalState) :: is_local - integer :: i,j,m,n,n1,ncnt + integer :: m,n,nf,nc ! counters integer :: curr_ymd ! Current date YYYYMMDD integer :: curr_tod ! Current time-of-day (s) integer :: start_ymd ! Starting date YYYYMMDD @@ -164,7 +166,7 @@ subroutine med_phases_restart_write(gcomp, rc) integer :: next_tod ! Starting time-of-day (s) integer :: nx,ny ! global grid size integer :: yr,mon,day,sec ! time units - real(R8) :: dayssince ! Time interval since start time + real(R8) :: days_since ! Time interval since start time integer :: unitn ! unit number character(ESMF_MAXSTR) :: time_units ! units of time variable character(ESMF_MAXSTR) :: case_name ! case name @@ -177,8 +179,6 @@ subroutine med_phases_restart_write(gcomp, rc) integer :: freq_n ! freq_n setting relative to freq_option logical :: alarmIsOn ! generic alarm flag real(R8) :: tbnds(2) ! CF1.0 time bounds - logical :: whead,wdata ! for writing restart/restart cdf files - integer :: iam ! vm stuff character(ESMF_MAXSTR) :: tmpstr logical :: isPresent logical :: first_time = .true. @@ -198,16 +198,8 @@ subroutine med_phases_restart_write(gcomp, rc) nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - 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 - call NUOPC_CompAttributeGet(gcomp, name='case_name', value=case_name, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', isPresent=isPresent, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if(isPresent) then @@ -216,7 +208,6 @@ subroutine med_phases_restart_write(gcomp, rc) else cpl_inst_tag = "" endif - call NUOPC_CompAttributeGet(gcomp, name='restart_dir', isPresent=isPresent, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if(isPresent) then @@ -238,39 +229,38 @@ subroutine med_phases_restart_write(gcomp, rc) call NUOPC_ModelGet(gcomp, modelClock=clock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! --- Restart Alarm - !--------------------------------------- - + ! Restart Alarm call ESMF_ClockGetAlarm(clock, alarmname='alarm_restart', alarm=alarm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ESMF_AlarmIsRinging(alarm, rc=rc)) then if (ChkErr(rc,__LINE__,u_FILE_u)) return alarmIsOn = .true. call ESMF_AlarmRingerOff( alarm, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return else - AlarmIsOn = .false. + ! Stop Alarm + call ESMF_ClockGetAlarm(clock, alarmname='alarm_stop', alarm=alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsRinging(alarm, rc=rc) .and. write_restart_at_endofrun) then + AlarmIsOn = .true. + else + AlarmIsOn = .false. + endif endif if (alarmIsOn) then call ESMF_ClockGet(clock, currtime=currtime, starttime=starttime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGetNextTime(clock, nextTime=nexttime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGet(clock, calendar=calendar, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(currtime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec if (dbug_flag > 1) then call ESMF_LogWrite(trim(subname)//": currtime = "//trim(currtimestr), ESMF_LOGMSG_INFO) endif - call ESMF_TimeGet(nexttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return write(nexttimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec @@ -285,7 +275,7 @@ subroutine med_phases_restart_write(gcomp, rc) endif timediff = nexttime - starttime call ESMF_TimeIntervalGet(timediff, d=day, s=sec, rc=rc) - dayssince = day + sec/real(SecPerDay,R8) + days_since = day + sec/real(SecPerDay,R8) call ESMF_TimeGet(starttime, yy=yr, mm=mon, dd=day, s=sec, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -305,15 +295,15 @@ subroutine med_phases_restart_write(gcomp, rc) curr_tod = sec !--------------------------------------- - ! --- Restart File + ! Restart File ! Use nexttimestr rather than currtimestr here since that is the time at the end of ! the timestep and is preferred for restart file names !--------------------------------------- - write(restart_file,"(6a)") trim(restart_dir)//trim(case_name),'.cpl', & - trim(cpl_inst_tag),'.r.',trim(nexttimestr),'.nc' + write(restart_file,"(6a)") trim(restart_dir)//trim(case_name),'.cpl', trim(cpl_inst_tag),'.r.',& + trim(nexttimestr),'.nc' - if (iam == 0) then + if (mastertask) then restart_pfile = "rpointer.cpl"//cpl_inst_tag call ESMF_LogWrite(trim(subname)//" write rpointer file = "//trim(restart_pfile), ESMF_LOGMSG_INFO) open(newunit=unitn, file=restart_pfile, form='FORMATTED') @@ -322,129 +312,148 @@ subroutine med_phases_restart_write(gcomp, rc) endif call ESMF_LogWrite(trim(subname)//": write "//trim(restart_file), ESMF_LOGMSG_INFO) - call med_io_wopen(restart_file, vm, iam, clobber=.true.) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_wopen(restart_file, vm, clobber=.true.) do m = 1,2 - if (m == 1) then - whead = .true. - wdata = .false. - else if (m == 2) then - whead = .false. - wdata = .true. - endif - if (wdata) then + if (m == 2) then call med_io_enddef(restart_file) end if - tbnds = dayssince + tbnds = days_since call ESMF_LogWrite(trim(subname)//": time "//trim(time_units), ESMF_LOGMSG_INFO) - if (tbnds(1) >= tbnds(2)) then - call med_io_write(restart_file, iam=iam, & - time_units=time_units, calendar=calendar, time_val=dayssince, & - whead=whead, wdata=wdata, rc=rc) + if (whead(m)) then + call ESMF_ClockGet(clock, calendar=calendar, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_define_time(time_units, calendar, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return else - call med_io_write(restart_file, iam=iam, & - time_units=time_units, calendar=calendar, time_val=dayssince, & - whead=whead, wdata=wdata, tbnds=tbnds, rc=rc) + call med_io_write_time(days_since, tbnds=(/days_since,days_since/), nt=1, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + end if ! Write out next ymd/tod in place of curr ymd/tod because the ! restart represents the time at end of the current timestep ! and that is where we want to start the next run. - - call med_io_write(restart_file, iam, start_ymd, 'start_ymd', whead=whead, wdata=wdata, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_io_write(restart_file, iam, start_tod, 'start_tod', whead=whead, wdata=wdata, rc=rc) + call med_io_write(restart_file, start_ymd, 'start_ymd', whead(m), wdata(m), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_io_write(restart_file, iam, next_ymd , 'curr_ymd' , whead=whead, wdata=wdata, rc=rc) + call med_io_write(restart_file, start_tod, 'start_tod', whead(m), wdata(m), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_io_write(restart_file, iam, next_tod , 'curr_tod' , whead=whead, wdata=wdata, rc=rc) + call med_io_write(restart_file, next_ymd , 'curr_ymd' , whead(m), wdata(m), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call med_io_write(restart_file, iam, is_local%wrap%FBExpAccumCnt, dname='ExpAccumCnt', & - whead=whead, wdata=wdata, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_io_write(restart_file, iam, is_local%wrap%FBImpAccumCnt, dname='ImpAccumCnt', & - whead=whead, wdata=wdata, rc=rc) + call med_io_write(restart_file, next_tod , 'curr_tod' , whead(m), wdata(m), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1,ncomps if (is_local%wrap%comp_present(n)) then nx = is_local%wrap%nx(n) ny = is_local%wrap%ny(n) - ! Write import field bundles if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(n,n),rc=rc)) then - !write(tmpstr,*) subname,' nx,ny = ',trim(compname(n)),nx,ny - !call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call med_io_write(restart_file, iam, is_local%wrap%FBimp(n,n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'Imp', rc=rc) + call med_io_write(restart_file, is_local%wrap%FBimp(n,n), whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(n))//'Imp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - ! Write export field bundles if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(n),rc=rc)) then - !write(tmpstr,*) subname,' nx,ny = ',trim(compname(n)),nx,ny - !call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call med_io_write(restart_file, iam, is_local%wrap%FBexp(n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'Exp', rc=rc) + call med_io_write(restart_file, is_local%wrap%FBexp(n), whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(n))//'Exp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - ! Write fraction field bundles if (ESMF_FieldBundleIsCreated(is_local%wrap%FBfrac(n),rc=rc)) then - !write(tmpstr,*) subname,' nx,ny = ',trim(compname(n)),nx,ny - !call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call med_io_write(restart_file, iam, is_local%wrap%FBfrac(n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'Frac', rc=rc) + call med_io_write(restart_file, is_local%wrap%FBfrac(n), whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(n))//'Frac', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + end if + enddo - ! Write export field bundle accumulators - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccum(n),rc=rc)) then - ! TODO: only write this out if actually have done accumulation - !write(tmpstr,*) subname,' nx,ny = ',trim(compname(n)),nx,ny - !call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call med_io_write(restart_file, iam, is_local%wrap%FBExpAccum(n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'ExpAccum', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + ! Write export accumulation to ocn + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccumOcn)) then + nx = is_local%wrap%nx(compocn) + ny = is_local%wrap%ny(compocn) + call med_io_write(restart_file, is_local%wrap%FBExpAccumOcn, whead(m), wdata(m), nx, ny, & + nt=1, pre='ocnExpAccum', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_write(restart_file, is_local%wrap%ExpAccumOcnCnt, 'ocnExpAccum_cnt', whead(m), wdata(m), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - ! Write import field bundle accumulators - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBImpAccum(n,n),rc=rc)) then - ! TODO: only write this out if actually have done accumulation - !write(tmpstr,*) subname,' nx,ny = ',trim(compname(n)),nx,ny - !call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call med_io_write(restart_file, iam, is_local%wrap%FBImpAccum(n,n), & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'ImpAccum', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + ! Write accumulation from lnd to rof if lnd->rof coupling is on + if (ESMF_FieldBundleIsCreated(FBlndAccum2rof_l)) then + nx = is_local%wrap%nx(complnd) + ny = is_local%wrap%ny(complnd) + call med_io_write(restart_file, FBlndAccum2rof_l, whead(m), wdata(m), nx, ny, & + nt=1, pre='lndImpAccum2rof', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_write(restart_file, lndAccum2rof_cnt, 'lndImpAccum2rof_cnt', whead(m), wdata(m), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - endif - enddo + ! Write accumulation from lnd to glc if lnd->glc coupling is on + if (ESMF_FieldBundleIsCreated(FBlndAccum2glc_l)) then + nx = is_local%wrap%nx(complnd) + ny = is_local%wrap%ny(complnd) + call med_io_write(restart_file, FBlndAccum2glc_l, whead(m), wdata(m), nx, ny, & + nt=1, pre='lndImpAccum2glc', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_write(restart_file, lndAccum2glc_cnt, 'lndImpAccum2glc_cnt', whead(m), wdata(m), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + ! Write accumulation from ocn to glc if ocn->glc coupling is on + if (ESMF_FieldBundleIsCreated(FBocnAccum2glc_o)) then + nx = is_local%wrap%nx(compocn) + ny = is_local%wrap%ny(compocn) + call med_io_write(restart_file, FBocnAccum2glc_o, whead(m), wdata(m), nx, ny, & + nt=1, pre='ocnImpAccum2glc_o', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_write(restart_file, ocnAccum2glc_cnt, 'ocnImpAccum2glc_cnt', whead(m), wdata(m), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if ! Write ocn albedo field bundle (CESM only) if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_o,rc=rc)) then nx = is_local%wrap%nx(compocn) ny = is_local%wrap%ny(compocn) - call med_io_write(restart_file, iam, is_local%wrap%FBMed_ocnalb_o, & - nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='MedOcnAlb_o', rc=rc) + call med_io_write(restart_file, is_local%wrap%FBMed_ocnalb_o, whead(m), wdata(m), nx, ny, & + nt=1, pre='MedOcnAlb_o', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - enddo + ! Write auxiliary files accumulation - + ! For now assume that any time averaged history file has only + ! one time sample - this will be generalized in the future + do nc = 2,ncomps + do nf = 1,auxcomp(nc)%num_auxfiles + if (auxcomp(nc)%files(nf)%doavg .and. auxcomp(nc)%files(nf)%accumcnt > 0) then + nx = is_local%wrap%nx(nc) + ny = is_local%wrap%ny(nc) + call med_io_write(restart_file, auxcomp(nc)%files(nf)%FBaccum, & + whead(m), wdata(m), nx, ny, & + nt=1, pre=trim(compname(nc))//trim(auxcomp(nc)%files(nf)%auxname), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_write(restart_file, auxcomp(nc)%files(nf)%accumcnt, & + trim(compname(nc))//trim(auxcomp(nc)%files(nf)%auxname)//'_accumcnt', & + whead(m), wdata(m), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end do + end do + + enddo ! end of whead/wdata loop ! Close file - call med_io_close(restart_file, iam, rc=rc) + call med_io_close(restart_file, vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------------- !--- clean up !--------------------------------------- - + lasttimewritten = currtime if (dbug_flag > 5) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) endif @@ -453,7 +462,6 @@ subroutine med_phases_restart_write(gcomp, rc) end subroutine med_phases_restart_write !=============================================================================== - subroutine med_phases_restart_read(gcomp, rc) ! Read mediator restart @@ -461,14 +469,14 @@ subroutine med_phases_restart_read(gcomp, rc) use ESMF , only : ESMF_GridComp, ESMF_VM, ESMF_Clock, ESMF_Time, ESMF_MAXSTR use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_VMBroadCast - use ESMF , only : ESMF_GridCompGet, ESMF_VMGet, ESMF_ClockGet, ESMF_ClockPrint + use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_ClockPrint use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_TimeGet use NUOPC , only : NUOPC_CompAttributeGet use med_io_mod , only : med_io_read ! Input/output variables - type(ESMF_GridComp) :: gcomp - integer, intent(out) :: rc + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc ! Local variables type(ESMF_VM) :: vm @@ -476,76 +484,56 @@ subroutine med_phases_restart_read(gcomp, rc) type(ESMF_Time) :: currtime character(len=CS) :: currtimestr type(InternalState) :: is_local - integer :: i,j,m,n,n1,ncnt + integer :: i,j,m,n integer :: ierr, unitn integer :: yr,mon,day,sec ! time units - integer :: iam ! vm stuff character(ESMF_MAXSTR) :: case_name ! case name character(ESMF_MAXSTR) :: restart_file ! Local path to restart filename character(ESMF_MAXSTR) :: restart_pfile ! Local path to restart pointer filename character(ESMF_MAXSTR) :: cpl_inst_tag ! instance tag logical :: isPresent - character(len=*), parameter :: sp_str = 'str_undefined' character(len=*), parameter :: subname='(med_phases_restart_read)' !--------------------------------------- call t_startf('MED:'//subname) call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) rc = ESMF_SUCCESS - !--------------------------------------- - ! --- 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 - 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 - + ! Get case name and inst suffix call NUOPC_CompAttributeGet(gcomp, name='case_name', value=case_name, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', isPresent=isPresent, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(isPresent) then + if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='inst_suffix', value=cpl_inst_tag, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return else cpl_inst_tag = "" endif - !--------------------------------------- - ! --- Get the clock info - !--------------------------------------- - + ! Get the clock info call ESMF_GridCompGet(gcomp, clock=clock) 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=yr, mm=mon, dd=day, s=sec, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') yr,'-',mon,'-',day,'-',sec if (dbug_flag > 1) then call ESMF_LogWrite(trim(subname)//": currtime = "//trim(currtimestr), ESMF_LOGMSG_INFO) endif - if (iam==0) 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 endif - !--------------------------------------- - ! --- Restart File - !--------------------------------------- - ! Get the restart file name from the pointer file - restart_pfile = "rpointer.cpl"//cpl_inst_tag - if (iam == 0) then + if (mastertask) then call ESMF_LogWrite(trim(subname)//" read rpointer file = "//trim(restart_pfile), ESMF_LOGMSG_INFO) open(newunit=unitn, file=restart_pfile, form='FORMATTED', status='old', iostat=ierr) if (ierr < 0) then @@ -562,54 +550,64 @@ subroutine med_phases_restart_read(gcomp, rc) close(unitn) call ESMF_LogWrite(trim(subname)//' restart file from rpointer = '//trim(restart_file), ESMF_LOGMSG_INFO) endif + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMBroadCast(vm, restart_file, len(restart_file), 0, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(trim(subname)//": read "//trim(restart_file), ESMF_LOGMSG_INFO) ! Now read in the restart file - - call med_io_read(restart_file, vm, iam, is_local%wrap%FBExpAccumCnt, dname='ExpAccumCnt', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_io_read(restart_file, vm, iam, is_local%wrap%FBImpAccumCnt, dname='ImpAccumCnt', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - do n = 1,ncomps if (is_local%wrap%comp_present(n)) then ! Read import field bundle if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(n,n),rc=rc)) then - call med_io_read(restart_file, vm, iam, is_local%wrap%FBimp(n,n), pre=trim(compname(n))//'Imp', rc=rc) + call med_io_read(restart_file, vm, is_local%wrap%FBimp(n,n), pre=trim(compname(n))//'Imp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - ! Read export field bundle if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExp(n),rc=rc)) then - call med_io_read(restart_file, vm, iam, is_local%wrap%FBexp(n), pre=trim(compname(n))//'Exp', rc=rc) + call med_io_read(restart_file, vm, is_local%wrap%FBexp(n), pre=trim(compname(n))//'Exp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - ! Read fraction field bundles if (ESMF_FieldBundleIsCreated(is_local%wrap%FBfrac(n),rc=rc)) then - call med_io_read(restart_file, vm, iam, is_local%wrap%FBfrac(n), pre=trim(compname(n))//'Frac', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - - ! Read export field bundle accumulator - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccum(n),rc=rc)) then - call med_io_read(restart_file, vm, iam, is_local%wrap%FBExpAccum(n), pre=trim(compname(n))//'ExpAccum', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - - ! Read import field bundle accumulator - if (ESMF_FieldBundleIsCreated(is_local%wrap%FBImpAccum(n,n),rc=rc)) then - call med_io_read(restart_file, vm, iam, is_local%wrap%FBImpAccum(n,n), pre=trim(compname(n))//'ImpAccum', rc=rc) + call med_io_read(restart_file, vm, is_local%wrap%FBfrac(n), pre=trim(compname(n))//'Frac', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif endif enddo + ! Read export field bundle accumulator + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccumOcn,rc=rc)) then + call med_io_read(restart_file, vm, is_local%wrap%FBExpAccumOcn, pre='ocnExpAccum', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_read(restart_file, vm, is_local%wrap%ExpAccumOcnCnt, 'ocnExpAccum_cnt', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + ! If lnd->rof, read accumulation from lnd to rof (CESM only) + if (ESMF_FieldBundleIsCreated(FBlndAccum2rof_l)) then + call med_io_read(restart_file, vm, FBlndAccum2rof_l, pre='lndImpAccum2rof', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_read(restart_file, vm, lndAccum2rof_cnt, 'lndImpAccum2rof_cnt', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + ! If lnd->glc, read accumulation from lnd to glc (CESM only) + if (ESMF_FieldBundleIsCreated(FBlndAccum2glc_l)) then + call med_io_read(restart_file, vm, FBlndAccum2glc_l, pre='lndImpAccum2glc', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_read(restart_file, vm, lndAccum2glc_cnt, 'lndImpAccum2glc_cnt', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + ! If ocn->glc, read accumulation from ocn to glc (CESM only) + if (ESMF_FieldBundleIsCreated(FBocnAccum2glc_o)) then + call med_io_read(restart_file, vm, FBocnAccum2glc_o, pre='ocnImpAccum2glc', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_read(restart_file, vm, ocnAccum2glc_cnt, 'ocnImpAccum2glc_cnt', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if ! Read ocn albedo field bundle (CESM only) if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_o,rc=rc)) then - call med_io_read(restart_file, vm, iam, is_local%wrap%FBMed_ocnalb_o, pre='MedOcnAlb_o', rc=rc) + call med_io_read(restart_file, vm, is_local%wrap%FBMed_ocnalb_o, pre='MedOcnAlb_o', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -623,7 +621,6 @@ subroutine med_phases_restart_read(gcomp, rc) end subroutine med_phases_restart_read !=============================================================================== - subroutine ymd2date(year,month,day,date) ! Converts year, month, day to coded-date ! NOTE: this calendar has a year zero (but no day or month zero) diff --git a/mediator/med_time_mod.F90 b/mediator/med_time_mod.F90 index 09dbaffb9..51e4db6e4 100644 --- a/mediator/med_time_mod.F90 +++ b/mediator/med_time_mod.F90 @@ -4,7 +4,7 @@ module med_time_mod use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSet use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockSet use ESMF , only : ESMF_ClockAdvance - use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmGet + use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmGet, ESMF_AlarmSet use ESMF , only : ESMF_Calendar, ESMF_CalKind_Flag, ESMF_CalendarCreate use ESMF , only : ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet @@ -15,9 +15,9 @@ module med_time_mod use ESMF , only : operator(<), operator(/=), operator(+) use ESMF , only : operator(-), operator(*) , operator(>=) use ESMF , only : operator(<=), operator(>), operator(==) - use NUOPC , only : NUOPC_CompAttributeGet 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 : mastertask, logunit implicit none private ! default private @@ -38,6 +38,7 @@ module med_time_mod optMonthly = "monthly" , & optYearly = "yearly" , & optDate = "date" , & + optEnd = "end" , & optGLCCouplingPeriod = "glc_coupling_period" ! Module data @@ -50,7 +51,7 @@ module med_time_mod !=============================================================================== subroutine med_time_alarmInit( clock, alarm, option, & - opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + opt_n, opt_ymd, opt_tod, reftime, alarmname, advance_clock, rc) ! Setup an alarm in a clock ! Notes: The ringtime sent to AlarmCreate MUST be the next alarm @@ -64,15 +65,16 @@ subroutine med_time_alarmInit( clock, alarm, option, & ! advance it properly based on the ring interval. ! input/output variables - type(ESMF_Clock) , intent(inout) :: clock ! clock - type(ESMF_Alarm) , intent(inout) :: alarm ! alarm - character(len=*) , intent(in) :: option ! alarm option - integer , optional , intent(in) :: opt_n ! alarm freq - integer , optional , intent(in) :: opt_ymd ! alarm ymd - integer , optional , intent(in) :: opt_tod ! alarm tod (sec) - type(ESMF_Time) , optional , intent(in) :: RefTime ! ref time - character(len=*) , optional , intent(in) :: alarmname ! alarm name - integer , intent(inout) :: rc ! Return code + type(ESMF_Clock) , intent(inout) :: clock ! clock + type(ESMF_Alarm) , intent(inout) :: alarm ! alarm + character(len=*) , intent(in) :: option ! alarm option + integer , optional , intent(in) :: opt_n ! alarm freq + integer , optional , intent(in) :: opt_ymd ! alarm ymd + integer , optional , intent(in) :: opt_tod ! alarm tod (sec) + type(ESMF_Time) , optional , intent(in) :: reftime ! reference time + character(len=*) , optional , intent(in) :: alarmname ! alarm name + logical , optional , intent(in) :: advance_clock ! advance clock to trigger alarm + integer , intent(out) :: rc ! Return code ! local variables type(ESMF_Calendar) :: cal ! calendar @@ -82,7 +84,7 @@ subroutine med_time_alarmInit( clock, alarm, option, & character(len=64) :: lalarmname ! local alarm name logical :: update_nextalarm ! update next alarm type(ESMF_Time) :: CurrTime ! Current Time - type(ESMF_Time) :: NextAlarm ! Next restart alarm time + type(ESMF_Time) :: NextAlarm ! Next alarm time type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval integer :: sec character(len=*), parameter :: subname = '(med_time_alarmInit): ' @@ -154,6 +156,20 @@ subroutine med_time_alarmInit( clock, alarm, option, & if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. + case (optNever) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optEnd) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + case (optDate) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -163,13 +179,6 @@ subroutine med_time_alarmInit( clock, alarm, option, & if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. - case (optNever) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. - case (optNSteps) call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -224,7 +233,6 @@ subroutine med_time_alarmInit( clock, alarm, option, & call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. - case default call ESMF_LogWrite(subname//'unknown option '//trim(option), ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE @@ -246,12 +254,32 @@ subroutine med_time_alarmInit( clock, alarm, option, & enddo endif + if (mastertask) then + write(logunit,*) + write(logunit,'(a)') trim(subname) //' creating alarm '// trim(lalarmname) + end if + alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & ringInterval=AlarmInterval, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Advance model clock to trigger alarm then reset model clock back to currtime + if (present(advance_clock)) then + if (advance_clock) then + call ESMF_AlarmSet(alarm, 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_ClockAdvance(clock,rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockSet(clock, currTime=currtime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + end subroutine med_time_alarmInit + !=============================================================================== subroutine med_time_date2ymd (date, year, month, day) ! input/output variables @@ -262,7 +290,6 @@ subroutine med_time_date2ymd (date, year, month, day) integer :: tdate ! temporary date character(*),parameter :: subName = "(med_time_date2ymd)" !------------------------------------------------------------------------------- - tdate = abs(date) year = int(tdate/10000) if (date < 0) then @@ -270,8 +297,6 @@ subroutine med_time_date2ymd (date, year, month, day) end if month = int( mod(tdate,10000)/ 100) day = mod(tdate, 100) - end subroutine med_time_date2ymd - !=============================================================================== end module med_time_mod diff --git a/nuopc_cap_share/nuopc_shr_methods.F90 b/nuopc_cap_share/nuopc_shr_methods.F90 index 8cbf91056..421606fd1 100644 --- a/nuopc_cap_share/nuopc_shr_methods.F90 +++ b/nuopc_cap_share/nuopc_shr_methods.F90 @@ -60,8 +60,10 @@ module nuopc_shr_methods optNYear = "nyear" , & optMonthly = "monthly" , & optYearly = "yearly" , & + optEnd = "end" , & optDate = "date" + ! Module data integer, parameter :: SecPerDay = 86400 ! Seconds per day integer, parameter :: memdebug_level=1 @@ -558,6 +560,13 @@ subroutine alarmInit( clock, alarm, option, & if (chkerr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. + case (optEnd) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + case (optDate) if (.not. present(opt_ymd)) then call shr_sys_abort(subname//trim(option)//' requires opt_ymd') @@ -747,7 +756,7 @@ subroutine alarmInit( clock, alarm, option, & call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) if (chkerr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .true. - + case default call shr_sys_abort(subname//'unknown option '//trim(option)) @@ -766,7 +775,6 @@ subroutine alarmInit( clock, alarm, option, & NextAlarm = NextAlarm + AlarmInterval enddo endif - alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & ringInterval=AlarmInterval, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return From 16364c255a203d77e9d58a510b7f5880c10dccf9 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Fri, 29 Oct 2021 12:32:44 -0600 Subject: [PATCH 05/31] add more wav coupling fields --- mediator/esmFldsExchange_nems_mod.F90 | 34 ++++++++++++++++++++++++--- mediator/med_map_mod.F90 | 26 ++++++++++++++++---- 2 files changed, 52 insertions(+), 8 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 81de079f2..8dfd899e3 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -363,18 +363,46 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) !===================================================================== ! to wav - 10m winds from atm - allocate(flds(2)) - flds = (/'Sa_u10m', 'Sa_v10m'/) + allocate(flds(3)) + flds = (/'Sa_u10m', 'Sa_v10m', 'Sa_tbot'/) do n = 1,size(flds) fldname = trim(flds(n)) call addfld(fldListFr(compatm)%flds, trim(fldname)) call addfld(fldListTo(compwav)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, maptype, 'one', 'unset') + !call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, maptype, 'one', 'unset') + call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') end do deallocate(flds) + ! to wav: sea ice fraction + allocate(flds(1)) + flds = (/'Si_ifrac'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + call addfld(fldListFr(compice)%flds, trim(fldname)) + !call addmap(fldListFr(compice)%flds, trim(fldname), compice, maptype , 'unset', 'unset') + call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapnstod_consf , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + + ! to wav: zonal sea water velocity from ocn + ! to wav: meridional sea water velocity from ocn + allocate(flds(3)) + flds = (/'So_u', 'So_v', 'So_t'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + call addfld(fldListFr(compocn)%flds, trim(fldname)) + !call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, maptype , 'unset', 'unset') + call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapnstod_consf , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + end subroutine esmFldsExchange_nems end module esmFldsExchange_nems_mod diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 41b1931f2..2d0183d50 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -325,7 +325,7 @@ end subroutine med_map_routehandles_initfrom_fieldbundle subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, routehandles, mapfile, rc) use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandlePrint, ESMF_Field, ESMF_MAXSTR - use ESMF , only : ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG + use ESMF , only : ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG, ESMF_POLEMETHOD_NONE use ESMF , only : ESMF_FieldSMMStore, ESMF_FieldRedistStore, ESMF_FieldRegridStore use ESMF , only : ESMF_RouteHandleIsCreated, ESMF_RouteHandleCreate use ESMF , only : ESMF_REGRIDMETHOD_BILINEAR, ESMF_REGRIDMETHOD_PATCH @@ -368,7 +368,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, integer :: ns integer(I4), pointer :: dof(:) integer :: srcTermProcessing_Value = 0 - type(ESMF_PoleMethod_Flag), parameter :: polemethod=ESMF_POLEMETHOD_ALLAVG + type(ESMF_PoleMethod_Flag) :: polemethod character(len=*), parameter :: subname=' (module_med_map: med_map_routehandles_initfrom_field) ' !--------------------------------------------- @@ -388,24 +388,38 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, ! set local flag to false ldstprint = .false. + polemethod=ESMF_POLEMETHOD_ALLAVG if (trim(coupling_mode) == 'cesm') then dstMaskValue = ispval_mask srcMaskValue = ispval_mask if (n1 == compocn .or. n1 == compice) srcMaskValue = 0 if (n2 == compocn .or. n2 == compice) dstMaskValue = 0 + if (n1 == compwav .and. n2 == compocn) then + srcMaskValue = 0 + dstMaskValue = ispval_mask + endif + if (n1 == compwav .or. n2 == compwav) then + polemethod = ESMF_POLEMETHOD_NONE ! todo: remove this when ESMF tripolar mapping fix is in place. + endif else if (coupling_mode(1:4) == 'nems') then - if (n1 == compatm .and. (n2 == compocn .or. n2 == compice)) then + if (n1 == compatm .and. (n2 == compocn .or. n2 == compice .or. n2 == compwav)) then srcMaskValue = 1 dstMaskValue = 0 if (atm_name(1:4).eq.'datm') then srcMaskValue = 0 endif - else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice)) then + else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice .or. n1 == compwav)) then srcMaskValue = 0 dstMaskValue = 1 else if ((n1 == compocn .and. n2 == compice) .or. (n1 == compice .and. n2 == compocn)) then srcMaskValue = 0 dstMaskValue = 0 + else if ((n1 == compocn .and. n2 == compwav) .or. (n1 == compice .and. n2 == compwav)) then + srcMaskValue = 0 + dstMaskValue = 0 + else if ((n1 == compwav .and. n2 == compocn) .or. (n1 == compwav .and. n2 == compice)) then + srcMaskValue = 0 + dstMaskValue = 0 else ! TODO: what should the condition be here? dstMaskValue = ispval_mask @@ -432,7 +446,9 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, endif end if - write(string,'(a)') trim(compname(n1))//' to '//trim(compname(n2)) + write(string,'(a,i4,a,i4)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & + srcMaskValue,' dstMask = ',dstMaskValue + call ESMF_LogWrite(trim(string), ESMF_LOGMSG_INFO) ! Create route handle if (mapindex == mapfcopy) then From fff8fbc0ba7750981c1449267a9a347aa918ced1 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Fri, 29 Oct 2021 12:34:25 -0600 Subject: [PATCH 06/31] change mapping for z0 --- mediator/esmFldsExchange_nems_mod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 8dfd899e3..7f186a794 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -162,7 +162,8 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to atm: surface roughness length from wav call addfld(fldListFr(compwav)%flds, 'Sw_z0') call addfld(fldListTo(compatm)%flds, 'Sw_z0') - call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, maptype, 'wfrac', 'unset') + !call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, maptype, 'wfrac', 'unset') + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'wfrac', 'unset') call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') !===================================================================== ! FIELDS TO OCEAN (compocn) From 8be8da038f2a71c38e9dbc211970e78f94182fba Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sat, 30 Oct 2021 09:39:39 -0600 Subject: [PATCH 07/31] add -> wav in post atm and post ocn --- mediator/med_phases_post_atm_mod.F90 | 15 ++++++++++++++- mediator/med_phases_post_ocn_mod.F90 | 15 ++++++++++++++- 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index acf1c2298..1a059e714 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -32,7 +32,7 @@ subroutine med_phases_post_atm(gcomp, rc) use med_map_mod , only : med_map_field_packed use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_utils_mod , only : chkerr => med_utils_ChkErr - use esmFlds , only : compocn, compatm, compice, complnd + use esmFlds , only : compocn, compatm, compice, complnd, compwav use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -96,6 +96,19 @@ subroutine med_phases_post_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_atm2lnd') end if + ! map atm->wav + if (is_local%wrap%med_coupling_active(compatm,compwav)) then + call t_startf('MED:'//trim(subname)//' map_atm2wav') + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(compatm,compatm), & + FBDst=is_local%wrap%FBImp(compatm,compwav), & + FBFracSrc=is_local%wrap%FBFrac(compatm), & + field_normOne=is_local%wrap%field_normOne(compatm,compwav,:), & + packed_data=is_local%wrap%packed_data(compatm,compwav,:), & + routehandles=is_local%wrap%RH(compatm,compwav,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf('MED:'//trim(subname)//' map_atm2wav') + end if ! Write atm inst, avg or aux if requested in mediator attributes call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index c51f9eecf..78609d459 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -31,7 +31,7 @@ subroutine med_phases_post_ocn(gcomp, rc) use med_internalstate_mod , only : InternalState, logunit, mastertask use med_phases_history_mod , only : med_phases_history_write_comp use med_phases_prep_glc_mod , only : med_phases_prep_glc_accum_ocn - use esmFlds , only : compice, compglc, compocn, num_icesheets + use esmFlds , only : compice, compglc, compocn, compwav, num_icesheets use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -71,6 +71,19 @@ subroutine med_phases_post_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_ocn2ice') end if + ! Map ocn->wav + if (is_local%wrap%med_coupling_active(compocn,compwav)) then + call t_startf('MED:'//trim(subname)//' map_ocn2wav') + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(compocn,compocn), & + FBDst=is_local%wrap%FBImp(compocn,compwav), & + FBFracSrc=is_local%wrap%FBFrac(compocn), & + field_normOne=is_local%wrap%field_normOne(compocn,compwav,:), & + packed_data=is_local%wrap%packed_data(compocn,compwav,:), & + routehandles=is_local%wrap%RH(compocn,compwav,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf('MED:'//trim(subname)//' map_ocn2wav') + end if ! Accumulate ocn input for glc if there is ocn->glc coupling if (first_call) then From 8ec7328df766444299ee28a7b403a2818fdcbb0e Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sat, 30 Oct 2021 10:21:46 -0600 Subject: [PATCH 08/31] add unity norm for wave * this is running but not sure of right setting here --- mediator/esmFldsExchange_nems_mod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 7f186a794..883baed04 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -163,7 +163,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addfld(fldListFr(compwav)%flds, 'Sw_z0') call addfld(fldListTo(compatm)%flds, 'Sw_z0') !call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, maptype, 'wfrac', 'unset') - call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'wfrac', 'unset') + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') !===================================================================== ! FIELDS TO OCEAN (compocn) @@ -385,7 +385,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addfld(fldListTo(compwav)%flds, trim(fldname)) call addfld(fldListFr(compice)%flds, trim(fldname)) !call addmap(fldListFr(compice)%flds, trim(fldname), compice, maptype , 'unset', 'unset') - call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapnstod_consf , 'unset', 'unset') + call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapnstod_consf , 'one', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') end do deallocate(flds) @@ -399,7 +399,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addfld(fldListTo(compwav)%flds, trim(fldname)) call addfld(fldListFr(compocn)%flds, trim(fldname)) !call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, maptype , 'unset', 'unset') - call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapnstod_consf , 'unset', 'unset') + call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapnstod_consf , 'one', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') end do deallocate(flds) From 6b599262d1c22f95b6f87eca3279a1a11ab3bbc4 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Fri, 12 Nov 2021 06:22:27 -0700 Subject: [PATCH 09/31] current tested changes for wave coupling --- mediator/esmFldsExchange_nems_mod.F90 | 3 --- mediator/med_map_mod.F90 | 2 +- mediator/med_phases_post_atm_mod.F90 | 24 ++++++++++++------------ mediator/med_phases_post_ocn_mod.F90 | 24 ++++++++++++------------ mediator/med_phases_prep_wav_mod.F90 | 1 + 5 files changed, 26 insertions(+), 28 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 883baed04..7cf3bf5aa 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -371,7 +371,6 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListFr(compatm)%flds, trim(fldname)) call addfld(fldListTo(compwav)%flds, trim(fldname)) - !call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, maptype, 'one', 'unset') call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') end do @@ -384,7 +383,6 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListTo(compwav)%flds, trim(fldname)) call addfld(fldListFr(compice)%flds, trim(fldname)) - !call addmap(fldListFr(compice)%flds, trim(fldname), compice, maptype , 'unset', 'unset') call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapnstod_consf , 'one', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') end do @@ -398,7 +396,6 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListTo(compwav)%flds, trim(fldname)) call addfld(fldListFr(compocn)%flds, trim(fldname)) - !call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, maptype , 'unset', 'unset') call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapnstod_consf , 'one', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') end do diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 2d0183d50..d4607d8e0 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -83,7 +83,7 @@ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogun use ESMF , only : ESMF_Mesh, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT use med_methods_mod , only : med_methods_FB_getFieldN, med_methods_FB_getNameN use med_constants_mod , only : czero => med_constants_czero - use esmFlds , only : fldListFr, ncomps, mapunset, compname, compocn, compatm + use esmFlds , only : fldListFr, ncomps, mapunset, compocn, compatm use esmFlds , only : ncomps, nmappers, compname, mapnames, mapfcopy ! input/output variables diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index 1a059e714..b2e7f15c0 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -97,18 +97,18 @@ subroutine med_phases_post_atm(gcomp, rc) call t_stopf('MED:'//trim(subname)//' map_atm2lnd') end if ! map atm->wav - if (is_local%wrap%med_coupling_active(compatm,compwav)) then - call t_startf('MED:'//trim(subname)//' map_atm2wav') - call med_map_field_packed( & - FBSrc=is_local%wrap%FBImp(compatm,compatm), & - FBDst=is_local%wrap%FBImp(compatm,compwav), & - FBFracSrc=is_local%wrap%FBFrac(compatm), & - field_normOne=is_local%wrap%field_normOne(compatm,compwav,:), & - packed_data=is_local%wrap%packed_data(compatm,compwav,:), & - routehandles=is_local%wrap%RH(compatm,compwav,:), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call t_stopf('MED:'//trim(subname)//' map_atm2wav') - end if + !if (is_local%wrap%med_coupling_active(compatm,compwav)) then + ! call t_startf('MED:'//trim(subname)//' map_atm2wav') + ! call med_map_field_packed( & + ! FBSrc=is_local%wrap%FBImp(compatm,compatm), & + ! FBDst=is_local%wrap%FBImp(compatm,compwav), & + ! FBFracSrc=is_local%wrap%FBFrac(compatm), & + ! field_normOne=is_local%wrap%field_normOne(compatm,compwav,:), & + ! packed_data=is_local%wrap%packed_data(compatm,compwav,:), & + ! routehandles=is_local%wrap%RH(compatm,compwav,:), rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! call t_stopf('MED:'//trim(subname)//' map_atm2wav') + !end if ! Write atm inst, avg or aux if requested in mediator attributes call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index 78609d459..4fc82cbdb 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -72,18 +72,18 @@ subroutine med_phases_post_ocn(gcomp, rc) call t_stopf('MED:'//trim(subname)//' map_ocn2ice') end if ! Map ocn->wav - if (is_local%wrap%med_coupling_active(compocn,compwav)) then - call t_startf('MED:'//trim(subname)//' map_ocn2wav') - call med_map_field_packed( & - FBSrc=is_local%wrap%FBImp(compocn,compocn), & - FBDst=is_local%wrap%FBImp(compocn,compwav), & - FBFracSrc=is_local%wrap%FBFrac(compocn), & - field_normOne=is_local%wrap%field_normOne(compocn,compwav,:), & - packed_data=is_local%wrap%packed_data(compocn,compwav,:), & - routehandles=is_local%wrap%RH(compocn,compwav,:), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call t_stopf('MED:'//trim(subname)//' map_ocn2wav') - end if + ! if (is_local%wrap%med_coupling_active(compocn,compwav)) then + ! call t_startf('MED:'//trim(subname)//' map_ocn2wav') + ! call med_map_field_packed( & + ! FBSrc=is_local%wrap%FBImp(compocn,compocn), & + ! FBDst=is_local%wrap%FBImp(compocn,compwav), & + ! FBFracSrc=is_local%wrap%FBFrac(compocn), & + ! field_normOne=is_local%wrap%field_normOne(compocn,compwav,:), & + ! packed_data=is_local%wrap%packed_data(compocn,compwav,:), & + ! routehandles=is_local%wrap%RH(compocn,compwav,:), rc=rc) + ! if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! call t_stopf('MED:'//trim(subname)//' map_ocn2wav') + ! end if ! Accumulate ocn input for glc if there is ocn->glc coupling if (first_call) then diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 8ff29e432..14153a16e 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -68,6 +68,7 @@ subroutine med_phases_prep_wav(gcomp, rc) ! map to create FBimp(:,compwav) do n1 = 1,ncomps if (is_local%wrap%med_coupling_active(n1,compwav)) then + call ESMF_LogWrite(trim(subname)//": "//compname(n1)//" to "//compname(compwav), ESMF_LOGMSG_INFO) call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(n1,n1), & FBDst=is_local%wrap%FBImp(n1,compwav), & From 7a44b63d586f7e38898d003b28a2e14a286a86ca Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sun, 14 Nov 2021 06:02:31 -0700 Subject: [PATCH 10/31] fix merge of stokes to ocn --- mediator/esmFldsExchange_nems_mod.F90 | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 7cf3bf5aa..29029623b 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -165,6 +165,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) !call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, maptype, 'wfrac', 'unset') call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + !===================================================================== ! FIELDS TO OCEAN (compocn) !===================================================================== @@ -297,6 +298,19 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end do deallocate(flds) + ! to ocn: partitioned stokes drift from wav + allocate(flds(6)) + flds = (/'Sw_ustokes1', 'Sw_ustokes2', 'Sw_ustokes3', & + 'Sw_vstokes1', 'Sw_vstokes2', 'Sw_vstokes3'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListTo(compocn)%flds, trim(fldname)) + call addfld(fldListFr(compwav)%flds, trim(fldname)) + call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + !===================================================================== ! FIELDS TO ICE (compice) !===================================================================== @@ -383,7 +397,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListTo(compwav)%flds, trim(fldname)) call addfld(fldListFr(compice)%flds, trim(fldname)) - call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapnstod_consf , 'one', 'unset') + call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') end do deallocate(flds) @@ -396,7 +410,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListTo(compwav)%flds, trim(fldname)) call addfld(fldListFr(compocn)%flds, trim(fldname)) - call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapnstod_consf , 'one', 'unset') + call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') end do deallocate(flds) From 8b117b4bc9fae268f362577170b218dbb4398390 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 16 Dec 2021 08:01:16 -0500 Subject: [PATCH 11/31] Update CMEPS (#60) * moved files into ufs * implemented different interface for ufs flux_atmocn_mod * add compile fixes for ufs * removed reference to util and replaced with ufs * clean up of Makefile * removed references to use of med_kind_mod and introduced ufs_kind_mod * removed unneeded files needed by ufs * Optional tiled history files for ATM (#257) --- .github/workflows/srt.yml | 153 ++ CMakeLists.txt | 4 +- Makefile | 77 - .../cime => cesm/driver}/ensemble_driver.F90 | 0 {drivers/cime => cesm/driver}/esm.F90 | 0 {drivers/cime => cesm/driver}/esmApp.F90 | 0 .../cime => cesm/driver}/esm_time_mod.F90 | 0 .../cime => cesm/driver}/esm_utils_mod.F90 | 0 .../driver}/t_driver_timers_mod.F90 | 0 {drivers/cime => cesm/driver}/util.F90 | 0 cesm/flux_atmocn/shr_flux_mod.F90 | 2299 +++++++++++++++++ cesm/nuopc_cap_share/glc_elevclass_mod.F90 | 569 ++++ .../nuopc_cap_share}/nuopc_shr_methods.F90 | 0 cesm/nuopc_cap_share/seq_drydep_mod.F90 | 1220 +++++++++ cesm/nuopc_cap_share/shr_carma_mod.F90 | 76 + cesm/nuopc_cap_share/shr_expr_parser_mod.F90 | 185 ++ cesm/nuopc_cap_share/shr_fire_emis_mod.F90 | 297 +++ cesm/nuopc_cap_share/shr_megan_mod.F90 | 310 +++ cesm/nuopc_cap_share/shr_ndep_mod.F90 | 106 + .../shr_ozone_coupling_mod.F90 | 124 + cime_config/buildexe | 3 +- cime_config/buildnml | 3 +- cime_config/namelist_definition_drv.xml | 31 +- mediator/CMakeLists.txt | 2 +- mediator/esmFldsExchange_cesm_mod.F90 | 36 +- mediator/fd_cesm.yaml | 7 + mediator/med.F90 | 22 +- mediator/med_constants_mod.F90 | 5 + mediator/med_diag_mod.F90 | 572 ++-- mediator/med_io_mod.F90 | 71 +- mediator/med_map_mod.F90 | 14 +- mediator/med_phases_aofluxes_mod.F90 | 46 +- mediator/med_phases_history_mod.F90 | 66 +- mediator/med_phases_ocnalb_mod.F90 | 2 +- mediator/med_phases_post_glc_mod.F90 | 53 +- mediator/med_phases_prep_glc_mod.F90 | 280 +- mediator/med_phases_profile_mod.F90 | 6 +- mediator/med_phases_restart_mod.F90 | 2 +- ufs/CMakeLists.txt | 6 + .../flux_atmocn_mod.F90 | 111 +- {util => ufs}/glc_elevclass_mod.F90 | 4 +- {util => ufs}/perf_mod.F90 | 0 .../ufs_const_mod.F90 | 11 +- util/shr_kind_mod.F90 => ufs/ufs_kind_mod.F90 | 4 +- util/CMakeLists.txt | 7 - util/Makefile | 50 - util/dtypes.h | 5 - util/genf90.pl | 387 --- util/shr_abort_mod.F90 | 164 -- util/shr_log_mod.F90 | 26 - util/shr_mem_mod.F90 | 17 - util/shr_mpi_mod.F90 | 2217 ---------------- util/shr_sys_mod.F90 | 320 --- 53 files changed, 6185 insertions(+), 3785 deletions(-) create mode 100644 .github/workflows/srt.yml delete mode 100644 Makefile rename {drivers/cime => cesm/driver}/ensemble_driver.F90 (100%) rename {drivers/cime => cesm/driver}/esm.F90 (100%) rename {drivers/cime => cesm/driver}/esmApp.F90 (100%) rename {drivers/cime => cesm/driver}/esm_time_mod.F90 (100%) rename {drivers/cime => cesm/driver}/esm_utils_mod.F90 (100%) rename {drivers/cime => cesm/driver}/t_driver_timers_mod.F90 (100%) rename {drivers/cime => cesm/driver}/util.F90 (100%) create mode 100644 cesm/flux_atmocn/shr_flux_mod.F90 create mode 100644 cesm/nuopc_cap_share/glc_elevclass_mod.F90 rename {nuopc_cap_share => cesm/nuopc_cap_share}/nuopc_shr_methods.F90 (100%) create mode 100644 cesm/nuopc_cap_share/seq_drydep_mod.F90 create mode 100644 cesm/nuopc_cap_share/shr_carma_mod.F90 create mode 100644 cesm/nuopc_cap_share/shr_expr_parser_mod.F90 create mode 100644 cesm/nuopc_cap_share/shr_fire_emis_mod.F90 create mode 100644 cesm/nuopc_cap_share/shr_megan_mod.F90 create mode 100644 cesm/nuopc_cap_share/shr_ndep_mod.F90 create mode 100644 cesm/nuopc_cap_share/shr_ozone_coupling_mod.F90 create mode 100644 ufs/CMakeLists.txt rename util/shr_flux_mod.F90 => ufs/flux_atmocn_mod.F90 (75%) rename {util => ufs}/glc_elevclass_mod.F90 (97%) rename {util => ufs}/perf_mod.F90 (100%) rename util/shr_const_mod.F90 => ufs/ufs_const_mod.F90 (93%) rename util/shr_kind_mod.F90 => ufs/ufs_kind_mod.F90 (95%) delete mode 100644 util/CMakeLists.txt delete mode 100644 util/Makefile delete mode 100644 util/dtypes.h delete mode 100755 util/genf90.pl delete mode 100644 util/shr_abort_mod.F90 delete mode 100644 util/shr_log_mod.F90 delete mode 100644 util/shr_mem_mod.F90 delete mode 100644 util/shr_mpi_mod.F90 delete mode 100644 util/shr_sys_mod.F90 diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml new file mode 100644 index 000000000..74859525d --- /dev/null +++ b/.github/workflows/srt.yml @@ -0,0 +1,153 @@ +# CIME scripts regression tests + +name: scripts regression tests + +# Controls when the action will run. Triggers the workflow on push or pull request +# events but only for the master branch +on: + push: + branches: main + pull_request: + branches: main + +# A workflow run is made up of one or more jobs that can run sequentially or in parallel +jobs: + # This workflow contains a single job called "build" + build: + # The type of runner that the job will run on + runs-on: ubuntu-latest + strategy: + matrix: + python-version: [3.8, 3.9] + env: + CC: mpicc + FC: mpifort + CXX: mpicxx + CPPFLAGS: "-I/usr/include -I/usr/local/include" + # Versions of all dependencies can be updated here + PNETCDF_VERSION: pnetcdf-1.12.2 + NETCDF_FORTRAN_VERSION: v4.5.2 + MCT_VERSION: MCT_2.11.0 + PARALLELIO_VERSION: pio2_5_4 + NETCDF_C_PATH: /usr + NETCDF_FORTRAN_PATH: ${HOME}/netcdf-fortran + PNETCDF_PATH: ${HOME}/pnetcdf + CIME_MODEL: cesm + CIME_DRIVER: mct + + # Steps represent a sequence of tasks that will be executed as part of the job + steps: + # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it + + - name: cime checkout + uses: actions/checkout@v2 + with: + repository: ESMCI/cime + + - name: share checkout + uses: actions/checkout@v2 + with: + repository: ESCOMP/CESM_share + path: share + + - name: cpl7 checkout + uses: actions/checkout@v2 + with: + repository: ESCOMP/CESM_CPL7andDataComps + path: components/cpl7 + + - id: load-env + run: | + sudo apt-get update + sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev + + - name: Set up Python ${{ matrix.python-version }} + uses: actions/setup-python@v2 + with: + python-version: ${{ matrix.python-version }} + + - name: mct install + run: | + git clone -b ${{ env.MCT_VERSION }} https://github.com/MCSclimate/MCT libraries/mct + ls -l libraries/mct + + - name: parallelio install + run: | + git clone -b ${{ env.PARALLELIO_VERSION }} https://github.com/NCAR/ParallelIO libraries/parallelio + ls -l libraries/parallelio + + - name: cache pnetcdf + id: cache-pnetcdf + uses: actions/cache@v2 + with: + path: ~/pnetcdf + key: ${{ runner.os }}-${{ env.PNETCDF_VERSION}}-pnetcdf-redo + + - name: pnetcdf build + if: steps.cache-pnetcdf.outputs.cache-hit != 'true' + run: | + wget https://parallel-netcdf.github.io/Release/${{ env.PNETCDF_VERSION }}.tar.gz + tar -xzvf ${{ env.PNETCDF_VERSION }}.tar.gz + ls -l + pushd ${{ env.PNETCDF_VERSION }} + ./configure --prefix=$HOME/pnetcdf --enable-shared --disable-cxx + make + make install + popd + + - name: Cache netcdf-fortran + id: cache-netcdf-fortran + uses: actions/cache@v2 + with: + path: ~/netcdf-fortran + key: ${{ runner.os }}-${{ env.NETCDF_FORTRAN_VERSION }}-netcdf-fortran-redo + + - name: netcdf fortran build + if: steps.cache-netcdf-fortran.outputs.cache-hit != 'true' + run: | + sudo apt-get install libnetcdf-dev + wget https://github.com/Unidata/netcdf-fortran/archive/${{ env.NETCDF_FORTRAN_VERSION }}.tar.gz + tar -xzvf ${{ env.NETCDF_FORTRAN_VERSION }}.tar.gz + ls -l + pushd netcdf-fortran-* + ./configure --prefix=$HOME/netcdf-fortran + make + make install + + - name: link netcdf-c to netcdf-fortran path + # link netcdf c library here to simplify build + run: | + pushd ${{ env.NETCDF_FORTRAN_PATH }}/include + ln -fs /usr/include/*netcdf* . + pushd ${{ env.NETCDF_FORTRAN_PATH }}/lib + clibdir=`nc-config --libdir` + ln -fs $clibdir/lib* . + + - name: Cache inputdata + id: cache-inputdata + uses: actions/cache@v2 + with: + path: $HOME/cesm/inputdata + key: inputdata +# +# The following can be used to ssh to the testnode for debugging +# see https://github.com/mxschmitt/action-tmate for details +# - name: Setup tmate session +# uses: mxschmitt/action-tmate@v3 + + - name: scripts regression tests + run: | + mkdir -p $HOME/cesm/scratch + mkdir -p $HOME/cesm/inputdata + cd $HOME/work/CESM_share/CESM_share/scripts/tests + ls -l $HOME/work/CESM_share/CESM_share + export NETCDF=$HOME/netcdf-fortran + export PATH=$NETCDF/bin:$PATH + export LD_LIBRARY_PATH=$NETCDF/lib:$HOME/pnetcdf/lib:$LD_LIBRARY_PATH + ./scripts_regression_tests.py --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest + +# the following can be used by developers to login to the github server in case of errors +# see https://github.com/marketplace/actions/debugging-with-tmate for further details +# - name: Setup tmate session +# if: ${{ failure() }} +# uses: mxschmitt/action-tmate@v3 diff --git a/CMakeLists.txt b/CMakeLists.txt index 363e2077a..70172df11 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -40,9 +40,9 @@ if (NOT DEFINED MPILIB OR NOT ${MPILIB} STREQUAL "mpi-serial") endif() if(BLD_STANDALONE) - add_subdirectory(util) + add_subdirectory(ufs) list(APPEND EXTRA_LIBS cmeps_share) - list(APPEND EXTRA_INCLUDES "${CMAKE_BINARY_DIR}/util") + list(APPEND EXTRA_INCLUDES "${CMAKE_BINARY_DIR}/ufs") endif() add_subdirectory(mediator) diff --git a/Makefile b/Makefile deleted file mode 100644 index 60e46b200..000000000 --- a/Makefile +++ /dev/null @@ -1,77 +0,0 @@ -# BASE_DIR points to root of CMEPS clone -BASE_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) - -ifneq ($(origin ESMFMKFILE), environment) -$(error Environment variable ESMFMKFILE was not set.) -endif - -include $(ESMFMKFILE) - -ifndef FC -$(error FC not defined) -endif - -ifndef CC -$(error CC not defined) -endif - -ifndef CXX -$(error CXX not defined) -endif - -ifndef PIO_LIBDIR -$(error PIO_LIBDIR should point to PIO library directory.) -endif - -ifndef PIO_INC -$(error PIO_INC should point to PIO include directory.) -endif - -ifndef INTERNAL_PIO_INIT -INTERNAL_PIO_INIT := 1 -endif -$(info INTERNAL_PIO_INIT is set to $(INTERNAL_PIO_INIT)) - -MEDIATOR_DIR := $(BASE_DIR)/mediator -LIBRARY_MEDIATOR := $(MEDIATOR_DIR)/libcmeps.a -LIBRARY_UTIL := $(BASE_DIR)/util/libcmeps_util.a - -all default: install - -install: $(LIBRARY_MEDIATOR) -ifndef INSTALLDIR - $(error INSTALLDIR not defined for CMEPS installation location) -else - rm -f cmeps.mk.install - @echo "# ESMF self-describing build dependency makefile fragment" > cmeps.mk.install - @echo "# src location: $(PWD)" >> cmeps.mk.install - @echo >> cmeps.mk.install - @echo "ESMF_DEP_FRONT = MED" >> cmeps.mk.install - @echo "ESMF_DEP_INCPATH = $(INSTALLDIR)/include" >> cmeps.mk.install - @echo "ESMF_DEP_CMPL_OBJS = " >> cmeps.mk.install - @echo "ESMF_DEP_LINK_OBJS = $(INSTALLDIR)/libcmeps.a $(INSTALLDIR)/libcmeps_util.a $(PIO_LIBDIR)/libpiof.a $(PIO_LIBDIR)/libpioc.a $(PNETCDF_LD_OPTS)" >> cmeps.mk.install - mkdir -p $(INSTALLDIR) - mkdir -p $(INSTALLDIR)/include - cp -f $(LIBRARY_UTIL) $(INSTALLDIR) - cp -f $(LIBRARY_MEDIATOR) $(INSTALLDIR) - cp -f mediator/*.mod $(INSTALLDIR)/include - cp -f util/*.mod $(INSTALLDIR)/include - cp -f cmeps.mk.install $(INSTALLDIR)/cmeps.mk -endif - -$(LIBRARY_MEDIATOR): $(LIBRARY_UTIL) .FORCE - cd mediator ;\ - exec $(MAKE) PIO_INC=$(PIO_INC) INTERNAL_PIO_INIT=$(INTERNAL_PIO_INIT) - -$(LIBRARY_UTIL): .FORCE - cd util ;\ - exec $(MAKE) PIO_INC=$(PIO_INC) - -.FORCE: - -clean: - cd mediator; \ - exec $(MAKE) clean - cd util; \ - exec $(MAKE) clean - diff --git a/drivers/cime/ensemble_driver.F90 b/cesm/driver/ensemble_driver.F90 similarity index 100% rename from drivers/cime/ensemble_driver.F90 rename to cesm/driver/ensemble_driver.F90 diff --git a/drivers/cime/esm.F90 b/cesm/driver/esm.F90 similarity index 100% rename from drivers/cime/esm.F90 rename to cesm/driver/esm.F90 diff --git a/drivers/cime/esmApp.F90 b/cesm/driver/esmApp.F90 similarity index 100% rename from drivers/cime/esmApp.F90 rename to cesm/driver/esmApp.F90 diff --git a/drivers/cime/esm_time_mod.F90 b/cesm/driver/esm_time_mod.F90 similarity index 100% rename from drivers/cime/esm_time_mod.F90 rename to cesm/driver/esm_time_mod.F90 diff --git a/drivers/cime/esm_utils_mod.F90 b/cesm/driver/esm_utils_mod.F90 similarity index 100% rename from drivers/cime/esm_utils_mod.F90 rename to cesm/driver/esm_utils_mod.F90 diff --git a/drivers/cime/t_driver_timers_mod.F90 b/cesm/driver/t_driver_timers_mod.F90 similarity index 100% rename from drivers/cime/t_driver_timers_mod.F90 rename to cesm/driver/t_driver_timers_mod.F90 diff --git a/drivers/cime/util.F90 b/cesm/driver/util.F90 similarity index 100% rename from drivers/cime/util.F90 rename to cesm/driver/util.F90 diff --git a/cesm/flux_atmocn/shr_flux_mod.F90 b/cesm/flux_atmocn/shr_flux_mod.F90 new file mode 100644 index 000000000..87d8be9d5 --- /dev/null +++ b/cesm/flux_atmocn/shr_flux_mod.F90 @@ -0,0 +1,2299 @@ +module shr_flux_mod + + ! atm/ocn/flux calculations + + ! !USES: + + use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_const_mod ! shared constants + use shr_sys_mod ! shared system routines + + implicit none + + private ! default private + + ! !PUBLIC TYPES: + + ! none + + ! !PUBLIC MEMBER FUNCTIONS: + + public :: flux_atmOcn ! computes atm/ocn fluxes + public :: flux_atmOcn_diurnal ! computes atm/ocn fluxes with diurnal cycle + public :: flux_atmOcn_UA ! computes atm/ocn fluxes using University of Ariz algorithm (Zeng et al., 1998) + public :: flux_MOstability ! boundary layer stability scales/functions + public :: shr_flux_adjust_constants ! adjust constant values used in flux calculations. (used by CAM as well) + + ! !PRIVATE MEMBER FUNCTIONS: + private :: psi_ua + private :: qsat_ua + private :: rough_ua + private :: cuberoot + private :: cor30a + private :: psiuo + private :: psit_30 + + ! !PUBLIC DATA MEMBERS: + + integer(IN),parameter,public :: shr_flux_MOwScales = 1 ! w scales option + integer(IN),parameter,public :: shr_flux_MOfunctions = 2 ! functions option + real (R8),parameter,public :: shr_flux_MOgammaM = 3.59_R8 + real (R8),parameter,public :: shr_flux_MOgammaS = 7.86_R8 + + !--- rename kinds for local readability only --- + + integer,parameter :: debug = 0 ! internal debug level + + ! The follow variables are not declared as parameters so that they can be + ! adjusted to support aquaplanet and potentially other simple model modes. + ! The flux_adjust_constants subroutine is called to set the desired + ! values. The default values are from shr_const_mod. Currently they are + ! only used by the flux_atmocn routine. + real(R8) :: loc_zvir = shr_const_zvir + real(R8) :: loc_cpdair = shr_const_cpdair + real(R8) :: loc_cpvir = shr_const_cpvir + real(R8) :: loc_karman = shr_const_karman + real(R8) :: loc_g = shr_const_g + real(R8) :: loc_latvap = shr_const_latvap + real(R8) :: loc_latice = shr_const_latice + real(R8) :: loc_stebol = shr_const_stebol + real(R8) :: loc_tkfrz = shr_const_tkfrz + + ! These control convergence of the iterative flux calculation + ! (For Large and Pond scheme only; not UA or COARE). + real(r8) :: flux_con_tol = 0.0_R8 + integer(IN) :: flux_con_max_iter = 2 + + !--- cold air outbreak parameters (Mahrt & Sun 1995,MWR) ------------- + logical :: use_coldair_outbreak_mod = .false. + real(R8),parameter :: alpha = 1.4_R8 + real(R8),parameter :: maxscl =2._R8 ! maximum wind scaling for flux + real(R8),parameter :: td0 = -10._R8 ! start t-ts for scaling + + character(len=*), parameter :: sourcefile = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine shr_flux_adjust_constants( & + zvir, cpair, cpvir, karman, gravit, & + latvap, latice, stebol, flux_convergence_tolerance, & + flux_convergence_max_iteration, & + coldair_outbreak_mod) + + ! Adjust local constants. Used to support simple models. + + real(R8), optional, intent(in) :: zvir + real(R8), optional, intent(in) :: cpair + real(R8), optional, intent(in) :: cpvir + real(R8), optional, intent(in) :: karman + real(R8), optional, intent(in) :: gravit + real(R8), optional, intent(in) :: latvap + real(R8), optional, intent(in) :: latice + real(R8), optional, intent(in) :: stebol + real(r8), optional, intent(in) :: flux_convergence_tolerance + integer(in), optional, intent(in) :: flux_convergence_max_iteration + logical, optional, intent(in) :: coldair_outbreak_mod + !---------------------------------------------------------------------------- + + if (present(zvir)) loc_zvir = zvir + if (present(cpair)) loc_cpdair = cpair + if (present(cpvir)) loc_cpvir = cpvir + if (present(karman)) loc_karman = karman + if (present(gravit)) loc_g = gravit + if (present(latvap)) loc_latvap = latvap + if (present(latice)) loc_latice = latice + if (present(stebol)) loc_stebol = stebol + if (present(flux_convergence_tolerance)) flux_con_tol = flux_convergence_tolerance + if (present(flux_convergence_max_iteration)) flux_con_max_iter = flux_convergence_max_iteration + if (present(coldair_outbreak_mod)) use_coldair_outbreak_mod = coldair_outbreak_mod + + end subroutine shr_flux_adjust_constants + + !=============================================================================== + ! !IROUTINE: flux_atmOcn -- internal atm/ocn flux calculation + ! + ! !DESCRIPTION: + ! + ! Internal atm/ocn flux calculation + ! + ! !REVISION HISTORY: + ! 2002-Jun-10 - B. Kauffman - code migrated from cpl5 to cpl6 + ! 2003-Apr-02 - B. Kauffman - taux & tauy now utilize ocn velocity + ! 2003-Apr-02 - B. Kauffman - tref,qref,duu10n mods as per Bill Large + ! 2006-Nov-07 - B. Kauffman - code migrated from cpl6 to share + ! + ! 2011-Mar-13 - J. Nusbaumer - Water Isotope ocean flux added. + + ! 2019-May-16 - Jack Reeves Eyre (UA) and Kai Zhang (PNNL) - + ! Added COARE/Fairall surface flux scheme option + ! (ocn_surface_flux_scheme .eq. 1) based on code from + ! Thomas Toniazzo (Bjerknes Centre, Bergen) ” + !=============================================================================== + SUBROUTINE flux_atmOcn(logunit, nMax ,zbot ,ubot ,vbot ,thbot , & + & qbot ,s16O ,sHDO ,s18O ,rbot , & + & tbot ,us ,vs , & + & ts ,mask , seq_flux_atmocn_minwind, & + & sen ,lat ,lwup , & + & r16O, rhdo, r18O, & + & evap ,evap_16O, evap_HDO, evap_18O, & + & taux ,tauy ,tref ,qref , & + & ocn_surface_flux_scheme, & + & duu10n, ustar_sv ,re_sv ,ssq_sv, & + & missval) + + ! !USES: + use water_isotopes, only: wiso_flxoce !subroutine used to calculate water isotope fluxes. + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + integer(IN),intent(in) :: nMax ! data vector length + integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + integer(IN),intent(in) :: ocn_surface_flux_scheme + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) + real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) + real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) + real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd + real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd + real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + real(R8) ,intent(in) :: seq_flux_atmocn_minwind ! minimum wind speed for atmocn (m/s) + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + + real(R8),intent(in) ,optional :: missval ! masked value + + !--- local constants -------------------------------- + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + !!++ Large only + !real(R8),parameter :: cexcd = 0.0346_R8 ! ratio Ch(water)/CD + !real(R8),parameter :: chxcds = 0.018_R8 ! ratio Ch(heat)/CD for stable case + !real(R8),parameter :: chxcdu = 0.0327_R8 ! ratio Ch(heat)/CD for unstable case + !!++ COARE only + real(R8),parameter :: zpbl =700.0_R8 ! PBL depth [m] for gustiness parametriz. + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + integer(IN) :: iter + real(R8) :: vmag ! surface wind magnitude (m/s) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delt ! potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: stable ! stability factor + real(R8) :: rdn ! sqrt of neutral exchange coeff (momentum) + real(R8) :: rhn ! sqrt of neutral exchange coeff (heat) + real(R8) :: ren ! sqrt of neutral exchange coeff (water) + real(R8) :: rd ! sqrt of exchange coefficient (momentum) + real(R8) :: rh ! sqrt of exchange coefficient (heat) + real(R8) :: re ! sqrt of exchange coefficient (water) + real(R8) :: ustar ! ustar + real(r8) :: ustar_prev + real(R8) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: xsq ! ? + real(R8) :: xqq ! ? + !!++ Large only + real(R8) :: psimh ! stability function at zbot (momentum) + real(R8) :: psixh ! stability function at zbot (heat and water) + real(R8) :: psix2 ! stability function at ztref reference height + real(R8) :: alz ! ln(zbot/zref) + real(R8) :: al2 ! ln(zref/ztref) + real(R8) :: u10n ! 10m neutral wind + real(R8) :: tau ! stress at zbot + real(R8) :: cp ! specific heat of moist air + real(R8) :: fac ! vertical interpolation factor + real(R8) :: spval ! local missing value + !!++ COARE only + real(R8) :: zo,zot,zoq ! roughness lengths + real(R8) :: hsb,hlb ! sens & lat heat flxs at zbot + real(R8) :: trf,qrf,urf,vrf ! reference-height quantities + + + !--- local functions -------------------------------- + real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) + !!++ Large only (formula v*=[c4/U10+c5+c6*U10]*U10 in Large et al. 1994) + real(R8) :: cdn ! function: neutral drag coeff at 10m + !!++ Large only (stability functions) + real(R8) :: psimhu ! function: unstable part of psimh + real(R8) :: psixhu ! function: unstable part of psimx + real(R8) :: Umps ! dummy arg ~ wind velocity (m/s) + real(R8) :: Tk ! dummy arg ~ temperature (K) + real(R8) :: xd ! dummy arg ~ ? + !--- for cold air outbreak calc -------------------------------- + real(R8) :: tdiff(nMax) ! tbot - ts + real(R8) :: vscl + + + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + cdn(Umps) = 0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps + psimhu(xd) = log((1.0_R8+xd*(2.0_R8+xd))*(1.0_R8+xd*xd)/8.0_R8) - 2.0_R8*atan(xd) + 1.571_R8 + psixhu(xd) = 2.0_R8 * log((1.0_R8 + xd*xd)/2.0_R8) + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn) ' + character(*),parameter :: F00 = "('(flux_atmOcn) ',4a)" + + !------------------------------------------------------------------------------- + ! PURPOSE: + ! computes atm/ocn surface fluxes + ! + ! NOTES: + ! o all fluxes are positive downward + ! o net heat flux = net sw + lw up + lw down + sen + lat + ! o here, tstar = /U*, and qstar = /U*. + ! o wind speeds should all be above a minimum speed (eg. 1.0 m/s) + ! + ! ASSUMPTIONS: + ! Large: + ! o Neutral 10m drag coeff: cdn = .0027/U10 + .000142 + .0000764 U10 + ! o Neutral 10m stanton number: ctn = .0327 sqrt(cdn), unstable + ! ctn = .0180 sqrt(cdn), stable + ! o Neutral 10m dalton number: cen = .0346 sqrt(cdn) + ! o The saturation humidity of air at T(K): qsat(T) (kg/m^3) + ! COARE: + ! o use COAREv3.0 function (tht 22/11/2013) + !------------------------------------------------------------------------------- + + if (debug > 0) write(logunit,F00) "enter" + + if (present(missval)) then + spval = missval + else + spval = shr_const_spval + endif + u10n = spval + rh = spval + psixh = spval + hol=spval + + !--- for cold air outbreak calc -------------------------------- + tdiff= tbot - ts + + !!................................................................. + !! ocn_surface_flux_scheme = 0 : Default CESM1.2 + !! = 1 : COARE algorithm + !! = 2 : UA algorithm (separate subroutine) + !!................................................................. + + ! Default flux scheme. + if (ocn_surface_flux_scheme .eq. 0) then + + al2 = log(zref/ztref) + DO n=1,nMax + if (mask(n) /= 0) then + + !--- compute some needed quantities --- + vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + if (use_coldair_outbreak_mod) then + ! Cold Air Outbreak Modification: + ! Increase windspeed for negative tbot-ts + ! based on Mahrt & Sun 1995,MWR + + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) + vmag=vmag*vscl + endif + endif + ssq = 0.98_R8 * qsat(ts(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - ts(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + alz = log(zbot(n)/zref) + cp = loc_cpdair*(1.0_R8 + loc_cpvir*ssq) + + !------------------------------------------------------------ + ! first estimate of Z/L and ustar, tstar and qstar + !------------------------------------------------------------ + !--- neutral coefficients, z/L = 0.0 --- + stable = 0.5_R8 + sign(0.5_R8 , delt) + rdn = sqrt(cdn(vmag)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + !(1.0_R8-stable) * chxcdu + stable * chxcds + ren = 0.0346_R8 !cexcd + + !--- ustar, tstar, qstar --- + ustar = rdn * vmag + tstar = rhn * delt + qstar = ren * delq + ustar_prev = ustar*2.0_R8 + iter = 0 + do while( abs((ustar - ustar_prev)/ustar) > flux_con_tol .and. iter < flux_con_max_iter) + iter = iter + 1 + ustar_prev = ustar + !--- compute stability & evaluate all stability functions --- + hol = loc_karman*loc_g*zbot(n)* & + (tstar/thbot(n)+qstar/(1.0_R8/loc_zvir+qbot(n)))/ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift wind speed using old coefficient --- + rd = rdn / (1.0_R8 + max(rdn/loc_karman*(alz-psimh), -0.5_r8)) + u10n = vmag * rd / rdn + + !--- update transfer coeffs at 10m and neutral stability --- + rdn = sqrt(cdn(u10n)) + ren = 0.0346_R8 !cexcd + rhn = (1.0_R8-stable)*0.0327_R8 + stable * 0.018_R8 + !(1.0_R8-stable) * chxcdu + stable * chxcds + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) + rh = rhn / (1.0_R8 + rhn/loc_karman*(alz-psixh)) + re = ren / (1.0_R8 + ren/loc_karman*(alz-psixh)) + + !--- update ustar, tstar, qstar using updated, shifted coeffs -- + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + enddo + if (iter < 1) then + write(logunit,*) ustar,ustar_prev,flux_con_tol,flux_con_max_iter + call shr_sys_abort('No iterations performed in flux_atmocn_mod') + end if + !------------------------------------------------------------ + ! compute the fluxes + !------------------------------------------------------------ + + tau = rbot(n) * ustar * ustar + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- heat flux --- + sen (n) = cp * tau * tstar / ustar + lat (n) = loc_latvap * tau * qstar / ustar + lwup(n) = -loc_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/loc_latvap + + !---water isotope flux --- + + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq,evap_16O(n), & + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n), & + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnositcs: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + hol = hol*ztref/zbot(n) + xsq = max( 1.0_R8, sqrt(abs(1.0_R8-16.0_R8*hol)) ) + xqq = sqrt(xsq) + psix2 = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + fac = (rh/loc_karman) * (alz + al2 - psixh + psix2 ) + tref(n) = thbot(n) - delt*fac + tref(n) = tref(n) - 0.01_R8*ztref ! pot temp to temp correction + fac = (re/loc_karman) * (alz + al2 - psixh + psix2 ) + qref(n) = qbot(n) - delq*fac + + duu10n(n) = u10n*u10n ! 10m wind speed squared + + !------------------------------------------------------------ + ! optional diagnostics, needed for water tracer fluxes (dcn) + !------------------------------------------------------------ + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv(n) = re + if (present(ssq_sv )) ssq_sv(n) = ssq + + else + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval !water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval !HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval !H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + endif + ENDDO + + else if (ocn_surface_flux_scheme .eq. 1) then + !!................................. + !! use COARE algorithm + !!................................. + + + DO n=1,nMax + if (mask(n) /= 0) then + + !--- compute some needed quantities --- + vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + + if (use_coldair_outbreak_mod) then + ! Cold Air Outbreak Modification: + ! Increase windspeed for negative tbot-ts + ! based on Mahrt & Sun 1995,MWR + + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) + vmag=vmag*vscl + endif + endif + ssq = 0.98_R8 * qsat(ts(n)) / rbot(n) ! sea surf hum (kg/kg) + + call cor30a(ubot(n),vbot(n),tbot(n),qbot(n),rbot(n) & ! in atm params + & ,us(n),vs(n),ts(n),ssq & ! in surf params + & ,zpbl,zbot(n),zbot(n),zref,ztref,ztref & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,hol,ustar,tstar,qstar & ! out: ss scales + & ,rd,rh,re & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + + ! for the sake of maintaining same defs + hol=zbot(n)/hol + rd=sqrt(rd) + rh=sqrt(rh) + re=sqrt(re) + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- heat flux --- + sen (n) = hsb + lat (n) = hlb + lwup(n) = -shr_const_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/shr_const_latvap + + !---water isotope flux --- + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq, evap_16O(n), & + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n), & + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnositcs: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + tref(n) = trf + qref(n) = qrf + duu10n(n) = urf**2+vrf**2 + + !------------------------------------------------------------ + ! optional diagnostics, needed for water tracer fluxes (dcn) + !------------------------------------------------------------ + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv(n) = re + if (present(ssq_sv )) ssq_sv(n) = ssq + + else + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval ! water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval ! HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval ! H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n (n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + endif + ENDDO + + else + + call shr_sys_abort(subName//" subroutine flux_atmOcn requires ocn_surface_flux_scheme = 0 or 1") + + endif !! ocn_surface_flux_scheme + + END subroutine flux_atmOcn + + !=============================================================================== + ! !IROUTINE: flux_atmOcn_UA -- internal atm/ocn flux calculation + ! + ! !DESCRIPTION: + ! + ! Internal atm/ocn flux calculation + ! using University of Arizona method. + ! + ! Reference: + ! Zeng, X., M. Zhao, and R.E. Dickinson, 1998: Intercomparison of Bulk + ! Aerodynamic Algorithms for the Computation of Sea Surface Fluxes + ! Using TOGA COARE and TAO Data. J. Climate, 11, 2628–2644, + ! https://doi.org/10.1175/1520-0442(1998)011<2628%3AIOBAAF>2.0.CO%3B2 + ! + ! Equation numbers are from this paper. + ! + ! !REVISION HISTORY: + ! 2017-Aug-28 - J. Reeves Eyre - code re-written for E3SM + ! 2018-Oct-30 - J. Reeves Eyre - bug fix and add + ! convective gustiness. + ! 2019-May-08 - J. Reeves Eyre - remove convective gustiness + ! and add cold air outbreak modification. + !=============================================================================== + SUBROUTINE flux_atmOcn_UA(logunit, & + & nMax ,zbot ,ubot ,vbot ,thbot , & + & qbot ,s16O ,sHDO ,s18O ,rbot , & + & tbot , pslv ,us , vs , & + & ts ,mask ,sen ,lat ,lwup , & + & r16O, rhdo, r18O, & + & evap ,evap_16O, evap_HDO, evap_18O, & + & taux ,tauy ,tref ,qref , & + & duu10n, ustar_sv ,re_sv ,ssq_sv, & + & missval) + + + ! !USES: + use water_isotopes, only: wiso_flxoce !subroutine used to calculate water isotope fluxes. + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + integer ,intent(in) :: nMax ! data vector length + integer ,intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) + real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) + real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) + real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd + real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd + real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: pslv (nMax) ! sea level pressure (Pa) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + + real(R8),intent(in) ,optional :: missval ! masked value + + !--- local constants -------------------------------- + real(R8),parameter :: zetam = -1.574_R8 ! Very unstable zeta cutoff for momentum (-) + real(R8),parameter :: zetat = -0.465_R8 ! Very unstable zeta cutoff for T/q (-) + real(R8),parameter :: umin = 0.1_R8 ! minimum wind speed (m/s) + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + real(R8),parameter :: beta = 1.0_R8 ! constant used in W* calculation (-) + real(R8),parameter :: zpbl = 1000.0_R8 ! PBL height used in W* calculation (m) + real(R8),parameter :: gamma = 0.0098_R8 ! Dry adiabatic lapse rate (K/m) + real(R8),parameter :: onethird = 1.0_R8/3.0_R8 ! Used repeatedly. + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + integer(IN) :: i ! iteration loop index + real(R8) :: vmag_abs ! surface wind magnitude (m s-1) + real(R8) :: vmag_rel ! surface wind magnitude relative to + ! surface current (m s-1) + real(R8) :: vmag ! surface wind magnitude with large + ! eddy correction and minimum value (m s-1) + ! (This can change on each iteration.) + real(R8) :: thv ! virtual temperature (K) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delth ! potential T difference (K) + real(R8) :: delthv ! virtual potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: ustar ! friction velocity (m s-1) + real(R8) :: qstar ! humidity scaling parameter (kg/kg) + real(R8) :: tstar ! temperature scaling parameter (K) + real(R8) :: thvstar ! virtual temperature scaling parameter (K) + real(R8) :: wstar ! convective velocity scale (m s-1) + real(R8) :: zeta ! dimensionless height (z / Obukhov length) + real(R8) :: obu ! Obukhov length (m) + real(R8) :: tau ! magnitude of wind stress (N m-2) + real(R8) :: cp ! specific heat of moist air (J kg-1 K-1) + real(R8) :: xlv ! Latent heat of vaporization (J kg-1) + real(R8) :: visa ! Kinematic viscosity of dry air (m2 s-1) + real(R8) :: tbot_oC ! Temperature used in visa (deg C) + real(R8) :: rb ! Bulk Richardson number (-) + real(R8) :: zo ! Roughness length for momentum (m) + real(R8) :: zoq ! Roughness length for moisture (m) + real(R8) :: zot ! Roughness length for heat (m) + real(R8) :: u10 ! 10-metre wind speed (m s-1) + real(R8) :: re ! Moisture exchange coefficient for compatibility + ! with default algorithm. + real(R8) :: spval ! local missing value + real(R8) :: loc_epsilon ! Ratio of gas constants (-) + + !--- for cold air outbreak calc -------------------------------- + real(R8) :: tdiff(nMax) ! tbot - ts + real(R8) :: vscl + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn) ' + character(*),parameter :: F00 = "('(flux_atmOcn) ',4a)" + + !----- + ! Straight from original subroutine. + if (debug > 0) write(logunit,F00) "enter" + + if (present(missval)) then + spval = missval + else + spval = shr_const_spval + endif + !----- + + ! Evaluate loc_epsilon. + loc_epsilon = 1.0_R8 / (1.0_R8 + loc_zvir) + + !--- for cold air outbreak calc -------------------------------- + tdiff = tbot - ts + + ! Loop over grid points. + DO n=1,nMax + if (mask(n) /= 0) then + + !-----Calculate some required near surface variables.--------- + vmag_abs = sqrt( ubot(n)**2 + vbot(n)**2 ) + vmag_rel = sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2 ) + + ! For Cold Air Outbreak Modification (based on Mahrt & Sun 1995,MWR): + if (use_coldair_outbreak_mod) then + ! Increase windspeed for negative tbot-ts + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag_rel))),maxscl) + vmag_rel=vmag_rel*vscl + endif + endif + + delth = thbot(n) - ts(n) ! Pot. temp. difference with surface (K) + ! Note this is equivalent to Zeng et al + ! (1998) version = delt + 0.0098*zbot + thv = thbot(n)*(1.0_R8+0.61_R8*qbot(n)) ! Virtual potential temperature (K) + ! EQN (17): + !ssq = 0.98_R8 * qsat_ua(ts(n),ps, & ! Surface specific humidity (kg kg-1) + ! loc_epsilon) + ssq = 0.98_R8 * qsat_ua(ts(n),pslv(n), & ! Surface specific humidity (kg kg-1) + loc_epsilon) + delq = qbot(n) - ssq ! Difference to surface (kg kg-1) + delthv = delth*(1.0_R8+0.61_R8*qbot(n)) + & ! Difference of virtual potential + & 0.61_R8*thbot(n)*delq ! temperature with surface (K) + + xlv = 1.0e+6_R8 * & ! Latent heat of vaporization (J kg-1) + & (2.501_R8 - 0.00237_R8 * (ts(n) - loc_tkfrz)) + tbot_oC = tbot(n) - loc_tkfrz + visa = 1.326e-5_R8 * (1.0_R8 + & ! Kinematic viscosity of dry + & 6.542e-3_R8*tbot_oC + & ! air (m2 s-1) from Andreas (1989) + & 8.301e-6_R8*tbot_oC*tbot_oC - & ! CRREL Rep. 89-11 + & 4.84e-9_R8*tbot_oC*tbot_oC*tbot_oC) + cp = loc_cpdair*(1.0_R8 + loc_cpvir*ssq) ! specific heat of moist air (J kg-1 K-1) + + !-----Initial values of u* and convective velocity.----------- + ustar = 0.06_R8 + wstar = 0.5_R8 + ! Update wind speed if unstable regime. + if (delthv.lt.0.0_R8) then + ! EQN (19) + vmag = sqrt( vmag_rel**2 + beta*beta*wstar*wstar ) + else + ! EQN (18) + vmag = max(umin,vmag_rel) + endif + + !-----Iterate to compute new u* and z0.----------------------- + do i = 1,5 + ! EQN (24) + zo = 0.013_R8*ustar*ustar/loc_g + 0.11_R8*visa/ustar + ! EQN (9) assuming neutral + ustar = loc_karman*vmag/log(zbot(n)/zo) + enddo + + !-----Assess stability.--------------------------------------- + rb = loc_g*zbot(n)*delthv / (thv*vmag*vmag) ! bulk Richardson number + + if(rb.ge.0.0_R8) then + ! Neutral or stable: EQNs (4), (9), (13) and definition of rb. + zeta = rb*log(zbot(n)/zo) / & + & (1.0_R8 - 5.0_R8*min(rb,0.19_R8)) + else + ! Unstable: EQNs (4), (8), (12) and definition of rb. + zeta = rb*log(zbot(n)/zo) + endif + + obu = zbot(n)/zeta ! Obukhov length + obu = sign(max(zbot(n)/10.0_R8, abs(obu)), obu) + + !-----Main iterations (2-10 iterations would be fine).------- + do i=1,10 + + ! Update roughness lengths. + call rough_ua(zo,zot,zoq,ustar,visa) + + ! Wind variables. + zeta = zbot(n) / obu + if (zeta.lt.zetam) then + ! Very unstable regime + ! EQN (7) with extra z0 term. + ustar = loc_karman * vmag / (log(zetam*obu/zo) - & + & psi_ua(1_IN, zetam) + & + & psi_ua(1_IN, zo/obu) + & + & 1.14_R8 * ((-zeta)**onethird - (-zetam)**onethird) ) + else if (zeta.lt.0.0_R8) then + ! Unstable regime + ! EQN (8) with extra z0 term. + ustar = loc_karman * vmag / (log(zbot(n)/zo) - & + & psi_ua(1_IN,zeta) + psi_ua(1_IN,zo/obu) ) + else if (zeta.le.1.0_R8) then + ! Stable regime + ! EQN (9) with extra z0 term. + ustar = loc_karman * vmag / (log(zbot(n)/zo) + & + & 5.0_R8*zeta - 5.0_R8*zo/obu) + else + ! Very stable regime + ! EQN (10) with extra z0 term. + ustar = loc_karman * vmag / (log(obu/zo) + 5.0_R8 - & + & 5.0_R8*zo/obu + & + & (5.0_R8*log(zeta) + zeta - 1.0_R8) ) + endif + + ! Temperature variables. + if(zeta.lt.zetat) then + ! Very unstable regime + ! EQN (11) with extra z0 term. + tstar = loc_karman * delth / (log(zetat*obu/zot) - & + & psi_ua(2_IN, zetat) + & + & psi_ua(2_IN, zot/obu) + & + & 0.8_R8*((-zetat)**(-onethird) - (-zeta)**(-onethird)) ) + else if (zeta.lt.0.0_R8) then + ! Unstable regime + ! EQN (12) with extra z0 term. + tstar = loc_karman * delth / & + & (log(zbot(n)/zot) - psi_ua(2_IN,zeta) + psi_ua(2_IN,zot/obu)) + else if (zeta.le.1.0_R8) then + ! Stable regime + ! EQN (13) with extra z0 term. + tstar = loc_karman * delth / (log(zbot(n)/zot) + & + & 5.0_R8*zeta - 5.0_R8*zot/obu) + else + ! Very stable regime + ! EQN (14) with extra z0 term. + tstar = loc_karman * delth / (log(obu/zot) + & + & 5.0_R8 - 5.0_R8*zot/obu + & + & (5.0_R8*log(zeta) + zeta - 1.0_R8) ) + endif + + ! Humidity variables. + ! This is done with re to give variable to save out like + ! in old algorithm. + if (zeta.lt.zetat) then + ! Very unstable regime + ! EQN (11) with extra z0 term. + re = loc_karman / (log(zetat*obu/zoq) - psi_ua(2_IN,zetat) + & + & psi_ua(2_IN,zoq/obu) + & + & 0.8_R8*((-zetat)**(-onethird) - (-zeta)**(-onethird)) ) + else if (zeta.lt.0.0_R8) then + ! Unstable regime + ! EQN (12) with extra z0 term. + re = loc_karman / & + & (log(zbot(n)/zoq) - psi_ua(2_IN,zeta) + psi_ua(2_IN,zoq/obu)) + else if (zeta.le.1.0_R8) then + ! Stable regime + ! EQN (13) with extra z0 term. + re = loc_karman / & + & (log(zbot(n)/zoq) + 5.0_R8*zeta - 5.0_R8*zoq/obu) + else + ! Very stable regime + ! EQN (14) with extra z0 term. + re = loc_karman / & + & (log(obu/zoq) + 5.0_R8 - 5.0_R8*zoq/obu + & + & (5.0_R8*log(zeta) + zeta - 1.0_R8) ) + endif + qstar = re * delq + + ! Update Obukhov length. + thvstar = tstar*(1.0_R8 + 0.61_R8*qbot(n)) + 0.61_R8*thbot(n)*qstar + ! EQN (4) + obu = ustar*ustar * thv / (loc_karman*loc_g*thvstar) + obu = sign( max(zbot(n)/10.0_R8, abs(obu)) ,obu) + + ! Update wind speed if in unstable regime. + if (delthv.lt.0.0_R8) then + ! EQN (20) + wstar = beta * (-loc_g*ustar*thvstar*zpbl/thv)**onethird + ! EQN (19) + vmag = sqrt(vmag_rel**2 + wstar*wstar) + else + ! EQN (18) + vmag = max(umin,vmag_rel) + endif + + enddo ! End of iterations for ustar, tstar, qstar etc. + + + !-----Calculate fluxes and wind stress.--------------------- + + !--- momentum flux --- + ! This should ensure zero wind stress when (relative) wind speed is zero, + ! components are consistent with total, and we don't ever divide by zero. + ! EQN (21) + tau = rbot(n) * ustar * ustar + taux(n) = tau * (ubot(n)-us(n)) / max(umin, vmag_rel) + tauy(n) = tau * (vbot(n)-vs(n)) / max(umin, vmag_rel) + + !--- heat flux --- + ! EQNs (22) and (23) + sen (n) = cp * rbot(n) * tstar * ustar + lat (n) = xlv * rbot(n) * qstar * ustar + lwup(n) = -loc_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/xlv + + !---water isotope flux --- + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq,evap_16O(n), & + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n), & + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnositcs: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + + zeta = zbot(n) / obu + if (zeta.lt.zetat) then + if (zeta.lt.zetam) then + ! Very unstable regime for U. + ! EQN (7) + u10 = vmag_abs + (ustar/loc_karman) * & + & 1.14_R8 * ((-zref/obu)**onethird - (-zeta)**onethird) + else + ! Unstable regime for U. + ! EQN (8) + u10 = vmag_abs + (ustar/loc_karman) * & + & (log(zref/zbot(n)) - (psi_ua(1_IN,zref/obu) - psi_ua(1_IN,zeta)) ) + endif + ! Very unstable regime for T and q. + ! EQN (11) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & 0.8_R8 * ((-zeta)**(-onethird) - (-ztref/obu)**(-onethird)) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & 0.8_R8 * ((-zeta)**(-onethird) - (-ztref/obu)**(-onethird)) + + else if (zeta.lt.0.0_R8) then + ! Unstable regime. + ! EQN (8) + u10 = vmag_abs + (ustar/loc_karman) * & + & (log(zref/zbot(n)) - (psi_ua(1_IN,zref/obu) - psi_ua(1_IN,zeta)) ) + ! EQN (12) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & (log(ztref/zbot(n)) - (psi_ua(2_IN,ztref/obu) - psi_ua(2_IN,zeta)) ) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & (log(ztref/zbot(n)) - (psi_ua(2_IN,ztref/obu) - psi_ua(2_IN,zeta)) ) + else if (zeta.le.1.0_R8) then + ! Stable regime. + ! EQN (9) + u10 = vmag_abs + (ustar/loc_karman) * & + & (log(zref/zbot(n)) + 5.0_R8*zref/obu - 5.0_R8*zeta) + ! EQN (13) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & (log(ztref/zbot(n)) + 5.0_R8*ztref/obu - 5.0_R8*zeta) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & (log(ztref/zbot(n)) + 5.0_R8*ztref/obu - 5.0_R8*zeta) + else + ! Very stable regime. + ! EQN (10) + u10 = vmag_abs + (ustar/loc_karman) * & + & (5.0_R8*log(zref/zbot(n)) + zref/obu - zeta) + ! EQN (14) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & (5.0_R8*log(ztref/zbot(n)) + ztref/obu - zeta) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & (5.0_R8*log(ztref/zbot(n)) + ztref/obu - zeta) + + endif + + tref(n) = tref(n) - gamma*ztref ! pot. temp to temp correction + duu10n(n) = u10*u10 ! 10m wind speed squared + + !------------------------------------------------------------ + ! optional diagnostics, needed for water tracer fluxes (dcn) + !------------------------------------------------------------ + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(ssq_sv )) ssq_sv(n) = ssq + if (present(re_sv )) re_sv(n) = re + + + else + + !------------------------------------------------------------ + ! no valid data here -- out of ocean domain + !------------------------------------------------------------ + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval !water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval !HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval !H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + ! Optional diagnostics too: + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + + endif + + ENDDO ! loop over grid points + + END subroutine flux_atmOcn_UA + + !=============================================================================== + ! Functions/subroutines used by UA surface flux scheme. + !=============================================================================== + + ! Stability function for rb < 0 + + real(R8) function psi_ua(k,zeta) + + implicit none + + !-----Input variables.---------- + integer(IN), intent(in) :: k ! Indicates whether this is for momentum (k=1) + ! or for heat/moisture (k=2) + real(R8), intent(in) :: zeta ! Dimensionless height (=z/L) + + !-----Local variables.---------- + real(R8) :: chik ! Function of zeta. + + ! EQN (16) + chik = (1.0_R8 - 16.0_R8*zeta)**0.25_R8 + + if(k.eq.1) then + ! EQN (15) for momentum + psi_ua = 2.0_R8 * log((1.0_R8 + chik)*0.5_R8) + & + & log((1.0_R8 + chik*chik)*0.5_R8) - & + & 2.0_R8 * atan(chik) + 2.0_R8 * atan(1.0_R8) + else + ! EQN (15) for heat/moisture + psi_ua = 2.0_R8 * log((1.0_R8 + chik*chik)*0.5_R8) + endif + + end function psi_ua + + !=============================================================================== + ! Uses Tetens' formula for saturation vapor pressure from + ! Buck(1981) JAM 20, 1527-1532 + + real(R8) function qsat_ua(t,p,loc_epsilon) + + implicit none + + !-----Input variables.---------- + real(R8), intent(in) :: t ! temperature (K) + real(R8), intent(in) :: p ! pressure (Pa) + real(R8), intent(in) :: loc_epsilon ! Ratio of gas constants (-) + + !-----Local variables.---------- + real(R8) :: esat ! saturated vapor pressure (hPa) + + ! Calculate saturated vapor pressure in hPa. + esat = (1.0007_R8 + 0.00000346_R8 * (p/100.0_R8)) * 6.1121_R8 * & + & exp(17.502_R8 * (t - loc_tkfrz) / (240.97_R8 + (t - loc_tkfrz))) + + ! Convert to specific humidity (kg kg-1). + qsat_ua = loc_epsilon * esat / ((p/100.0_R8) - (1.0_R8 - loc_epsilon)*esat) + + end function qsat_ua + + !=============================================================================== + ! Calculate roughness lengths: zo, zot, zoq. + + subroutine rough_ua(zo,zot,zoq,ustar,visa) + + implicit none + + !-----Input variables.---------- + real(R8), intent(in) :: ustar ! friction velocity (m s-1) + real(R8), intent(in) :: visa ! kinematic viscosity of dry air (m2 s-1) + + !-----Output variables.--------- + real(R8), intent(out) :: zo ! roughness length for momentum (m) + real(R8), intent(out) :: zot ! roughness length for heat (m) + real(R8), intent(out) :: zoq ! roughness length for water vapor (m) + + !-----Local variables.---------- + real(R8) :: re_rough ! Rougness Reynold's number (-) + real(R8) :: xq ! Logarithm of roughness length ratios (moisture) + real(R8) :: xt ! Logarithm of roughness length ratios (heat) + + zo = 0.013_R8*ustar*ustar/loc_g + 0.11_R8*visa/ustar ! EQN (24) + re_rough = ustar*zo/visa ! By definition. + xq = 2.67_R8*re_rough**0.25_R8 - 2.57_R8 ! EQN (25) + xt = xq ! EQN (26) + zoq = zo/exp(xq) ! By definition of xq + zot = zo/exp(xt) ! By definition of xt + + end subroutine rough_ua + + real(R8) elemental function cuberoot(a) + real(R8), intent(in) :: a + real(R8), parameter :: one_third = 1._R8/3._R8 + cuberoot = sign(abs(a)**one_third, a) + end function cuberoot + + !=============================================================================== + ! !IROUTINE: flux_atmOcn_diurnal -- internal atm/ocn flux calculation + ! + ! !DESCRIPTION: + ! + ! Internal atm/ocn flux calculation + ! + ! !REVISION HISTORY: + ! 2002-Jun-10 - B. Kauffman - code migrated from cpl5 to cpl6 + ! 2003-Apr-02 - B. Kauffman - taux & tauy now utilize ocn velocity + ! 2003-Apr-02 - B. Kauffman - tref,qref,duu10n mods as per Bill Large + ! 2006-Nov-07 - B. Kauffman - code migrated from cpl6 to share + !=============================================================================== + SUBROUTINE flux_atmOcn_diurnal & + (logunit, nMax ,zbot ,ubot ,vbot ,thbot , & + qbot ,s16O ,sHDO ,s18O ,rbot , & + tbot ,us ,vs , & + ts ,mask , seq_flux_atmocn_minwind, & + sen ,lat ,lwup , & + r16O ,rhdo ,r18O ,evap ,evap_16O, & + evap_HDO ,evap_18O, & + taux ,tauy ,tref ,qref , & + uGust, lwdn , swdn , swup, prec , & + swpen, ocnsal, ocn_prognostic, flux_diurnal, & + ocn_surface_flux_scheme, & + latt, long , warm , salt , speed, regime, & + warmMax, windMax, qSolAvg, windAvg, & + warmMaxInc, windMaxInc, qSolInc, windInc, nInc, & + tBulk, tSkin, tSkin_day, tSkin_night, & + cSkin, cSkin_night, secs ,dt, & + duu10n, ustar_sv ,re_sv ,ssq_sv, & + missval, cold_start ) + ! !USES: + + use water_isotopes, only: wiso_flxoce !subroutine used to calculate water isotope fluxes. + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + integer(IN),intent(in) :: nMax ! data vector length + integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) + real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) + real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) + real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd + real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd + real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + + !--- new arguments ------------------------------- + real(R8),intent(inout) :: swpen (nMax) ! NEW + real(R8),intent(inout) :: ocnsal(nMax) ! NEW (kg/kg) + logical ,intent(in) :: ocn_prognostic ! NEW + logical ,intent(in) :: flux_diurnal ! NEW logical for diurnal on/off + integer(IN) ,intent(in) :: ocn_surface_flux_scheme + + real(R8),intent(in) :: uGust (nMax) ! NEW not used + real(R8),intent(in) :: lwdn (nMax) ! NEW + real(R8),intent(in) :: swdn (nMax) ! NEW + real(R8),intent(in) :: swup (nMax) ! NEW + real(R8),intent(in) :: prec (nMax) ! NEW + real(R8),intent(in) :: latt (nMax) ! NEW + real(R8),intent(in) :: long (nMax) ! NEW + real(R8),intent(inout) :: warm (nMax) ! NEW + real(R8),intent(inout) :: salt (nMax) ! NEW + real(R8),intent(inout) :: speed (nMax) ! NEW + real(R8),intent(inout) :: regime(nMax) ! NEW + real(R8),intent(out) :: warmMax(nMax) ! NEW + real(R8),intent(out) :: windMax(nMax) ! NEW + real(R8),intent(inout) :: qSolAvg(nMax) ! NEW + real(R8),intent(inout) :: windAvg(nMax) ! NEW + real(R8),intent(inout) :: warmMaxInc(nMax) ! NEW + real(R8),intent(inout) :: windMaxInc(nMax) ! NEW + real(R8),intent(inout) :: qSolInc(nMax) ! NEW + real(R8),intent(inout) :: windInc(nMax) ! NEW + real(R8),intent(inout) :: nInc(nMax) ! NEW + + real(R8),intent(out) :: tBulk (nMax) ! NEW + real(R8),intent(out) :: tSkin (nMax) ! NEW + real(R8),intent(out) :: tSkin_day (nMax) ! NEW + real(R8),intent(out) :: tSkin_night (nMax) ! NEW + real(R8),intent(out) :: cSkin (nMax) ! NEW + real(R8),intent(out) :: cSkin_night (nMax) ! NEW + integer(IN),intent(in) :: secs ! NEW elsapsed seconds in day (GMT) + integer(IN),intent(in) :: dt ! NEW + logical ,intent(in) :: cold_start ! cold start flag + real(R8),intent(in) :: seq_flux_atmocn_minwind ! minimum wind speed for atmocn (m/s) + + real(R8),intent(in) ,optional :: missval ! masked value + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + + + !--- local constants -------------------------------- + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + + real(R8),parameter :: lambdaC = 6.0_R8 + real(R8),parameter :: lambdaL = 0.0_R8 + real(R8),parameter :: doLMax = 1.0_R8 + real(R8),parameter :: pwr = 0.2_R8 + real(R8),parameter :: Rizero = 1.0_R8 + real(R8),parameter :: NUzero = 40.0e-4_R8 + real(R8),parameter :: Prandtl = 1.0_R8 + real(R8),parameter :: kappa0 = 0.2e-4_R8 + + real(R8),parameter :: F0 = 0.5_R8 + real(R8),parameter :: F1 = 0.15_R8 + real(R8),parameter :: R1 = 10.0_R8 + + real(R8),parameter :: Ricr = 0.30_R8 + real(R8),parameter :: tiny = 1.0e-12_R8 + real(R8),parameter :: tiny2 = 1.0e-6_R8 + real(R8),parameter :: pi = SHR_CONST_PI + + !!++ COARE only + real(R8),parameter :: zpbl =700.0_R8 ! PBL depth [m] for gustiness parametriz. + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + integer(IN) :: iter ! iteration loop index + integer(IN) :: lsecs ! local seconds elapsed + integer(IN) :: lonsecs ! incrememnt due to lon offset + real(R8) :: vmag ! surface wind magnitude (m/s) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delt ! potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: stable ! stability factor + real(R8) :: rdn ! sqrt of neutral exchange coeff (momentum) + real(R8) :: rhn ! sqrt of neutral exchange coeff (heat) + real(R8) :: ren ! sqrt of neutral exchange coeff (water) + real(R8) :: rd ! sqrt of exchange coefficient (momentum) + real(R8) :: rh ! sqrt of exchange coefficient (heat) + real(R8) :: re ! sqrt of exchange coefficient (water) + real(R8) :: ustar ! ustar + real(R8) :: ustar_prev ! ustar + real(R8) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: xsq ! ? + real(R8) :: xqq ! ? + real(R8) :: psimh ! stability function at zbot (momentum) + real(R8) :: psixh ! stability function at zbot (heat and water) + real(R8) :: psix2 ! stability function at ztref reference height + real(R8) :: alz ! ln(zbot/zref) + real(R8) :: al2 ! ln(zref/ztref) + real(R8) :: u10n ! 10m neutral wind + real(R8) :: tau ! stress at zbot + real(R8) :: cp ! specific heat of moist air + real(R8) :: fac ! vertical interpolation factor + real(R8) :: DTiter ! + real(R8) :: DSiter ! + real(R8) :: DViter ! + + real(R8) :: Dcool ! + real(R8) :: Qdel ! net cool skin heating + real(R8) :: Hd ! net heating above -z=d + real(R8) :: Hb ! net kinematic heating above -z = delta + real(R8) :: lambdaV ! + real(R8) :: Fd ! net fresh water forcing above -z=d + real(R8) :: ustarw ! surface wind forcing of layer above -z=d + + real(R8) :: Qsol ! solar heat flux (W/m2) + real(R8) :: Qnsol ! non-solar heat flux (W/m2) + + real(R8) :: SSS ! sea surface salinity + real(R8) :: alphaT ! + real(R8) :: betaS ! + + real(R8) :: doL ! ocean forcing stablity parameter + real(R8) :: Rid ! Richardson number at depth d + real(R8) :: Ribulk ! Bulk Richardson number at depth d + real(R8) :: FofRi ! Richardon number dependent diffusivity + real(R8) :: Smult ! multiplicative term based on regime + real(R8) :: Sfact ! multiplicative term based on regime + real(R8) :: Kdiff ! diffusive term based on regime + real(R8) :: Kvisc ! viscosity term based on regime + real(R8) :: rhocn ! + real(R8) :: rcpocn ! + real(R8) :: Nreset ! value for multiplicative reset factor + logical :: lmidnight + logical :: ltwopm + logical :: ltwoam + logical :: lfullday + integer :: nsum + real(R8) :: pexp ! eqn 19 + real(R8) :: AMP ! eqn 18 + real(R8) :: dif3 + real(R8) :: phid + real(R8) :: spval + + !!++ COARE only + real(R8) :: zo,zot,zoq ! roughness lengths + real(R8) :: hsb,hlb ! sens & lat heat flxs at zbot + real(R8) :: trf,qrf,urf,vrf ! reference-height quantities + + !--- local functions -------------------------------- + real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) + real(R8) :: cdn ! function: neutral drag coeff at 10m + real(R8) :: psimhu ! function: unstable part of psimh + real(R8) :: psixhu ! function: unstable part of psimx + real(R8) :: Umps ! dummy arg ~ wind velocity (m/s) + real(R8) :: Tk ! dummy arg ~ temperature (K) + real(R8) :: xd ! dummy arg ~ ? + real(R8) :: molvisc ! molecular viscosity + real(R8) :: molPr ! molecular Prandtl number + + !--- for cold air outbreak calc -------------------------------- + real(R8) :: tdiff(nMax) ! tbot - ts + real(R8) :: vscl + + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + cdn(Umps) = 0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps + psimhu(xd) = log((1.0_R8+xd*(2.0_R8+xd))*(1.0_R8+xd*xd)/8.0_R8) - 2.0_R8*atan(xd) + 1.571_R8 + psixhu(xd) = 2.0_R8 * log((1.0_R8 + xd*xd)/2.0_R8) + molvisc(Tk) = 1.623e-6_R8 * exp((-1.0_R8*(Tk-273.15_R8))/45.2_R8) + molPr(Tk) = 11.64_R8 * exp((-1.0_R8*(Tk-273.15_R8))/40.7_R8) + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn_diurnal) ' + character(*),parameter :: F00 = "('(flux_atmOcn_diurnal) ',4a)" + + !------------------------------------------------------------------------------- + ! PURPOSE: + ! computes atm/ocn surface fluxes + ! + ! NOTES: + ! o all fluxes are positive downward + ! o net heat flux = net sw + lw up + lw down + sen + lat + ! o here, tstar = /U*, and qstar = /U*. + ! o wind speeds should all be above a minimum speed (eg. 1.0 m/s) + ! + ! ASSUMPTIONS: + ! o Neutral 10m drag coeff: cdn = .0027/U10 + .000142 + .0000764 U10 + ! o Neutral 10m stanton number: ctn = .0327 sqrt(cdn), unstable + ! ctn = .0180 sqrt(cdn), stable + ! o Neutral 10m dalton number: cen = .0346 sqrt(cdn) + ! o The saturation humidity of air at T(K): qsat(T) (kg/m^3) + !------------------------------------------------------------------------------- + + if (debug > 0) write(logunit,F00) "enter" + + ! this is especially for flux_diurnal calculations + if (.not. flux_diurnal) then + write(logunit,F00) "ERROR: flux_diurnal must be true" + call shr_sys_abort(subName//"flux diurnal must be true") + endif + spval = shr_const_spval + rh = spval + dviter = spval + dtiter = spval + dsiter = spval + al2 = log(zref/ztref) + !--- for cold air outbreak calc -------------------------------- + tdiff= tbot - ts + + ! equations 18 and 19 + AMP = 1.0_R8/F0-1.0_R8 + pexp = log( (1.0_R8/F1-F0) / (1.0_R8-F0) ) / log(R1) + + if (.not. ocn_prognostic) then + ! Set swpen and ocean salinity from following analytic expressions + swpen(:) = 0.67_R8*(exp((-1._R8*shr_const_zsrflyr)/1.0_R8)) + & + 0.33_R8*exp((-1._R8*shr_const_zsrflyr)/17.0_R8) + ocnsal(:) = shr_const_ocn_ref_sal/1000.0_R8 + else + ! use swpen and ocnsal from input argument + endif + + if (cold_start) then + write(logunit,F00) "Initialize diurnal cycle fields" + warm (:) = 0.0_R8 + salt (:) = 0.0_R8 + speed (:) = 0.0_R8 + regime (:) = 0.0_R8 + qSolAvg (:) = 0.0_R8 + windAvg (:) = 0.0_R8 + warmMax (:) = 0.0_R8 + windMax (:) = 0.0_R8 + warmMaxInc (:) = 0.0_R8 + windMaxInc (:) = 0.0_R8 + qSolInc (:) = 0.0_R8 + windInc (:) = 0.0_R8 + nInc (:) = 0.0_R8 + tSkin_day (:) = ts(:) + tSkin_night(:) = ts(:) + cSkin_night(:) = 0.0_R8 + endif + + DO n=1,nMax + + if (mask(n) /= 0) then + + !--- compute some initial and useful flux quantities --- + + vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + if (use_coldair_outbreak_mod) then + ! Cold Air Outbreak Modification: + ! Increase windspeed for negative tbot-ts + ! based on Mahrt & Sun 1995,MWR + + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) + vmag=vmag*vscl + endif + endif + alz = log(zbot(n)/zref) + hol = 0.0 + psimh = 0.0 + psixh = 0.0 + rdn = sqrt(cdn(vmag)) + + tBulk(n) = ts(n)+warm(n) ! first guess for tBulk from read in ts,warm + tSkin(n) = tBulk(n) + Qsol = swdn(n) + swup(n) + SSS = 1000.0_R8*ocnsal(n)+salt(n) + lambdaV = lambdaC + + alphaT = 0.000297_R8*(1.0_R8+0.0256_R8*(ts(n)-298.15_R8)+0.003_R8*(SSS - 35.0_R8)) + betaS = 0.000756_R8*(1.0_R8-0.0016_R8*(ts(n)-298.15_R8)) + rhocn = 1023.342_R8*(1.0_R8-0.000297_R8*(ts(n)-298.15_R8)+0.000756_R8 * (SSS - 35.0_R8)) + rcpocn = rhocn * 3990.0_R8*(1.0_R8-0.0012_R8*(SSS - 35.0_R8)) + + Rid = shr_const_g * (alphaT*warm(n) - betaS*salt(n)) *pwr*shr_const_zsrflyr / & + ( pwr*MAX(tiny,speed(n)) )**2 + + Ribulk = 0.0 + + !---------------------------------------------------------- + ! convert elapsed time from GMT to local & + ! check elapsed time. reset warm if near lsecs = reset_sec + !---------------------------------------------------------- + Nreset = 1.0_R8 + + lonsecs = ceiling(long(n)/360.0_R8*86400.0) + lsecs = mod(secs + lonsecs,86400) + + lmidnight = (lsecs >= 0 .and. lsecs < dt) ! 0 = midnight + ltwopm = (lsecs >= 48600 .and. lsecs < 48600+dt) ! 48600 = 1:30pm + ltwoam = (lsecs >= 5400 .and. lsecs < 5400 +dt) ! 5400 = 1:30am + lfullday = (lsecs > 86400-dt .and. lsecs <= 86400) + nsum = nint(nInc(n)) + + if ( lmidnight ) then + Regime(n) = 1.0_R8 ! RESET DIURNAL + warm(n) = 0.0_R8 + salt(n) = 0.0_R8 + speed(n) = 0.0_R8 + endif + + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - tBulk(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + cp = shr_const_cpdair*(1.0_R8 + shr_const_cpvir*ssq) + + !!................................................................. + !! ocn_surface_flux_scheme = 0 : Default E3SMv1 + !! = 1 : COARE algorithm + !!................................................................. + if (ocn_surface_flux_scheme .eq. 0) then! use Large algorithm + stable = 0.5_R8 + sign(0.5_R8 , delt) + + + !--- shift wind speed using old coefficient and stability function + + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + u10n = vmag * rd / rdn + + !--- initial neutral transfer coeffs at 10m + rdn = sqrt(cdn(u10n)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + ren = 0.0346_R8 + + !--- initial ustar, tstar, qstar --- + ustar = rdn * vmag + tstar = rhn * delt + qstar = ren * delq + + else if (ocn_surface_flux_scheme .eq. 1) then! use COARE algorithm + + call cor30a(ubot(n),vbot(n),tbot(n),qbot(n),rbot(n) & ! in atm params + & ,us(n),vs(n),tBulk(n),ssq & ! in surf params (NB ts -> tBulk) + & ,zpbl,zbot(n),zbot(n),zref,ztref,ztref & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,hol,ustar,tstar,qstar & ! out: ss scales + & ,rd,rh,re & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + ! for the sake of maintaining same defs + hol=zbot(n)/hol + rd=sqrt(rd) + rh=sqrt(rh) + re=sqrt(re) + + ELSE ! N.B.: *no* valid ocn_surface_flux_scheme=2 option if diurnal=.true. + + call shr_sys_abort(subName//" flux_atmOcn_diurnal requires ocn_surface_flux_scheme = 0 or 1") + ENDIF + + ustar_prev = ustar * 2.0_R8 + iter = 0 + ! --- iterate --- + ! Originally this code did three iterations while the non-diurnal version did two + ! So in the new loop this is <= flux_con_max_iter instead of < so that the same defaults + ! will give the same answers in both cases. + do while( abs((ustar - ustar_prev)/ustar) > flux_con_tol .and. iter <= flux_con_max_iter) + iter = iter + 1 + ustar_prev = ustar + !------------------------------------------------------------ + ! iterate to converge on FLUXES Z/L, ustar, tstar and qstar + ! and on Rid in the DIURNAL CYCLE + !------------------------------------------------------------ + Smult = 0.0_R8 + Sfact = 0.0_R8 + Kdiff = 0.0_R8 + Kvisc = 0.0_R8 + dif3 = 0.0_R8 + + ustarw = ustar*sqrt(max(tiny,rbot(n)/rhocn)) + Qnsol = lwdn(n) - shr_const_stebol*(tSkin(n))**4 + & + rbot(n)*ustar*(cp*tstar + shr_const_latvap*qstar) + Hd = (Qnsol + Qsol*(1.0_R8-swpen(n)) ) / rcpocn + Fd = (prec(n) + rbot(n)*ustar*qstar ) * SSS / rhocn + + !--- COOL SKIN EFFECT --- + Dcool = lambdaV*molvisc(tBulk(n)) / ustarw + Qdel = Qnsol + Qsol * & + (0.137_R8 + 11.0_R8*Dcool - 6.6e-5/Dcool *(1.0_R8 - exp((-1.0_R8*Dcool)/8.0e-4))) + Hb = (Qdel/rcpocn)+(Fd*betaS/alphaT) + Hb = min(Hb , 0.0_R8) + + ! lambdaV = lambdaC*(1.0_R8 + ( (0.0_R8-Hb)*16.0_R8*molvisc(tBulk(n))* & + ! shr_const_g*alphaT*molPr(tBulk(n))**2/ustarw**4)**0.75)**(-1._R8/3._R8) + lambdaV = 6.5_R8 + cSkin(n) = MIN(0.0_R8, lambdaV * molPr(tBulk(n)) * Qdel / ustarw / rcpocn ) + + !--- REGIME --- + doL = shr_const_zsrflyr*shr_const_karman*shr_const_g* & + (alphaT*Hd + betaS*Fd ) / ustarw**3 + Rid = MAX(0.0_R8,Rid) + Smult = dt * (pwr+1.0_R8) / (shr_const_zsrflyr*pwr) + Sfact = dt * (pwr+1.0_R8) / (shr_const_zsrflyr)**2 + FofRi = 1.0_R8/(1.0_R8 + AMP*(Rid/Rizero)**pexp) + + if ( (doL.gt.0.0_R8) .and. (Qsol.gt.0.0) ) then + phid = MIN(1.0_R8 + 5.0_R8 * doL, 5.0_R8 + doL) + FofRi = 1.0_R8/(1.0_R8 + AMP*(Rid/Rizero)**pexp) + dif3 = (kappa0 + NUzero *FofRi) + + if ((doL.le.lambdaL).and.(NINT(regime(n)).le.2)) then + regime(n) = 2.0_R8 + Kdiff = shr_const_karman * ustarw * shr_const_zsrflyr / phid + Kvisc = Kdiff * (1.0_R8 - doL/lambdaL)**2 + & + dif3 * (doL/lambdaL)**2 * (3.0_R8 - 2.0_R8 * doL/lambdaL) + Kdiff = Kvisc + else + regime(n) = 3.0_R8 + Kdiff = kappa0 + NUzero * FofRi + Kvisc = Prandtl* kappa0 + NUzero * FofRi + endif + else + if (regime(n).eq.1.0_R8) then + Smult = 0.0_R8 + else + if (Ribulk .gt. Ricr) then + regime(n) = 3.0_R8 + Kdiff = kappa0 + NUzero * FofRi + Kvisc = Prandtl* kappa0 + NUzero * FofRi + else + regime(n) = 4.0_R8 + Kdiff = shr_const_karman*ustarw*shr_const_zsrflyr *cuberoot(1.0_R8-7.0_R8*doL) + Kvisc = Kdiff + endif + endif + + endif + + !--- IMPLICIT INTEGRATION --- + + DTiter = (warm(n) +(Smult*Hd)) /(1.+ Sfact*Kdiff) + DSiter = (salt(n) -(Smult*Fd)) /(1.+ Sfact*Kdiff) + DViter = (speed(n) +(Smult*ustarw*ustarw)) /(1.+ Sfact*Kvisc) + DTiter = MAX( 0.0_R8, DTiter) + DViter = MAX( 0.0_R8, DViter) + + Rid =(shr_const_g*(alphaT*DTiter-betaS*DSiter)*pwr*shr_const_zsrflyr) / & + (pwr*MAX(tiny,DViter))**2 + Ribulk = Rid * pwr + Ribulk = 0.0_R8 + tBulk(n) = ts(n) + DTiter + tSkin(n) = tBulk(n) + cskin(n) + + !--need to update ssq,delt,delq as function of tBulk ---- + + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - tBulk(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + + !--- UPDATE FLUX ITERATION --- + + !!................................................................. + !! ocn_surface_flux_scheme = 0 : Default CESM1.2 + !! = 1 : COARE algorithm + !!................................................................. + if (ocn_surface_flux_scheme .eq. 0) then! use Large algorithm + + !--- compute stability & evaluate all stability functions --- + hol = shr_const_karman*shr_const_g*zbot(n)* & + (tstar/thbot(n)+qstar/(1.0_R8/shr_const_zvir+qbot(n)))/ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift wind speed using old coefficient and stability function --- + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + u10n = vmag * rd / rdn + + !--- update neutral transfer coeffs at 10m + rdn = sqrt(cdn(u10n)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + ren = 0.0346_R8 + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + rh = rhn / (1.0_R8 + rhn/shr_const_karman*(alz-psixh)) + re = ren / (1.0_R8 + ren/shr_const_karman*(alz-psixh)) + + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + + !--- heat flux --- + + tau = rbot(n) * ustar * ustar + sen (n) = cp * tau * tstar / ustar + lat (n) = shr_const_latvap * tau * qstar / ustar + + else if (ocn_surface_flux_scheme .eq. 1) then! use COARE algorithm + + call cor30a(ubot(n),vbot(n),tbot(n),qbot(n),rbot(n) & ! in atm params + & ,us(n),vs(n),tBulk(n),ssq & ! in surf params (NB ts -> tBulk) + & ,zpbl,zbot(n),zbot(n),zref,ztref,ztref & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,hol,ustar,tstar,qstar & ! out: ss scales + & ,rd,rh,re & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + ! for the sake of maintaining same defs + hol=zbot(n)/hol + rd=sqrt(rd) + rh=sqrt(rh) + re=sqrt(re) + + !--- heat flux --- + + sen (n) = hsb + lat (n) = hlb + + else ! N.B.: NO ocn_surface_flux_scheme=2 option + call shr_sys_abort(subName//", flux_diurnal requires ocn_surface_flux_scheme = 0 or 1") + endif + + ENDDO ! end iteration loop + if (iter < 1) then + call shr_sys_abort('No iterations performed ') + end if + !--- COMPUTE FLUXES TO ATMOSPHERE AND OCEAN --- + + ! Now calculated further up in subroutine. + !tau = rbot(n) * ustar * ustar + !sen (n) = cp * tau * tstar / ustar + !lat (n) = shr_const_latvap * tau * qstar / ustar + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- LW radiation --- + lwup(n) = -shr_const_stebol * Tskin(n)**4 + + !--- water flux --- + evap(n) = lat(n)/shr_const_latvap + + !---water isotope flux --- + !!ZZZ bugfix to be done + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq, evap_16O(n),& + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n),& + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnostics: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + + if (ocn_surface_flux_scheme .eq. 0) then ! use Large algorithm + + hol = hol*ztref/zbot(n) + xsq = max( 1.0_R8, sqrt(abs(1.0_R8-16.0_R8*hol)) ) + xqq = sqrt(xsq) + psix2 = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + fac = (rh/shr_const_karman) * (alz + al2 - psixh + psix2 ) + tref(n) = thbot(n) - delt*fac + tref(n) = tref(n) - 0.01_R8*ztref ! pot temp to temp correction + fac = (re/shr_const_karman) * (alz + al2 - psixh + psix2 ) + qref(n) = qbot(n) - delq*fac + + duu10n(n) = u10n*u10n ! 10m wind speed squared + + else if (ocn_surface_flux_scheme .eq. 1) then! use COARE algorithm + + tref(n) = trf + qref(n) = qrf + duu10n(n) = urf**2+vrf**2 + u10n = sqrt(duu10n(n)) + endif + + if (flux_diurnal) then + + !------------------------------------------------------------ + ! update new prognostic variables + !------------------------------------------------------------ + + warm (n) = DTiter + salt (n) = DSiter + speed (n) = DViter + + if (ltwopm) then + tSkin_day(n) = tSkin(n) + warmmax(n) = max(DTiter,0.0_R8) + endif + + if (ltwoam) then + tSkin_night(n) = tSkin(n) + cSkin_night(n) = cSkin(n) + endif + + if ((lmidnight).and.(lfullday)) then + qSolAvg(n) = qSolInc(n)/real(nsum+1,R8) + windAvg(n) = windInc(n)/real(nsum+1,R8) + ! warmMax(n) = max(DTiter,warmMaxInc(n)) + windMax(n) = max(u10n,windMaxInc(n)) + + nsum = 0 + + qSolInc(n) = Qsol + windInc(n) = u10n + + ! warmMaxInc(n) = 0.0_R8 + windMaxInc(n) = 0.0_R8 + + ! tSkin_night(n) = tSkin(n) + ! cSkin_night(n) = cSkin(n) + + else + + if ((lmidnight).and.(.not.(lfullday))) then + + nsum = 0 + + qSolInc(n) = Qsol + windInc(n) = u10n + + ! warmMaxInc(n) = 0.0_R8 + windMaxInc(n) = 0.0_R8 + + else + + nsum = nsum + 1 + + ! warmMaxInc (n) = max(DTiter,warmMaxInc(n)) + windMaxInc (n) = max(u10n, windMaxInc(n)) + ! windMaxInc (n) = max(Qsol, windMaxInc(n)) + qSolInc (n) = qSolInc(n)+Qsol + windInc (n) = windInc(n)+u10n + + endif + endif + + nInc(n) = real(nsum,R8) ! set nInc to incremented or reset nsum + + + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv (n) = re + if (present(ssq_sv )) ssq_sv (n) = ssq + + else ! mask = 0 + + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + warm (n) = spval ! NEW + salt (n) = spval ! NEW + speed (n) = spval ! NEW + regime (n) = spval ! NEW + tBulk (n) = spval ! NEW + tSkin (n) = spval ! NEW + tSkin_night(n) = spval ! NEW + tSkin_day (n) = spval ! NEW + cSkin (n) = spval ! NEW + cSkin_night(n) = spval ! NEW + warmMax (n) = spval ! NEW + windMax (n) = spval ! NEW + qSolAvg (n) = spval ! NEW + windAvg (n) = spval ! NEW + warmMaxInc (n) = spval ! NEW + windMaxInc (n) = spval ! NEW + qSolInc (n) = spval ! NEW + windInc (n) = spval ! NEW + nInc (n) = 0.0_R8 ! NEW + + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval ! water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval ! HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval ! H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + + endif ! mask + + endif ! flux diurnal logic + + ENDDO ! end n loop + + END subroutine flux_atmOcn_diurnal + + !=============================================================================== + ! !IROUTINE: shr_flux_MOstability -- Monin-Obukhov BL stability functions + ! + ! !DESCRIPTION: + ! + ! Monin-Obukhov boundary layer stability functions, two options: + ! turbulent velocity scales or gradient and integral functions + ! via option = shr_flux_MOwScales or shr_flux_MOfunctions + ! + ! !REVISION HISTORY: + ! 2007-Sep-19 - B. Kauffman, Bill Large - first version + !=============================================================================== + subroutine flux_MOstability(logunit,option,arg1,arg2,arg3,arg4,arg5) + + ! !USES: + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + integer ,intent(in) :: logunit + integer ,intent(in) :: option ! shr_flux_MOwScales or MOfunctions + real(R8) ,intent(in) :: arg1 ! scales: uStar (in) funct: zeta (in) + real(R8) ,intent(inout) :: arg2 ! scales: zkB (in) funct: phim (out) + real(R8) ,intent(out) :: arg3 ! scales: phim (out) funct: phis (out) + real(R8) ,intent(out) :: arg4 ! scales: phis (out) funct: psim (out) + real(R8) ,intent(out),optional :: arg5 ! scales: (unused) funct: psis (out) + + !----- local variables ----- + real(R8) :: zeta ! z/L + real(R8) :: uStar ! friction velocity + real(R8) :: zkB ! (height)*(von Karman)*(surface bouyancy flux) + real(R8) :: phim ! momentum gradient function or scale + real(R8) :: phis ! temperature gradient function or scale + real(R8) :: psim ! momentum integral function or scale + real(R8) :: psis ! temperature integral function or scale + real(R8) :: temp ! temporary-variable/partial calculation + + !----- local variables, stable case ----- + real(R8),parameter :: uStarMin = 0.001_R8 ! lower bound on uStar + real(R8),parameter :: a = 1.000_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: b = 0.667_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: c = 5.000_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: d = 0.350_R8 ! constant from Holtslag & de Bruin, equation 12 + + !----- local variables, unstable case ----- + real(R8),parameter :: a2 = 3.0_R8 ! constant from Wilson, equation 10 + + !----- formats ----- + character(*),parameter :: subName = '(shr_flux_MOstability) ' + character(*),parameter :: F00 = "('(shr_flux_MOstability) ',4a)" + character(*),parameter :: F01 = "('(shr_flux_MOstability) ',a,i5)" + + !------------------------------------------------------------------------------- + ! Notes:: + ! o this could be two routines, but are one to help keep them aligned + ! o the stable calculation is taken from... + ! A.A.M. HoltSlag and H.A.R. de Bruin, 1988: + ! "Applied Modeling of the Nighttime Surface Energy Balance over Land", + ! Journal of Applied Meteorology, Vol. 27, No. 6, June 1988, 659-704 + ! o the unstable calculation is taken from... + ! D. Keith Wilson, 2001: "An Alternative Function for the Wind and + ! Temperature Gradients in Unstable Surface Layers", + ! Boundary-Layer Meteorology, 99 (2001), 151-158 + !------------------------------------------------------------------------------- + + !----- check for consistancy between option and arguments ------------------ + if (debug > 1) then + if (debug > 2) write(logunit,F01) "enter, option = ",option + if ( option == shr_flux_MOwScales .and. present(arg5) ) then + write(logunit,F01) "ERROR: option1 must have four arguments" + call shr_sys_abort(subName//"option inconsistant with arguments") + else if ( option == shr_flux_MOfunctions .and. .not. present(arg5) ) then + write(logunit,F01) "ERROR: option2 must have five arguments" + call shr_sys_abort(subName//"option inconsistant with arguments") + else + write(logunit,F01) "invalid option = ",option + call shr_sys_abort(subName//"invalid option") + end if + end if + + !------ velocity scales option ---------------------------------------------- + if (option == shr_flux_MOwScales) then + + !--- input --- + uStar = arg1 + zkB = arg2 + + if (zkB >= 0.0_R8) then ! ----- stable ----- + zeta = zkB/(max(uStar,uStarMin)**3) + temp = exp(-d*zeta) + phim = uStar/(1.0_R8 + zeta*(a + b*(1.0_R8 + c - d*zeta)*temp)) + phis = phim + else ! ----- unstable ----- + temp = (zkB*zkB)**(1.0_R8/a2) ! note: zkB < 0, zkB*zkB > 0 + phim = sqrt(uStar**2 + shr_flux_MOgammaM*temp) + phis = sqrt(uStar**2 + shr_flux_MOgammaS*temp) + end if + + !--- output --- + arg3 = phim + arg4 = phis + ! arg5 = + + !------ stability function option ------------------------------------------- + else if (option == shr_flux_MOfunctions) then + + !--- input --- + zeta = arg1 + + if (zeta >= 0.0_R8) then ! ----- stable ----- + temp = exp(-d*zeta) + phim = 1.0_R8 + zeta*(a + b*(1.0_R8 + c - d*zeta)*temp) + phis = phim + psim = -a*zeta - b*(zeta - c/d)*temp - b*c/d + psis = psim + else ! ----- unstable ---- + temp = (zeta*zeta)**(1.0_R8/a2) ! note: zeta < 0, zeta*zeta > 0 + phim = 1.0_R8/sqrt(1.0_R8 + shr_flux_MOgammaM*temp) + phis = 1.0_R8/sqrt(1.0_R8 + shr_flux_MOgammaS*temp) + psim = a2*log(0.5_R8 + 0.5_R8/phim) + psis = a2*log(0.5_R8 + 0.5_R8/phis) + end if + + !--- output --- + arg2 = phim + arg3 = phis + arg4 = psim + arg5 = psis + !---------------------------------------------------------------------------- + else + write(logunit,F01) "invalid option = ",option + call shr_sys_abort(subName//"invalid option") + endif + + end subroutine flux_MOstability + + !=============================================================================== + ! !DESCRIPTION: + ! + ! COARE v3.0 parametrisation + ! + ! !REVISION HISTORY: + ! 2013-Nov-22: Thomas Toniazzo's adaptation of Chris Fairall's code, + ! downloaded from + ! ftp://ftp1.esrl.noaa.gov/users/cfairall/wcrp_wgsf/computer_programs/cor3_0/ + ! * no wave, standard coare 2.6 charnock + ! * skin parametrisation also off (would require radiative fluxes and + ! rainrate in input) + ! * added diagnostics, comments and references + !=============================================================================== + subroutine cor30a(ubt,vbt,tbt,qbt,rbt & ! in atm params + & ,uss,vss,tss,qss & ! in surf params + & ,zbl,zbu,zbt,zrfu,zrfq,zrft & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,L,usr,tsr,qsr & ! out: ss scales + & ,Cd,Ch,Ce & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + + ! !USES: + + IMPLICIT NONE + + ! !INPUT/OUTPUT PARAMETERS: + + real(R8),intent(in) :: ubt,vbt,tbt,qbt,rbt,uss,vss,tss,qss + real(R8),intent(in) :: zbl,zbu,zbt,zrfu,zrfq,zrft + real(R8),intent(out):: tau,hsb,hlb,zo,zot,zoq,L,usr,tsr,qsr,Cd,Ch,Ce & + & ,trf,qrf,urf,vrf + + real(R8) ua,va,ta,q,rb,us,vs,ts,qs,zi,zu,zt,zq,zru,zrq,zrt ! internal vars + + real(R8):: cpa,rgas,grav,pi,von,beta ! phys. params + real(R8):: le,rhoa,cpv ! derived phys. params + real(R8):: t,visa,du,dq,dt ! params of problem + + real(R8):: u10,zo10,zot10,cd10,ch10,ct10,ct,cc,ribu,zetu,l10,charn ! init vars + real(R8):: zet,rr,bf,ug,ut ! loop iter vars + real(R8):: cdn_10,chn_10,cen_10 ! aux. output vars + + integer(IN):: i,nits ! iter loop counters + + integer(IN):: jcool ! aux. cool-skin vars + real(R8):: dter,wetc,dqer + + ua=ubt !wind components (m/s) at height zu (m) + va=vbt + ta=tbt !bulk air temperature (K), height zt + Q =qbt !bulk air spec hum (kg/kg), height zq + rb=rbt ! air density + us=uss !surface current components (m/s) + vs=vss + ts=tss !bulk water temperature (K) if jcool=1, interface water T if jcool=0 + qs=qss !bulk water spec hum (kg/kg) if jcool=1 etc + zi=zbl !PBL depth (m) + zu=zbu !wind speed measurement height (m) + zt=zbt !air T measurement height (m) + zq=zbt !air q measurement height (m) + zru=zrfu ! reference height for st.diagn.U + zrq=zrfq ! reference height for st.diagn.T,q + zrt=zrft ! reference height for st.diagn.T,q + + !**** constants + Beta= 1.2_R8 + von = 0.4_R8 + pi = 3.141593_R8 + grav= SHR_CONST_G + Rgas= SHR_CONST_RGAS + cpa = SHR_CONST_CPDAIR + + !*** physical parameters + Le = SHR_CONST_LATVAP -.00237e6_R8*(ts-273.16_R8) + ! cpv = shr_const_cpdair*(1.0_R8 + shr_const_cpvir*Qs) ! form in NCAR code + cpv = cpa*(1.0_R8+0.84_R8*Q) + ! rhoa= P/(Rgas*ta*(1+0.61*Q)) ! if input were pressure + rhoa= rb + + ! parametrisation for air kinematic viscosity (Andreas 1989,p.31) + t = ta-273.16_R8 + visa= 1.326e-5_R8*(1.0_R8+6.542e-3_R8*t+8.301e-6_R8*t*t-4.84e-9_R8*t*t*t) + + du = sqrt((ua-us)**2+(va-vs)**2) + dt = ts-ta -.0098_R8*zt + dq = Qs-Q + + !*** don't use cool-skin params for now, but assign values to Ter and Qer + jcool=0_IN + dter=0.3_R8 + wetc=0.622_R8*Le*Qs/(Rgas*ts**2) + dqer=wetc*dter + + !***************** Begin bulk-model calculations *************** + + !*************** first guess + ug=0.5_R8 + + ut = sqrt(du*du+ug*ug) + u10 = ut*log(10.0_R8/1.0e-4_R8)/log(zu/1.0e-4_R8) + usr = .035_R8*u10 + zo10 = 0.011_R8*usr*usr/grav+0.11_R8*visa/usr + Cd10 = (von/log(10.0_R8/zo10))**2 + Ch10 = 0.00115_R8 + Ct10 = Ch10/sqrt(Cd10) + zot10= 10.0_R8/exp(von/Ct10) + Cd =(von/log(zu/zo10))**2 + Ct = von/log(zt/zot10) + CC = von*Ct/Cd + + ! Bulk Richardson number + Ribu=-grav*zu/ta*((dt-dter*jcool)+.61_R8*ta*dq)/ut**2 + ! initial guess for stability parameter... + if (Ribu .LT. 0.0_R8) then + ! pbl-height dependent + zetu=CC*Ribu/( 1.0_R8 - (.004_R8*Beta**3*zi/zu) * Ribu ) + else + zetu=CC*Ribu*(1.0_R8 + 27.0_R8/9.0_R8*Ribu/CC) + endif + ! ...and MO length + L10=zu/zetu + + if (zetu .GT. 50.0_R8) then + nits=1_IN + else + nits=3_IN + endif + + usr = ut*von/(log(zu/zo10)-psiuo(zu/L10)) + tsr = (dt-dter*jcool)*von/(log(zt/zot10)-psit_30(zt/L10)) + qsr = (dq-dqer*jcool)*von/(log(zq/zot10)-psit_30(zq/L10)) + + ! parametrisation for Charney parameter (section 3c of Fairall et al. 2003) + charn=0.011_R8 + if (ut .GT. 10.0_R8) then + charn=0.011_R8+(ut-10.0_R8)/(18.0_R8-10.0_R8)*(0.018_R8-0.011_R8) + endif + if (ut .GT. 18.0_R8) then + charn=0.018_R8 + endif + + !*************** iteration loop ************ + do i=1, nits + + ! stability parameter + zet=-von*grav*zu/ta*(tsr*(1.0_R8+0.61_R8*Q)+.61_R8*ta*qsr)/(usr*usr)/(1.0_R8+0.61_R8*Q) + + ! momentum roughness length... + zo = charn*usr*usr/grav+0.11_R8*visa/usr + ! ...& MO length + L = zu/zet + + ! tracer roughness length + rr = zo*usr/visa + zoq= min(1.15e-4_R8,5.5e-5_R8/rr**.6_R8) + zot= zoq ! N.B. same for vapour and heat + + ! new surface-layer scales + usr = ut *von/(log(zu/zo )-psiuo(zu/L)) + tsr = (dt-dter*jcool)*von/(log(zt/zot)-psit_30(zt/L)) + qsr = (dq-dqer*jcool)*von/(log(zq/zoq)-psit_30(zq/L)) + + ! gustiness parametrisation + Bf=-grav/ta*usr*(tsr+.61_R8*ta*qsr) + if (Bf .GT. 0.0_R8) then + ug=Beta*(Bf*zi)**.333_R8 + else + ug=.2_R8 + endif + ut=sqrt(du*du+ug*ug) + + enddo + !*************** end loop ************ + + !******** fluxes @ measurement heights zu,zt,zq ******** + tau= rhoa*usr*usr*du/ut !stress magnitude + hsb=-rhoa*cpa*usr*tsr !heat downwards + hlb=-rhoa*Le*usr*qsr !wv downwards + + !****** transfer coeffs relative to ut @meas. hts ****** + Cd= tau/rhoa/ut/max(.1_R8,du) + if (tsr.ne.0._r8) then + Ch= usr/ut*tsr/(dt-dter*jcool) + else + Ch= usr/ut* von/(log(zt/zot)-psit_30(zt/L)) + endif + if (qsr.ne.0.0_R8) then + Ce= usr/ut*qsr/(dq-dqer*jcool) + else + Ce= usr/ut* von/(log(zq/zoq)-psit_30(zq/L)) + endif + + !********** 10-m neutral coeff relative to ut ********* + Cdn_10=von*von/log(10.0_R8/zo)/log(10.0_R8/zo) + Chn_10=von*von/log(10.0_R8/zo)/log(10.0_R8/zot) + Cen_10=von*von/log(10.0_R8/zo)/log(10.0_R8/zoq) + + !********** reference-height values for u,q,T ********* + urf=us+(ua-us)*(log(zru/zo)-psiuo(zru/L))/(log(zu/zo)-psiuo(zu/L)) + vrf=vs+(va-vs)*(log(zru/zo)-psiuo(zru/L))/(log(zu/zo)-psiuo(zu/L)) + qrf=qs-dq*(log(zrq/zoq)-psit_30(zrq/L))/(log(zq/zoq)-psit_30(zq/L)) + trf=ts-dt*(log(zrt/zot)-psit_30(zrt/L))/(log(zt/zot)-psit_30(zt/L)) + trf=trf+.0098_R8*zrt + + end subroutine cor30a + + !=============================================================================== + ! !IROUTINE: PSIUo + ! + ! !DESCRIPTION: + ! + ! momentum stability functions adopted in COARE v3.0 parametrisation. + ! Chris Fairall's code (see cor30a) + ! + ! !REVISION HISTORY: + ! 22/11/2013: Thomas Toniazzo: comments added + !=============================================================================== + + real (R8) function psiuo(zet) + ! !INPUT/OUTPUT PARAMETERS: + real(R8),intent(in) :: zet + real(R8) ::c,x,psik,psic,f + !----------------------------------------------------------------- + ! N.B.: z0/L always neglected compared to z/L and to 1 + !----------------------------------------------------------------- + if(zet>0.0_R8)then + ! Beljaars & Holtslag (1991) + c=min(50._R8,.35_R8*zet) + psiuo=-((1.0_R8+1.0_R8*zet)**1.0_R8+.667_R8*(zet-14.28_R8)/exp(c)+8.525_R8) + else + ! Dyer & Hicks (1974) for weak instability + x=(1.0_R8-15.0_R8*zet)**.25_R8 ! 15 instead of 16 + psik=2.0_R8*log((1.0_R8+x)/2.0_R8)+log((1.0_R8+x*x)/2.0_R8)-2.0_R8*atan(x)+2.0_R8*atan(1.0_R8) + ! Fairall et al. (1996) for strong instability (Eq.(13)) + x=(1.0_R8-10.15_R8*zet)**.3333_R8 + psic= 1.5_R8*log((1.0_R8+x+x*x)/3.0_R8)-sqrt(3.0_R8)*atan((1.0_R8+2.0_R8*x)/sqrt(3.0_R8)) & + & +4.0_R8*atan(1.0_R8)/sqrt(3.0_R8) + f=zet*zet/(1.0_R8+zet*zet) + psiuo=(1.0_R8-f)*psik+f*psic + endif + END FUNCTION psiuo + + !=============================================================================== + ! !IROUTINE: PSIT_30 + ! + ! !DESCRIPTION: + ! + ! momentum stability functions adopted in COARE v3.0 parametrisation. + ! Chris Fairall's code (see cor30a) + ! + ! !REVISION HISTORY: + ! 22/11/2013: Thomas Toniazzo: comments added + !=============================================================================== + real (R8) function psit_30(zet) + ! !INPUT/OUTPUT PARAMETERS: + real(R8),intent(in) :: zet + ! !EOP + real(R8) ::c,x,psik,psic,f + !----------------------------------------------------------------- + ! N.B.: z0/L always neglected compared to z/L and to 1 + !----------------------------------------------------------------- + if(zet>0.0_R8)then + ! Beljaars & Holtslag (1991) + c=min(50._R8,.35_R8*zet) + psit_30=-((1.0_R8+2.0_R8/3.0_R8*zet)**1.5_R8+.667_R8*(zet-14.28_R8)/exp(c)+8.525_R8) + else + ! Dyer & Hicks (1974) for weak instability + x=(1.0_R8-15.0_R8*zet)**.5_R8 ! 15 instead of 16 + psik=2.0_R8*log((1.0_R8+x)/2.0_R8) + ! Fairall et al. (1996) for strong instability + x=(1.0_R8-(34.15_R8*zet))**.3333_R8 + psic= 1.5_R8*log((1.0_R8+x+x*x)/3.0_R8)-sqrt(3.0_R8)*atan((1.0_R8+2.0_R8*x)/sqrt(3.0_R8)) & + & +4.0_R8*atan(1.0_R8)/sqrt(3.0_R8) + f=zet*zet/(1.0_R8+zet*zet) + psit_30=(1.0_R8-f)*psik+f*psic + endif + end FUNCTION psit_30 + +end module shr_flux_mod diff --git a/cesm/nuopc_cap_share/glc_elevclass_mod.F90 b/cesm/nuopc_cap_share/glc_elevclass_mod.F90 new file mode 100644 index 000000000..3a984f642 --- /dev/null +++ b/cesm/nuopc_cap_share/glc_elevclass_mod.F90 @@ -0,0 +1,569 @@ +module glc_elevclass_mod + + !--------------------------------------------------------------------- + ! + ! Purpose: + ! + ! This module contains data and routines for operating on GLC elevation classes. + !--------------------------------------------------------------------- + +#include "shr_assert.h" + use shr_kind_mod , only : r8=>shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + + implicit none + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: glc_elevclass_init ! initialize GLC elevation class data + public :: glc_elevclass_clean ! deallocate memory allocated here + public :: glc_get_num_elevation_classes ! get the number of elevation classes + public :: glc_get_elevation_classes ! get elevation class of each grid cell on the glc grid. + public :: glc_get_elevation_class ! get the elevation class index for a given elevation + public :: glc_get_elevclass_bounds ! get the boundaries of all elevation classes + public :: glc_mean_elevation_virtual ! get the mean elevation of a virtual elevation class + public :: glc_elevclass_as_string ! returns a string corresponding to a given elevation class + public :: glc_get_fractional_icecov ! get the fractional ice cover for each glc elevation class + public :: glc_errcode_to_string ! convert an error code into a string describing the error + + interface glc_elevclass_init + module procedure glc_elevclass_init_default + module procedure glc_elevclass_init_override + end interface glc_elevclass_init + + interface glc_get_elevation_classes + module procedure glc_get_elevation_classes_with_bareland + module procedure glc_get_elevation_classes_without_bareland + end interface glc_get_elevation_classes + + !-------------------------------------------------------------------------- + ! Public data + !-------------------------------------------------------------------------- + + ! Possible error code values + integer, parameter, public :: GLC_ELEVCLASS_ERR_NONE = 0 ! err_code indicating no error + integer, parameter, public :: GLC_ELEVCLASS_ERR_UNDEFINED = 1 ! err_code indicating elevation classes have not been defined + integer, parameter, public :: GLC_ELEVCLASS_ERR_TOO_LOW = 2 ! err_code indicating topo below lowest elevation class + integer, parameter, public :: GLC_ELEVCLASS_ERR_TOO_HIGH = 3 ! err_code indicating topo above highest elevation class + + ! String length for glc elevation classes represented as strings + integer, parameter, public :: GLC_ELEVCLASS_STRLEN = 2 + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! number of elevation classes + integer :: glc_nec + + ! upper elevation limit of each class (m) + ! indexing starts at 0, with topomax(0) giving the lower elevation limit of EC 1 + real(r8), allocatable :: topomax(:) + +contains + + !----------------------------------------------------------------------- + subroutine glc_elevclass_init_default(my_glc_nec, logunit) + ! + ! !DESCRIPTION: + ! Initialize GLC elevation class data to default boundaries, based on given glc_nec + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: my_glc_nec ! number of GLC elevation classes + integer, intent(in), optional :: logunit + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'glc_elevclass_init' + !----------------------------------------------------------------------- + + glc_nec = my_glc_nec + if (.not. allocated(topomax)) allocate(topomax(0:glc_nec)) + + select case (glc_nec) + case(0) + ! do nothing + case(1) + topomax = [0._r8, 10000._r8] + case(3) + topomax = [0._r8, 1000._r8, 2000._r8, 10000._r8] + case(5) + topomax = [0._r8, 500._r8, 1000._r8, 1500._r8, 2000._r8, 10000._r8] + case(10) + topomax = [0._r8, 200._r8, 400._r8, 700._r8, 1000._r8, 1300._r8, & + 1600._r8, 2000._r8, 2500._r8, 3000._r8, 10000._r8] + case(36) + topomax = [ 0._r8, 200._r8, 400._r8, 600._r8, 800._r8, & + 1000._r8, 1200._r8, 1400._r8, 1600._r8, 1800._r8, & + 2000._r8, 2200._r8, 2400._r8, 2600._r8, 2800._r8, & + 3000._r8, 3200._r8, 3400._r8, 3600._r8, 3800._r8, & + 4000._r8, 4200._r8, 4400._r8, 4600._r8, 4800._r8, & + 5000._r8, 5200._r8, 5400._r8, 5600._r8, 5800._r8, & + 6000._r8, 6200._r8, 6400._r8, 6600._r8, 6800._r8, & + 7000._r8, 10000._r8] + case default + if (present(logunit)) then + write(logunit,*) subname,' ERROR: unknown glc_nec: ', glc_nec + end if + call shr_sys_abort(subname//' ERROR: unknown glc_nec') + end select + + end subroutine glc_elevclass_init_default + + !----------------------------------------------------------------------- + subroutine glc_elevclass_init_override(my_glc_nec, my_topomax) + ! + ! !DESCRIPTION: + ! Initialize GLC elevation class data to the given elevation class boundaries. + ! + ! The input, my_topomax, should have (my_glc_nec + 1) elements. + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: my_glc_nec ! number of GLC elevation classes + real(r8), intent(in) :: my_topomax(0:) ! elevation class boundaries (m) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_elevclass_init_override' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(my_topomax) == (/my_glc_nec/)), __FILE__, __LINE__) + + glc_nec = my_glc_nec + allocate(topomax(0:glc_nec)) + topomax = my_topomax + + end subroutine glc_elevclass_init_override + + !----------------------------------------------------------------------- + subroutine glc_elevclass_clean() + ! + ! !DESCRIPTION: + ! Deallocate memory allocated in this module + + character(len=*), parameter :: subname = 'glc_elevclass_clean' + !----------------------------------------------------------------------- + + if (allocated(topomax)) then + deallocate(topomax) + end if + glc_nec = 0 + + end subroutine glc_elevclass_clean + + !----------------------------------------------------------------------- + function glc_get_num_elevation_classes() result(num_elevation_classes) + ! + ! !DESCRIPTION: + ! Get the number of GLC elevation classes + ! + ! !ARGUMENTS: + integer :: num_elevation_classes ! function result + integer :: rc + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_get_num_elevation_classes' + !----------------------------------------------------------------------- + + num_elevation_classes = glc_nec + + end function glc_get_num_elevation_classes + + !----------------------------------------------------------------------- + subroutine glc_get_elevation_classes_without_bareland(glc_topo, glc_elevclass, logunit) + ! + ! !DESCRIPTION: + ! Get elevation class of each grid cell on the glc grid. + ! + ! This does not consider glc_frac: it simply gives the elevation class that the grid + ! cell would be in if it were ice-covered. So it never returns an elevation class of + ! 0 (bare land). (This design would allow us, in the future, to have glc grid cells + ! that are part ice-covered, part ice-free.) + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: glc_topo(:) ! topographic height + integer , intent(out) :: glc_elevclass(:) ! elevation class + integer , intent(in) :: logunit + ! + ! !LOCAL VARIABLES: + integer :: npts + integer :: glc_pt + integer :: err_code + + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_elevclass) + SHR_ASSERT_FL((size(glc_topo) == npts), __FILE__, __LINE__) + + do glc_pt = 1, npts + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), err_code) + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + ! Do nothing + case (GLC_ELEVCLASS_ERR_TOO_LOW, GLC_ELEVCLASS_ERR_TOO_HIGH) + write(logunit,*) subname, ': WARNING, for glc_pt, topo = ', glc_pt, glc_topo(glc_pt) + write(logunit,*) glc_errcode_to_string(err_code) + case default + write(logunit,*) subname, ': ERROR getting elevation class for glc_pt = ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end select + end do + + end subroutine glc_get_elevation_classes_without_bareland + + !----------------------------------------------------------------------- + subroutine glc_get_elevation_classes_with_bareland(glc_ice_covered, glc_topo, glc_elevclass, logunit) + ! + ! !DESCRIPTION: + ! Get the elevation class of each point on the glc grid. + ! For grid cells that are ice-free, the elevation class is set to 0. + ! All arguments (glc_ice_covered, glc_topo and glc_elevclass) must be the same size. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: glc_ice_covered(:) ! ice-covered (1) vs. ice-free (0) + real(r8), intent(in) :: glc_topo(:) ! ice topographic height + integer , intent(out) :: glc_elevclass(:) ! elevation class + integer , intent(in) :: logunit + ! + ! !LOCAL VARIABLES: + integer :: npts + integer :: glc_pt + integer :: err_code + + ! Tolerance for checking whether ice_covered is 0 or 1 + real(r8), parameter :: ice_covered_tol = 1.e-13 + + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_elevclass) + SHR_ASSERT_FL((size(glc_ice_covered) == npts), __FILE__, __LINE__) + SHR_ASSERT_FL((size(glc_topo) == npts), __FILE__, __LINE__) + + do glc_pt = 1, npts + if (abs(glc_ice_covered(glc_pt) - 1._r8) < ice_covered_tol) then + ! This is an ice-covered point + + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), err_code) + if ( err_code == GLC_ELEVCLASS_ERR_NONE .or. & + err_code == GLC_ELEVCLASS_ERR_TOO_LOW .or. & + err_code == GLC_ELEVCLASS_ERR_TOO_HIGH) then + ! These are all acceptable "errors" - it is even okay for these purposes if + ! the elevation is lower than the lower bound of elevation class 1, or + ! higher than the upper bound of the top elevation class. + + ! Do nothing + else + write(logunit,*) subname, ': ERROR getting elevation class for ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end if + else if (abs(glc_ice_covered(glc_pt) - 0._r8) < ice_covered_tol) then + ! This is a bare land point (no ice) + glc_elevclass(glc_pt) = 0 + else + ! glc_ice_covered is some value other than 0 or 1 + ! The lnd -> glc downscaling code would need to be reworked if we wanted to + ! handle a continuous fraction between 0 and 1. + write(logunit,*) subname, ': ERROR: glc_ice_covered must be 0 or 1' + write(logunit,*) 'glc_pt, glc_ice_covered = ', glc_pt, glc_ice_covered(glc_pt) + call shr_sys_abort(subname//': ERROR: glc_ice_covered must be 0 or 1') + end if + end do + + end subroutine glc_get_elevation_classes_with_bareland + + !----------------------------------------------------------------------- + subroutine glc_get_elevation_class(topo, elevation_class, err_code) + ! + ! !DESCRIPTION: + ! Get the elevation class index associated with a given topographic height. + ! + ! The returned elevation_class will be between 1 and num_elevation_classes, if this + ! topographic height is contained in an elevation class. In this case, err_code will + ! be GLC_ELEVCLASS_ERR_NONE (no error). + ! + ! If there are no elevation classes defined, the returned value will be 0, and + ! err_code will be GLC_ELEVCLASS_ERR_UNDEFINED + ! + ! If this topographic height is below the lowest elevation class, the returned value + ! will be 1, and err_code will be GLC_ELEVCLASS_ERR_TOO_LOW. + ! + ! If this topographic height is above the highest elevation class, the returned value + ! will be (num_elevation_classes), and err_code will be GLC_ELEVCLASS_ERR_TOO_HIGH. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: topo ! topographic height (m) + integer, intent(out) :: elevation_class ! elevation class index + integer, intent(out) :: err_code ! error code (see above for possible codes) + ! + ! !LOCAL VARIABLES: + integer :: ec ! temporary elevation class + + character(len=*), parameter :: subname = 'glc_get_elevation_class' + !----------------------------------------------------------------------- + + if (glc_nec < 1) then + elevation_class = 0 + err_code = GLC_ELEVCLASS_ERR_UNDEFINED + else if (topo < topomax(0)) then + elevation_class = 1 + err_code = GLC_ELEVCLASS_ERR_TOO_LOW + else if (topo >= topomax(glc_nec)) then + elevation_class = glc_nec + err_code = GLC_ELEVCLASS_ERR_TOO_HIGH + else + err_code = GLC_ELEVCLASS_ERR_NONE + elevation_class = 0 + do ec = 1, glc_nec + if (topo >= topomax(ec - 1) .and. topo < topomax(ec)) then + elevation_class = ec + exit + end if + end do + + SHR_ASSERT(elevation_class > 0, subname//' elevation class was not assigned') + + end if + + end subroutine glc_get_elevation_class + + !----------------------------------------------------------------------- + function glc_get_elevclass_bounds() result(elevclass_bounds) + ! + ! !DESCRIPTION: + ! Get the boundaries of all elevation classes. + ! + ! This returns an array of size glc_nec+1, since it contains both the lower and upper + ! bounds of each elevation class. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8) :: elevclass_bounds(0:glc_nec) ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_get_elevclass_bounds' + !----------------------------------------------------------------------- + + elevclass_bounds(:) = topomax(:) + + end function glc_get_elevclass_bounds + + !----------------------------------------------------------------------- + function glc_elevclass_as_string(elevation_class) result(ec_string) + ! + ! !DESCRIPTION: + ! Returns a string corresponding to a given elevation class. + ! + ! This string can be used as a suffix for fields in MCT attribute vectors. + ! This is still needed by dlnd in the data models - even if they have nuopc caps. + ! + ! ! NOTE(wjs, 2015-01-19) This function doesn't fully belong in this module, since it + ! doesn't refer to the data stored in this module. However, I can't think of a more + ! appropriate place for it. + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=GLC_ELEVCLASS_STRLEN) :: ec_string ! function result + integer, intent(in) :: elevation_class + ! + ! !LOCAL VARIABLES: + character(len=16) :: format_string + + character(len=*), parameter :: subname = 'glc_elevclass_as_string' + !----------------------------------------------------------------------- + + ! e.g., for GLC_ELEVCLASS_STRLEN = 2, format_string will be '(i2.2)' + write(format_string,'(a,i0,a,i0,a)') '(i', GLC_ELEVCLASS_STRLEN, '.', GLC_ELEVCLASS_STRLEN, ')' + + write(ec_string,trim(format_string)) elevation_class + end function glc_elevclass_as_string + + !----------------------------------------------------------------------- + function glc_mean_elevation_virtual(elevation_class, logunit) result(mean_elevation) + ! + ! !DESCRIPTION: + ! Returns the mean elevation of a virtual elevation class + ! + ! !ARGUMENTS: + real(r8) :: mean_elevation ! function result + integer, intent(in) :: elevation_class + integer, optional, intent(in) :: logunit + ! + ! !LOCAL VARIABLES: + integer :: resulting_elevation_class + integer :: err_code + + character(len=*), parameter :: subname = 'glc_mean_elevation_virtual' + !----------------------------------------------------------------------- + + if (elevation_class == 0) then + ! Bare land "elevation class" + mean_elevation = 0._r8 + else + if (elevation_class < glc_nec) then + ! Normal case + mean_elevation = (topomax(elevation_class - 1) + topomax(elevation_class)) / 2._r8 + else if (elevation_class == glc_nec) then + ! In the top elevation class; in this case, assignment of a "mean" elevation is + ! somewhat arbitrary (because we expect the upper bound of the top elevation + ! class to be very high). + + if (glc_nec > 1) then + mean_elevation = 2._r8 * topomax(elevation_class - 1) - topomax(elevation_class - 2) + else + ! entirely arbitrary + mean_elevation = 1000._r8 + end if + else + if (present(logunit)) then + write(logunit,*) subname,' ERROR: elevation class out of bounds: ', elevation_class + end if + call shr_sys_abort(subname // ' ERROR: elevation class out of bounds') + end if + end if + + ! Ensure that the resulting elevation is within the given elevation class + if (elevation_class > 0) then + call glc_get_elevation_class(mean_elevation, resulting_elevation_class, err_code) + if (err_code /= GLC_ELEVCLASS_ERR_NONE) then + if (present(logunit)) then + write(logunit,*) subname, ' ERROR: generated elevation that results in an error' + write(logunit,*) 'when trying to determine the resulting elevation class' + write(logunit,*) glc_errcode_to_string(err_code) + write(logunit,*) 'elevation_class, mean_elevation = ', elevation_class, mean_elevation + end if + call shr_sys_abort(subname // ' ERROR: generated elevation that results in an error') + else if (resulting_elevation_class /= elevation_class) then + if (present(logunit)) then + write(logunit,*) subname, ' ERROR: generated elevation outside the given elevation class' + write(logunit,*) 'elevation_class, mean_elevation, resulting_elevation_class = ', & + elevation_class, mean_elevation, resulting_elevation_class + end if + call shr_sys_abort(subname // ' ERROR: generated elevation outside the given elevation class') + end if + end if + + end function glc_mean_elevation_virtual + + !----------------------------------------------------------------------- + function glc_errcode_to_string(err_code) result(err_string) + ! + ! !DESCRIPTION: + ! + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=256) :: err_string ! function result + integer, intent(in) :: err_code ! error code (one of the GLC_ELEVCLASS_ERR* values) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_errcode_to_string' + !----------------------------------------------------------------------- + + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + err_string = '(no error)' + case (GLC_ELEVCLASS_ERR_UNDEFINED) + err_string = 'Elevation classes have not yet been defined' + case (GLC_ELEVCLASS_ERR_TOO_LOW) + err_string = 'Topographic height below the lower bound of the lowest elevation class' + case (GLC_ELEVCLASS_ERR_TOO_HIGH) + err_string = 'Topographic height above the upper bound of the highest elevation class' + case default + err_string = 'UNKNOWN ERROR' + end select + + end function glc_errcode_to_string + + !----------------------------------------------------------------------- + subroutine glc_get_fractional_icecov(nec, glc_topo, glc_icefrac, glc_icefrac_ec, logunit) + + !------------------ + ! Get the fractional ice cover for each glc elevation class + ! + ! First get elevation class of each grid cell on the glc grid. + ! This does not consider glc_frac: it simply gives the elevation class that the grid + ! cell would be in if it were ice-covered. So it never returns an elevation class of + ! 0 (bare land). (This design would allow us, in the future, to have glc grid cells + ! that are part ice-covered, part ice-free.) + !------------------ + + ! input/output variables + integer , intent(in) :: nec ! number of elevation classes + real(r8), intent(in) :: glc_topo(:) ! topographic height + real(r8), intent(in) :: glc_icefrac(:) + real(r8), intent(out) :: glc_icefrac_ec(:,:) + integer , intent(in) :: logunit + ! + ! local variables + integer , allocatable :: glc_elevclass(:) ! elevation class + integer :: npts + integer :: ec + integer :: glc_pt + integer :: err_code + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_topo) + allocate(glc_elevclass(npts)) + + do glc_pt = 1, npts + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), err_code) + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + ! Do nothing + case (GLC_ELEVCLASS_ERR_TOO_LOW, GLC_ELEVCLASS_ERR_TOO_HIGH) + write(logunit,*) subname, ': WARNING, for glc_pt, topo = ', glc_pt, glc_topo(glc_pt) + write(logunit,*) glc_errcode_to_string(err_code) + case default + write(logunit,*) subname, ': ERROR getting elevation class for glc_pt = ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end select + end do + + ! note that glc_elevclass gives the elevation class of each glc + ! grid cell, assuming that the grid cell is ice-covered. + ! glc_elevclass for a given glc gridcell spans [0 -> nec] + ! the first and undistributed dimension of glc_icefrac_ec spans [1 -> nec+1] + + do ec = 0, nec + do glc_pt = 1,npts + if (ec == 0) then + glc_icefrac_ec(ec+1,glc_pt) = 1._r8 - glc_icefrac(glc_pt) + else + if (glc_elevclass(glc_pt) == ec) then + glc_icefrac_ec(ec+1,glc_pt) = glc_icefrac(glc_pt) + else + glc_icefrac_ec(ec+1,glc_pt) = 0._r8 + end if + end if + end do + end do + + deallocate(glc_elevclass) + + end subroutine glc_get_fractional_icecov + +end module glc_elevclass_mod diff --git a/nuopc_cap_share/nuopc_shr_methods.F90 b/cesm/nuopc_cap_share/nuopc_shr_methods.F90 similarity index 100% rename from nuopc_cap_share/nuopc_shr_methods.F90 rename to cesm/nuopc_cap_share/nuopc_shr_methods.F90 diff --git a/cesm/nuopc_cap_share/seq_drydep_mod.F90 b/cesm/nuopc_cap_share/seq_drydep_mod.F90 new file mode 100644 index 000000000..34bb1423c --- /dev/null +++ b/cesm/nuopc_cap_share/seq_drydep_mod.F90 @@ -0,0 +1,1220 @@ +module seq_drydep_mod + + !======================================================================== + ! Module for handling dry depostion of tracers. + ! This module is shared by land and atmosphere models for the computations of + ! dry deposition of tracers + !======================================================================== + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8 => shr_kind_r8, CS => SHR_KIND_CS, CX => SHR_KIND_CX + use shr_const_mod , only : SHR_CONST_G, SHR_CONST_RDAIR, SHR_CONST_CPDAIR, SHR_CONST_MWWV + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + use shr_log_mod , only : s_logunit => shr_log_Unit + use shr_infnan_mod , only : shr_infnan_posinf, assignment(=) + + implicit none + private + + ! public member functions + public :: seq_drydep_readnl ! Read namelist + public :: seq_drydep_init ! Initialization of drydep data + public :: seq_drydep_setHCoeff ! Calculate Henry's law coefficients + + ! private array sizes + integer, public, parameter :: n_species_table = 192 ! Number of species to work with + integer, private, parameter :: maxspc = 210 ! Maximum number of species + integer, private, parameter :: NSeas = 5 ! Number of seasons + integer, private, parameter :: NLUse = 11 ! Number of land-use types + + logical, private :: drydep_initialized = .false. + + ! public data members: + ! method specification + character(16),public,parameter :: DD_XATM = 'xactive_atm' ! dry-dep atmosphere + character(16),public,parameter :: DD_XLND = 'xactive_lnd' ! dry-dep land + character(16),public,parameter :: DD_TABL = 'table' ! dry-dep table (atm and lnd) + character(16),public :: drydep_method = DD_XLND ! Which option choosen + + real(r8), public, parameter :: ph = 1.e-5_r8 ! measure of the acidity (dimensionless) + + logical, public :: lnd_drydep ! If dry-dep fields passed + integer, public :: n_drydep = 0 ! Number in drypdep list + logical :: drydep_init = .false. ! has seq_drydep_init been called? + character(len=CS), public, dimension(maxspc) :: drydep_list = '' ! List of dry-dep species + + real(r8), public, allocatable, dimension(:) :: foxd ! reactivity factor for oxidation (dimensioness) + real(r8), public, allocatable, dimension(:) :: drat ! ratio of molecular diffusivity (D_H2O/D_species; dimensionless) + integer, public, allocatable, dimension(:) :: mapping ! mapping to species table + + ! --- Indices for each species --- + integer, public :: h2_ndx, ch4_ndx, co_ndx, pan_ndx, mpan_ndx, so2_ndx, o3_ndx, o3a_ndx, xpan_ndx + + !--------------------------------------------------------------------------- + ! Table 1 from Wesely, Atmos. Environment, 1989, p1293 + ! Table 2 from Sheih, microfiche PB86-218104 and Walcek, Atmos. Environment, 1986, p949 + ! Table 3-5 compiled by P. Hess + ! + ! index #1 : season + ! 1 -> midsummer with lush vegetation + ! 2 -> autumn with unharvested cropland + ! 3 -> late autumn after frost, no snow + ! 4 -> winter, snow on ground, and subfreezing + ! 5 -> transitional spring with partially green short annuals + ! + ! index #2 : landuse type + ! 1 -> urban land + ! 2 -> agricultural land + ! 3 -> range land + ! 4 -> deciduous forest + ! 5 -> coniferous forest + ! 6 -> mixed forest including wetland + ! 7 -> water, both salt and fresh + ! 8 -> barren land, mostly desert + ! 9 -> nonforested wetland + ! 10 -> mixed agricultural and range land + ! 11 -> rocky open areas with low growing shrubs + ! + ! JFL August 2000 + !--------------------------------------------------------------------------- + + !--------------------------------------------------------------------------- + ! table to parameterize the impact of soil moisture on the deposition of H2 and + ! CO on soils (from Sanderson et al., J. Atmos. Chem., 46, 15-28, 2003). + !--------------------------------------------------------------------------- + + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_a(NLUse) = & + (/ 0.000_r8, 0.000_r8, 0.270_r8, 0.000_r8, 0.000_r8, & + 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8/) + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_b(NLUse) = & + (/ 0.000_r8,-41.390_r8, -0.472_r8,-41.900_r8,-41.900_r8, & + -41.900_r8, 0.000_r8, 0.000_r8, 0.000_r8,-41.390_r8, 0.000_r8/) + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_c(NLUse) = & + (/ 0.000_r8, 16.850_r8, 1.235_r8, 19.700_r8, 19.700_r8, & + 19.700_r8, 0.000_r8, 0.000_r8, 0.000_r8, 17.700_r8, 1.000_r8/) + + !--- deposition of h2 and CO on soils + ! + !--- ri: Richardson number (dimensionless) + !--- rlu: Resistance of leaves in upper canopy (s.m-1) + !--- rac: Aerodynamic resistance to lower canopy (s.m-1) + !--- rgss: Ground surface resistance for SO2 (s.m-1) + !--- rgso: Ground surface resistance for O3 (s.m-1) + !--- rcls: Lower canopy resistance for SO2 (s.m-1) + !--- rclo: Lower canopy resistance for O3 (s.m-1) + ! + real(r8), public, dimension(NSeas,NLUse) :: ri, rlu, rac, rgss, rgso, rcls, rclo + + data ri (1,1:NLUse) & + /1.e36_r8, 60._r8, 120._r8, 70._r8, 130._r8, 100._r8,1.e36_r8,1.e36_r8, 80._r8, 100._r8, 150._r8/ + data rlu (1,1:NLUse) & + /1.e36_r8,2000._r8,2000._r8,2000._r8,2000._r8,2000._r8,1.e36_r8,1.e36_r8,2500._r8,2000._r8,4000._r8/ + data rac (1,1:NLUse) & + / 100._r8, 200._r8, 100._r8,2000._r8,2000._r8,2000._r8, 0._r8, 0._r8, 300._r8, 150._r8, 200._r8/ + data rgss(1,1:NLUse) & + / 400._r8, 150._r8, 350._r8, 500._r8, 500._r8, 100._r8, 0._r8,1000._r8, 0._r8, 220._r8, 400._r8/ + data rgso(1,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(1,1:NLUse) & + /1.e36_r8,2000._r8,2000._r8,2000._r8,2000._r8,2000._r8,1.e36_r8,1.e36_r8,2500._r8,2000._r8,4000._r8/ + data rclo(1,1:NLUse) & + /1.e36_r8,1000._r8,1000._r8,1000._r8,1000._r8,1000._r8,1.e36_r8,1.e36_r8,1000._r8,1000._r8,1000._r8/ + + data ri (2,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 250._r8, 500._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (2,1:NLUse) & + /1.e36_r8,9000._r8,9000._r8,9000._r8,4000._r8,8000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (2,1:NLUse) & + / 100._r8, 150._r8, 100._r8,1500._r8,2000._r8,1700._r8, 0._r8, 0._r8, 200._r8, 120._r8, 140._r8/ + data rgss(2,1:NLUse) & + / 400._r8, 200._r8, 350._r8, 500._r8, 500._r8, 100._r8, 0._r8,1000._r8, 0._r8, 300._r8, 400._r8/ + data rgso(2,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8, 800._r8, 180._r8, 200._r8/ + data rcls(2,1:NLUse) & + /1.e36_r8,9000._r8,9000._r8,9000._r8,2000._r8,4000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rclo(2,1:NLUse) & + /1.e36_r8, 400._r8, 400._r8, 400._r8,1000._r8, 600._r8,1.e36_r8,1.e36_r8, 400._r8, 400._r8, 400._r8/ + + data ri (3,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 250._r8, 500._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (3,1:NLUse) & + /1.e36_r8,1.e36_r8,9000._r8,9000._r8,4000._r8,8000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (3,1:NLUse) & + / 100._r8, 10._r8, 100._r8,1000._r8,2000._r8,1500._r8, 0._r8, 0._r8, 100._r8, 50._r8, 120._r8/ + data rgss(3,1:NLUse) & + / 400._r8, 150._r8, 350._r8, 500._r8, 500._r8, 200._r8, 0._r8,1000._r8, 0._r8, 200._r8, 400._r8/ + data rgso(3,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(3,1:NLUse) & + /1.e36_r8,1.e36_r8,9000._r8,9000._r8,3000._r8,6000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rclo(3,1:NLUse) & + /1.e36_r8,1000._r8, 400._r8, 400._r8,1000._r8, 600._r8,1.e36_r8,1.e36_r8, 800._r8, 600._r8, 600._r8/ + + data ri (4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 400._r8, 800._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,6000._r8,9000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (4,1:NLUse) & + / 100._r8, 10._r8, 10._r8,1000._r8,2000._r8,1500._r8, 0._r8, 0._r8, 50._r8, 10._r8, 50._r8/ + data rgss(4,1:NLUse) & + / 100._r8, 100._r8, 100._r8, 100._r8, 100._r8, 100._r8, 0._r8,1000._r8, 100._r8, 100._r8, 50._r8/ + data rgso(4,1:NLUse) & + / 600._r8,3500._r8,3500._r8,3500._r8,3500._r8,3500._r8,2000._r8, 400._r8,3500._r8,3500._r8,3500._r8/ + data rcls(4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,9000._r8, 200._r8, 400._r8,1.e36_r8,1.e36_r8,9000._r8,1.e36_r8,9000._r8/ + data rclo(4,1:NLUse) & + /1.e36_r8,1000._r8,1000._r8, 400._r8,1500._r8, 600._r8,1.e36_r8,1.e36_r8, 800._r8,1000._r8, 800._r8/ + + data ri (5,1:NLUse) & + /1.e36_r8, 120._r8, 240._r8, 140._r8, 250._r8, 190._r8,1.e36_r8,1.e36_r8, 160._r8, 200._r8, 300._r8/ + data rlu (5,1:NLUse) & + /1.e36_r8,4000._r8,4000._r8,4000._r8,2000._r8,3000._r8,1.e36_r8,1.e36_r8,4000._r8,4000._r8,8000._r8/ + data rac (5,1:NLUse) & + / 100._r8, 50._r8, 80._r8,1200._r8,2000._r8,1500._r8, 0._r8, 0._r8, 200._r8, 60._r8, 120._r8/ + data rgss(5,1:NLUse) & + / 500._r8, 150._r8, 350._r8, 500._r8, 500._r8, 200._r8, 0._r8,1000._r8, 0._r8, 250._r8, 400._r8/ + data rgso(5,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(5,1:NLUse) & + /1.e36_r8,4000._r8,4000._r8,4000._r8,2000._r8,3000._r8,1.e36_r8,1.e36_r8,4000._r8,4000._r8,8000._r8/ + data rclo(5,1:NLUse) & + /1.e36_r8,1000._r8, 500._r8, 500._r8,1500._r8, 700._r8,1.e36_r8,1.e36_r8, 600._r8, 800._r8, 800._r8/ + + !--------------------------------------------------------------------------- + ! ... roughness length + !--------------------------------------------------------------------------- + real(r8), public, dimension(NSeas,NLUse) :: z0 + + data z0 (1,1:NLUse) & + /1.000_r8,0.250_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.150_r8,0.100_r8,0.100_r8/ + data z0 (2,1:NLUse) & + /1.000_r8,0.100_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.100_r8,0.080_r8,0.080_r8/ + data z0 (3,1:NLUse) & + /1.000_r8,0.005_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.100_r8,0.020_r8,0.060_r8/ + data z0 (4,1:NLUse) & + /1.000_r8,0.001_r8,0.001_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.001_r8,0.001_r8,0.040_r8/ + data z0 (5,1:NLUse) & + /1.000_r8,0.030_r8,0.020_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.010_r8,0.030_r8,0.060_r8/ + + !real(r8), private, dimension(11,5), parameter :: z0xxx = reshape ( & + ! (/ 1.000,0.250,0.050,1.000,1.000,1.000,0.0006,0.002,0.150,0.100,0.100 , & + ! 1.000,0.100,0.050,1.000,1.000,1.000,0.0006,0.002,0.100,0.080,0.080 , & + ! 1.000,0.005,0.050,1.000,1.000,1.000,0.0006,0.002,0.100,0.020,0.060 , & + ! 1.000,0.001,0.001,1.000,1.000,1.000,0.0006,0.002,0.001,0.001,0.040 , & + ! 1.000,0.030,0.020,1.000,1.000,1.000,0.0006,0.002,0.010,0.030,0.060 /), (/11,5/) ) + + !--------------------------------------------------------------------------- + ! public chemical data + !--------------------------------------------------------------------------- + + !--- data for foxd (reactivity factor for oxidation) ---- + real(r8), public, parameter :: dfoxd(n_species_table) = & + (/ 1._r8 & ! OX + ,1._r8 & ! H2O2 + ,1._r8 & ! OH + ,.1_r8 & ! HO2 + ,1.e-36_r8 & ! CO + ,1.e-36_r8 & ! CH4 + ,1._r8 & ! CH3O2 + ,1._r8 & ! CH3OOH + ,1._r8 & ! CH2O + ,1._r8 & ! HCOOH + ,0._r8 & ! NO + ,.1_r8 & ! NO2 + ,1.e-36_r8 & ! HNO3 + ,1.e-36_r8 & ! CO2 + ,1.e-36_r8 & ! NH3 + ,.1_r8 & ! N2O5 + ,1._r8 & ! NO3 + ,1._r8 & ! CH3OH + ,.1_r8 & ! HO2NO2 + ,1._r8 & ! O1D + ,1.e-36_r8 & ! C2H6 + ,.1_r8 & ! C2H5O2 + ,.1_r8 & ! PO2 + ,.1_r8 & ! MACRO2 + ,.1_r8 & ! ISOPO2 + ,1.e-36_r8 & ! C4H10 + ,1._r8 & ! CH3CHO + ,1._r8 & ! C2H5OOH + ,1.e-36_r8 & ! C3H6 + ,1._r8 & ! POOH + ,1.e-36_r8 & ! C2H4 + ,.1_r8 & ! PAN + ,1._r8 & ! CH3COOOH + ,1.e-36_r8 & ! MTERP + ,1._r8 & ! GLYOXAL + ,1._r8 & ! CH3COCHO + ,1._r8 & ! GLYALD + ,.1_r8 & ! CH3CO3 + ,1.e-36_r8 & ! C3H8 + ,.1_r8 & ! C3H7O2 + ,1._r8 & ! CH3COCH3 + ,1._r8 & ! C3H7OOH + ,.1_r8 & ! RO2 + ,1._r8 & ! ROOH + ,1.e-36_r8 & ! Rn + ,1.e-36_r8 & ! ISOP + ,1._r8 & ! MVK + ,1._r8 & ! MACR + ,1._r8 & ! C2H5OH + ,1._r8 & ! ONITR + ,.1_r8 & ! ONIT + ,.1_r8 & ! ISOPNO3 + ,1._r8 & ! HYDRALD + ,1.e-36_r8 & ! HCN + ,1.e-36_r8 & ! CH3CN + ,1.e-36_r8 & ! SO2 + ,0.1_r8 & ! SOAGff0 + ,0.1_r8 & ! SOAGff1 + ,0.1_r8 & ! SOAGff2 + ,0.1_r8 & ! SOAGff3 + ,0.1_r8 & ! SOAGff4 + ,0.1_r8 & ! SOAGbg0 + ,0.1_r8 & ! SOAGbg1 + ,0.1_r8 & ! SOAGbg2 + ,0.1_r8 & ! SOAGbg3 + ,0.1_r8 & ! SOAGbg4 + ,0.1_r8 & ! SOAG0 + ,0.1_r8 & ! SOAG1 + ,0.1_r8 & ! SOAG2 + ,0.1_r8 & ! SOAG3 + ,0.1_r8 & ! SOAG4 + ,0.1_r8 & ! IVOC + ,0.1_r8 & ! SVOC + ,0.1_r8 & ! IVOCbb + ,0.1_r8 & ! IVOCff + ,0.1_r8 & ! SVOCbb + ,0.1_r8 & ! SVOCff + ,1.e-36_r8 & ! N2O + ,1.e-36_r8 & ! H2 + ,1.e-36_r8 & ! C2H2 + ,1._r8 & ! CH3COOH + ,1._r8 & ! EOOH + ,1._r8 & ! HYAC + ,1.e-36_r8 & ! BIGENE + ,1.e-36_r8 & ! BIGALK + ,1._r8 & ! MEK + ,1._r8 & ! MEKOOH + ,1._r8 & ! MACROOH + ,1._r8 & ! MPAN + ,1._r8 & ! ALKNIT + ,1._r8 & ! NOA + ,1._r8 & ! ISOPNITA + ,1._r8 & ! ISOPNITB + ,1._r8 & ! ISOPNOOH + ,1._r8 & ! NC4CHO + ,1._r8 & ! NC4CH2OH + ,1._r8 & ! TERPNIT + ,1._r8 & ! NTERPOOH + ,1._r8 & ! ALKOOH + ,1._r8 & ! BIGALD + ,1._r8 & ! HPALD + ,1._r8 & ! IEPOX + ,1._r8 & ! XOOH + ,1._r8 & ! ISOPOOH + ,1.e-36_r8 & ! TOLUENE + ,1._r8 & ! CRESOL + ,1._r8 & ! TOLOOH + ,1.e-36_r8 & ! BENZENE + ,1._r8 & ! PHENOL + ,1._r8 & ! BEPOMUC + ,1._r8 & ! PHENOOH + ,1._r8 & ! C6H5OOH + ,1._r8 & ! BENZOOH + ,1._r8 & ! BIGALD1 + ,1._r8 & ! BIGALD2 + ,1._r8 & ! BIGALD3 + ,1._r8 & ! BIGALD4 + ,1._r8 & ! TEPOMUC + ,1._r8 & ! BZOOH + ,1._r8 & ! BZALD + ,1._r8 & ! PBZNIT + ,1.e-36_r8 & ! XYLENES + ,1._r8 & ! XYLOL + ,1._r8 & ! XYLOLOOH + ,1._r8 & ! XYLENOOH + ,1.e-36_r8 & ! BCARY + ,1._r8 & ! TERPOOH + ,1._r8 & ! TERPROD1 + ,1._r8 & ! TERPROD2 + ,1._r8 & ! TERP2OOH + ,1.e-36_r8 & ! DMS + ,1.e-36_r8 & ! H2SO4 + ,1._r8 & ! HONITR + ,1._r8 & ! MACRN + ,1._r8 & ! MVKN + ,1._r8 & ! ISOPN2B + ,1._r8 & ! ISOPN3B + ,1._r8 & ! ISOPN4D + ,1._r8 & ! ISOPN1D + ,1._r8 & ! ISOPNOOHD + ,1._r8 & ! ISOPNOOHB + ,1._r8 & ! ISOPNBNO3 + ,1._r8 & ! NO3CH2CHO + ,1._r8 & ! HYPERACET + ,1._r8 & ! HCOCH2OOH + ,1._r8 & ! DHPMPAL + ,1._r8 & ! MVKOOH + ,1._r8 & ! ISOPOH + ,1._r8 & ! ISOPFDN + ,1._r8 & ! ISOPFNP + ,1._r8 & ! INHEB + ,1._r8 & ! HMHP + ,1._r8 & ! HPALD1 + ,1._r8 & ! INHED + ,1._r8 & ! HPALD4 + ,1._r8 & ! ISOPHFP + ,1._r8 & ! HPALDB1C + ,1._r8 & ! HPALDB4C + ,1._r8 & ! ICHE + ,1._r8 & ! ISOPFDNC + ,1._r8 & ! ISOPFNC + ,1._r8 & ! TERPNT + ,1._r8 & ! TERPNS + ,1._r8 & ! TERPNT1 + ,1._r8 & ! TERPNS1 + ,1._r8 & ! TERPNPT + ,1._r8 & ! TERPNPS + ,1._r8 & ! TERPNPT1 + ,1._r8 & ! TERPNPS1 + ,1._r8 & ! TERPFDN + ,1._r8 & ! SQTN + ,1._r8 & ! TERPHFN + ,1._r8 & ! TERP1OOH + ,1._r8 & ! TERPDHDP + ,1._r8 & ! TERPF2 + ,1._r8 & ! TERPF1 + ,1._r8 & ! TERPA + ,1._r8 & ! TERPA2 + ,1._r8 & ! TERPK + ,1._r8 & ! TERPAPAN + ,1._r8 & ! TERPACID + ,1._r8 & ! TERPA2PAN + ,1.e-36_r8 & ! APIN + ,1.e-36_r8 & ! BPIN + ,1.e-36_r8 & ! LIMON + ,1.e-36_r8 & ! MYRC + ,1._r8 & ! TERPACID2 + ,1._r8 & ! TERPACID3 + ,1._r8 & ! TERPA3PAN + ,1._r8 & ! TERPOOHL + ,1._r8 & ! TERPA3 + ,1._r8 & ! TERP2AOOH + /) + + ! PRIVATE DATA: + + Interface seq_drydep_setHCoeff ! overload subroutine + Module Procedure set_hcoeff_scalar + Module Procedure set_hcoeff_vector + End Interface + + real(r8), private, parameter :: small_value = 1.e-36_r8 !--- smallest value to use --- + + !--------------------------------------------------------------------------- + ! private chemical data + !--------------------------------------------------------------------------- + + !--- Names of species that can work with --- + character(len=20), public, parameter :: species_name_table(n_species_table) = & + (/ 'OX ' & + ,'H2O2 ' & + ,'OH ' & + ,'HO2 ' & + ,'CO ' & + ,'CH4 ' & + ,'CH3O2 ' & + ,'CH3OOH ' & + ,'CH2O ' & + ,'HCOOH ' & + ,'NO ' & + ,'NO2 ' & + ,'HNO3 ' & + ,'CO2 ' & + ,'NH3 ' & + ,'N2O5 ' & + ,'NO3 ' & + ,'CH3OH ' & + ,'HO2NO2 ' & + ,'O1D ' & + ,'C2H6 ' & + ,'C2H5O2 ' & + ,'PO2 ' & + ,'MACRO2 ' & + ,'ISOPO2 ' & + ,'C4H10 ' & + ,'CH3CHO ' & + ,'C2H5OOH ' & + ,'C3H6 ' & + ,'POOH ' & + ,'C2H4 ' & + ,'PAN ' & + ,'CH3COOOH ' & + ,'MTERP ' & + ,'GLYOXAL ' & + ,'CH3COCHO ' & + ,'GLYALD ' & + ,'CH3CO3 ' & + ,'C3H8 ' & + ,'C3H7O2 ' & + ,'CH3COCH3 ' & + ,'C3H7OOH ' & + ,'RO2 ' & + ,'ROOH ' & + ,'Rn ' & + ,'ISOP ' & + ,'MVK ' & + ,'MACR ' & + ,'C2H5OH ' & + ,'ONITR ' & + ,'ONIT ' & + ,'ISOPNO3 ' & + ,'HYDRALD ' & + ,'HCN ' & + ,'CH3CN ' & + ,'SO2 ' & + ,'SOAGff0 ' & + ,'SOAGff1 ' & + ,'SOAGff2 ' & + ,'SOAGff3 ' & + ,'SOAGff4 ' & + ,'SOAGbg0 ' & + ,'SOAGbg1 ' & + ,'SOAGbg2 ' & + ,'SOAGbg3 ' & + ,'SOAGbg4 ' & + ,'SOAG0 ' & + ,'SOAG1 ' & + ,'SOAG2 ' & + ,'SOAG3 ' & + ,'SOAG4 ' & + ,'IVOC ' & + ,'SVOC ' & + ,'IVOCbb ' & + ,'IVOCff ' & + ,'SVOCbb ' & + ,'SVOCff ' & + ,'N2O ' & + ,'H2 ' & + ,'C2H2 ' & + ,'CH3COOH ' & + ,'EOOH ' & + ,'HYAC ' & + ,'BIGENE ' & + ,'BIGALK ' & + ,'MEK ' & + ,'MEKOOH ' & + ,'MACROOH ' & + ,'MPAN ' & + ,'ALKNIT ' & + ,'NOA ' & + ,'ISOPNITA ' & + ,'ISOPNITB ' & + ,'ISOPNOOH ' & + ,'NC4CHO ' & + ,'NC4CH2OH ' & + ,'TERPNIT ' & + ,'NTERPOOH ' & + ,'ALKOOH ' & + ,'BIGALD ' & + ,'HPALD ' & + ,'IEPOX ' & + ,'XOOH ' & + ,'ISOPOOH ' & + ,'TOLUENE ' & + ,'CRESOL ' & + ,'TOLOOH ' & + ,'BENZENE ' & + ,'PHENOL ' & + ,'BEPOMUC ' & + ,'PHENOOH ' & + ,'C6H5OOH ' & + ,'BENZOOH ' & + ,'BIGALD1 ' & + ,'BIGALD2 ' & + ,'BIGALD3 ' & + ,'BIGALD4 ' & + ,'TEPOMUC ' & + ,'BZOOH ' & + ,'BZALD ' & + ,'PBZNIT ' & + ,'XYLENES ' & + ,'XYLOL ' & + ,'XYLOLOOH ' & + ,'XYLENOOH ' & + ,'BCARY ' & + ,'TERPOOH ' & + ,'TERPROD1 ' & + ,'TERPROD2 ' & + ,'TERP2OOH ' & + ,'DMS ' & + ,'H2SO4 ' & + ,'HONITR ' & + ,'MACRN ' & + ,'MVKN ' & + ,'ISOPN2B ' & + ,'ISOPN3B ' & + ,'ISOPN4D ' & + ,'ISOPN1D ' & + ,'ISOPNOOHD' & + ,'ISOPNOOHB' & + ,'ISOPNBNO3' & + ,'NO3CH2CHO' & + ,'HYPERACET' & + ,'HCOCH2OOH' & + ,'DHPMPAL ' & + ,'MVKOOH ' & + ,'ISOPOH ' & + ,'ISOPFDN ' & + ,'ISOPFNP ' & + ,'INHEB ' & + ,'HMHP ' & + ,'HPALD1 ' & + ,'INHED ' & + ,'HPALD4 ' & + ,'ISOPHFP ' & + ,'HPALDB1C ' & + ,'HPALDB4C ' & + ,'ICHE ' & + ,'ISOPFDNC ' & + ,'ISOPFNC ' & + ,'TERPNT ' & + ,'TERPNS ' & + ,'TERPNT1 ' & + ,'TERPNS1 ' & + ,'TERPNPT ' & + ,'TERPNPS ' & + ,'TERPNPT1 ' & + ,'TERPNPS1 ' & + ,'TERPFDN ' & + ,'SQTN ' & + ,'TERPHFN ' & + ,'TERP1OOH ' & + ,'TERPDHDP ' & + ,'TERPF2 ' & + ,'TERPF1 ' & + ,'TERPA ' & + ,'TERPA2 ' & + ,'TERPK ' & + ,'TERPAPAN ' & + ,'TERPACID ' & + ,'TERPA2PAN' & + ,'APIN ' & + ,'BPIN ' & + ,'LIMON ' & + ,'MYRC ' & + ,'TERPACID2' & + ,'TERPACID3' & + ,'TERPA3PAN' & + ,'TERPOOHL ' & + ,'TERPA3 ' & + ,'TERP2AOOH' & + /) + + !--- data for effective Henry's Law coefficient --- + real(r8), public, parameter :: dheff(n_species_table*6) = & + (/1.03e-02_r8, 2830._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! OX + ,8.70e+04_r8, 7320._r8,2.2e-12_r8,-3730._r8,0._r8 , 0._r8 & ! H2O2 + ,3.90e+01_r8, 4300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! OH + ,6.90e+02_r8, 5900._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HO2 + ,9.81e-04_r8, 1650._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CO + ,1.41e-03_r8, 1820._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH4 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3O2 + ,3.00e+02_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3OOH + ,3.23e+03_r8, 7100._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH2O + ,8.90e+03_r8, 6100._r8,1.8e-04_r8, -20._r8,0._r8 , 0._r8 & ! HCOOH + ,1.92e-03_r8, 1762._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO + ,1.20e-02_r8, 2440._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO2 + ,2.10e+05_r8, 8700._r8,2.2e+01_r8, 0._r8,0._r8 , 0._r8 & ! HNO3 + ,3.44e-02_r8, 2715._r8,4.3e-07_r8,-1000._r8,4.7e-11_r8,-1760._r8 & ! CO2 + ,6.02e+01_r8, 4160._r8,1.7e-05_r8,-4325._r8,1.0e-14_r8,-6716._r8 & ! NH3 + ,2.14e+00_r8, 3362._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! N2O5 + ,3.80e-02_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO3 + ,2.03e+02_r8, 5645._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3OH + ,4.00e+01_r8, 8400._r8,1.3e-06_r8, 0._r8,0._r8 , 0._r8 & ! HO2NO2 + ,1.00e-16_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! O1D + ,1.88e-03_r8, 2750._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H6 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H5O2 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PO2 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACRO2 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPO2 + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C4H10 + ,1.29e+01_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3CHO + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H5OOH + ,5.57e-03_r8, 2800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H6 + ,1.50e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! POOH + ,5.96e-03_r8, 2200._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H4 + ,2.80e+00_r8, 5730._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PAN + ,8.37e+02_r8, 5310._r8,1.8e-04_r8, -20._r8,0._r8 , 0._r8 & ! CH3COOOH + ,2.94e-02_r8, 1800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MTERP + ,4.19e+05_r8, 7480._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! GLYOXAL + ,3.50e+03_r8, 7545._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3COCHO + ,4.00e+04_r8, 4630._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! GLYALD + ,1.00e-01_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3CO3 + ,1.51e-03_r8, 3120._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H8 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H7O2 + ,2.78e+01_r8, 5530._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3COCH3 + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H7OOH + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! RO2 + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ROOH + ,0.00e+00_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! Rn + ,3.45e-02_r8, 4400._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOP + ,4.10e+01_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MVK + ,6.50e+00_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACR + ,1.90e+02_r8, 6500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H5OH + ,1.44e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ONITR + ,1.00e+03_r8, 6000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ONIT + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNO3 + ,1.10e+05_r8, 6000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HYDRALD + ,9.02e+00_r8, 8258._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HCN + ,5.28e+01_r8, 3970._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3CN + ,1.36e+00_r8, 3100._r8,1.30e-02_r8,1960._r8,6.6e-08_r8, 1500._r8 & ! SO2 + ,1.3e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff0 + ,3.2e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff1 + ,4.0e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff2 + ,1.3e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff3 + ,1.6e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff4 + ,7.9e+11_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg0 + ,6.3e+10_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg1 + ,3.2e+09_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg2 + ,6.3e+08_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg3 + ,3.2e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg4 + ,4.0e+11_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG0 + ,3.2e+10_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG1 + ,1.6e+09_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG2 + ,3.2e+08_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG3 + ,1.6e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG4 + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IVOC + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SVOC + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IVOCbb + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IVOCff + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SVOCbb + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SVOCff + ,2.42e-02_r8, 2710._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! N2O + ,7.9e-04_r8, 530._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! H2 + ,4.14e-02_r8, 1890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H2 + ,4.1e+03_r8, 6200._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3COOH + ,1.9e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! EOOH + ,1.46e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HYAC + ,5.96e-03_r8, 2365._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGENE + ,1.24e-03_r8, 3010._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALK + ,1.80e+01_r8, 5740._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MEK + ,6.4e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MEKOOH + ,4.4e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACROOH + ,1.72e+00_r8, 5700._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MPAN + ,1.01e+00_r8, 5790._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ALKNIT + ,1.e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NOA + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNITA + ,4.82e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNITB + ,8.75e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNOOH + ,1.46e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NC4CHO + ,4.02e+04_r8, 9500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NC4CH2OH + ,8.41e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNIT + ,6.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NTERPOOH + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ALKOOH + ,9.6e+00_r8, 6220._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD + ,2.30e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALD + ,3.e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IEPOX + ,1.e+11_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XOOH + ,3.5e+06_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPOOH + ,1.5e-01_r8, 4300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TOLUENE + ,5.67e+02_r8, 5800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CRESOL + ,2.30e+04_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TOLOOH + ,1.8e-01_r8, 3800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BENZENE + ,2.84e+03_r8, 2700._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PHENOL + ,3.e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BEPOMUC + ,1.5e+06_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PHENOOH + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C6H5OOH + ,2.3e+03_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BENZOOH + ,1.e+05_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD1 + ,2.9e+04_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD2 + ,2.2e+04_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD3 + ,2.2e+04_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD4 + ,2.5e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TEPOMUC + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BZOOH + ,3.24e+01_r8, 6300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BZALD + ,2.8e+00_r8, 5730._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PBZNIT + ,2.e-01_r8, 4300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLENES + ,1.01e+03_r8, 6800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLOL + ,1.9e+06_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLOLOOH + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLENOOH + ,5.57e-03_r8, 2800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BCARY + ,3.6e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPOOH + ,3.92e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPROD1 + ,7.20e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPROD2 + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERP2OOH + ,5.4e-01_r8, 3460._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! DMS + ,1.e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! H2SO4 + ,2.64e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HONITR + ,4.14e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACRN + ,1.84e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MVKN + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN2B + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN3B + ,4.82e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN4D + ,4.82e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN1D + ,9.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNOOHD + ,6.61e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNOOHB + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNBNO3 + ,3.39e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO3CH2CHO + ,1.16e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HYPERACET + ,2.99e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HCOCH2OOH + ,9.37e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! DHPMPAL + ,1.24e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MVKOOH + ,8.77e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPOH + ,5.02e+08_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFDN + ,2.97e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFNP + ,1.05e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! INHEB + ,1.70e+06_r8, 9870._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HMHP + ,2.30e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALD1 + ,1.51e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! INHED + ,2.30e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALD4 + ,7.60e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPHFP + ,5.43e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALDB1C + ,5.43e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALDB4C + ,2.09e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ICHE + ,7.16e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFDNC + ,1.41e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFNC + ,8.41e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNT + ,8.41e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNS + ,8.55e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNT1 + ,8.55e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNS1 + ,6.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPT + ,6.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPS + ,6.78e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPT1 + ,6.78e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPS1 + ,1.65e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPFDN + ,9.04e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SQTN + ,7.53e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPHFN + ,3.64e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERP1OOH + ,3.41e+14_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPDHDP + ,6.54e+01_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPF2 + ,4.05e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPF1 + ,3.92e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA + ,7.20e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA2 + ,6.39e+01_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPK + ,7.94e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPAPAN + ,5.63e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPACID + ,9.59e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA2PAN + ,2.94e-02_r8, 1800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! APIN + ,1.52e-02_r8, 4500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BPIN + ,4.86e-02_r8, 4600._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! LIMON + ,7.30e-02_r8, 2800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MYRC + ,2.64e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPACID2 + ,3.38e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPACID3 + ,1.23e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA3PAN + ,4.41e+12_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPOOHL + ,1.04e+08_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA3 + ,3.67e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERP2AOOH + /) + + real(r8), private, parameter :: wh2o = SHR_CONST_MWWV + real(r8), private, parameter :: mol_wgts(n_species_table) = & + (/ 47.9981995_r8, 34.0135994_r8, 17.0067997_r8, 33.0061989_r8, 28.0104008_r8, & + 16.0405998_r8, 47.0320015_r8, 48.0393982_r8, 30.0251999_r8, 46.0246010_r8, & + 30.0061398_r8, 46.0055389_r8, 63.0123405_r8, 44.0098000_r8, 17.0289402_r8, & + 108.010483_r8, 62.0049400_r8, 32.0400009_r8, 79.0117416_r8, 15.9994001_r8, & + 30.0664005_r8, 61.0578003_r8, 91.0830002_r8, 119.093399_r8, 117.119797_r8, & + 58.1180000_r8, 44.0509987_r8, 62.0652008_r8, 42.0774002_r8, 92.0904007_r8, & + 28.0515995_r8, 121.047943_r8, 76.0497971_r8, 136.228394_r8, 58.0355988_r8, & + 72.0614014_r8, 60.0503998_r8, 75.0423965_r8, 44.0922012_r8, 75.0836029_r8, & + 58.0768013_r8, 76.0910034_r8, 89.070126_r8, 90.078067_r8, 222.000000_r8, & + 68.1141968_r8, 70.0877991_r8, 70.0877991_r8, 46.0657997_r8, 147.125946_r8, & + 119.074341_r8, 162.117935_r8, 100.112999_r8, 27.0256_r8 , 41.0524_r8 , & + 64.064800_r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 170.3_r8, 170.3_r8, 170.3_r8, 170.3_r8, & + 170.3_r8, 170.3_r8, 44.0129_r8, 2.0148_r8, 26.0368_r8, & + 60.0504_r8, 78.0646_r8, 74.0762_r8, 56.1032_r8, 72.1438_r8, & + 72.1026_r8, 104.101_r8, 120.101_r8, 147.085_r8, 133.141_r8, & + 119.074_r8, 147.126_r8, 147.126_r8, 163.125_r8, 145.111_r8, & + 147.126_r8, 215.24_r8, 231.24_r8, 104.143_r8, 98.0982_r8, & + 116.112_r8, 118.127_r8, 150.126_r8, 118.127_r8, 92.1362_r8, & + 108.136_r8, 174.148_r8, 78.1104_r8, 94.1098_r8, 126.109_r8, & + 176.122_r8, 110.109_r8, 160.122_r8, 84.0724_r8, 98.0982_r8, & + 98.0982_r8, 112.124_r8, 140.134_r8, 124.135_r8, 106.121_r8, & + 183.118_r8, 106.162_r8, 122.161_r8, 204.173_r8, 188.174_r8, & + 204.343_r8, 186.241_r8, 168.227_r8, 154.201_r8, 200.226_r8, & + 62.1324_r8, 98.0784_r8, 135.118733_r8, 149.102257_r8, 149.102257_r8, & + 147.129469_r8, 147.129469_r8, 147.129469_r8, 147.129469_r8, 163.128874_r8, & + 163.128874_r8, 147.129469_r8, 105.049617_r8, 90.078067_r8, 76.05145_r8, & + 136.103494_r8, 120.104089_r8, 102.131897_r8, 226.141733_r8, 197.143565_r8, & + 163.128874_r8, 64.040714_r8, 116.11542_r8, 163.128874_r8, 116.11542_r8, & + 150.130112_r8, 116.11542_r8, 116.11542_r8, 116.11542_r8, 224.125851_r8, & + 195.127684_r8, 215.246675_r8, 215.246675_r8, 215.246675_r8, 215.246675_r8, & + 231.24608_r8, 231.24608_r8, 231.24608_r8, 231.24608_r8, 294.258938_r8, & + 283.36388_r8, 265.260771_r8, 186.248507_r8, 236.262604_r8, 110.153964_r8, & + 168.233221_r8, 168.233221_r8, 154.206603_r8, 138.207199_r8, 245.229603_r8, & + 200.232031_r8, 231.202986_r8, 136.228394_r8, 136.228394_r8, 136.228394_r8, & + 136.228394_r8, 186.205413_r8, 202.204818_r8, 247.202391_r8, 218.247317_r8, & + 170.206008_r8, 186.248507_r8 /) + + +!=============================================================================== +CONTAINS +!=============================================================================== + + subroutine seq_drydep_readnl(NLFilename, drydep_nflds) + + !======================================================================== + ! reads drydep_inparm namelist and determines the number of drydep velocity + ! fields that are sent from the land component + !======================================================================== + + character(len=*), intent(in) :: NLFilename ! Namelist filename + integer, intent(out) :: drydep_nflds + + !----- local ----- + integer :: i ! Indices + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + type(ESMF_VM) :: vm + integer :: localPet + integer :: mpicom + integer :: rc + character(*),parameter :: F00 = "('(seq_drydep_read) ',8a)" + character(*),parameter :: FI1 = "('(seq_drydep_init) ',a,I2)" + character(*),parameter :: subName = '(seq_drydep_read) ' + !----------------------------------------------------------------------------- + + namelist /drydep_inparm/ drydep_list, drydep_method + + !----------------------------------------------------------------------------- + ! Read namelist and figure out the drydep field list to pass + ! First check if file exists and if not, n_drydep will be zero + !----------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 )then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (localPet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(s_logunit,F00) 'Read in drydep_inparm namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'drydep_inparm', ierr) + if (ierr == 0) then + ! Note that ierr /= 0, no namelist is present. + read(unitn, drydep_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of drydep_inparm namelist in seq_drydep_readnl') + end if + endif + close( unitn ) + end if + end if + call shr_mpi_bcast( drydep_list, mpicom ) + call shr_mpi_bcast( drydep_method, mpicom ) + + do i=1,maxspc + if(len_trim(drydep_list(i)) > 0) then + drydep_nflds=drydep_nflds+1 + endif + enddo + + ! set module variable + n_drydep = drydep_nflds + + ! Make sure method is valid and determine if land is passing drydep fields + lnd_drydep = (drydep_nflds>0 .and. drydep_method == DD_XLND) + if (localpet==0) then + write(s_logunit,*) 'seq_drydep_read: drydep_method: ', trim(drydep_method) + if ( drydep_nflds == 0 )then + write(s_logunit,F00) 'No dry deposition fields will be transfered' + else + write(s_logunit,FI1) 'Number of dry deposition fields transfered is ', drydep_nflds + end if + end if + + if ( trim(drydep_method)/=trim(DD_XATM) .and. & + trim(drydep_method)/=trim(DD_XLND) .and. & + trim(drydep_method)/=trim(DD_TABL) ) then + write(s_logunit,*) 'seq_drydep_read: drydep_method : ', trim(drydep_method) + write(s_logunit,*) 'seq_drydep_read: drydep_method must be set to : ', & + DD_XATM,', ', DD_XLND,', or ', DD_TABL + call shr_sys_abort('seq_drydep_read: incorrect dry deposition method specification') + endif + + if (.not. drydep_initialized) then + call seq_drydep_init() + end if + + end subroutine seq_drydep_readnl + +!==================================================================================== + + subroutine seq_drydep_init( ) + + !======================================================================== + ! Initialization of dry deposition fields + ! reads drydep_inparm namelist and sets up CCSM driver list of fields for + ! land-atmosphere communications. + !======================================================================== + + !----- local ----- + integer :: i, l ! Indices + character(len=32) :: test_name ! field test name + + !----- formats ----- + character(*),parameter :: subName = '(seq_drydep_init) ' + character(*),parameter :: F00 = "('(seq_drydep_init) ',8a)" + + !----------------------------------------------------------------------------- + ! Return if this routine has already been called (e.g. cam and clm both call this) + !----------------------------------------------------------------------------- + if(allocated(foxd)) return + !----------------------------------------------------------------------------- + ! Allocate and fill foxd, drat and mapping as well as species indices + !----------------------------------------------------------------------------- + + if ( n_drydep > 0 ) then + + allocate( foxd(n_drydep) ) + allocate( drat(n_drydep) ) + allocate( mapping(n_drydep) ) + + ! This initializes these variables to infinity. + foxd = shr_infnan_posinf + drat = shr_infnan_posinf + + mapping(:) = 0 + + end if + + h2_ndx=-1; ch4_ndx=-1; co_ndx=-1; mpan_ndx = -1; pan_ndx = -1; so2_ndx=-1; o3_ndx=-1; xpan_ndx=-1 + + !--- Loop over drydep species that need to be worked with --- + do i=1,n_drydep + if ( len_trim(drydep_list(i))==0 ) exit + + test_name = drydep_list(i) + + if( trim(test_name) == 'O3' ) then + test_name = 'OX' + end if + + !--- Figure out if species maps to a species in the species table --- + do l = 1,n_species_table + if( trim( test_name ) == trim( species_name_table(l) ) ) then + mapping(i) = l + exit + end if + end do + + !--- If it doesn't map to a species in the species table find species close enough --- + if( mapping(i) < 1 ) then + select case( trim(test_name) ) + case( 'O3S', 'O3INERT' ) + test_name = 'OX' + case( 'Pb' ) + test_name = 'HNO3' + case( 'SOGM','SOGI','SOGT','SOGB','SOGX' ) + test_name = 'CH3OOH' + case( 'SOA', 'SO4', 'CB1', 'CB2', 'OC1', 'OC2', 'NH4', 'SA1', 'SA2', 'SA3', 'SA4' ) + test_name = 'OX' ! this is just a place holder. values are explicitly set below + case( 'SOAM', 'SOAI', 'SOAT', 'SOAB', 'SOAX' ) + test_name = 'OX' ! this is just a place holder. values are explicitly set below + case( 'SOAGbb0' ) + test_name = 'SOAGff0' + case( 'SOAGbb1' ) + test_name = 'SOAGff1' + case( 'SOAGbb2' ) + test_name = 'SOAGff2' + case( 'SOAGbb3' ) + test_name = 'SOAGff3' + case( 'SOAGbb4' ) + test_name = 'SOAGff4' + case( 'O3A' ) + test_name = 'OX' + case( 'XMPAN' ) + test_name = 'MPAN' + case( 'XPAN' ) + test_name = 'PAN' + case( 'XNO' ) + test_name = 'NO' + case( 'XNO2' ) + test_name = 'NO2' + case( 'XHNO3' ) + test_name = 'HNO3' + case( 'XONIT' ) + test_name = 'ONIT' + case( 'XONITR' ) + test_name = 'ONITR' + case( 'XHO2NO2') + test_name = 'HO2NO2' + case( 'XNH4NO3' ) + test_name = 'HNO3' + case( 'NH4NO3' ) + test_name = 'HNO3' + case default + test_name = 'blank' + end select + + !--- If found a match check the species table again --- + if( trim(test_name) /= 'blank' ) then + do l = 1,n_species_table + if( trim( test_name ) == trim( species_name_table(l) ) ) then + mapping(i) = l + exit + end if + end do + else + write(s_logunit,F00) trim(drydep_list(i)),' not in tables; will have dep vel = 0' + call shr_sys_abort( subName//': '//trim(drydep_list(i))//' is not in tables' ) + end if + end if + + !--- Figure out the specific species indices --- + if ( trim(drydep_list(i)) == 'H2' ) h2_ndx = i + if ( trim(drydep_list(i)) == 'CO' ) co_ndx = i + if ( trim(drydep_list(i)) == 'CH4' ) ch4_ndx = i + if ( trim(drydep_list(i)) == 'MPAN' ) mpan_ndx = i + if ( trim(drydep_list(i)) == 'PAN' ) pan_ndx = i + if ( trim(drydep_list(i)) == 'SO2' ) so2_ndx = i + if ( trim(drydep_list(i)) == 'OX' .or. trim(drydep_list(i)) == 'O3' ) o3_ndx = i + if ( trim(drydep_list(i)) == 'O3A' ) o3a_ndx = i + if ( trim(drydep_list(i)) == 'XPAN' ) xpan_ndx = i + + if( mapping(i) > 0) then + l = mapping(i) + foxd(i) = dfoxd(l) + drat(i) = sqrt(mol_wgts(l)/wh2o) + endif + + enddo + + where( rgss < 1._r8 ) + rgss = 1._r8 + endwhere + + where( rac < small_value) + rac = small_value + endwhere + + drydep_initialized = .true. + + end subroutine seq_drydep_init + +!==================================================================================== + + subroutine set_hcoeff_scalar( sfc_temp, heff ) + + !======================================================================== + ! Interface to seq_drydep_setHCoeff when input is scalar + ! wrapper routine used when surface temperature is a scalar (single column) rather + ! than an array (multiple columns). + ! + ! !REVISION HISTORY: + ! 2008-Nov-12 - F. Vitt - first version + !======================================================================== + + implicit none + + real(r8), intent(in) :: sfc_temp ! Input surface temperature + real(r8), intent(out) :: heff(n_drydep) ! Output Henry's law coefficients + + !----- local ----- + real(r8) :: sfc_temp_tmp(1) ! surface temp + + sfc_temp_tmp(:) = sfc_temp + call set_hcoeff_vector( 1, sfc_temp_tmp, heff(:n_drydep) ) + + end subroutine set_hcoeff_scalar + +!==================================================================================== + + subroutine set_hcoeff_vector( ncol, sfc_temp, heff ) + + !======================================================================== + ! Interface to seq_drydep_setHCoeff when input is vector + ! sets dry depositions coefficients -- used by both land and atmosphere models + !======================================================================== + + integer, intent(in) :: ncol ! Input size of surface-temp vector + real(r8), intent(in) :: sfc_temp(ncol) ! Surface temperature + real(r8), intent(out) :: heff(ncol,n_drydep) ! Henry's law coefficients + + !----- local ----- + real(r8), parameter :: t0 = 298._r8 ! Standard Temperature + real(r8), parameter :: ph_inv = 1._r8/ph ! Inverse of PH + integer :: m, l, id ! indices + real(r8) :: e298 ! Henry's law coefficient @ standard temperature (298K) + real(r8) :: dhr ! temperature dependence of Henry's law coefficient + real(r8) :: dk1s(ncol) ! DK Work array 1 + real(r8) :: dk2s(ncol) ! DK Work array 2 + real(r8) :: wrk(ncol) ! Work array + + !----- formats ----- + character(*),parameter :: subName = '(seq_drydep_set_hcoeff) ' + character(*),parameter :: F00 = "('(seq_drydep_set_hcoeff) ',8a)" + + !------------------------------------------------------------------------------- + ! notes: + !------------------------------------------------------------------------------- + + wrk(:) = (t0 - sfc_temp(:))/(t0*sfc_temp(:)) + do m = 1,n_drydep + l = mapping(m) + id = 6*(l - 1) + e298 = dheff(id+1) + dhr = dheff(id+2) + heff(:,m) = e298*exp( dhr*wrk(:) ) + !--- Calculate coefficients based on the drydep tables --- + if( dheff(id+3) /= 0._r8 .and. dheff(id+5) == 0._r8 ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + where( heff(:,m) /= 0._r8 ) + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph_inv) + elsewhere + heff(:,m) = dk1s(:)*ph_inv + endwhere + end if + !--- For coefficients that are non-zero AND CO2 or NH3 handle things this way --- + if( dheff(id+5) /= 0._r8 ) then + if( trim( drydep_list(m) ) == 'CO2' .or. trim( drydep_list(m) ) == 'NH3' & + .or. trim( drydep_list(m) ) == 'SO2' ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + e298 = dheff(id+5) + dhr = dheff(id+6) + dk2s(:) = e298*exp( dhr*wrk(:) ) + !--- For Carbon dioxide --- + if( trim(drydep_list(m)) == 'CO2'.or. trim( drydep_list(m) ) == 'SO2' ) then + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph_inv*(1._r8 + dk2s(:)*ph_inv)) + !--- For NH3 --- + else if( trim( drydep_list(m) ) == 'NH3' ) then + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph/dk2s(:)) + !--- This can't happen --- + else + write(s_logunit,F00) 'Bad species ',drydep_list(m) + call shr_sys_abort( subName//'ERROR: in assigning coefficients' ) + end if + end if + end if + end do + + end subroutine set_hcoeff_vector + +!=============================================================================== + +end module seq_drydep_mod diff --git a/cesm/nuopc_cap_share/shr_carma_mod.F90 b/cesm/nuopc_cap_share/shr_carma_mod.F90 new file mode 100644 index 000000000..3946b8878 --- /dev/null +++ b/cesm/nuopc_cap_share/shr_carma_mod.F90 @@ -0,0 +1,76 @@ +module shr_carma_mod + + !================================================================================ + ! This reads the carma_inparm namelist in drv_flds_in and makes the relavent + ! information available to CAM, CLM, and driver. + !================================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8, CX => SHR_KIND_CX + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : logunit => shr_log_Unit + use shr_nl_mod , only : shr_nl_find_group_name + + implicit none + private + + public :: shr_carma_readnl ! reads carma_inparm namelist + +!------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------- + + subroutine shr_carma_readnl( NLFileName, carma_fields) + + !------------------------------------------------------------------------- + ! This reads the carma_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + !------------------------------------------------------------------------- + + use ESMF, only : ESMF_VM, ESMF_VMGetCurrent, ESMF_VMGet, ESMF_VMBroadcast + + character(len=*) , intent(in) :: NLFileName + character(len=CX), intent(out) :: carma_fields + + type(ESMF_VM) :: vm + integer :: localPet + integer :: rc + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: i, tmp(1) + character(*),parameter :: F00 = "('(shr_carma_readnl) ',2a)" + + namelist /carma_inparm/ carma_fields + + carma_fields = ' ' + call ESMF_VMGetCurrent(vm, rc=rc) + call ESMF_VMGet(vm, localpet=localpet, rc=rc) + tmp = 0 + if (localpet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(logunit,F00) 'Read in carma_inparm namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'carma_inparm', status=ierr) + if (ierr == 0) then + read(unitn, carma_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of carma_inparm namelist in shr_carma_readnl' ) + endif + else + write(logunit,*) 'shr_carma_readnl: no carma_inparm namelist found in ',NLFilename + end if + close( unitn ) + else + write(logunit,*) 'shr_carma_readnl: no file ',NLFilename, ' found' + end if + if (len_trim(carma_fields) > 0) tmp(1)=1 + end if + call ESMF_VMBroadcast(vm, tmp, 1, 0, rc=rc) + if(tmp(1) == 1) then + call ESMF_VMBroadcast(vm, carma_fields, CX, 0, rc=rc) + endif + + end subroutine shr_carma_readnl + +endmodule shr_carma_mod diff --git a/cesm/nuopc_cap_share/shr_expr_parser_mod.F90 b/cesm/nuopc_cap_share/shr_expr_parser_mod.F90 new file mode 100644 index 000000000..f37a4ac3c --- /dev/null +++ b/cesm/nuopc_cap_share/shr_expr_parser_mod.F90 @@ -0,0 +1,185 @@ +!============================================================================= +! expression parser utility -- +! for parsing simple linear mathematical expressions of the form +! X = a*Y + b*Z + ... +! +!============================================================================= +module shr_expr_parser_mod + use shr_kind_mod,only : r8 => shr_kind_r8 + use shr_kind_mod,only : cx => shr_kind_cx + + implicit none + private + + public :: shr_exp_parse ! parses simple strings which contain expressions + public :: shr_exp_item_t ! user defined type which contains an expression component + public :: shr_exp_list_destroy ! destroy the linked list returned by shr_exp_parse + + ! contains componets of expression + type shr_exp_item_t + character(len=64) :: name + character(len=64),pointer :: vars(:) => null() + real(r8) ,pointer :: coeffs(:) => null() + integer :: n_terms = 0 + type(shr_exp_item_t), pointer :: next_item => null() + end type shr_exp_item_t + +contains + + ! ----------------------------------------------------------------- + ! parses expressions provided in array of strings + ! ----------------------------------------------------------------- + function shr_exp_parse( exp_array, nitems ) result(exp_items_list) + + character(len=*), intent(in) :: exp_array(:) ! contains a expressions + integer, optional, intent(out) :: nitems ! number of expressions parsed + type(shr_exp_item_t), pointer :: exp_items_list ! linked list of items returned + + integer :: i,j, jj, nmax, nterms, n_exp_items + character(len=cx) :: tmp_str + type(shr_exp_item_t), pointer :: exp_item, list_item + + nullify( exp_items_list ) + nullify( exp_item ) + nullify( list_item ) + + n_exp_items = 0 + nmax = size( exp_array ) + + do i = 1,nmax + if (len_trim(exp_array(i))>0) then + + j = scan( exp_array(i), '=' ) + + if ( j>0 ) then + + n_exp_items = n_exp_items + 1 + + allocate( exp_item ) + exp_item%n_terms = 0 + exp_item%name = trim(adjustl(exp_array(i)(:j-1))) + + tmp_str = trim(adjustl(exp_array(i)(j+1:))) + + nterms = 1 + jj = scan( tmp_str, '+' ) + do while(jj>0) + nterms = nterms + 1 + tmp_str = tmp_str(jj+1:) + jj = scan( tmp_str, '+' ) + enddo + + allocate( exp_item%vars(nterms) ) + allocate( exp_item%coeffs(nterms) ) + + tmp_str = trim(adjustl(exp_array(i)(j+1:))) + + j = scan( tmp_str, '+' ) + + if (j>0) then + call set_coefvar( tmp_str(:j-1), exp_item ) + tmp_str = tmp_str(j-1:) + else + call set_coefvar( tmp_str, exp_item ) + endif + + else + + tmp_str = trim(adjustl(exp_array(i))) ! assumed to begin with '+' + + endif + + ! at this point tmp_str begins with '+' + j = scan( tmp_str, '+' ) + + if (j>0) then + + ! remove the leading + ... + tmp_str = tmp_str(j+1:) + j = scan( tmp_str, '+' ) + + do while(j>0) + + call set_coefvar( tmp_str(:j-1), exp_item ) + + tmp_str = tmp_str(j+1:) + j = scan( tmp_str, '+' ) + + enddo + + call set_coefvar( tmp_str, exp_item ) + + endif + + + if (associated(exp_item)) then + if (associated(exp_items_list)) then + list_item => exp_items_list + do while(associated(list_item%next_item)) + list_item => list_item%next_item + enddo + list_item%next_item => exp_item + else + exp_items_list => exp_item + endif + endif + + endif + enddo + + if ( present(nitems) ) then + nitems = n_exp_items + endif + + end function shr_exp_parse + + ! ----------------------------------------------------------------- + ! deallocates memory occupied by linked list + ! ----------------------------------------------------------------- + subroutine shr_exp_list_destroy( list ) + type(shr_exp_item_t), pointer, intent(inout) :: list + + type(shr_exp_item_t), pointer :: item, next + + item => list + do while(associated(item)) + next => item%next_item + if (associated(item%vars)) then + deallocate(item%vars) + nullify(item%vars) + deallocate(item%coeffs) + nullify(item%coeffs) + endif + deallocate(item) + nullify(item) + item => next + enddo + + end subroutine shr_exp_list_destroy + + !========================== + ! Private Methods + + ! ----------------------------------------------------------------- + ! ----------------------------------------------------------------- + subroutine set_coefvar( term, item ) + character(len=*), intent(in) :: term + type(shr_exp_item_t) , intent(inout) :: item + + integer :: k, n + + item%n_terms = item%n_terms + 1 + n = item%n_terms + + k = scan( term, '*' ) + if (k>0) then + item%vars(n) = trim(adjustl(term(k+1:))) + read( term(:k-1), *) item%coeffs(n) + else + item%vars(n) = trim(adjustl(term)) + item%coeffs(n) = 1.0_r8 + endif + + end subroutine set_coefvar + +end module shr_expr_parser_mod diff --git a/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 b/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 new file mode 100644 index 000000000..30931271e --- /dev/null +++ b/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 @@ -0,0 +1,297 @@ +module shr_fire_emis_mod + + !================================================================================ + ! Coordinates carbon emissions fluxes from CLM fires for use as sources of + ! chemical constituents in CAM + ! + ! This module reads fire_emis_nl namelist which specifies the compound fluxes + ! that are to be passed through the model coupler. + !================================================================================ + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cx=>shr_kind_cx, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : logunit => shr_log_Unit + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + use shr_expr_parser_mod , only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy + + implicit none + private + + public :: shr_fire_emis_readnl ! reads fire_emis_nl namelist + public :: shr_fire_emis_mechcomps ! points to an array of chemical compounds (in CAM-Chem mechanism) than have fire emissions + public :: shr_fire_emis_mechcomps_n ! number of unique compounds in the CAM chemical mechanism that have fire emissions + public :: shr_fire_emis_comps_n ! number of unique emissions components + public :: shr_fire_emis_linkedlist ! points to linked list of shr_fire_emis_comp_t objects + public :: shr_fire_emis_elevated ! elevated emissions in ATM + public :: shr_fire_emis_comp_ptr ! user defined type that points to fire emis data obj (shr_fire_emis_comp_t) + public :: shr_fire_emis_comp_t ! emission component data type + public :: shr_fire_emis_mechcomp_t ! data type for chemical compound in CAM mechanism than has fire emissions + + logical :: fire_emis_initialized = .false. ! true => shr_fire_emis_readnl alreay called + logical :: shr_fire_emis_elevated = .true. + + character(len=CL), public :: shr_fire_emis_factors_file = '' ! a table of basic fire emissions compounds + character(len=CS), public :: shr_fire_emis_ztop_token = 'Sl_fztop' ! token for emissions top of vertical distribution + integer, parameter :: name_len=16 + + ! fire emissions component data structure (or user defined type) + type shr_fire_emis_comp_t + character(len=name_len) :: name ! emissions component name (in fire emissions input table) + integer :: index + real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) + real(r8) :: coeff ! emissions component coeffecient + real(r8) :: molec_weight ! molecular weight of the fire emissions compound (g/mole) + type(shr_fire_emis_comp_t), pointer :: next_emiscomp ! points to next member in the linked list + endtype shr_fire_emis_comp_t + + type shr_fire_emis_comp_ptr + type(shr_fire_emis_comp_t), pointer :: ptr ! points to fire emis data obj (shr_fire_emis_comp_t) + endtype shr_fire_emis_comp_ptr + + ! chemical compound in CAM mechanism that has fire emissions + type shr_fire_emis_mechcomp_t + character(len=16) :: name ! compound name + type(shr_fire_emis_comp_ptr), pointer :: emis_comps(:) ! an array of pointers to fire emis components + integer :: n_emis_comps ! number of fire emis compounds that make up the emissions for this mechanis compound + end type shr_fire_emis_mechcomp_t + + type(shr_fire_emis_mechcomp_t), pointer :: shr_fire_emis_mechcomps(:) ! array of chemical compounds (in CAM mechanism) that have fire emissions + type(shr_fire_emis_comp_t), pointer :: shr_fire_emis_linkedlist ! points to linked list top + + integer :: shr_fire_emis_comps_n = 0 ! number of unique fire components + integer :: shr_fire_emis_mechcomps_n = 0 ! number of unique compounds in the CAM chemical mechanism that have fire emissions + +!------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------- + + subroutine shr_fire_emis_readnl( NLFileName, emis_nflds ) + + !------------------------------------------------------------------------- + ! + ! This reads the fire_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + ! + ! Namelist variables: + ! fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + ! + ! fire_emis_specifier (array of strings) -- Each array element specifies + ! how CAM-Chem constituents are mapped to basic smoke compounds in + ! the fire emissions factors table (fire_emis_factors_file). Each + ! chemistry constituent name (left of '=' sign) is mapped to one or more + ! smoke compound (separated by + sign if more than one), which can be + ! proceeded by a multiplication factor (separated by '*'). + ! Example: + ! fire_emis_specifier = 'bc_a1 = BC','pom_a1 = 1.4*OC','SO2 = SO2' + ! + ! fire_emis_factors_file (string) -- Input file that contains the table + ! of basic compounds that make up the smoke from the CLM fires. This is + ! used in CLM module FireEmisFactorsMod. + ! + ! fire_emis_elevated (locical) -- If true then CAM-Chem treats the fire + ! emission sources as 3-D vertically distributed forcings for the + ! corresponding chemical tracers. + ! + !------------------------------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: NLFileName ! name of namelist file + integer , intent(out) :: emis_nflds + + ! local variables + type(ESMF_VM) :: vm + integer :: localPet + integer :: mpicom + integer :: rc + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer, parameter :: maxspc = 100 + character(len=2*CX) :: fire_emis_specifier(maxspc) = ' ' + character(len=CL) :: fire_emis_factors_file = ' ' + logical :: fire_emis_elevated = .true. + integer :: i, tmp(1) + character(*),parameter :: F00 = "('(shr_fire_emis_readnl) ',2a)" + character(len=*), parameter :: subname='(shr_fire_emis_readnl)' + !------------------------------------------------------------------ + + namelist /fire_emis_nl/ fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + + rc = ESMF_SUCCESS + + ! If other processes have already initialized megan - then the info will just be re-initialized + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! call on all the pes of mpicom + if (localPet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(logunit,F00) 'Read in fire_emis_readnl namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'fire_emis_nl', status=ierr) + ! If ierr /= 0, no namelist present. + if (ierr == 0) then + read(unitn, fire_emis_nl, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of fire_emis_nl namelist in shr_fire_emis_readnl' ) + endif + endif + close( unitn ) + end if + end if + call shr_mpi_bcast(fire_emis_specifier , mpicom) + call shr_mpi_bcast(fire_emis_factors_file , mpicom) + call shr_mpi_bcast(fire_emis_elevated , mpicom) + + shr_fire_emis_factors_file = fire_emis_factors_file + shr_fire_emis_elevated = fire_emis_elevated + + ! parse the namelist info and initialize the module data - only if it has not been initialized + if (.not. fire_emis_initialized) then + call shr_fire_emis_init( fire_emis_specifier ) + end if + emis_nflds = shr_fire_emis_mechcomps_n + + end subroutine shr_fire_emis_readnl + +!------------------------------------------------------------------------- +! private methods... +!------------------------------------------------------------------------- + + subroutine shr_fire_emis_init( specifier ) + + !-------------------------------------------------- + ! module data initializer + !-------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: specifier(:) + + ! local variables + integer :: n_entries + integer :: i, j, k + type(shr_exp_item_t), pointer :: items_list, item + !------------------------------------------------------ + + nullify(shr_fire_emis_linkedlist) + + items_list => shr_exp_parse( specifier, nitems=n_entries ) + + allocate(shr_fire_emis_mechcomps(n_entries)) + shr_fire_emis_mechcomps(:)%n_emis_comps = 0 + + item => items_list + i = 1 + do while(associated(item)) + + do k=1,shr_fire_emis_mechcomps_n + if ( trim(shr_fire_emis_mechcomps(k)%name) == trim(item%name) ) then + call shr_sys_abort( 'shr_fire_emis_init : multiple emissions definitions specified for : '//trim(item%name)) + endif + enddo + if (len_trim(item%name) .le. name_len) then + shr_fire_emis_mechcomps(i)%name = item%name(1:name_len) + else + call shr_sys_abort("shr_file_emis_init : name too long for data structure :"//trim(item%name)) + endif + shr_fire_emis_mechcomps(i)%n_emis_comps = item%n_terms + allocate(shr_fire_emis_mechcomps(i)%emis_comps(item%n_terms)) + + do j = 1,item%n_terms + shr_fire_emis_mechcomps(i)%emis_comps(j)%ptr => add_emis_comp( item%vars(j), item%coeffs(j) ) + enddo + shr_fire_emis_mechcomps_n = shr_fire_emis_mechcomps_n+1 + + item => item%next_item + i = i+1 + enddo + if (associated(items_list)) call shr_exp_list_destroy(items_list) + + ! Need to explicitly add Fl_ based on naming convention + + fire_emis_initialized = .true. + + end subroutine shr_fire_emis_init + + !------------------------------------------------------------------------- + + function add_emis_comp( name, coeff ) result(emis_comp) + + character(len=*), intent(in) :: name + real(r8), intent(in) :: coeff + type(shr_fire_emis_comp_t), pointer :: emis_comp + + emis_comp => get_emis_comp_by_name(shr_fire_emis_linkedlist, name) + if(associated(emis_comp)) then + ! already in the list so return... + return + endif + + ! create new emissions component and add it to the list + allocate(emis_comp) + + ! element%index = lookup_element( name ) + ! element%emis_factors = get_factors( list_elem%index ) + + emis_comp%index = shr_fire_emis_comps_n+1 + + emis_comp%name = trim(name) + emis_comp%coeff = coeff + nullify(emis_comp%next_emiscomp) + + call add_emis_comp_to_list(emis_comp) + + end function add_emis_comp + + !------------------------------------------------------------------------- + + recursive function get_emis_comp_by_name(list_comp, name) result(emis_comp) + + type(shr_fire_emis_comp_t), pointer :: list_comp + character(len=*), intent(in) :: name ! variable name + type(shr_fire_emis_comp_t), pointer :: emis_comp ! returned object + + if(associated(list_comp)) then + if(list_comp%name .eq. name) then + emis_comp => list_comp + else + emis_comp => get_emis_comp_by_name(list_comp%next_emiscomp, name) + end if + else + nullify(emis_comp) + end if + + end function get_emis_comp_by_name + + !------------------------------------------------------------------------- + + subroutine add_emis_comp_to_list( new_emis_comp ) + + type(shr_fire_emis_comp_t), target, intent(in) :: new_emis_comp + + type(shr_fire_emis_comp_t), pointer :: list_comp + + if(associated(shr_fire_emis_linkedlist)) then + list_comp => shr_fire_emis_linkedlist + do while(associated(list_comp%next_emiscomp)) + list_comp => list_comp%next_emiscomp + end do + list_comp%next_emiscomp => new_emis_comp + else + shr_fire_emis_linkedlist => new_emis_comp + end if + + shr_fire_emis_comps_n = shr_fire_emis_comps_n + 1 + + end subroutine add_emis_comp_to_list + +endmodule shr_fire_emis_mod diff --git a/cesm/nuopc_cap_share/shr_megan_mod.F90 b/cesm/nuopc_cap_share/shr_megan_mod.F90 new file mode 100644 index 000000000..4273217c0 --- /dev/null +++ b/cesm/nuopc_cap_share/shr_megan_mod.F90 @@ -0,0 +1,310 @@ +module shr_megan_mod + + !================================================================================ + ! Handles MEGAN VOC emissions metadata for CLM produced chemical emissions + ! MEGAN = Model of Emissions of Gases and Aerosols from Nature + ! + ! This reads the megan_emis_nl namelist in drv_flds_in and makes the relavent + ! information available to CAM, CLM, and driver. + ! - The driver sets up CLM to CAM communication for the VOC flux fields. + ! - CLM needs to know what specific VOC fluxes need to be passed to the coupler + ! and how to assemble the fluxes. + ! - CAM needs to know what specific VOC fluxes to expect from CLM. + !================================================================================ + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cx=>shr_kind_cx, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : logunit => shr_log_Unit + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + use shr_expr_parser_mod , only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy + + implicit none + private + + public :: shr_megan_readnl ! reads megan_emis_nl namelist + public :: shr_megan_mechcomps ! points to an array of chemical compounds (in CAM-Chem mechanism) that have MEGAN emissions + public :: shr_megan_mechcomps_n ! number of unique compounds in the CAM chemical mechanism that have MEGAN emissions + public :: shr_megan_megcomps_n ! number of unique MEGAN compounds + public :: shr_megan_megcomp_t ! MEGAN compound data type + public :: shr_megan_mechcomp_t ! data type for chemical compound in CAM mechanism that has MEGAN emissions + public :: shr_megan_linkedlist ! points to linked list of shr_megan_comp_t objects + public :: shr_megan_mapped_emisfctrs ! switch to use mapped emission factors + public :: shr_megan_comp_ptr + + logical , public :: megan_initialized = .false. ! true => shr_megan_readnl alreay called + character(len=CL), public :: shr_megan_factors_file = '' + + ! MEGAN compound data structure (or user defined type) + type shr_megan_megcomp_t + character(len=16) :: name ! MEGAN compound name (in MEGAN input table) + integer :: index + real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) + integer :: class_number ! MEGAN class number + real(r8) :: coeff ! emissions component coeffecient + real(r8) :: molec_weight ! molecular weight of the MEGAN compound (g/mole) + type(shr_megan_megcomp_t), pointer :: next_megcomp ! points to next member in the linked list + endtype shr_megan_megcomp_t + + type shr_megan_comp_ptr + type(shr_megan_megcomp_t), pointer :: ptr + endtype shr_megan_comp_ptr + + ! chemical compound in CAM mechanism that has MEGAN emissions + type shr_megan_mechcomp_t + character(len=16) :: name ! compound name + type(shr_megan_comp_ptr), pointer :: megan_comps(:) ! an array of pointers to megan emis compounds + integer :: n_megan_comps ! number of megan emis compounds that make up the emissions for this mechanis compound + end type shr_megan_mechcomp_t + + type(shr_megan_mechcomp_t), pointer :: shr_megan_mechcomps(:) ! array of chemical compounds (in CAM mechanism) that have MEGAN emissions + type(shr_megan_megcomp_t), pointer :: shr_megan_linkedlist ! points to linked list top + + integer :: shr_megan_megcomps_n = 0 ! number of unique megan compounds + integer :: shr_megan_mechcomps_n = 0 ! number of unique compounds in the CAM chemical mechanism that have MEGAN emissions + + ! switch to use mapped emission factors + logical :: shr_megan_mapped_emisfctrs = .false. + +!-------------------------------------------------------- +contains +!-------------------------------------------------------- + + subroutine shr_megan_readnl( NLFileName, megan_nflds) + + !------------------------------------------------------------------------- + ! + ! This reads the megan_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + ! + ! Namelist variables: + ! megan_specifier, megan_mapped_emisfctrs, megan_factors_file + ! + ! megan_specifier is a series of strings where each string contains one + ! CAM chemistry constituent name (left of = sign) and one or more MEGAN + ! compound (separated by + sign if more than one). Each MEGAN compound + ! can be proceeded by a multiplication factor (separated by *). The + ! specification of the MEGAN compounds to the right of the = signs tells + ! the MEGAN VOC model within CLM how to construct the VOC fluxes using + ! the factors in megan_factors_file and land surface state. + ! + ! megan_factors_file read by CLM contains valid MEGAN compound names, + ! MEGAN class groupings and scalar emission factors + ! + ! megan_mapped_emisfctrs switch is used to tell the MEGAN model to use + ! mapped emission factors read in from the CLM surface data input file + ! rather than the scalar factors from megan_factors_file + ! + ! Example: + ! &megan_emis_nl + ! megan_specifier = 'ISOP = isoprene', + ! 'C10H16 = myrcene + sabinene + limonene + carene_3 + ocimene_t_b + pinene_b + ...', + ! 'CH3OH = methanol', + ! 'C2H5OH = ethanol', + ! 'CH2O = formaldehyde', + ! 'CH3CHO = acetaldehyde', + ! ... + ! megan_factors_file = '$datapath/megan_emis_factors.nc' + ! / + !------------------------------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: NLFileName + integer, intent(out) :: megan_nflds + + ! local variables + type(ESMF_VM) :: vm + integer :: localPet + integer :: mpicom + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer, parameter :: maxspc = 100 + character(len=2*CX) :: megan_specifier(maxspc) = ' ' + logical :: megan_mapped_emisfctrs = .false. + character(len=CL) :: megan_factors_file = ' ' + integer :: rc + integer :: i, tmp(1) + character(*), parameter :: F00 = "('(shr_megan_readnl) ',2a)" + character(len=*), parameter :: subname='(shr_megan_readnl)' + !-------------------------------------------------------------- + + namelist /megan_emis_nl/ megan_specifier, megan_factors_file, megan_mapped_emisfctrs + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 ) then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! call on all the pes of mpicom + if (localPet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(logunit,F00) 'Read in megan_emis_readnl namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'megan_emis_nl', status=ierr) + if (ierr == 0) then + ! Note that ierr /= 0, no namelist is present. + read (unitn, megan_emis_nl, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of megan_emis_nl namelist in shr_megan_readnl' ) + endif + endif + close( unitn ) + end if + end if + call shr_mpi_bcast( megan_specifier , mpicom ) + call shr_mpi_bcast( megan_factors_file , mpicom ) + call shr_mpi_bcast( megan_mapped_emisfctrs , mpicom ) + + shr_megan_factors_file = megan_factors_file + shr_megan_mapped_emisfctrs = megan_mapped_emisfctrs + + ! parse the namelist info and initialize the module data - only if it has not been initialized + if (.not. megan_initialized) then + call shr_megan_init( megan_specifier ) + end if + megan_nflds = shr_megan_mechcomps_n + + end subroutine shr_megan_readnl + +!------------------------------------------------------------------------- +! private methods... +!------------------------------------------------------------------------- + + subroutine shr_megan_init( specifier) + + !----------------------------------------- + ! Initialize module data + !----------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: specifier(:) + + ! local variables + integer :: n_entries + integer :: i, j, k + type(shr_exp_item_t), pointer :: items_list, item + !-------------------------------------------------------------- + + nullify(shr_megan_linkedlist) + + items_list => shr_exp_parse( specifier, nitems=n_entries ) + + allocate(shr_megan_mechcomps(n_entries)) + shr_megan_mechcomps(:)%n_megan_comps = 0 + + item => items_list + i = 1 + do while(associated(item)) + + do k=1,shr_megan_mechcomps_n + if ( trim(shr_megan_mechcomps(k)%name) == trim(item%name) ) then + call shr_sys_abort( 'shr_megan_init : duplicate compound names : '//trim(item%name)) + endif + enddo + if (len_trim(item%name) .le. len(shr_megan_mechcomps(i)%name)) then + shr_megan_mechcomps(i)%name = item%name(1:len(shr_megan_mechcomps(i)%name)) + else + call shr_sys_abort( 'shr_megan_init : name too long for data structure : '//trim(item%name)) + endif + shr_megan_mechcomps(i)%n_megan_comps = item%n_terms + allocate(shr_megan_mechcomps(i)%megan_comps(item%n_terms)) + + do j = 1,item%n_terms + shr_megan_mechcomps(i)%megan_comps(j)%ptr => add_megan_comp( item%vars(j), item%coeffs(j) ) + enddo + shr_megan_mechcomps_n = shr_megan_mechcomps_n+1 + + item => item%next_item + i = i+1 + + enddo + if (associated(items_list)) call shr_exp_list_destroy(items_list) + + megan_initialized = .true. + + end subroutine shr_megan_init + + !------------------------------------------------------------------------- + + function add_megan_comp( name, coeff ) result(megan_comp) + + character(len=16), intent(in) :: name + real(r8), intent(in) :: coeff + type(shr_megan_megcomp_t), pointer :: megan_comp + + megan_comp => get_megan_comp_by_name(shr_megan_linkedlist, name) + if(associated(megan_comp)) then + ! already in the list so return... + return + endif + + ! create new megan compound and add it to the list + allocate(megan_comp) + + ! element%index = lookup_element( name ) + ! element%emis_factors = get_factors( list_elem%index ) + + megan_comp%index = shr_megan_megcomps_n+1 + + megan_comp%name = trim(name) + megan_comp%coeff = coeff + nullify(megan_comp%next_megcomp) + + call add_megan_comp_to_list(megan_comp) + + end function add_megan_comp + + !------------------------------------------------------------------------- + + recursive function get_megan_comp_by_name(list_comp, name) result(megan_comp) + + type(shr_megan_megcomp_t), pointer :: list_comp + character(len=*), intent(in) :: name ! variable name + type(shr_megan_megcomp_t), pointer :: megan_comp ! returned object + + if(associated(list_comp)) then + if(list_comp%name .eq. name) then + megan_comp => list_comp + else + megan_comp => get_megan_comp_by_name(list_comp%next_megcomp, name) + end if + else + nullify(megan_comp) + end if + + end function get_megan_comp_by_name + + !------------------------------------------------------------------------- + + subroutine add_megan_comp_to_list( new_megan_comp ) + + type(shr_megan_megcomp_t), target, intent(in) :: new_megan_comp + + type(shr_megan_megcomp_t), pointer :: list_comp + + if(associated(shr_megan_linkedlist)) then + list_comp => shr_megan_linkedlist + do while(associated(list_comp%next_megcomp)) + list_comp => list_comp%next_megcomp + end do + list_comp%next_megcomp => new_megan_comp + else + shr_megan_linkedlist => new_megan_comp + end if + + shr_megan_megcomps_n = shr_megan_megcomps_n + 1 + + end subroutine add_megan_comp_to_list + +endmodule shr_megan_mod diff --git a/cesm/nuopc_cap_share/shr_ndep_mod.F90 b/cesm/nuopc_cap_share/shr_ndep_mod.F90 new file mode 100644 index 000000000..d3a9f9801 --- /dev/null +++ b/cesm/nuopc_cap_share/shr_ndep_mod.F90 @@ -0,0 +1,106 @@ +module shr_ndep_mod + + !======================================================================== + ! Module for handling nitrogen depostion of tracers. + ! This module is shared by land and atmosphere models for the computations of + ! dry deposition of tracers + !======================================================================== + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : s_logunit => shr_log_Unit + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_nl_mod , only : shr_nl_find_group_name + use shr_mpi_mod , only : shr_mpi_bcast + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS + public :: shr_ndep_readnl ! Read namelist + + character(len=*), parameter :: & + u_FILE_u=__FILE__ + +!==================================================================================== +CONTAINS +!==================================================================================== + + subroutine shr_ndep_readnl(NLFilename, ndep_nflds) + + !======================================================================== + ! reads ndep_inparm namelist and sets up driver list of fields for + ! atmosphere -> land and atmosphere -> ocn communications. + !======================================================================== + + ! input/output variables + character(len=*), intent(in) :: NLFilename ! Namelist filename + integer , intent(out) :: ndep_nflds + + !----- local ----- + type(ESMF_VM) :: vm + integer :: i ! Indices + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: rc + integer, parameter :: maxspc = 100 ! Maximum number of species + character(len=32) :: ndep_list(maxspc) = '' ! List of ndep species + integer :: localpet + integer :: mpicom + character(*),parameter :: F00 = "('(shr_ndep_read) ',8a)" + character(*),parameter :: FI1 = "('(shr_ndep_init) ',a,I2)" + character(*),parameter :: subName = '(shr_ndep_read) ' + ! ------------------------------------------------------------------ + + namelist /ndep_inparm/ ndep_list + + !----------------------------------------------------------------------------- + ! Read namelist and figure out the ndep field list to pass + ! First check if file exists and if not, n_ndep will be zero + !----------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 ) then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! call on all the pes of mpicom + if (localpet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(s_logunit,F00) 'Read in ndep_inparm namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'ndep_inparm', ierr) + if (ierr == 0) then + ! Note that ierr /= 0, no namelist is present. + read(unitn, ndep_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort(trim(subName) //'problem of read of ndep_inparm ') + endif + endif + close( unitn ) + end if + end if + call shr_mpi_bcast( ndep_list, mpicom ) + + ndep_nflds = 0 + do i=1,maxspc + if (len_trim(ndep_list(i)) > 0) then + ndep_nflds = ndep_nflds+1 + endif + enddo + + end subroutine shr_ndep_readnl + +end module shr_ndep_mod diff --git a/cesm/nuopc_cap_share/shr_ozone_coupling_mod.F90 b/cesm/nuopc_cap_share/shr_ozone_coupling_mod.F90 new file mode 100644 index 000000000..fbd601c3c --- /dev/null +++ b/cesm/nuopc_cap_share/shr_ozone_coupling_mod.F90 @@ -0,0 +1,124 @@ +module shr_ozone_coupling_mod + + !======================================================================== + ! Module for handling namelist variables related to ozone coupling + !======================================================================== + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : s_logunit => shr_log_Unit + use shr_nl_mod , only : shr_nl_find_group_name + use shr_mpi_mod , only : shr_mpi_bcast + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS + public shr_ozone_coupling_readnl ! Read namelist + + ! !PUBLIC DATA MEMBERS + ! atm_ozone_frequency can be one of the following values + integer, parameter, public :: atm_ozone_frequency_unset = 0 + integer, parameter, public :: atm_ozone_frequency_subdaily = 1 + integer, parameter, public :: atm_ozone_frequency_multiday_average = 2 + + character(len=*), parameter :: & + u_FILE_u=__FILE__ + + !==================================================================================== +CONTAINS + !==================================================================================== + + subroutine shr_ozone_coupling_readnl(NLFilename, atm_ozone_frequency_val) + + !======================================================================== + ! reads ozone_coupling_nl namelist and returns a variable specifying the frequency at + ! which the atmosphere model computes surface ozone + !======================================================================== + + ! input/output variables + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! atm_ozone_frequency will be one of the above constants (atm_ozone_frequency_*), + ! specifying the frequency at which the atmosphere model computes surface ozone + integer , intent(out) :: atm_ozone_frequency_val + + !----- local ----- + character(len=64) :: atm_ozone_frequency + type(ESMF_VM) :: vm + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: rc + integer :: localpet + integer :: mpicom + + character(len=*), parameter :: atm_ozone_frequency_not_present = 'NOT_PRESENT' + character(len=*), parameter :: subname = '(shr_ozone_coupling_readnl) ' + ! ------------------------------------------------------------------ + + namelist /ozone_coupling_nl/ atm_ozone_frequency + + rc = ESMF_SUCCESS + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 ) then + call shr_sys_abort( subname//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localpet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (localpet==0) then + ! ------------------------------------------------------------------------ + ! Set default values in case namelist file doesn't exist, ozone_coupling_nl group + ! doesn't exist within the file, or a given variable isn't present in the namelist + ! group in the file. + ! ------------------------------------------------------------------------ + atm_ozone_frequency = atm_ozone_frequency_not_present + + ! ------------------------------------------------------------------------ + ! Read namelist file + ! ------------------------------------------------------------------------ + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(s_logunit,'(a)') '(shr_ozone_coupling_readnl) Read in ozone_coupling_nl namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'ozone_coupling_nl', ierr) + if (ierr == 0) then + ! Note that ierr /= 0 means no namelist is present. + read(unitn, ozone_coupling_nl, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort(trim(subname)//'problem reading ozone_coupling_nl ') + end if + end if + close( unitn ) + end if + + ! ------------------------------------------------------------------------ + ! Translate read-in values to appropriate return values + ! ------------------------------------------------------------------------ + select case(atm_ozone_frequency) + case(atm_ozone_frequency_not_present) + atm_ozone_frequency_val = atm_ozone_frequency_unset + case("subdaily") + atm_ozone_frequency_val = atm_ozone_frequency_subdaily + case("multiday_average") + atm_ozone_frequency_val = atm_ozone_frequency_multiday_average + case default + call shr_sys_abort(trim(subname)//'unknown value for atm_ozone_frequency: '// & + trim(atm_ozone_frequency)) + end select + end if + + ! ------------------------------------------------------------------------ + ! Broadcast values to all processors + ! ------------------------------------------------------------------------ + call shr_mpi_bcast(atm_ozone_frequency_val, mpicom) + + end subroutine shr_ozone_coupling_readnl + +end module shr_ozone_coupling_mod diff --git a/cime_config/buildexe b/cime_config/buildexe index e76fc7344..f02d0a399 100755 --- a/cime_config/buildexe +++ b/cime_config/buildexe @@ -90,7 +90,8 @@ def _main_func(): out.write(os.path.join(caseroot, "SourceMods", "src.drv") + "\n") if not skip_mediator: out.write(os.path.join(cmeps_dir, "mediator") + "\n") - out.write(os.path.join(cmeps_dir, "drivers", "cime") + "\n") + out.write(os.path.join(cmeps_dir, "cesm", "flux_atmocn") + "\n") + out.write(os.path.join(cmeps_dir, "cesm", "driver") + "\n") # build model executable makefile = os.path.join(casetools, "Makefile") diff --git a/cime_config/buildnml b/cime_config/buildnml index f8a43852b..11c20e276 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -33,7 +33,6 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): config['iyear'] = case.get_value('COMPSET').split('_')[0] config['BGC_MODE'] = case.get_value("CCSM_BGC") config['CPL_I2O_PER_CAT'] = case.get_value('CPL_I2O_PER_CAT') - config['COMP_RUN_BARRIERS'] = case.get_value('COMP_RUN_BARRIERS') config['DRV_THREADING'] = case.get_value('DRV_THREADING') config['CPL_ALBAV'] = case.get_value('CPL_ALBAV') config['CPL_EPBAL'] = case.get_value('CPL_EPBAL') @@ -44,11 +43,11 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): config['OS'] = case.get_value('OS') config['glc_nec'] = 0 if case.get_value('GLC_NEC') == 0 else case.get_value('GLC_NEC') config['timer_level'] = 'pos' if case.get_value('TIMER_LEVEL') >= 1 else 'neg' - config['bfbflag'] = 'on' if case.get_value('BFBFLAG') else 'off' config['continue_run'] = '.true.' if case.get_value('CONTINUE_RUN') else '.false.' config['flux_epbal'] = 'ocn' if case.get_value('CPL_EPBAL') == 'ocn' else 'off' config['mask_grid'] = case.get_value('MASK_GRID') config['rest_option'] = case.get_value('REST_OPTION') + config['comp_ocn'] = case.get_value('COMP_OCN') atm_grid = case.get_value('ATM_GRID') lnd_grid = case.get_value('LND_GRID') diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index e909eaf9b..a38cfed1c 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -919,6 +919,21 @@ + + char + budget + MED_attributes + v0,v1 + + currently v0 refers to budgets using POP and v1 refers to budgets using MOM6 + + + v0 + v1 + v0 + + + integer budget @@ -2250,18 +2265,6 @@ - - integer - expdef - ALLCOMP_attributes - - number of glc ice sheets - - - 1 - - - logical flds @@ -2319,7 +2322,7 @@ ALLCOMP_attributes If set to .true. BGC fields will be passed back and forth between the ocean and seaice - via the coupler. + via the mediator. .false. @@ -3895,7 +3898,7 @@ char mapping - GLC_attributes + ALLCOMP_attributes MESH description of glc grid diff --git a/mediator/CMakeLists.txt b/mediator/CMakeLists.txt index 5ee25a5cb..a851018ba 100644 --- a/mediator/CMakeLists.txt +++ b/mediator/CMakeLists.txt @@ -32,7 +32,7 @@ if(BLD_STANDALONE) endif() target_include_directories (cmeps PUBLIC ${ESMF_F90COMPILEPATHS}) -target_include_directories (cmeps PUBLIC "${CMAKE_BINARY_DIR}/util") +target_include_directories (cmeps PUBLIC "${CMAKE_BINARY_DIR}/ufs") target_include_directories (cmeps PUBLIC ${PIO_Fortran_INCLUDE_DIR}) install(TARGETS cmeps diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index e853d7073..2bb45a90d 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -77,7 +77,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) use esmflds , only : compmed, compatm, complnd, compocn use esmflds , only : compice, comprof, compwav, ncomps use esmflds , only : compglc, num_icesheets, ocn2glc_coupling ! compglc is an array of integers - use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d + use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d, mapbilnr_nstod use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf use esmflds , only : map_glc2ocn_ice, map_glc2ocn_liq, map_rof2ocn_ice, map_rof2ocn_liq use esmflds , only : fldListTo, fldListFr, fldListMed_aoflux, fldListMed_ocnalb @@ -2228,7 +2228,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_lamult', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_lamult', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_lamult', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_lamult', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_lamult', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') end if end if @@ -2241,7 +2241,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_ustokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_ustokes', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_ustokes', mrg_from=compwav, mrg_fld='Sw_ustokes', mrg_type='copy') end if end if @@ -2254,7 +2254,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_vstokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_vstokes', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_vstokes', mrg_from=compwav, mrg_fld='Sw_vstokes', mrg_type='copy') end if end if @@ -2267,10 +2267,36 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_hstokes', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_hstokes', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_hstokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_hstokes', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_hstokes', mrg_from=compwav, mrg_fld='Sw_hstokes', mrg_type='copy') end if end if + !----------------------------- + ! to ocn: Partitioned stokes drift components in x-direction + !----------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_pstokes_x') + call addfld(fldListTo(compocn)%flds, 'Sw_pstokes_x') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_pstokes_x', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_pstokes_x', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_pstokes_x', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_pstokes_x', mrg_from=compwav, mrg_fld='Sw_pstokes_x', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: Stokes drift depth from wave + !----------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_pstokes_y') + call addfld(fldListTo(compocn)%flds, 'Sw_pstokes_y') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_pstokes_y', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_pstokes_y', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_pstokes_y', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_pstokes_y', mrg_from=compwav, mrg_fld='Sw_pstokes_y', mrg_type='copy') + end if + end if !===================================================================== ! FIELDS TO ICE (compice) diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index b4a407a06..55da80619 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -1117,6 +1117,13 @@ canonical_units: m/s description: ocean import - Stokes drift v component # + - standard_name: Sw_pstokes_x + canonical_units: m/s + description: Eastward partitioned stokes drift components + # + - standard_name: Sw_pstokes_y + canonical_units: m/s + description: Northward partitioned stokes drift components #----------------------------------- # mediator fields #----------------------------------- diff --git a/mediator/med.F90 b/mediator/med.F90 index 7f2b323af..8e8c4fdf1 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -654,9 +654,9 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) ! TransferOfferGeomObject Attribute. use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Clock, ESMF_SUCCESS, ESMF_LogFoundAllocError - use ESMF , only : ESMF_StateIsCreated + use ESMF , only : ESMF_StateIsCreated use ESMF , only : ESMF_LogMsg_Info, ESMF_LogWrite - use ESMF , only : ESMF_END_ABORT, ESMF_Finalize + use ESMF , only : ESMF_END_ABORT, ESMF_Finalize, ESMF_MAXSTR use NUOPC , only : NUOPC_AddNamespace, NUOPC_Advertise, NUOPC_AddNestedState use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd @@ -676,6 +676,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) type(InternalState) :: is_local integer :: stat character(len=CS) :: attrList(8) + character(len=ESMF_MAXSTR) :: mesh_glc character(len=*),parameter :: subname=' (InitializeIPDv03p1) ' !----------------------------------------------------------- @@ -735,13 +736,20 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) nestedState=is_local%wrap%NStateExp(compwav), rc=rc) ! Only create nested states for active ice sheets - call NUOPC_CompAttributeGet(gcomp, name='num_icesheets', value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='mesh_glc', value=mesh_glc, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + num_icesheets = 0 if (isPresent .and. isSet) then - read(cvalue,*) num_icesheets - else - num_icesheets = 0 + ! determine number of ice sheets - search in mesh_glc for colon deliminted strings + if (len_trim(cvalue) > 0) then + do n = 1, len_trim(mesh_glc) + if (mesh_glc(n:n) == ':') num_icesheets = num_icesheets + 1 + end do + num_icesheets = num_icesheets + 1 + endif + if (mastertask) then + write(logunit,'(a,i8)') trim(subname)//' number of ice sheets is ',num_icesheets + end if end if do ns = 1,num_icesheets write(cnum,'(i0)') ns diff --git a/mediator/med_constants_mod.F90 b/mediator/med_constants_mod.F90 index 4cc96f4f7..7313a9be9 100644 --- a/mediator/med_constants_mod.F90 +++ b/mediator/med_constants_mod.F90 @@ -1,6 +1,11 @@ module med_constants_mod use med_kind_mod, only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 +#ifdef CESMCOUPLED + use shr_const_mod +#else + use ufs_const_mod +#endif implicit none public diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index c8bb304e4..8f15f625e 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -24,13 +24,14 @@ module med_diag_mod use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet, ESMF_ClockGetNextTime use ESMF , only : ESMF_Alarm, ESMF_ClockGetAlarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff use ESMF , only : ESMF_FieldBundle, ESMF_Field, ESMF_FieldGet - use shr_const_mod , only : shr_const_rearth, shr_const_pi, shr_const_latice - use shr_const_mod , only : shr_const_ice_ref_sal, shr_const_ocn_ref_sal, shr_const_isspval + use med_constants_mod , only : shr_const_rearth, shr_const_pi, shr_const_latice, shr_const_latvap + use med_constants_mod , only : shr_const_ice_ref_sal, shr_const_ocn_ref_sal, shr_const_isspval use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 use med_internalstate_mod , only : InternalState, logunit, mastertask, diagunit use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_fldChk => med_methods_FB_FldChk + use med_time_mod , only : alarmInit => med_time_alarmInit use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf @@ -130,58 +131,60 @@ module med_diag_mod ! --------------------------------- ! F for field ! --------------------------------- - - integer :: f_area ! area (wrt to unit sphere) - integer :: f_heat_frz ! heat : latent, freezing - integer :: f_heat_melt ! heat : latent, melting - integer :: f_heat_swnet ! heat : short wave, net - integer :: f_heat_lwdn ! heat : longwave down - integer :: f_heat_lwup ! heat : longwave up - integer :: f_heat_latvap ! heat : latent, vaporization - integer :: f_heat_latf ! heat : latent, fusion, snow - integer :: f_heat_ioff ! heat : latent, fusion, frozen runoff - integer :: f_heat_sen ! heat : sensible - integer :: f_watr_frz ! water: freezing - integer :: f_watr_melt ! water: melting - integer :: f_watr_rain ! water: precip, liquid - integer :: f_watr_snow ! water: precip, frozen - integer :: f_watr_evap ! water: evaporation - integer :: f_watr_salt ! water: water equivalent of salt flux - integer :: f_watr_roff ! water: runoff/flood - integer :: f_watr_ioff ! water: frozen runoff - integer :: f_watr_frz_16O ! water isotope: freezing - integer :: f_watr_melt_16O ! water isotope: melting - integer :: f_watr_rain_16O ! water isotope: precip, liquid - integer :: f_watr_snow_16O ! water isotope: prcip, frozen - integer :: f_watr_evap_16O ! water isotope: evaporation - integer :: f_watr_roff_16O ! water isotope: runoff/flood - integer :: f_watr_ioff_16O ! water isotope: frozen runoff - integer :: f_watr_frz_18O ! water isotope: freezing - integer :: f_watr_melt_18O ! water isotope: melting - integer :: f_watr_rain_18O ! water isotope: precip, liquid - integer :: f_watr_snow_18O ! water isotope: precip, frozen - integer :: f_watr_evap_18O ! water isotope: evaporation - integer :: f_watr_roff_18O ! water isotope: runoff/flood - integer :: f_watr_ioff_18O ! water isotope: frozen runoff - integer :: f_watr_frz_HDO ! water isotope: freezing - integer :: f_watr_melt_HDO ! water isotope: melting - integer :: f_watr_rain_HDO ! water isotope: precip, liquid - integer :: f_watr_snow_HDO ! water isotope: precip, frozen - integer :: f_watr_evap_HDO ! water isotope: evaporation - integer :: f_watr_roff_HDO ! water isotope: runoff/flood - integer :: f_watr_ioff_HDO ! water isotope: frozen runoff - - integer :: f_heat_beg ! 1st index for heat - integer :: f_heat_end ! Last index for heat - integer :: f_watr_beg ! 1st index for water - integer :: f_watr_end ! Last index for water - - integer :: f_16O_beg ! 1st index for 16O water isotope - integer :: f_16O_end ! Last index for 16O water isotope - integer :: f_18O_beg ! 1st index for 18O water isotope - integer :: f_18O_end ! Last index for 18O water isotope - integer :: f_HDO_beg ! 1st index for HDO water isotope - integer :: f_HDO_end ! Last index for HDO water isotope + integer, parameter :: unset_index = -999 + integer :: f_area = unset_index ! area (wrt to unit sphere) + integer :: f_heat_frz = unset_index ! heat : latent, freezing + integer :: f_heat_melt = unset_index ! heat : latent, melting + integer :: f_heat_swnet = unset_index ! heat : short wave, net + integer :: f_heat_lwdn = unset_index ! heat : longwave down + integer :: f_heat_lwup = unset_index ! heat : longwave up + integer :: f_heat_latvap = unset_index ! heat : latent, vaporization + integer :: f_heat_latf = unset_index ! heat : latent, fusion, snow + integer :: f_heat_ioff = unset_index ! heat : latent, fusion, frozen runoff + integer :: f_heat_sen = unset_index ! heat : sensible + integer :: f_watr_frz = unset_index ! water: freezing + integer :: f_watr_melt = unset_index ! water: melting + integer :: f_watr_rain = unset_index ! water: precip, liquid + integer :: f_watr_snow = unset_index ! water: precip, frozen + integer :: f_watr_evap = unset_index ! water: evaporation + integer :: f_watr_salt = unset_index ! water: water equivalent of salt flux + integer :: f_watr_roff = unset_index ! water: runoff/flood + integer :: f_watr_ioff = unset_index ! water: frozen runoff + integer :: f_watr_frz_16O = unset_index ! water isotope: freezing + integer :: f_watr_melt_16O = unset_index ! water isotope: melting + integer :: f_watr_rain_16O = unset_index ! water isotope: precip, liquid + integer :: f_watr_snow_16O = unset_index ! water isotope: prcip, frozen + integer :: f_watr_evap_16O = unset_index ! water isotope: evaporation + integer :: f_watr_roff_16O = unset_index ! water isotope: runoff/flood + integer :: f_watr_ioff_16O = unset_index ! water isotope: frozen runoff + integer :: f_watr_frz_18O = unset_index ! water isotope: freezing + integer :: f_watr_melt_18O = unset_index ! water isotope: melting + integer :: f_watr_rain_18O = unset_index ! water isotope: precip, liquid + integer :: f_watr_snow_18O = unset_index ! water isotope: precip, frozen + integer :: f_watr_evap_18O = unset_index ! water isotope: evaporation + integer :: f_watr_roff_18O = unset_index ! water isotope: runoff/flood + integer :: f_watr_ioff_18O = unset_index ! water isotope: frozen runoff + integer :: f_watr_frz_HDO = unset_index ! water isotope: freezing + integer :: f_watr_melt_HDO = unset_index ! water isotope: melting + integer :: f_watr_rain_HDO = unset_index ! water isotope: precip, liquid + integer :: f_watr_snow_HDO = unset_index ! water isotope: precip, frozen + integer :: f_watr_evap_HDO = unset_index ! water isotope: evaporation + integer :: f_watr_roff_HDO = unset_index ! water isotope: runoff/flood + integer :: f_watr_ioff_HDO = unset_index ! water isotope: frozen runoff + + integer :: f_heat_beg = unset_index ! 1st index for heat + integer :: f_heat_end = unset_index ! Last index for heat + integer :: f_watr_beg = unset_index ! 1st index for water + integer :: f_watr_end = unset_index ! Last index for water + integer :: f_salt_beg = unset_index ! 1st index for salt + integer :: f_salt_end = unset_index ! Last index for salt + + integer :: f_16O_beg = unset_index ! 1st index for 16O water isotope + integer :: f_16O_end = unset_index ! Last index for 16O water isotope + integer :: f_18O_beg = unset_index ! 1st index for 18O water isotope + integer :: f_18O_end = unset_index ! Last index for 18O water isotope + integer :: f_HDO_beg = unset_index ! 1st index for HDO water isotope + integer :: f_HDO_end = unset_index ! Last index for HDO water isotope ! --------------------------------- ! water isotopes names and indices @@ -232,6 +235,8 @@ module med_diag_mod character(len=*), parameter :: u_FILE_u = & __FILE__ + character(len=CS) :: budget_table_version + !=============================================================================== contains !=============================================================================== @@ -252,15 +257,24 @@ subroutine med_diag_init(gcomp, rc) integer :: f_size ! number of fields integer :: p_size ! number of period types type(ESMF_Clock) :: mediatorClock - character(CS) :: stop_option - integer :: stop_n ! Number until restart interval - integer :: stop_ymd ! Restart date (YYYYMMDD) - type(ESMF_ALARM) :: stop_alarm character(CS) :: cvalue + logical :: isPresent, isSet + character(*), parameter :: subName = '(med_phases_diag_init) ' ! ------------------------------------------------------------------ rc = ESMF_SUCCESS + call NUOPC_CompAttributeGet(gcomp, name="budget_table_version", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (isPresent .and. isSet) then + read(cvalue,*) budget_table_version + else + budget_table_version = 'v1' + end if + if (mastertask) then + write(logunit,'(a)') trim(subname) //' budget table version is '//trim(budget_table_version) + end if + call add_to_budget_diag(budget_diags%comps, c_atm_send , 'c2a_atm' ) ! comp index: atm call add_to_budget_diag(budget_diags%comps, c_atm_recv , 'a2c_atm' ) ! comp index: atm call add_to_budget_diag(budget_diags%comps, c_inh_send , 'c2i_inh' ) ! comp index: ice, northern @@ -286,6 +300,10 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_area ,'area' ) ! field area (wrt to unit sphere) + ! ----------------------------------------- + ! Heat fluxes budget terms + ! ----------------------------------------- + ! Note that this order is important here to determine f_heat_beg and f_heat_end call add_to_budget_diag(budget_diags%fields, f_heat_frz ,'hfreeze' ) ! field heat : latent, freezing call add_to_budget_diag(budget_diags%fields, f_heat_melt ,'hmelt' ) ! field heat : latent, melting @@ -296,55 +314,79 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_heat_latf ,'hlatfus' ) ! field heat : latent, fusion, snow call add_to_budget_diag(budget_diags%fields, f_heat_ioff ,'hiroff' ) ! field heat : latent, fusion, frozen runoff call add_to_budget_diag(budget_diags%fields, f_heat_sen ,'hsen' ) ! field heat : sensible + f_heat_beg = f_heat_frz ! field first index for heat + f_heat_end = f_heat_sen ! field last index for heat + + ! ----------------------------------------- + ! Water fluxes budget terms + ! ----------------------------------------- ! Note that this order is important here to determine f_watr_beg and f_watr_end - call add_to_budget_diag(budget_diags%fields, f_watr_frz ,'wfreeze' ) ! field water: freezing + if (trim(budget_table_version) == 'v0') then + call add_to_budget_diag(budget_diags%fields, f_watr_frz ,'wfreeze' ) ! field water: freezing + end if call add_to_budget_diag(budget_diags%fields, f_watr_melt ,'wmelt' ) ! field water: melting call add_to_budget_diag(budget_diags%fields, f_watr_rain ,'wrain' ) ! field water: precip, liquid call add_to_budget_diag(budget_diags%fields, f_watr_snow ,'wsnow' ) ! field water: precip, frozen call add_to_budget_diag(budget_diags%fields, f_watr_evap ,'wevap' ) ! field water: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_salt ,'weqsaltf' ) ! field water: water equivalent of salt flux + if (trim(budget_table_version) == 'v0') then + call add_to_budget_diag(budget_diags%fields, f_watr_salt ,'weqsaltf' ) ! field water: water equivalent of salt flux + endif call add_to_budget_diag(budget_diags%fields, f_watr_roff ,'wrunoff' ) ! field water: runoff/flood call add_to_budget_diag(budget_diags%fields, f_watr_ioff ,'wfrzrof' ) ! field water: frozen runoff + if (trim(budget_table_version) == 'v0') then + f_watr_beg = f_watr_frz ! field firs index for water + else + f_watr_beg = f_watr_melt ! field firs index for water + end if + f_watr_end = f_watr_ioff ! field last index for water + + if (flds_wiso) then + call add_to_budget_diag(budget_diags%fields, f_watr_frz_16O ,'wfreeze_16O' ) ! field water isotope: freezing + call add_to_budget_diag(budget_diags%fields, f_watr_melt_16O ,'wmelt_16O' ) ! field water isotope: melting + call add_to_budget_diag(budget_diags%fields, f_watr_rain_16O ,'wrain_16O' ) ! field water isotope: precip, liquid + call add_to_budget_diag(budget_diags%fields, f_watr_snow_16O ,'wsnow_16O' ) ! field water isotope: prcip, frozen + call add_to_budget_diag(budget_diags%fields, f_watr_evap_16O ,'wevap_16O' ) ! field water isotope: evaporation + call add_to_budget_diag(budget_diags%fields, f_watr_roff_16O ,'wrunoff_16O' ) ! field water isotope: runoff/flood + call add_to_budget_diag(budget_diags%fields, f_watr_ioff_16O ,'wfrzrof_16O' ) ! field water isotope: frozen runoff + f_16O_beg = f_watr_frz_16O ! field 1st index for 16O water isotope + f_16O_end = f_watr_ioff_16O ! field Last index for 16O water isotope + + call add_to_budget_diag(budget_diags%fields, f_watr_frz_18O ,'wfreeze_18O' ) ! field water isotope: freezing + call add_to_budget_diag(budget_diags%fields, f_watr_melt_18O ,'wmelt_18O' ) ! field water isotope: melting + call add_to_budget_diag(budget_diags%fields, f_watr_rain_18O ,'wrain_18O' ) ! field water isotope: precip, liquid + call add_to_budget_diag(budget_diags%fields, f_watr_snow_18O ,'wsnow_18O' ) ! field water isotope: precip, frozen + call add_to_budget_diag(budget_diags%fields, f_watr_evap_18O ,'wevap_18O' ) ! field water isotope: evaporation + call add_to_budget_diag(budget_diags%fields, f_watr_roff_18O ,'wrunoff_18O' ) ! field water isotope: runoff/flood + call add_to_budget_diag(budget_diags%fields, f_watr_ioff_18O ,'wfrzrof_18O' ) ! field water isotope: frozen runoff + f_18O_beg = f_watr_frz_18O ! field 1st index for 18O water isotope + f_18O_end = f_watr_ioff_18O ! field Last index for 18O water isotope + + call add_to_budget_diag(budget_diags%fields, f_watr_frz_HDO ,'wfreeze_HDO' ) ! field water isotope: freezing + call add_to_budget_diag(budget_diags%fields, f_watr_melt_HDO ,'wmelt_HDO' ) ! field water isotope: melting + call add_to_budget_diag(budget_diags%fields, f_watr_rain_HDO ,'wrain_HDO' ) ! field water isotope: precip, liquid + call add_to_budget_diag(budget_diags%fields, f_watr_snow_HDO ,'wsnow_HDO' ) ! field water isotope: precip, frozen + call add_to_budget_diag(budget_diags%fields, f_watr_evap_HDO ,'wevap_HDO' ) ! field water isotope: evaporation + call add_to_budget_diag(budget_diags%fields, f_watr_roff_HDO ,'wrunoff_HDO' ) ! field water isotope: runoff/flood + call add_to_budget_diag(budget_diags%fields, f_watr_ioff_HDO ,'wfrzrof_HDO' ) ! field water isotope: frozen runoff + f_HDO_beg = f_watr_frz_HDO ! field 1st index for HDO water isotope + f_HDO_end = f_watr_ioff_HDO ! field Last index for HDO water isotope + + ! water isotopes + iso0(:) = (/ f_16O_beg, f_18O_beg, f_hdO_beg /) + isof(:) = (/ f_16O_end, f_18O_end, f_hdO_end /) + isoname(:) = (/ 'H216O', 'H218O', ' HDO' /) + end if - call add_to_budget_diag(budget_diags%fields, f_watr_frz_16O ,'wfreeze_16O' ) ! field water isotope: freezing - call add_to_budget_diag(budget_diags%fields, f_watr_melt_16O ,'wmelt_16O' ) ! field water isotope: melting - call add_to_budget_diag(budget_diags%fields, f_watr_rain_16O ,'wrain_16O' ) ! field water isotope: precip, liquid - call add_to_budget_diag(budget_diags%fields, f_watr_snow_16O ,'wsnow_16O' ) ! field water isotope: prcip, frozen - call add_to_budget_diag(budget_diags%fields, f_watr_evap_16O ,'wevap_16O' ) ! field water isotope: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_roff_16O ,'wrunoff_16O' ) ! field water isotope: runoff/flood - call add_to_budget_diag(budget_diags%fields, f_watr_ioff_16O ,'wfrzrof_16O' ) ! field water isotope: frozen runoff - call add_to_budget_diag(budget_diags%fields, f_watr_frz_18O ,'wfreeze_18O' ) ! field water isotope: freezing - call add_to_budget_diag(budget_diags%fields, f_watr_melt_18O ,'wmelt_18O' ) ! field water isotope: melting - call add_to_budget_diag(budget_diags%fields, f_watr_rain_18O ,'wrain_18O' ) ! field water isotope: precip, liquid - call add_to_budget_diag(budget_diags%fields, f_watr_snow_18O ,'wsnow_18O' ) ! field water isotope: precip, frozen - call add_to_budget_diag(budget_diags%fields, f_watr_evap_18O ,'wevap_18O' ) ! field water isotope: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_roff_18O ,'wrunoff_18O' ) ! field water isotope: runoff/flood - call add_to_budget_diag(budget_diags%fields, f_watr_ioff_18O ,'wfrzrof_18O' ) ! field water isotope: frozen runoff - call add_to_budget_diag(budget_diags%fields, f_watr_frz_HDO ,'wfreeze_HDO' ) ! field water isotope: freezing - call add_to_budget_diag(budget_diags%fields, f_watr_melt_HDO ,'wmelt_HDO' ) ! field water isotope: melting - call add_to_budget_diag(budget_diags%fields, f_watr_rain_HDO ,'wrain_HDO' ) ! field water isotope: precip, liquid - call add_to_budget_diag(budget_diags%fields, f_watr_snow_HDO ,'wsnow_HDO' ) ! field water isotope: precip, frozen - call add_to_budget_diag(budget_diags%fields, f_watr_evap_HDO ,'wevap_HDO' ) ! field water isotope: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_roff_HDO ,'wrunoff_HDO' ) ! field water isotope: runoff/flood - call add_to_budget_diag(budget_diags%fields, f_watr_ioff_HDO ,'wfrzrof_HDO' ) ! field water isotope: frozen runoff - - f_heat_beg = f_heat_frz ! field first index for heat - f_heat_end = f_heat_sen ! field last index for heat - f_watr_beg = f_watr_frz ! field firs index for water - f_watr_end = f_watr_ioff ! field last index for water - - f_16O_beg = f_watr_frz_16O ! field 1st index for 16O water isotope - f_16O_end = f_watr_ioff_16O ! field Last index for 16O water isotope - f_18O_beg = f_watr_frz_18O ! field 1st index for 18O water isotope - f_18O_end = f_watr_ioff_18O ! field Last index for 18O water isotope - f_HDO_beg = f_watr_frz_HDO ! field 1st index for HDO water isotope - f_HDO_end = f_watr_ioff_HDO ! field Last index for HDO water isotope + ! ----------------------------------------- + ! Salt fluxes budget terms (for v1 only) + ! ----------------------------------------- - ! water isotopes - iso0(:) = (/ f_16O_beg, f_18O_beg, f_hdO_beg /) - isof(:) = (/ f_16O_end, f_18O_end, f_hdO_end /) - isoname(:) = (/ 'H216O', 'H218O', ' HDO' /) + if (trim(budget_table_version) == 'v1') then + call add_to_budget_diag(budget_diags%fields, f_watr_salt ,'saltf') ! field water: salt flux + f_salt_beg = f_watr_salt + f_salt_end = f_watr_salt + endif !------------------------------------------------------------------------------- ! Get config variables @@ -356,18 +398,18 @@ subroutine med_diag_init(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return budget_print_month = get_diag_attribute(gcomp, 'budget_month', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - budget_print_ann = get_diag_attribute(gcomp, 'budget_ann', rc) + budget_print_ann = get_diag_attribute(gcomp, 'budget_ann', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - budget_print_ltann = get_diag_attribute(gcomp, 'budget_ltann', rc) + budget_print_ltann = get_diag_attribute(gcomp, 'budget_ltann', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - budget_print_ltend = get_diag_attribute(gcomp, 'budget_ltend', rc) + budget_print_ltend = get_diag_attribute(gcomp, 'budget_ltend', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! period types call add_to_budget_diag(budget_diags%periods, period_inst,' inst') if(budget_print_daily > 0) call add_to_budget_diag(budget_diags%periods, period_day ,' daily') if(budget_print_month > 0) call add_to_budget_diag(budget_diags%periods, period_mon ,' monthly') - if(budget_print_ann > 0) call add_to_budget_diag(budget_diags%periods, period_ann ,' annual') + if(budget_print_ann > 0) call add_to_budget_diag(budget_diags%periods, period_ann ,' annual') call add_to_budget_diag(budget_diags%periods, period_inf ,'all_time') ! allocate module budget arrays @@ -653,12 +695,14 @@ subroutine med_phases_diag_atm(gcomp, rc) areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (flds_wiso) then + call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if ! heat implied by snow flux from atm to mediator budget_local(f_heat_latf,c_atm_recv ,ip) = -budget_local(f_watr_snow,c_atm_recv ,ip)*shr_const_latice @@ -698,9 +742,12 @@ subroutine med_phases_diag_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! water isotopes - call diag_atm_wiso_send(is_local%wrap%FBImp(compatm,compatm), 'Faxa_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, & - areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_atm_wiso_send(is_local%wrap%FBImp(compatm,compatm), 'Faxa_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, & + areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if deallocate(afrac) call t_stopf('MED:'//subname) @@ -938,28 +985,43 @@ subroutine med_phases_diag_lnd( gcomp, rc) end do call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_swnet', f_heat_swnet , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_lwup' , f_heat_lwup , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_lat' , f_heat_latvap , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_sen' , f_heat_sen , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_evap' , f_watr_evap , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsur', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofgwl', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsub', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_irrig' , f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi' , f_watr_ioff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofl_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi_wiso', & - f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofl_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi_wiso', & + f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -974,22 +1036,34 @@ subroutine med_phases_diag_lnd( gcomp, rc) budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*lfrac(n) end do call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_lwdn' , f_heat_lwdn, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_rainc', f_watr_rain, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_rainl', f_watr_rain, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_snowc', f_watr_snow, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_snowl', f_watr_snow, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Flrl_flood', f_watr_roff, ic, areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainc_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainl_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowc_wiso', & - f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowl_wiso', & - f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Flrl_flood_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, minus=.true., rc=rc) + if (flds_wiso) then + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainc_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainl_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowc_wiso', & + f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowl_wiso', & + f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Flrl_flood_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, minus=.true., rc=rc) + end if budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice @@ -1103,16 +1177,25 @@ subroutine med_phases_diag_rof( gcomp, rc) ip = period_inst call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Flrr_flood', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofl' , f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofi' , f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Firr_rofi' , f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_flood_wiso', & - f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, rc=rc) - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofl_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, minus=.true., rc=rc) - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofi_wiso', & - f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, minus=.true., rc=rc) + if (flds_wiso) then + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_flood_wiso', & + f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofl_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofi_wiso', & + f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1124,15 +1207,24 @@ subroutine med_phases_diag_rof( gcomp, rc) ip = period_inst call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofsur', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofgwl', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofsub', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_irrig' , f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofi' , f_watr_ioff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofl_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, rc=rc) - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofi_wiso', & + if (flds_wiso) then + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofl_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofi_wiso', & f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1248,8 +1340,11 @@ subroutine med_phases_diag_glc( gcomp, rc) do ns = 1,num_icesheets areas => is_local%wrap%mesh_info(compglc(ns))%areas call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Fogg_rofl', f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Fogg_rofi', f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Figg_rofi', f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end do budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1326,11 +1421,11 @@ subroutine med_phases_diag_ocn( gcomp, rc) call fldbun_getdata1d(is_local%wrap%FBfrac(compocn), 'ofrac', ofrac, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(sfrac(size(ofrac))) - sfrac(:) = ifrac(:) + ofrac(:) - allocate(sfrac_x_ofrac(size(ofrac))) - sfrac_x_ofrac(:) = sfrac(:) * ofrac(:) + sfrac(:) = 1._r8 - areas => is_local%wrap%mesh_info(compocn)%areas + !areas => is_local%wrap%mesh_info(compocn)%areas + call fldbun_getdata1d(is_local%wrap%FBarea(compocn), 'area', areas, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------------------- ! from ocn to mediator @@ -1352,15 +1447,9 @@ subroutine med_phases_diag_ocn( gcomp, rc) end do end if - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_lwup', f_heat_lwup , ic, areas, ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_lat' , f_heat_latvap , ic, areas, ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_sen' , f_heat_sen , ic, areas, ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_evap', f_watr_evap , ic, areas, ofrac, budget_local, rc=rc) - - call diag_ocn_wiso(is_local%wrap%FBImp(compocn,compocn), 'Faox_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, ofrac, budget_local, rc=rc) - - budget_local(f_watr_frz,ic,ip) = budget_local(f_heat_frz,ic,ip) * HFLXtoWFLX + if (f_watr_frz /= unset_index) then + budget_local(f_watr_frz,ic,ip) = budget_local(f_heat_frz,ic,ip) * HFLXtoWFLX + end if !------------------------------- ! from mediator to ocn @@ -1373,56 +1462,92 @@ subroutine med_phases_diag_ocn( gcomp, rc) budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*ofrac(n) end do - if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lwnet', rc=rc)) then - call diag_ocn(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup', f_heat_lwup, ic, areas, sfrac_x_ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compatm,compocn), 'Faxa_lwdn', f_heat_lwdn, ic, areas, sfrac_x_ofrac, budget_local, rc=rc) - else - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lwup' , f_heat_lwup , ic, areas, sfrac, budget_local, rc=rc) + if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lwnet', rc=rc)) then ! MOM6 + call diag_ocn(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup', f_heat_lwup, ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBImp(compatm,compocn), 'Faxa_lwdn', f_heat_lwdn, ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else ! POP + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_lwup' , f_heat_lwup , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_lwdn' , f_heat_lwdn , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lat', rc=rc)) then - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lat' , f_heat_latvap , ic, areas, sfrac, budget_local, rc=rc) - else - call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_lat' , f_heat_latvap , ic, areas, sfrac_x_ofrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_sen' , f_heat_sen , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_evap', f_watr_evap , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lat', rc=rc)) then ! POP + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_lat' , f_heat_latvap , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else ! MOM6 + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_evap' , f_heat_latvap , ic, areas, ofrac, budget_local, & + scale=shr_const_latvap, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_sen' , f_heat_sen , ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_evap' , f_watr_evap , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_meltw', f_watr_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_bergw', f_watr_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_melth', f_heat_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_bergh', f_heat_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_salt' , f_watr_salt , ic, areas, sfrac, budget_local, & scale=SFLXtoWFLX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet', rc=rc)) then call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', rc=rc)) then call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_rain' , f_watr_rain , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_snow' , f_watr_snow , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_rofl' , f_watr_roff , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_rofi' , f_watr_ioff , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_meltw_wiso', & - f_watr_melt_16O, f_watr_melt_HDO, f_watr_melt_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_rain_wiso' , & - f_watr_rain_16O, f_watr_rain_HDO, f_watr_rain_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_snow_wiso' , & - f_watr_snow_16O, f_watr_snow_HDO, f_watr_snow_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofl_wiso' , & - f_watr_roff_16O, f_watr_roff_HDO, f_watr_roff_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofi_wiso' , & - f_watr_ioff_16O, f_watr_ioff_HDO, f_watr_ioff_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_ocn_wiso(is_local%wrap%FBMed_aoflux_o, 'Faox_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_meltw_wiso', & + f_watr_melt_16O, f_watr_melt_HDO, f_watr_melt_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_rain_wiso' , & + f_watr_rain_16O, f_watr_rain_HDO, f_watr_rain_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_snow_wiso' , & + f_watr_snow_16O, f_watr_snow_HDO, f_watr_snow_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofl_wiso' , & + f_watr_roff_16O, f_watr_roff_HDO, f_watr_roff_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofi_wiso' , & + f_watr_ioff_16O, f_watr_ioff_HDO, f_watr_ioff_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1449,6 +1574,7 @@ subroutine diag_ocn(FB, fldname, nf, ic, areas, frac, budget, scale, rc) real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1546,10 +1672,13 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_melth', f_heat_melt, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_meltw', f_watr_melt, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_salt', f_watr_salt, & areas, lats, ifrac, budget_local, minus=.true., scale=SFLXtoWFLX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdf', rc=rc) .and. & @@ -1557,32 +1686,46 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idf', rc=rc)) then call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdf', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idr', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idf', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_swnet', f_heat_swnet, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_lwup', f_heat_lwup, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_lat', f_heat_latvap, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_sen', f_heat_sen, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_evap', f_watr_evap, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Fioi_meltw_wiso', & - f_watr_melt_16O, f_watr_melt_18O, f_watr_melt_HDO, areas, lats, ifrac, budget_local, rc=rc) - call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Faii_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Fioi_meltw_wiso', & + f_watr_melt_16O, f_watr_melt_18O, f_watr_melt_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Faii_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if call t_stopf('MED:'//subname) end subroutine med_phases_diag_ice_ice2med @@ -1728,9 +1871,13 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) end do call diag_ice_send(is_local%wrap%FBExp(compice), 'Faxa_lwdn', f_heat_lwdn, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_send(is_local%wrap%FBExp(compice), 'Faxa_rain', f_watr_rain, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_send(is_local%wrap%FBExp(compice), 'Faxa_snow', f_watr_snow, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_send(is_local%wrap%FBExp(compice), 'Fixx_rofi', f_watr_ioff, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( fldbun_fldchk(is_local%wrap%FBExp(compice), 'Fioo_q', rc=rc)) then call fldbun_getdata1d(is_local%wrap%FBExp(compice), 'Fioo_q', data, rc=rc) @@ -1757,10 +1904,14 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice budget_local(f_watr_frz ,ic,ip) = budget_local(f_heat_frz ,ic,ip)*HFLXtoWFLX - call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_rain_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, ifrac, budget_local, rc=rc) - call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_snow_wiso', & - f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_rain_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_snow_wiso', & + f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if call t_stopf('MED:'//subname) end subroutine med_phases_diag_ice_med2ice @@ -2328,13 +2479,21 @@ subroutine med_diag_print_summary(data, ip, date, tod) real(r8) :: net_heat_ice_nh , sum_net_heat_ice_nh real(r8) :: net_heat_ice_sh , sum_net_heat_ice_sh real(r8) :: net_heat_tot , sum_net_heat_tot + real(r8) :: net_salt_atm , sum_net_salt_atm + real(r8) :: net_salt_lnd , sum_net_salt_lnd + real(r8) :: net_salt_rof , sum_net_salt_rof + real(r8) :: net_salt_ocn , sum_net_salt_ocn + real(r8) :: net_salt_glc , sum_net_salt_glc + real(r8) :: net_salt_ice_nh , sum_net_salt_ice_nh + real(r8) :: net_salt_ice_sh , sum_net_salt_ice_sh + real(r8) :: net_salt_tot , sum_net_salt_tot character(len=40) :: str character(*), parameter:: subName = '(med_diag_print_summary) ' ! ------------------------------------------------------------------ call t_startf('MED:'//subname) - ! write out areas + ! write out areas write(diagunit,*) ' ' write(diagunit,FAH) subname,'NET AREA BUDGET (m2/m2): period = ',& trim(budget_diags%periods(ip)%name),& @@ -2347,7 +2506,10 @@ subroutine med_diag_print_summary(data, ip, date, tod) ice_area_sh = data(f_area,c_ish_recv,ip) sum_area = atm_area + lnd_area + ocn_area + ice_area_nh + ice_area_sh write(diagunit,FA1) budget_diags%fields(f_area)%name, atm_area, lnd_area, ocn_area, ice_area_nh, ice_area_sh, sum_area + + ! ----------------------------- ! write out net heat budgets + ! ----------------------------- write(diagunit,*) ' ' write(diagunit,FAH) subname,'NET HEAT BUDGET (W/m2): period = ',& @@ -2370,7 +2532,6 @@ subroutine med_diag_print_summary(data, ip, date, tod) end do ! Write out sum over all net heat budgets (sum over f_heat_beg -> f_heat_end) - sum_net_heat_atm = sum(data(f_heat_beg:f_heat_end, c_atm_recv, ip)) + & sum(data(f_heat_beg:f_heat_end, c_atm_send, ip)) sum_net_heat_lnd = sum(data(f_heat_beg:f_heat_end, c_lnd_recv, ip)) + & @@ -2392,7 +2553,9 @@ subroutine med_diag_print_summary(data, ip, date, tod) sum_net_heat_atm, sum_net_heat_lnd, sum_net_heat_rof, sum_net_heat_ocn, & sum_net_heat_ice_nh, sum_net_heat_ice_sh, sum_net_heat_glc, sum_net_heat_tot + ! ----------------------------- ! write out net water budgets + ! ----------------------------- write(diagunit,*) ' ' write(diagunit,FAH) subname,'NET WATER BUDGET (kg/m2s*1e6): period = ',& @@ -2414,8 +2577,7 @@ subroutine med_diag_print_summary(data, ip, date, tod) net_water_ice_nh, net_water_ice_sh, net_water_glc, net_water_tot enddo - ! Write out sum over all net heat budgets (sum over f_watr_beg -> f_watr_end) - + ! Write out sum over all net water budgets (sum over f_watr_beg -> f_watr_end) sum_net_water_atm = sum(data(f_watr_beg:f_watr_end, c_atm_recv, ip)) + & sum(data(f_watr_beg:f_watr_end, c_atm_send, ip)) sum_net_water_lnd = sum(data(f_watr_beg:f_watr_end, c_lnd_recv, ip)) + & @@ -2486,6 +2648,54 @@ subroutine med_diag_print_summary(data, ip, date, tod) end do end if + ! ----------------------------- + ! write out net salt budgets + ! ----------------------------- + + if (trim(budget_table_version) == 'v1') then + write(diagunit,*) ' ' + write(diagunit,FAH) subname,'NET SALT BUDGET (kg/m2s): period = ',& + trim(budget_diags%periods(ip)%name), ': date = ',date,tod + write(diagunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + do nf = f_salt_beg, f_salt_end + net_salt_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip) + net_salt_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip) + net_salt_rof = data(nf, c_rof_recv, ip) + data(nf, c_rof_send, ip) + net_salt_ocn = data(nf, c_ocn_recv, ip) + data(nf, c_ocn_send, ip) + net_salt_ice_nh = data(nf, c_inh_recv, ip) + data(nf, c_inh_send, ip) + net_salt_ice_sh = data(nf, c_ish_recv, ip) + data(nf, c_ish_send, ip) + net_salt_glc = data(nf, c_glc_recv, ip) + data(nf, c_glc_send, ip) + net_salt_tot = net_salt_atm + net_salt_lnd + net_salt_rof + net_salt_ocn + & + net_salt_ice_nh + net_salt_ice_sh + net_salt_glc + + write(diagunit,FA1r) budget_diags%fields(nf)%name,& + net_salt_atm, net_salt_lnd, net_salt_rof, net_salt_ocn, & + net_salt_ice_nh, net_salt_ice_sh, net_salt_glc, net_salt_tot + enddo + + ! Write out sum over all net heat budgets (sum over f_salt_beg -> f_salt_end) + sum_net_salt_atm = sum(data(f_salt_beg:f_salt_end, c_atm_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_atm_send, ip)) + sum_net_salt_lnd = sum(data(f_salt_beg:f_salt_end, c_lnd_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_lnd_send, ip)) + sum_net_salt_rof = sum(data(f_salt_beg:f_salt_end, c_rof_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_rof_send, ip)) + sum_net_salt_ocn = sum(data(f_salt_beg:f_salt_end, c_ocn_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_ocn_send, ip)) + sum_net_salt_ice_nh = sum(data(f_salt_beg:f_salt_end, c_inh_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_inh_send, ip)) + sum_net_salt_ice_sh = sum(data(f_salt_beg:f_salt_end, c_ish_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_ish_send, ip)) + sum_net_salt_glc = sum(data(f_salt_beg:f_salt_end, c_glc_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_glc_send, ip)) + sum_net_salt_tot = sum_net_salt_atm + sum_net_salt_lnd + sum_net_salt_rof + sum_net_salt_ocn + & + sum_net_salt_ice_nh + sum_net_salt_ice_sh + sum_net_salt_glc + + write(diagunit,FA1r)' *SUM*',& + sum_net_salt_atm, sum_net_salt_lnd, sum_net_salt_rof, sum_net_salt_ocn, & + sum_net_salt_ice_nh, sum_net_salt_ice_sh, sum_net_salt_glc, sum_net_salt_tot + end if + call t_stopf('MED:'//subname) end subroutine med_diag_print_summary diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90 index e26748b8f..90fb0eb3f 100644 --- a/mediator/med_io_mod.F90 +++ b/mediator/med_io_mod.F90 @@ -6,7 +6,7 @@ module med_io_mod use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, I8=>SHR_KIND_I8, R8=>SHR_KIND_R8 use med_kind_mod , only : R4=>SHR_KIND_R4 - use shr_const_mod , only : fillvalue => SHR_CONST_SPVAL + use med_constants_mod , only : fillvalue => SHR_CONST_SPVAL use ESMF , only : ESMF_VM, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LogFoundError use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_END_ABORT, ESMF_LOGERR_PASSTHRU use ESMF , only : ESMF_VMGetCurrent, ESMF_VMGet, ESMF_VMBroadCast, ESMF_Finalize @@ -746,13 +746,13 @@ end function med_io_sec2hms !=============================================================================== subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & - fillval, pre, flds, tavg, use_float, file_ind, rc) + fillval, pre, flds, tavg, use_float, file_ind, tilesize, rc) !--------------- ! Write FB to netcdf file !--------------- - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE, ESMF_END_ABORT use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_FieldBundle, ESMF_Mesh, ESMF_DistGrid use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldGet, ESMF_MeshGet, ESMF_DistGridGet use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_AttributeGet @@ -775,6 +775,7 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & logical, optional , intent(in) :: tavg ! is this a tavg logical, optional , intent(in) :: use_float ! write output as float rather than double integer, optional , intent(in) :: file_ind + integer, optional , intent(in) :: tilesize ! if non-zero, write atm component on tiles integer , intent(out):: rc ! local variables @@ -789,6 +790,7 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & integer :: ndims, nelements integer ,target :: dimid2(2) integer ,target :: dimid3(3) + integer ,target :: dimid4(4) integer ,pointer :: dimid(:) type(var_desc_t) :: varid type(io_desc_t) :: iodesc @@ -817,6 +819,8 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields integer :: gridToFieldMap(1) ! currently the size must equal 1 for rank 2 fields logical :: isPresent + logical :: atmtiles + integer :: ntiles = 1 character(CL), allocatable :: fieldNameList(:) character(*),parameter :: subName = '(med_io_write_FB) ' !------------------------------------------------------------------------------- @@ -831,6 +835,10 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & if (present(use_float)) luse_float = use_float lfile_ind = 0 if (present(file_ind)) lfile_ind=file_ind + atmtiles = .false. + if (present(tilesize)) then + if (tilesize > 0) atmtiles = .true. + end if ! Error check if (.not. ESMF_FieldBundleIsCreated(FB, rc=rc)) then @@ -900,15 +908,27 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & ! all the global grid values in the distgrid - e.g. CTSM ng = maxval(maxIndexPTile) - lnx = ng - lny = 1 + if (atmtiles) then + lnx = tilesize + lny = tilesize + ntiles = ng/(lnx*lny) + write(tmpstr,*) subname, 'ng,lnx,lny,ntiles = ',ng,lnx,lny,ntiles + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + if (ntiles /= 6) then + call ESMF_LogWrite(trim(subname)//' ERROR: only cubed sphere atm tiles valid ', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + else + lnx = ng + lny = 1 + if (nx > 0) lnx = nx + if (ny > 0) lny = ny + if (lnx*lny /= ng) then + write(tmpstr,*) subname,' WARNING: grid2d size not consistent ',ng,lnx,lny + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + endif + end if deallocate(minIndexPTile, maxIndexPTile) - if (nx > 0) lnx = nx - if (ny > 0) lny = ny - if (lnx*lny /= ng) then - write(tmpstr,*) subname,' WARNING: grid2d size not consistent ',ng,lnx,lny - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - endif if (present(nt)) then frame = nt @@ -918,6 +938,18 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & ! Write header if (whead) then + if (atmtiles) then + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_nx', lnx, dimid3(1)) + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_ny', lny, dimid3(2)) + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_ntiles', ntiles, dimid3(3)) + if (present(nt)) then + dimid4(1:3) = dimid3 + rcode = pio_inq_dimid(io_file(lfile_ind), 'time', dimid4(4)) + dimid => dimid4 + else + dimid => dimid3 + endif + else rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_nx', lnx, dimid2(1)) rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_ny', lny, dimid2(2)) if (present(nt)) then @@ -927,8 +959,9 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & else dimid => dimid2 endif - write(tmpstr,*) subname,' dimid = ',dimid - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + endif + write(tmpstr,*) subname,' dimid = ',dimid + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) do k = 1,nf ! Determine field name @@ -1034,8 +1067,12 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & call ESMF_DistGridGet(distgrid, localDE=0, seqIndexList=dof, rc=rc) write(tmpstr,*) subname,' dof = ',ns,size(dof),dof(1),dof(ns) !,minval(dof),maxval(dof) call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call pio_initdecomp(io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) - ! call pio_writedof(lpre, (/lnx,lny/), int(dof,kind=PIO_OFFSET_KIND), mpicom) + if (atmtiles) then + call pio_initdecomp(io_subsystem, pio_double, (/lnx,lny,ntiles/), dof, iodesc) + else + call pio_initdecomp(io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + !call pio_writedof(lpre, (/lnx,lny/), int(dof,kind=PIO_OFFSET_KIND), mpicom) + end if deallocate(dof) do k = 1,nf @@ -1356,7 +1393,7 @@ end subroutine med_io_write_char !=============================================================================== subroutine med_io_define_time(time_units, calendar, file_ind, rc) - use ESMF, only : operator(==), operator(/=) + use ESMF, only : operator(==), operator(/=) use ESMF, only : ESMF_Calendar, ESMF_CalendarIsCreated use ESMF, only : ESMF_CALKIND_360DAY, ESMF_CALKIND_GREGORIAN use ESMF, only : ESMF_CALKIND_JULIAN, ESMF_CALKIND_JULIANDAY, ESMF_CALKIND_MODJULIANDAY @@ -1913,7 +1950,7 @@ subroutine med_io_read_r81d(filename, vm, rdata, dname, rc) type(var_desc_t) :: varid character(CL) :: lversion character(CL) :: name1 - integer :: iam + integer :: iam character(*),parameter :: subName = '(med_io_read_r81d) ' !------------------------------------------------------------------------------- diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 41b1931f2..6b713398a 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -325,7 +325,7 @@ end subroutine med_map_routehandles_initfrom_fieldbundle subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, routehandles, mapfile, rc) use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandlePrint, ESMF_Field, ESMF_MAXSTR - use ESMF , only : ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG + use ESMF , only : ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG, ESMF_POLEMETHOD_NONE use ESMF , only : ESMF_FieldSMMStore, ESMF_FieldRedistStore, ESMF_FieldRegridStore use ESMF , only : ESMF_RouteHandleIsCreated, ESMF_RouteHandleCreate use ESMF , only : ESMF_REGRIDMETHOD_BILINEAR, ESMF_REGRIDMETHOD_PATCH @@ -368,7 +368,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, integer :: ns integer(I4), pointer :: dof(:) integer :: srcTermProcessing_Value = 0 - type(ESMF_PoleMethod_Flag), parameter :: polemethod=ESMF_POLEMETHOD_ALLAVG + type(ESMF_PoleMethod_Flag) :: polemethod character(len=*), parameter :: subname=' (module_med_map: med_map_routehandles_initfrom_field) ' !--------------------------------------------- @@ -388,11 +388,19 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, ! set local flag to false ldstprint = .false. + polemethod=ESMF_POLEMETHOD_ALLAVG if (trim(coupling_mode) == 'cesm') then dstMaskValue = ispval_mask srcMaskValue = ispval_mask if (n1 == compocn .or. n1 == compice) srcMaskValue = 0 if (n2 == compocn .or. n2 == compice) dstMaskValue = 0 + if (n1 == compwav .and. n2 == compocn) then + srcMaskValue = 0 + dstMaskValue = ispval_mask + endif + if (n1 == compwav .or. n2 == compwav) then + polemethod = ESMF_POLEMETHOD_NONE ! todo: remove this when ESMF tripolar mapping fix is in place. + endif else if (coupling_mode(1:4) == 'nems') then if (n1 == compatm .and. (n2 == compocn .or. n2 == compice)) then srcMaskValue = 1 @@ -1349,7 +1357,7 @@ subroutine med_map_uv_cart3d(FBsrc, FBdst, routehandles, mapindex, rc) use ESMF , only : ESMF_Field, ESMF_FieldCreate, ESMF_FieldGet use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet use ESMF , only : ESMF_RouteHandle - use shr_const_mod , only : shr_const_pi + use med_constants_mod , only : shr_const_pi ! input/output variables type(ESMF_FieldBundle) , intent(in) :: FBsrc diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index 42382d3d9..d8aa7acdd 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -312,8 +312,11 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldBundle use esmFlds , only : coupling_mode use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk +#ifdef CESMCOUPLED use shr_flux_mod , only : shr_flux_adjust_constants - +#else + use flux_atmocn_mod , only : flux_adjust_constants +#endif !----------------------------------------------------------------------- ! Initialize pointers to the module variables !----------------------------------------------------------------------- @@ -397,7 +400,7 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) end if !---------------------------------- - ! Initialize shr_flux_adjust_constants + ! Initialize flux_adjust_constants !---------------------------------- call NUOPC_CompAttributeGet(gcomp, name='coldair_outbreak_mod', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) @@ -421,10 +424,18 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) else flux_convergence = 0.0_r8 end if + +#ifdef CESMCOUPLED call shr_flux_adjust_constants(& flux_convergence_tolerance=flux_convergence, & flux_convergence_max_iteration=flux_max_iteration, & coldair_outbreak_mod=coldair_outbreak_mod) +#else + call flux_adjust_constants(& + flux_convergence_tolerance=flux_convergence, & + flux_convergence_max_iteration=flux_max_iteration, & + coldair_outbreak_mod=coldair_outbreak_mod) +#endif if (dbug_flag > 5) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) @@ -855,10 +866,14 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) ! 3) Map aoflux output to relevant atm/ocn grid(s) !----------------------------------------------------------------------- - use ESMF , only : ESMF_GridComp - use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info, ESMF_SUCCESS - use med_map_mod , only : med_map_field_packed, med_map_rh_is_created - use shr_flux_mod , only : shr_flux_atmocn + use ESMF , only : ESMF_GridComp + use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info, ESMF_SUCCESS + use med_map_mod , only : med_map_field_packed, med_map_rh_is_created +#ifdef CESMCOUPLED + use shr_flux_mod , only : flux_atmocn +#else + use flux_atmocn_mod, only : flux_atmocn +#endif ! Arguments type(ESMF_GridComp) :: gcomp @@ -1001,7 +1016,9 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) ! Update atmosphere/ocean surface fluxes !---------------------------------- - call shr_flux_atmocn (& +#ifdef CESMCOUPLED + + call flux_atmocn (logunit=logunit, & nMax=aoflux_in%lsize, & zbot=aoflux_in%zbot, ubot=aoflux_in%ubot, vbot=aoflux_in%vbot, thbot=aoflux_in%thbot, qbot=aoflux_in%shum, & s16O=aoflux_in%shum_16O, sHDO=aoflux_in%shum_HDO, s18O=aoflux_in%shum_18O, rbot=aoflux_in%dens, & @@ -1013,7 +1030,20 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) taux=aoflux_out%taux, tauy=aoflux_out%tauy, tref=aoflux_out%tref, qref=aoflux_out%qref, & ocn_surface_flux_scheme=ocn_surface_flux_scheme, & duu10n=aoflux_out%duu10n, ustar_sv=aoflux_out%ustar, re_sv=aoflux_out%re, ssq_sv=aoflux_out%ssq, & - missval = 0.0_r8) + missval=0.0_r8) + +#else + + call flux_atmocn (logunit=logunit, & + nMax=aoflux_in%lsize, mask=aoflux_in%mask, & + zbot=aoflux_in%zbot, ubot=aoflux_in%ubot, vbot=aoflux_in%vbot, thbot=aoflux_in%thbot, qbot=aoflux_in%shum, & + rbot=aoflux_in%dens, tbot=aoflux_in%tbot, us=aoflux_in%uocn, vs=aoflux_in%vocn, ts=aoflux_in%tocn, & + ocn_surface_flux_scheme=ocn_surface_flux_scheme, & + sen=aoflux_out%sen, lat=aoflux_out%lat, lwup=aoflux_out%lwup, evap=aoflux_out%evap, & + taux=aoflux_out%taux, tauy=aoflux_out%tauy, tref=aoflux_out%tref, qref=aoflux_out%qref, & + duu10n=aoflux_out%duu10n, missval=0.0_r8) + +#endif do n = 1,aoflux_in%lsize if (aoflux_in%mask(n) /= 0) then diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 77496e1d7..5bf3c3a53 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -47,7 +47,13 @@ module med_phases_history_mod private :: med_phases_history_fldbun_average ! ---------------------------- - ! Instantaneous history files datatypes/variables + ! Instantaneous history files all components + ! ---------------------------- + character(CL) :: hist_option_all_inst ! freq_option setting (ndays, nsteps, etc) + integer :: hist_n_all_inst ! freq_n setting relative to freq_option + + ! ---------------------------- + ! Instantaneous history files datatypes/variables per component ! ---------------------------- type, public :: instfile_type logical :: write_inst @@ -144,8 +150,6 @@ subroutine med_phases_history_write(gcomp, rc) type(ESMF_Clock) :: mclock type(ESMF_Alarm) :: alarm character(CS) :: alarmname - character(CL) :: hist_option ! freq_option setting (ndays, nsteps, etc) - integer :: hist_n ! freq_n setting relative to freq_option character(CL) :: cvalue ! attribute string logical :: isPresent logical :: isSet @@ -185,27 +189,27 @@ subroutine med_phases_history_write(gcomp, rc) call NUOPC_CompAttributeGet(gcomp, name='history_option', isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name='history_option', value=hist_option, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='history_option', value=hist_option_all_inst, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name='history_n', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) hist_n + read(cvalue,*) hist_n_all_inst else ! If attribute is not present - don't write history output - hist_option = 'none' - hist_n = -999 + hist_option_all_inst = 'none' + hist_n_all_inst = -999 end if ! Set alarm name and initialize clock and alarm for instantaneous history output ! The alarm for the full history write is set on the mediator clock not as a separate alarm - if (hist_option /= 'none' .and. hist_option /= 'never') then + if (hist_option_all_inst /= 'none' .and. hist_option_all_inst /= 'never') then ! Initialize alarm on mediator clock for instantaneous mediator history output for all variables call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(mclock, startTime=starttime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_time_alarmInit(mclock, alarm, option=hist_option, opt_n=hist_n, & + call med_time_alarmInit(mclock, alarm, option=hist_option_all_inst, opt_n=hist_n_all_inst, & reftime=starttime, alarmname=alarmname, rc=rc) call ESMF_AlarmSet(alarm, clock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -221,14 +225,14 @@ subroutine med_phases_history_write(gcomp, rc) ! Write diagnostic info if (mastertask) then write(logunit,'(a,2x,i8)') trim(subname) // " initialized history alarm "//& - trim(alarmname)//" with option "//trim(hist_option)//" and frequency ",hist_n + trim(alarmname)//" with option "//trim(hist_option_all_inst)//" and frequency ",hist_n_all_inst end if end if first_time = .false. end if write_now = .false. - if (hist_option /= 'none' .and. hist_option /= 'never') then + if (hist_option_all_inst /= 'none' .and. hist_option_all_inst /= 'never') then call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGetAlarm(mclock, alarmname=trim(alarmname), alarm=alarm, rc=rc) @@ -615,7 +619,7 @@ end subroutine med_phases_history_write_lnd2glc !=============================================================================== subroutine med_phases_history_write_comp(gcomp, compid, rc) - ! Write mediator history file for atm variables + ! Write mediator history file for compid variables ! input/output variables type(ESMF_GridComp), intent(inout) :: gcomp @@ -654,6 +658,7 @@ subroutine med_phases_history_write_comp_inst(gcomp, compid, instfile, rc) integer :: hist_n ! freq_n setting relative to freq_option character(CL) :: hist_option_in character(CL) :: hist_n_in + integer :: hist_tilesize logical :: isPresent logical :: isSet type(ESMF_VM) :: vm @@ -676,10 +681,20 @@ subroutine med_phases_history_write_comp_inst(gcomp, compid, instfile, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Determine if tiled output to history file is requested + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_tilesize + else + hist_tilesize = 0 + end if ! alarm is not set determine hist_option and hist_n if (.not. instfile%is_clockset) then - ! Determine attribute prefix + ! Determine attribute name write(hist_option_in,'(a)') 'history_option_'//trim(compname(compid))//'_inst' write(hist_n_in,'(a)') 'history_n_'//trim(compname(compid))//'_inst' @@ -749,19 +764,19 @@ subroutine med_phases_history_write_comp_inst(gcomp, compid, instfile, rc) ! Define/write import field bundle if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(compid,compid),rc=rc)) then call med_io_write(hist_file, is_local%wrap%FBimp(compid,compid), whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Imp', rc=rc) + nt=1, pre=trim(compname(compid))//'Imp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! Define/write import export bundle if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid),rc=rc)) then call med_io_write(hist_file, is_local%wrap%FBexp(compid), whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Exp', rc=rc) + nt=1, pre=trim(compname(compid))//'Exp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! Define/Write mediator fractions if (ESMF_FieldBundleIsCreated(is_local%wrap%FBFrac(compid),rc=rc)) then call med_io_write(hist_file, is_local%wrap%FBFrac(compid), whead(m), wdata(m), nx, ny, & - nt=1, pre='Med_frac_'//trim(compname(compid)), rc=rc) + nt=1, pre='Med_frac_'//trim(compname(compid)), tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -801,6 +816,7 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) integer :: hist_n ! freq_n setting relative to freq_option character(CL) :: hist_option_in character(CL) :: hist_n_in + integer :: hist_tilesize logical :: isPresent logical :: isSet type(ESMF_VM) :: vm @@ -825,10 +841,20 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Determine if tiled output to history file is requested + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_tilesize + else + hist_tilesize = 0 + end if ! alarm is not set determine hist_option and hist_n if (.not. avgfile%is_clockset) then - ! Determine attribute prefix + ! Determine attribute name write(hist_option_in,'(a)') 'history_option_'//trim(compname(compid))//'_avg' write(hist_n_in,'(a)') 'history_n_'//trim(compname(compid))//'_avg' @@ -944,7 +970,7 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) ny = is_local%wrap%ny(compid) if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(compid,compid),rc=rc)) then call med_io_write(hist_file, avgfile%FBaccum_import, whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Imp', rc=rc) + nt=1, pre=trim(compname(compid))//'Imp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (wdata(m)) then call med_methods_FB_reset(avgfile%FBAccum_import, czero, rc=rc) @@ -953,7 +979,7 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) endif if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid),rc=rc)) then call med_io_write(hist_file, avgfile%FBaccum_export, whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Exp', rc=rc) + nt=1, pre=trim(compname(compid))//'Exp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (wdata(m)) then call med_methods_FB_reset(avgfile%FBAccum_export, czero, rc=rc) @@ -1049,7 +1075,7 @@ subroutine med_phases_history_write_comp_aux(gcomp, compid, auxcomp, rc) if (isPresent .and. isSet) then call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_enabled', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,'(l)') enable_auxfile + read(cvalue,'(l7)') enable_auxfile else enable_auxfile = .false. end if diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90 index c9c4d76fe..ce3ef2a82 100644 --- a/mediator/med_phases_ocnalb_mod.F90 +++ b/mediator/med_phases_ocnalb_mod.F90 @@ -210,7 +210,7 @@ subroutine med_phases_ocnalb_run(gcomp, rc) use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldBundleIsCreated use ESMF , only : operator(+) use NUOPC , only : NUOPC_CompAttributeGet - use shr_const_mod , only : shr_const_pi + use med_constants_mod , only : shr_const_pi ! input/output variables type(ESMF_GridComp) :: gcomp diff --git a/mediator/med_phases_post_glc_mod.F90 b/mediator/med_phases_post_glc_mod.F90 index 44e013641..5987ee355 100644 --- a/mediator/med_phases_post_glc_mod.F90 +++ b/mediator/med_phases_post_glc_mod.F90 @@ -2,16 +2,16 @@ module med_phases_post_glc_mod !----------------------------------------------------------------------------- ! Mediator phase for mapping glc->lnd and glc->ocn after the receive of glc + ! ASSUMES that multiple ice sheets do not overlap !----------------------------------------------------------------------------- use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 use NUOPC , only : NUOPC_CompAttributeGet - use ESMF , only : operator(/=) use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR, ESMF_SUCCESS, ESMF_FAILURE use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_StateGet, ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND - use ESMF , only : ESMF_Mesh, ESMF_MeshLoc, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_StateGet, ESMF_StateItem_Flag + use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8 use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandleIsCreated use esmFlds , only : compatm, compice, complnd, comprof, compocn, ncomps, compname @@ -30,10 +30,7 @@ module med_phases_post_glc_mod use med_internalstate_mod , only : InternalState, mastertask, logunit use med_map_mod , only : med_map_rh_is_created, med_map_routehandles_init use med_map_mod , only : med_map_field_packed, med_map_field_normalized, med_map_field - use med_merge_mod , only : med_merge_auto - use glc_elevclass_mod , only : glc_get_num_elevation_classes - use glc_elevclass_mod , only : glc_mean_elevation_virtual - use glc_elevclass_mod , only : glc_get_fractional_icecov + use glc_elevclass_mod , only : glc_mean_elevation_virtual, glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf implicit none @@ -159,7 +156,7 @@ subroutine med_phases_post_glc(gcomp, rc) end if !--------------------------------------- - ! glc->ocn mapping - + ! glc->ocn mapping ! merging with rof->ocn fields is done in med_phases_prep_ocn !--------------------------------------- if (glc2ocn_coupling) then @@ -236,7 +233,6 @@ subroutine med_phases_post_glc(gcomp, rc) end subroutine med_phases_post_glc !================================================================================================ - subroutine map_glc2lnd_init(gcomp, rc) ! input/output variables @@ -384,6 +380,7 @@ subroutine map_glc2lnd( gcomp, rc) real(r8), pointer :: topo_l_ec_sum(:,:) real(r8), pointer :: dataptr1d_src(:) real(r8), pointer :: dataptr1d_dst(:) + real(r8), pointer :: icemask_l(:) character(len=*), parameter :: subname = 'map_glc2lnd' !----------------------------------------------------------------------- @@ -553,25 +550,53 @@ subroutine map_glc2lnd( gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call field_getdata2d(field_frac_x_icemask_l_ec, frac_x_icemask_l_ec, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + call field_getdata1d(field_icemask_l, icemask_l, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! set Sg_topo values in export state to land (in multiple elevation classes) ! also set the topo field for virtual columns, in a given elevation class. ! This is needed because virtual columns (i.e., elevation classes that have no ! contributing glc grid cells) won't have any topographic information mapped onto ! them, so would otherwise end up with an elevation of 0. + ! ASSUME that multiple ice sheets do not overlap do ec = 1,ungriddedCount topo_virtual = glc_mean_elevation_virtual(ec-1) ! glc_mean_elevation_virtual uses 0:glc_nec do l = 1,size(frac_x_icemask_l_ec, dim=2) - if (frac_l_ec_sum(ec,l) <= 0._r8) then - topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_virtual - else - if (frac_x_icemask_l_ec(ec,l) /= 0.0_r8) then - topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_l_ec(ec,l) / frac_x_icemask_l_ec(ec,l) + if (icemask_l(l) > 0._r8) then + ! We only do this where icemask_l > 0 to avoid adding topo_virtual + ! multiple times. If icemask_l == 0 for all ice sheets, then lnd should + ! ignore the topo values from glc, so it's safe to leave them unset; if + ! icemask_l is 0 for this ice sheet but > 0 for some other ice sheet, + ! then we'll get the appropriate topo setting from that other ice + ! sheet. + ! + ! Note that frac_l_ec_sum is the sum over ice sheets we have handled so + ! far in the outer loop over ice sheets. At first glance, that could + ! seem wrong (because what if a later ice sheet causes this sum to + ! become greater than 0?), and it may be that we should rework this for + ! clarity. However, since icemask_l > 0 (which is the ice mask for this + ! ice sheet) and we assume that multiple ice sheets do not overlap, we + ! can be confident that no other ice sheet will contribute to + ! frac_l_ec_sum for this land point, so if it is <= 0 at this point, + ! it should remain <= 0. + if (frac_l_ec_sum(ec,l) <= 0._r8) then + ! This is formulated as an addition for consistency with other + ! additions to the *_sum variables, but in practice only one ice + ! sheet will contribute to any land point, given the assumption of + ! non-overlapping ice sheet domains. (If more than one ice sheet + ! contributed to a given land point, the following line would do the + ! wrong thing, since it would add topo_virtual multiple times.) + topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_virtual + else + if (frac_x_icemask_l_ec(ec,l) /= 0.0_r8) then + topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_l_ec(ec,l) / frac_x_icemask_l_ec(ec,l) + end if end if end if end do end do end if + end do if (dbug_flag > 5) then diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index 890bb5501..8098d4106 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -31,6 +31,7 @@ module med_phases_prep_glc_mod use med_map_mod , only : med_map_field_normalized, med_map_field use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_constants_mod , only : czero => med_constants_czero + use med_constants_mod , only : shr_const_pi, shr_const_spval use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d @@ -45,8 +46,6 @@ module med_phases_prep_glc_mod use glc_elevclass_mod , only : glc_get_elevation_classes use glc_elevclass_mod , only : glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf - use shr_const_mod , only : shr_const_pi, shr_const_spval - use shr_mpi_mod , only : shr_mpi_sum implicit none private @@ -962,7 +961,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! scaling in the CISM NUOPC cap if (smb_renormalize) then - call med_phases_prep_glc_renormalize_smb(gcomp, rc) + call med_phases_prep_glc_renormalize_smb(gcomp, ns, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if @@ -975,7 +974,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) end subroutine med_phases_prep_glc_map_lnd2glc !================================================================================================ - subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) + subroutine med_phases_prep_glc_renormalize_smb(gcomp, ns, rc) !------------------ ! Renormalizes surface mass balance (smb, here named qice_g) so that the global @@ -1033,6 +1032,7 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) ! input/output variables type(ESMF_GridComp) :: gcomp + integer , intent(in) :: ns ! icesheet instance index integer , intent(out) :: rc ! return error code ! local variables @@ -1051,7 +1051,7 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) real(r8) , pointer :: dataptr1d(:) ! temporary 1d pointer real(r8) , pointer :: dataptr2d(:,:) ! temporary 2d pointer integer :: ec ! loop index over elevation classes - integer :: n, ns + integer :: n ! local and global sums of accumulation and ablation; used to compute renormalization factors real(r8) :: local_accum_lnd(1), global_accum_lnd(1) @@ -1082,160 +1082,156 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - do ns = 1,num_icesheets - - !--------------------------------------- - ! Map icemask_g from the glc grid to the land grid. - !--------------------------------------- - - ! determine icemask_g and set as contents of field_icemask_g - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_icemask_fieldname, dataptr1d, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata1d(toglc_frlnd(ns)%field_icemask_g, icemask_g, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - icemask_g(:) = dataptr1d(:) - - ! map ice mask from glc to lnd with no normalization - call med_map_field( & - field_src=toglc_frlnd(ns)%field_icemask_g, & - field_dst=field_icemask_l, & - routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & - maptype=mapconsd, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! get icemask_l - call field_getdata1d(field_icemask_l, icemask_l, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return - - ! ------------------------------------------------------------------------ - ! Map frac_field on glc grid without elevation classes to frac_field on land grid with elevation classes - ! ------------------------------------------------------------------------ + !--------------------------------------- + ! Map icemask_g from the glc grid to the land grid. + !--------------------------------------- - ! get topo_g(:), the topographic height of each glc gridcell - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_topo_fieldname, topo_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! determine icemask_g and set as contents of field_icemask_g + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_icemask_fieldname, dataptr1d, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call field_getdata1d(toglc_frlnd(ns)%field_icemask_g, icemask_g, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + icemask_g(:) = dataptr1d(:) + + ! map ice mask from glc to lnd with no normalization + call med_map_field( & + field_src=toglc_frlnd(ns)%field_icemask_g, & + field_dst=field_icemask_l, & + routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & + maptype=mapconsd, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! get icemask_l + call field_getdata1d(field_icemask_l, icemask_l, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - ! get frac_g(:), the total ice fraction in each glc gridcell - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_frac_fieldname, frac_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! ------------------------------------------------------------------------ + ! Map frac_field on glc grid without elevation classes to frac_field on land grid with elevation classes + ! ------------------------------------------------------------------------ - ! get frac_g_ec - the glc_elevclass gives the elevation class of each - ! glc grid cell, assuming that the grid cell is ice-covered, spans [1 -> ungriddedcount] - call field_getdata2d(toglc_frlnd(ns)%field_frac_g_ec, frac_g_ec, rc=rc) ! module field - if (chkerr(rc,__LINE__,u_FILE_u)) return - call glc_get_fractional_icecov(ungriddedCount-1, topo_g, frac_g, frac_g_ec, logunit) - - ! map fraction in each elevation class from the glc grid to the land grid and normalize by the icemask on the - ! glc grid - call med_map_field_normalized( & - field_src=toglc_frlnd(ns)%field_frac_g_ec, & - field_dst=field_frac_l_ec, & - routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & - maptype=mapconsd, & - field_normsrc=toglc_frlnd(ns)%field_icemask_g, & - field_normdst=field_normdst_l, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! get topo_g(:), the topographic height of each glc gridcell + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_topo_fieldname, topo_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! get frac_g(:), the total ice fraction in each glc gridcell + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_frac_fieldname, frac_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! get frac_g_ec - the glc_elevclass gives the elevation class of each + ! glc grid cell, assuming that the grid cell is ice-covered, spans [1 -> ungriddedcount] + call field_getdata2d(toglc_frlnd(ns)%field_frac_g_ec, frac_g_ec, rc=rc) ! module field + if (chkerr(rc,__LINE__,u_FILE_u)) return + call glc_get_fractional_icecov(ungriddedCount-1, topo_g, frac_g, frac_g_ec, logunit) + + ! map fraction in each elevation class from the glc grid to the land grid and normalize by the icemask on the + ! glc grid + call med_map_field_normalized( & + field_src=toglc_frlnd(ns)%field_frac_g_ec, & + field_dst=field_frac_l_ec, & + routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & + maptype=mapconsd, & + field_normsrc=toglc_frlnd(ns)%field_icemask_g, & + field_normdst=field_normdst_l, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! Sum qice_l_ec over all elevation classes for each local land grid cell then do a global sum - !--------------------------------------- + !--------------------------------------- + ! Sum qice_l_ec over all elevation classes for each local land grid cell then do a global sum + !--------------------------------------- - ! get fractional ice coverage for each elevation class on the land grid, frac_l_ec(:,:) - call field_getdata2d(field_frac_l_ec, frac_l_ec, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return + ! get fractional ice coverage for each elevation class on the land grid, frac_l_ec(:,:) + call field_getdata2d(field_frac_l_ec, frac_l_ec, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - ! determine fraction on land grid, lfrac(:) - call fldbun_getdata1d(is_local%wrap%FBFrac(complnd), 'lfrac', lfrac, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return + ! determine fraction on land grid, lfrac(:) + call fldbun_getdata1d(is_local%wrap%FBFrac(complnd), 'lfrac', lfrac, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - ! get qice_l_ec - call fldbun_getdata2d(FBlndAccum2glc_l, trim(qice_fieldname)//'_elev', qice_l_ec, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return + ! get qice_l_ec + call fldbun_getdata2d(FBlndAccum2glc_l, trim(qice_fieldname)//'_elev', qice_l_ec, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - local_accum_lnd(1) = 0.0_r8 - local_ablat_lnd(1) = 0.0_r8 - do n = 1, size(lfrac) - ! Calculate effective area for sum - need the mapped icemask_l - effective_area = min(lfrac(n), icemask_l(n)) * is_local%wrap%mesh_info(complnd)%areas(n) - if (effective_area > 0.0_r8) then - do ec = 1, ungriddedCount - if (qice_l_ec(ec,n) >= 0.0_r8) then - local_accum_lnd(1) = local_accum_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) - else - local_ablat_lnd(1) = local_ablat_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) - endif - end do ! ec - end if ! if landmaks > 0 - enddo ! n - - call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMAllreduce(vm, senddata=local_accum_lnd, recvdata=global_accum_lnd, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMAllreduce(vm, senddata=local_ablat_lnd, recvdata=global_ablat_lnd, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(logunit,'(a,d21.10)') trim(subname)//'global_accum_lnd = ', global_accum_lnd - write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_lnd = ', global_ablat_lnd - endif + local_accum_lnd(1) = 0.0_r8 + local_ablat_lnd(1) = 0.0_r8 + do n = 1, size(lfrac) + ! Calculate effective area for sum - need the mapped icemask_l + effective_area = min(lfrac(n), icemask_l(n)) * is_local%wrap%mesh_info(complnd)%areas(n) + if (effective_area > 0.0_r8) then + do ec = 1, ungriddedCount + if (qice_l_ec(ec,n) >= 0.0_r8) then + local_accum_lnd(1) = local_accum_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) + else + local_ablat_lnd(1) = local_ablat_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) + endif + end do ! ec + end if ! if landmaks > 0 + enddo ! n - !--------------------------------------- - ! Sum qice_g over local glc grid cells. - !--------------------------------------- + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllreduce(vm, senddata=local_accum_lnd, recvdata=global_accum_lnd, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllreduce(vm, senddata=local_ablat_lnd, recvdata=global_ablat_lnd, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,'(a,d21.10)') trim(subname)//'global_accum_lnd = ', global_accum_lnd + write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_lnd = ', global_ablat_lnd + endif - ! determine qice_g - call fldbun_getdata1d(is_local%wrap%FBExp(compglc(ns)), qice_fieldname, qice_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + !--------------------------------------- + ! Sum qice_g over local glc grid cells. + !--------------------------------------- - ! get areas internal to glc grid - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Sg_area', area_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! determine qice_g + call fldbun_getdata1d(is_local%wrap%FBExp(compglc(ns)), qice_fieldname, qice_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - local_accum_glc(1) = 0.0_r8 - local_ablat_glc(1) = 0.0_r8 - do n = 1, size(qice_g) - if (qice_g(n) >= 0.0_r8) then - local_accum_glc(1) = local_accum_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) - else - local_ablat_glc(1) = local_ablat_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) - endif - enddo ! n - call ESMF_VMAllreduce(vm, senddata=local_accum_glc, recvdata=global_accum_glc, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - call ESMF_VMAllreduce(vm, senddata=local_ablat_glc, recvdata=global_ablat_glc, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - if (mastertask) then - write(logunit,'(a,d21.10)') trim(subname)//'global_accum_glc = ', global_accum_glc - write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_glc = ', global_ablat_glc - endif + ! get areas internal to glc grid + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Sg_area', area_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Renormalize - if (global_accum_glc(1) > 0.0_r8) then - accum_renorm_factor = global_accum_lnd(1) / global_accum_glc(1) + local_accum_glc(1) = 0.0_r8 + local_ablat_glc(1) = 0.0_r8 + do n = 1, size(qice_g) + if (qice_g(n) >= 0.0_r8) then + local_accum_glc(1) = local_accum_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) else - accum_renorm_factor = 0.0_r8 - endif - if (global_ablat_glc(1) < 0.0_r8) then ! negative by definition - ablat_renorm_factor = global_ablat_lnd(1) / global_ablat_glc(1) - else - ablat_renorm_factor = 0.0_r8 - endif - if (mastertask) then - write(logunit,'(a,d21.10)') trim(subname)//'accum_renorm_factor = ', accum_renorm_factor - write(logunit,'(a,d21.10)') trim(subname)//'ablat_renorm_factor = ', ablat_renorm_factor + local_ablat_glc(1) = local_ablat_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) endif + enddo ! n + call ESMF_VMAllreduce(vm, senddata=local_accum_glc, recvdata=global_accum_glc, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + call ESMF_VMAllreduce(vm, senddata=local_ablat_glc, recvdata=global_ablat_glc, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (mastertask) then + write(logunit,'(a,d21.10)') trim(subname)//'global_accum_glc = ', global_accum_glc + write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_glc = ', global_ablat_glc + endif - do n = 1, size(qice_g) - if (qice_g(n) >= 0.0_r8) then - qice_g(n) = qice_g(n) * accum_renorm_factor - else - qice_g(n) = qice_g(n) * ablat_renorm_factor - endif - enddo + ! Renormalize + if (global_accum_glc(1) > 0.0_r8) then + accum_renorm_factor = global_accum_lnd(1) / global_accum_glc(1) + else + accum_renorm_factor = 0.0_r8 + endif + if (global_ablat_glc(1) < 0.0_r8) then ! negative by definition + ablat_renorm_factor = global_ablat_lnd(1) / global_ablat_glc(1) + else + ablat_renorm_factor = 0.0_r8 + endif + if (mastertask) then + write(logunit,'(a,d21.10)') trim(subname)//'accum_renorm_factor = ', accum_renorm_factor + write(logunit,'(a,d21.10)') trim(subname)//'ablat_renorm_factor = ', ablat_renorm_factor + endif - end do ! end of loop over ice sheets + do n = 1, size(qice_g) + if (qice_g(n) >= 0.0_r8) then + qice_g(n) = qice_g(n) * accum_renorm_factor + else + qice_g(n) = qice_g(n) * ablat_renorm_factor + endif + enddo call t_stopf('MED:'//subname) diff --git a/mediator/med_phases_profile_mod.F90 b/mediator/med_phases_profile_mod.F90 index 447b1e4c2..46d8f2a73 100644 --- a/mediator/med_phases_profile_mod.F90 +++ b/mediator/med_phases_profile_mod.F90 @@ -11,7 +11,9 @@ module med_phases_profile_mod use med_utils_mod , only : chkerr => med_utils_ChkErr use med_time_mod , only : alarmInit => med_time_alarmInit use perf_mod , only : t_startf, t_stopf +#ifdef CESMCOUPLED use shr_mem_mod , only : shr_mem_getusage +#endif implicit none private @@ -179,11 +181,13 @@ subroutine med_phases_profile(gcomp, rc) write(logunit,101) 'Model Date: ',trim(nexttimestr), ' wall clock = ',trim(walltimestr),' avg dt = ', & avgdt, ' s/day, dt = ',wallclockelapsed/ringdays,' s/day, rate = ',ypd,' ypd' +#ifdef CESMCOUPLED call shr_mem_getusage(msize,mrss,.true.) - write(logunit,105) ' memory_write: model date = ',trim(nexttimestr), & ' memory = ',msize,' MB (highwater) ',mrss,' MB (usage)' +#endif previous_time = current_time + endif endif iterations = iterations + 1 diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index e2e00c474..d87cfba80 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -113,7 +113,7 @@ subroutine med_phases_restart_alarm_init(gcomp, rc) write(logunit,'(a,2x,i8)') trim(subname)//" restart clock timestep = ",timestep_length write(logunit,'(a,2x,i8)') trim(subname)//" set restart alarm with option "//& trim(restart_option)//" and frequency ",restart_n - write(logunit,'(a)') trim(subname)//" write_restart_at_endofrun : ", write_restart_at_endofrun + write(logunit,'(a,l7)') trim(subname)//" write_restart_at_endofrun : ", write_restart_at_endofrun write(logunit,*) end if diff --git a/ufs/CMakeLists.txt b/ufs/CMakeLists.txt new file mode 100644 index 000000000..bb047dabb --- /dev/null +++ b/ufs/CMakeLists.txt @@ -0,0 +1,6 @@ +project(CMEPS_share Fortran) +include(ExternalProject) + +add_library(cmeps_share flux_atmocn_mod.F90 glc_elevclass_mod.F90 perf_mod.F90 ufs_const_mod.F90 ufs_kind_mod.F90) + +target_include_directories (cmeps_share PUBLIC ${CMAKE_CURRENT_SOURCE_DIR} ${ESMF_F90COMPILEPATHS} ${PIO_Fortran_INCLUDE_DIRS}) diff --git a/util/shr_flux_mod.F90 b/ufs/flux_atmocn_mod.F90 similarity index 75% rename from util/shr_flux_mod.F90 rename to ufs/flux_atmocn_mod.F90 index b04a13497..ca0bc200c 100644 --- a/util/shr_flux_mod.F90 +++ b/ufs/flux_atmocn_mod.F90 @@ -1,9 +1,8 @@ -module shr_flux_mod +module flux_atmocn_mod - use shr_kind_mod ! shared kinds - use shr_const_mod ! shared constants - use shr_sys_mod ! shared system routines - use shr_log_mod, only: s_logunit => shr_log_Unit + use ufs_kind_mod ! shared kinds + use ufs_const_mod ! shared constants + use ESMF, only : ESMF_FINALIZE, ESMF_END_ABORT implicit none @@ -11,18 +10,15 @@ module shr_flux_mod ! !PUBLIC MEMBER FUNCTIONS: - public :: shr_flux_atmOcn ! computes atm/ocn fluxes - public :: shr_flux_adjust_constants ! adjust constant values used in flux calculations. + public :: flux_atmOcn ! computes atm/ocn fluxes + public :: flux_adjust_constants ! adjust constant values used in flux calculations. !--- rename kinds for local readability only --- integer,parameter :: R8 = SHR_KIND_R8 ! 8 byte real integer,parameter :: IN = SHR_KIND_IN ! native/default integer - ! The follow variables are not declared as parameters so that they can be - ! adjusted to support aquaplanet and potentially other simple model modes. - ! The shr_flux_adjust_constants subroutine is called to set the desired - ! values. The default values are from shr_const_mod. Currently they are - ! only used by the shr_flux_atmocn and shr_flux_atmice routines. + ! The follow variables are not declared as parameters so that they can be adjusted. + ! The default values are from ufs_const_mod. real(R8) :: loc_zvir = shr_const_zvir real(R8) :: loc_cpdair = shr_const_cpdair real(R8) :: loc_cpvir = shr_const_cpvir @@ -51,56 +47,32 @@ module shr_flux_mod contains !=============================================================================== - subroutine shr_flux_adjust_constants( & - zvir, cpair, cpvir, karman, gravit, & - latvap, latice, stebol, flux_convergence_tolerance, & - flux_convergence_max_iteration, & - coldair_outbreak_mod) + subroutine flux_adjust_constants( flux_convergence_tolerance, & + flux_convergence_max_iteration, coldair_outbreak_mod) ! Adjust local constants. Used to support simple models. - - real(R8), optional, intent(in) :: zvir - real(R8), optional, intent(in) :: cpair - real(R8), optional, intent(in) :: cpvir - real(R8), optional, intent(in) :: karman - real(R8), optional, intent(in) :: gravit - real(R8), optional, intent(in) :: latvap - real(R8), optional, intent(in) :: latice - real(R8), optional, intent(in) :: stebol - real(r8), optional, intent(in) :: flux_convergence_tolerance - integer(in), optional, intent(in) :: flux_convergence_max_iteration - logical, optional, intent(in) :: coldair_outbreak_mod + real(r8) , optional, intent(in) :: flux_convergence_tolerance + integer(in) , optional, intent(in) :: flux_convergence_max_iteration + logical , optional, intent(in) :: coldair_outbreak_mod !---------------------------------------------------------------------------- - if (present(zvir)) loc_zvir = zvir - if (present(cpair)) loc_cpdair = cpair - if (present(cpvir)) loc_cpvir = cpvir - if (present(karman)) loc_karman = karman - if (present(gravit)) loc_g = gravit - if (present(latvap)) loc_latvap = latvap - if (present(latice)) loc_latice = latice - if (present(stebol)) loc_stebol = stebol if (present(flux_convergence_tolerance)) flux_con_tol = flux_convergence_tolerance if (present(flux_convergence_max_iteration)) flux_con_max_iter = flux_convergence_max_iteration - if(present(coldair_outbreak_mod)) use_coldair_outbreak_mod = coldair_outbreak_mod - end subroutine shr_flux_adjust_constants + if (present(coldair_outbreak_mod)) use_coldair_outbreak_mod = coldair_outbreak_mod + + end subroutine flux_adjust_constants !=============================================================================== - subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & - & qbot ,s16O ,sHDO ,s18O ,rbot , & - & tbot ,us ,vs , & - & ts ,mask ,seq_flux_atmocn_minwind, & - & sen ,lat ,lwup , & - & r16O, rhdo, r18O, & - & evap ,evap_16O, evap_HDO, evap_18O, & - & taux ,tauy ,tref ,qref , & - & ocn_surface_flux_scheme, & - & duu10n, ustar_sv ,re_sv ,ssq_sv, & - & missval ) + subroutine flux_atmOcn(logunit, nMax,zbot ,ubot ,vbot ,thbot , & + & qbot , rbot ,tbot ,us ,vs , & + & ts , mask ,sen ,lat ,lwup , & + & evap , taux ,tauy ,tref ,qref , & + & ocn_surface_flux_scheme, duu10n, missval ) implicit none !--- input arguments -------------------------------- + integer ,intent(in) :: logunit integer(IN),intent(in) :: nMax ! data vector length integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) @@ -108,38 +80,23 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (bottom or 10m) (m/s) real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (bottom or 2m) (kg/kg) - real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) - real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) - real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) - real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd - real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd - real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) real(R8) ,intent(in) :: tbot (nMax) ! atm T (bottom or 2m) (K) real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) integer(IN),intent(in), optional :: ocn_surface_flux_scheme - real(R8) ,intent(in), optional :: seq_flux_atmocn_minwind ! minimum wind speed for atmocn (m/s) !--- output arguments ------------------------------- real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) - real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) - real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) - real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 - - real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar - real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) - real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) - real(R8),intent(in) ,optional :: missval ! masked value ! !EOP @@ -170,7 +127,7 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & real(R8) :: rh ! sqrt of exchange coefficient (heat) real(R8) :: re ! sqrt of exchange coefficient (water) real(R8) :: ustar ! ustar - real(r8) :: ustar_prev + real(r8) :: ustar_prev real(R8) :: qstar ! qstar real(R8) :: tstar ! tstar real(R8) :: hol ! H (at zbot) over L @@ -329,9 +286,10 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & qstar = re * delq enddo if (iter < 1) then - write(s_logunit,*) ustar,ustar_prev,flux_con_tol,flux_con_max_iter - call shr_sys_abort('shr_flux_mod: No iterations performed ') + write(logunit,*) ustar,ustar_prev,flux_con_tol,flux_con_max_iter + call ESMF_Finalize(endflag=ESMF_END_ABORT) end if + !------------------------------------------------------------ ! compute the fluxes !------------------------------------------------------------ @@ -365,13 +323,6 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & duu10n(n) = u10n*u10n ! 10m wind speed squared - !------------------------------------------------------------ - ! optional diagnostics, needed for water tracer fluxes (dcn) - !------------------------------------------------------------ - if (present(ustar_sv)) ustar_sv(n) = ustar - if (present(re_sv )) re_sv(n) = re - if (present(ssq_sv )) ssq_sv(n) = ssq - else !------------------------------------------------------------ ! no valid data here -- out of domain @@ -380,21 +331,15 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & lat (n) = spval ! latent heat flux (W/m^2) lwup (n) = spval ! long-wave upward heat flux (W/m^2) evap (n) = spval ! evaporative water flux ((kg/s)/m^2) - evap_16O (n) = spval !water tracer flux (kg/s)/m^2) - evap_HDO (n) = spval !HDO tracer flux (kg/s)/m^2) - evap_18O (n) = spval !H218O tracer flux (kg/s)/m^2) taux (n) = spval ! x surface stress (N) tauy (n) = spval ! y surface stress (N) tref (n) = spval ! 2m reference height temperature (K) qref (n) = spval ! 2m reference height humidity (kg/kg) duu10n(n) = spval ! 10m wind speed squared (m/s)^2 - if (present(ustar_sv)) ustar_sv(n) = spval - if (present(re_sv )) re_sv (n) = spval - if (present(ssq_sv )) ssq_sv (n) = spval endif end DO - end subroutine shr_flux_atmOcn + end subroutine flux_atmOcn -end module shr_flux_mod +end module flux_atmocn_mod diff --git a/util/glc_elevclass_mod.F90 b/ufs/glc_elevclass_mod.F90 similarity index 97% rename from util/glc_elevclass_mod.F90 rename to ufs/glc_elevclass_mod.F90 index ea4c4c9e0..3bcefc23c 100644 --- a/util/glc_elevclass_mod.F90 +++ b/ufs/glc_elevclass_mod.F90 @@ -2,10 +2,10 @@ module glc_elevclass_mod !--------------------------------------------------------------------- ! This module contains the interfaces needed by mediator code - but - ! is not used by the NEMS system + ! is not used by the UFS system !--------------------------------------------------------------------- - use shr_kind_mod , only : r8=>shr_kind_r8 + use ufs_kind_mod , only : r8=>shr_kind_r8 implicit none private diff --git a/util/perf_mod.F90 b/ufs/perf_mod.F90 similarity index 100% rename from util/perf_mod.F90 rename to ufs/perf_mod.F90 diff --git a/util/shr_const_mod.F90 b/ufs/ufs_const_mod.F90 similarity index 93% rename from util/shr_const_mod.F90 rename to ufs/ufs_const_mod.F90 index 8437190c7..173baf3ab 100644 --- a/util/shr_const_mod.F90 +++ b/ufs/ufs_const_mod.F90 @@ -1,11 +1,6 @@ -!=============================================================================== -! SVN $Id: shr_const_mod.F90 61510 2014-06-26 21:58:56Z tcraig $ -! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_const_mod.F90 $ -!=============================================================================== +MODULE ufs_const_mod -MODULE shr_const_mod - - use shr_kind_mod, only : R8 => shr_kind_r8 + use ufs_kind_mod, only : R8 => shr_kind_r8 !---------------------------------------------------------------------------- ! physical constants (all data public) @@ -102,4 +97,4 @@ end function shr_const_isspval !----------------------------------------------------------------------------- -END MODULE shr_const_mod +END MODULE ufs_const_mod diff --git a/util/shr_kind_mod.F90 b/ufs/ufs_kind_mod.F90 similarity index 95% rename from util/shr_kind_mod.F90 rename to ufs/ufs_kind_mod.F90 index e9e7d170c..195485e9a 100644 --- a/util/shr_kind_mod.F90 +++ b/ufs/ufs_kind_mod.F90 @@ -1,4 +1,4 @@ -MODULE shr_kind_mod +MODULE ufs_kind_mod !---------------------------------------------------------------------------- ! precision/kind constants add data public @@ -16,4 +16,4 @@ MODULE shr_kind_mod integer,parameter :: SHR_KIND_CX = 512 ! extra-long char integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char -END MODULE shr_kind_mod +END MODULE ufs_kind_mod diff --git a/util/CMakeLists.txt b/util/CMakeLists.txt deleted file mode 100644 index 6b95eea08..000000000 --- a/util/CMakeLists.txt +++ /dev/null @@ -1,7 +0,0 @@ -project(CMEPS_share Fortran) -include(ExternalProject) - -add_library(cmeps_share shr_abort_mod.F90 shr_flux_mod.F90 shr_log_mod.F90 shr_mpi_mod.F90 shr_sys_mod.F90 - glc_elevclass_mod.F90 perf_mod.F90 shr_const_mod.F90 shr_kind_mod.F90 shr_mem_mod.F90) - -target_include_directories (cmeps_share PUBLIC ${CMAKE_CURRENT_SOURCE_DIR} ${ESMF_F90COMPILEPATHS} ${PIO_Fortran_INCLUDE_DIRS}) diff --git a/util/Makefile b/util/Makefile deleted file mode 100644 index 5cb72884a..000000000 --- a/util/Makefile +++ /dev/null @@ -1,50 +0,0 @@ -ifneq ($(origin ESMFMKFILE), environment) -$(error Environment variable ESMFMKFILE was not set.) -endif - -include $(ESMFMKFILE) - -ifndef PIO_INC -$(error PIO_INC should point to PIO include directory.) -endif - -LIBRARY = libcmeps_util.a - -OBJ1= \ -perf_mod.o \ -shr_abort_mod.o \ -shr_const_mod.o \ -shr_flux_mod.o \ -shr_kind_mod.o \ -shr_log_mod.o \ -shr_mem_mod.o \ -shr_mpi_mod.o \ -shr_pio_mod.o \ -shr_sys_mod.o \ -glc_elevclass_mod.o - -all default: $(LIBRARY) - -$(LIBRARY): $(OBJ1) - $(AR) $(ARFLAGS) $@ $(OBJ1) - -%.o: %.F90.in - perl genf90.pl $< > $(@:.o=.F90) - $(ESMF_F90COMPILER) -c $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) -I$(PIO_INC) -DFORTRANUNDERSCORE -DCPRINTEL $(@:.o=.F90) -%.o: %.F90 - $(ESMF_F90COMPILER) -c $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) -I$(PIO_INC) -I. $*.F90 - -clean: - $(RM) -f $(LIBRARY) *.f90 *.i90 *.o *.mod - $(RM) -f med_constants_mod.* - -perf_mod.o: shr_kind_mod.o -shr_abort_mod.o: shr_kind_mod.o shr_mpi_mod.o shr_log_mod.o -shr_const_mod.o: shr_kind_mod.o shr_const_mod.F90 -shr_flux_mod.o: shr_kind_mod.o shr_const_mod.o shr_sys_mod.o shr_log_mod.o -shr_log_mod.o: shr_kind_mod.o -shr_mem_mod.o: shr_kind_mod.o shr_log_mod.o -shr_mpi_mod.o: shr_kind_mod.o shr_log_mod.o -shr_pio_mod.o: shr_kind_mod.o shr_log_mod.o shr_mpi_mod.o shr_sys_mod.o -shr_sys_mod.o: shr_kind_mod.o shr_log_mod.o shr_abort_mod.o -glc_elevclass_mod.o: shr_kind_mod.o diff --git a/util/dtypes.h b/util/dtypes.h deleted file mode 100644 index 9076cf0f7..000000000 --- a/util/dtypes.h +++ /dev/null @@ -1,5 +0,0 @@ -#define TYPEDOUBLE 102 -#define TYPEINT 103 -#define TYPETEXT 100 -#define TYPELONG 104 -#define TYPEREAL 101 diff --git a/util/genf90.pl b/util/genf90.pl deleted file mode 100755 index 5d35112e9..000000000 --- a/util/genf90.pl +++ /dev/null @@ -1,387 +0,0 @@ -#!/usr/bin/env perl -use strict; -my $outfile; -# Beginning with F90, Fortran has strict typing of variables based on "TKR" -# (type, kind, and rank). In many cases we want to write subroutines that -# provide the same functionality for different variable types and ranks. In -# order to do this without cut-and-paste duplication of code, we create a -# template file with the extension ".F90.in", which can be parsed by this script -# to generate F90 code for all of the desired specific types. -# -# Keywords are delimited by curly brackets: {} -# -# {TYPE} and {DIMS} are used to generate the specific subroutine names from the -# generic template -# {TYPE} : Variable type name; implemented types are character, 4 or 8 byte real, -# and 4 or 8 byte integer. -# allowed values: text, real, double, int, long, logical -# default values: text, real, double, int -# {VTYPE} : Used to generate variable declarations to match the specific type. -# if {TYPE}=double then {VTYPE} is "real(r8)" -# {ITYPE}, {ITYPENAME} : Used to generate CPP statements for the specific type. -# {MPITYPE} : Used to generate MPI types corresponding to the specific type. -# -# {DIMS} : Rank of arrays, "0" for scalar. -# allowed values: 0-7 -# default values : 0-5 -# {DIMSTR} : Generates the parenthesis and colons used for a variable -# declaration of {DIMS} dimensions. -# if {DIMS}=3 then {DIMSTR} is (:,:,:) -# {REPEAT} : Repeats an expression for each number from 1 to {DIMS}, with each -# iteration separated by commas. -# {REPEAT: foo(#, bar)} -# expands to this: -# foo(1, bar), foo(2, bar), foo(3, bar), ... - -# defaults -my @types = qw(text real double int); -my $vtype = {'text' => 'character(len=*)', - 'real' => 'real(r4)', - 'double' => 'real(r8)', - 'int' => 'integer(i4)', - 'long' => 'integer(i8)', - 'logical' => 'logical' }; -my $itype = {'text' => 100, - 'real' => 101, - 'double' => 102, - 'int' => 103, - 'long' => 104, - 'logical' => 105}; -my $itypename = {'text' => 'TYPETEXT', - 'real' => 'TYPEREAL', - 'double' => 'TYPEDOUBLE', - 'int' => 'TYPEINT', - 'long' => 'TYPELONG', - 'logical' => 'TYPELOGICAL'}; -my $mpitype = {'text' => 'MPI_CHARACTER', - 'real' => 'MPI_REAL4', - 'double' => 'MPI_REAL8', - 'int' => 'MPI_INTEGER'}; -# Netcdf C datatypes -my $nctype = {'text' => 'text', - 'real' => 'float', - 'double' => 'double', - 'int' => 'int'}; -# C interoperability types -my $ctype = {'text' => 'character(C_CHAR)', - 'real' => 'real(C_FLOAT)', - 'double' => 'real(C_DOUBLE)', - 'int' => 'integer(C_INT)'}; - - - -my @dims =(0..5); - -my $write_dtypes = "no"; -# begin - -foreach(@ARGV){ - my $infile = $_; - usage() unless($infile =~ /(.*.F90).in/); - $outfile = $1; - open(F,"$infile") || die "$0 Could not open $infile to read"; - my @parsetext; - my $cnt=0; - foreach(){ - $cnt++; - if(/^\s*contains/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - if(/^\s*interface/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - if(/^[^!]*subroutine/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - if(/^[^!]*function/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - - push(@parsetext,$_); - } - - close(F); - - my $end; - my $contains=0; - my $in_type_block=0; - my @unit; - my $unitcnt=0; - my $date = localtime(); - my $preamble = -"!=================================================== -! DO NOT EDIT THIS FILE, it was generated using $0 -! Any changes you make to this file may be lost -!===================================================\n"; - my @output ; - push(@output,$preamble); - - my $line; - my $dimmodifier; - my $typemodifier; - my $itypeflag; - my $block; - my $block_type; - my $cppunit; - foreach $line (@parsetext){ -# skip parser comments - next if($line =~ /\s*!pl/); - - $itypeflag=1 if($line =~ /{ITYPE}/); - $itypeflag=1 if($line =~ /TYPETEXT/); - $itypeflag=1 if($line =~ /TYPEREAL/); - $itypeflag=1 if($line =~ /TYPEDOUBLE/); - $itypeflag=1 if($line =~ /TYPEINT/); - $itypeflag=1 if($line =~ /TYPELONG/); - - - if($contains==0){ - if($line=~/\s*!\s*DIMS\s+[\d,]+!*/){ - $dimmodifier=$line; - next; - } - if($line=~/\s*!\s*TYPE\s+[^!]+!*$/){ - $typemodifier=$line; - next; - } - if ((defined $typemodifier or defined $dimmodifier) - and not defined $block and $line=~/^\s*#[^{]*$/) { - push(@output, $line); - next; - } - # Figure out the bounds of a type statement. - # Type blocks start with "type," "type foo" or "type::" but not - # "type(". - $in_type_block=1 if($line=~/^\s*type\s*[,:[:alpha:]]/i); - $in_type_block=0 if($line=~/^\s*end\s*type/i); - if(not defined $block) { - if ($line=~/^\s*type[^[:alnum:]_].*(\{TYPE\}|\{DIMS\})/i or - $line=~/^[^!]*(function|subroutine).*(\{TYPE\}|\{DIMS\})/i) { - $block=$line; - next; - } - if ($line=~/^\s*interface.*(\{TYPE\}|\{DIMS\})/i) { - $block_type="interface"; - $block=$line; - next; - } - } - if(not defined $block_type and - ($line=~/^\s*end\s+type\s+.*(\{TYPE\}|\{DIMS\})/i or - $line=~/^\s*end\s+(function|subroutine)\s+.*(\{TYPE\}|\{DIMS\})/i)){ - - $line = $block.$line; - undef $block; - } - if ($line=~/^\s*end\s*interface/i and - defined $block) { - $line = $block.$line; - undef $block; - undef $block_type; - } - if(defined $block){ - $block = $block.$line; - next; - } - if(defined $dimmodifier){ - $line = $dimmodifier.$line; - undef $dimmodifier; - } - if(defined $typemodifier){ - $line = $typemodifier.$line; - undef $typemodifier; - } - - push(@output, buildout($line)); - if(($line =~ /^\s*contains\s*!*/i && ! $in_type_block) or - ($line =~ /^\s*!\s*Not a module/i)){ - $contains=1; - next; - } - } - if($line=~/^\s*end module\s*/){ - $end = $line; - last; - } - - if($contains==1){ - # first parse into functions or subroutines - if($cppunit || !(defined($unit[$unitcnt]))){ - # Make cpp lines and blanks between routines units. - if($line =~ /^\s*\#(?!\s[[:digit:]]+)/ || $line =~/^\s*$/ || $line=~/^\s*!(?!\s*(TYPE|DIMS))/){ - push(@{$unit[$unitcnt]},$line); - $cppunit=1; - next; - } else { - $cppunit=0; - $unitcnt++; - } - } - - - push(@{$unit[$unitcnt]},$line); - if ($line=~/^\s*interface/i) { - $block_type="interface"; - $block=$line; - } - if ($line=~/^\s*end\s*interface/i) { - undef $block_type; - undef $block; - } - unless(defined $block){ - if($line =~ /\s*end function/i or $line =~ /\s*end subroutine/i){ - $unitcnt++; - } - } - } - } - my $i; - - - for($i=0;$i<$unitcnt;$i++){ - if(defined($unit[$i])){ - my $func = join('',@{$unit[$i]}); - push(@output, buildout($func)); - } - } - push(@output,@{$unit[$#unit]}) if($unitcnt==$#unit); - push(@output, $end); - if($itypeflag==1){ - my $str; - $str.="#include \"dtypes.h\"\n"; - $write_dtypes = "yes"; - print $str; - } - print @output; - writedtypes() if(!(-e "dtypes.h") && $write_dtypes == "yes"); - - -} - - -sub usage{ - die("$0 Expected input filename of the form .*.F90.in"); -} - -sub build_repeatstr{ - my($dims) = @_; - # Create regex to repeat expression DIMS times. - my $repeatstr; - for(my $i=1;$i<=$dims;$i++){ - $repeatstr .="\$\{1\}$i\$\{2\},&\n"; - } - if(defined $repeatstr){ - $repeatstr="\"$repeatstr"; - chop $repeatstr; - chop $repeatstr; - chop $repeatstr; - $repeatstr.="\""; - }else{ - $repeatstr=''; - } -} - -sub writedtypes{ - open(F,">dtypes.h"); - print F -"#define TYPETEXT 100 -#define TYPEREAL 101 -#define TYPEDOUBLE 102 -#define TYPEINT 103 -#define TYPELONG 104 -#define TYPELOGICAL 105 -"; - close(F); -} - -sub buildout{ - my ($func) = @_; - - my $outstr; - my(@ldims, @ltypes); - - if($func=~/\s*!\s*DIMS\s+([\d,]+)\s*/){ - @ldims = split(/,/,$1); - }else{ - @ldims = @dims; - } - if($func=~/\s*!\s*TYPE\s+([^!\s]+)\s*/){ - @ltypes = split(/,/,$1); -# print ">$func<>@ltypes<\n"; - }else{ - @ltypes = @types; - } - - - if(($func =~ /{TYPE}/ && $func =~ /{DIMS}/) ){ - my ($type, $dims); - foreach $type (@ltypes){ - foreach $dims (@ldims){ - my $dimstr; - for(my $i=1;$i<=$dims;$i++){ - $dimstr .=':,'; - } - if(defined $dimstr){ - $dimstr="($dimstr"; - chop $dimstr; - $dimstr.=')'; - }else{ - $dimstr=''; - } - - my $repeatstr = build_repeatstr($dims); - - my $str = $func; - $str =~ s/{TYPE}/$type/g; - $str =~ s/{VTYPE}/$vtype->{$type}/g; - $str =~ s/{ITYPE}/$itype->{$type}/g; - $str =~ s/{MPITYPE}/$mpitype->{$type}/g; - $str =~ s/{NCTYPE}/$nctype->{$type}/g; - $str =~ s/{CTYPE}/$ctype->{$type}/g; - $str =~ s/{DIMS}/$dims/g; - $str =~ s/{DIMSTR}/$dimstr/g; - $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; - $outstr .= $str; - } - } - }elsif($func =~ /{DIMS}/){ - my $dims; - foreach $dims (@ldims){ - my $dimstr; - for(my $i=1;$i<=$dims;$i++){ - $dimstr .=':,'; - } - if(defined $dimstr){ - $dimstr="($dimstr"; - chop $dimstr; - $dimstr.=')'; - }else{ - $dimstr=''; - } - - my $repeatstr = build_repeatstr($dims); - - my $str = $func; - $str =~ s/{DIMS}/$dims/g; - $str =~ s/{DIMSTR}/$dimstr/g; - $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; - $outstr .= $str; - } - }elsif($func =~ /{TYPE}/){ - my ($type); - foreach $type (@ltypes){ - my $str = $func; - $str =~ s/{TYPE}/$type/g; - $str =~ s/{VTYPE}/$vtype->{$type}/g; - $str =~ s/{ITYPE}/$itype->{$type}/g; - $str =~ s/{MPITYPE}/$mpitype->{$type}/g; - $str =~ s/{NCTYPE}/$nctype->{$type}/g; - $str =~ s/{CTYPE}/$ctype->{$type}/g; - $outstr.=$str; - } - }else{ - $outstr=$func; - } - - return $outstr; -} diff --git a/util/shr_abort_mod.F90 b/util/shr_abort_mod.F90 deleted file mode 100644 index 9e4de5bd0..000000000 --- a/util/shr_abort_mod.F90 +++ /dev/null @@ -1,164 +0,0 @@ -module shr_abort_mod - ! This module defines procedures that can be used to abort the model cleanly in a - ! system-specific manner - ! - ! The public routines here are only meant to be used directly by shr_sys_mod. Other code - ! that wishes to use these routines should use the republished names from shr_sys_mod - ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from - ! when these routines were defined in shr_sys_mod.) - - use, intrinsic :: iso_fortran_env, only: output_unit, error_unit - - use shr_kind_mod, only : shr_kind_in, shr_kind_cx - use shr_mpi_mod , only : shr_mpi_initialized, shr_mpi_abort - use shr_log_mod , only : s_logunit => shr_log_Unit - -#ifdef CPRNAG - ! NAG does not provide this as an intrinsic, but it does provide modules - ! that implement commonly used POSIX routines. - use f90_unix_proc, only: abort -#endif - - implicit none - - ! PUBLIC: Public interfaces - - private - - ! The public routines here are only meant to be used directly by shr_sys_mod. Other code - ! that wishes to use these routines should use the republished names from shr_sys_mod - ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from - ! when these routines were defined in shr_sys_mod.) - public :: shr_abort_abort ! abort a program - public :: shr_abort_backtrace ! print a backtrace, if possible - -contains - - !=============================================================================== - subroutine shr_abort_abort(string,rc) - ! Consistent stopping mechanism - - !----- arguments ----- - character(len=*) , intent(in), optional :: string ! error message string - integer(shr_kind_in), intent(in), optional :: rc ! error code - - !----- local ----- - logical :: flag - - ! Local version of the string. - ! (Gets a default value if string is not present.) - character(len=shr_kind_cx) :: local_string - !------------------------------------------------------------------------------- - - if (present(string)) then - local_string = trim(string) - else - local_string = "Unknown error submitted to shr_abort_abort." - end if - - call print_error_to_logs("ERROR", local_string) - - call shr_abort_backtrace() - - call shr_mpi_initialized(flag) - - if (flag) then - if (present(rc)) then - call shr_mpi_abort(trim(local_string),rc) - else - call shr_mpi_abort(trim(local_string)) - endif - endif - - ! A compiler's abort method may print a backtrace or do other nice - ! things, but in fact we can rarely leverage this, because MPI_Abort - ! usually sends SIGTERM to the process, and we don't catch that signal. - call abort() - - end subroutine shr_abort_abort - !=============================================================================== - - !=============================================================================== - subroutine shr_abort_backtrace() - ! This routine uses compiler-specific facilities to print a backtrace to - ! error_unit (standard error, usually unit 0). - -#if defined(CPRIBM) - - ! This theoretically should be in xlfutility, but using it from that - ! module doesn't seem to always work. - interface - subroutine xl_trbk() - end subroutine xl_trbk - end interface - - call xl__trbk() - -#elif defined(CPRGNU) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8 )) - - ! gfortran 4.8 and later implement this intrinsic. We explicitly call it - ! out as such to make sure that it really is available, just in case the - ! CPP logic above screws up. - intrinsic :: backtrace - - call backtrace() - -#elif defined(CPRINTEL) - - ! tracebackqq uses optional arguments, so *must* have an explicit - ! interface. - use ifcore, only: tracebackqq - - ! An exit code of -1 is a special value that prevents this subroutine - ! from aborting the run. - call tracebackqq(user_exit_code=-1) - -#else - - ! Currently we have no means to request a backtrace from the NAG runtime, - ! even though it is capable of emitting backtraces itself, if you use the - ! "-gline" option. - - ! Similarly, PGI has a -traceback option, but no user interface for - ! requesting a backtrace to be printed. - -#endif - - flush(error_unit) - - end subroutine shr_abort_backtrace - !=============================================================================== - - !=============================================================================== - subroutine print_error_to_logs(error_type, message) - ! This routine prints error messages to s_logunit (which is standard output - ! for most tasks in CESM) and also to standard error if s_logunit is a - ! file. - ! - ! It also flushes these output units. - - character(len=*), intent(in) :: error_type, message - - integer, allocatable :: log_units(:) - - integer :: i - - if (s_logunit == output_unit .or. s_logunit == error_unit) then - ! If the log unit number is standard output or standard error, just - ! print to that. - allocate(log_units(1), source=[s_logunit]) - else - ! Otherwise print the same message to both the log unit and standard - ! error. - allocate(log_units(2), source=[error_unit, s_logunit]) - end if - - do i = 1, size(log_units) - write(log_units(i),*) trim(error_type), ": ", trim(message) - flush(log_units(i)) - end do - - end subroutine print_error_to_logs - !=============================================================================== - -end module shr_abort_mod diff --git a/util/shr_log_mod.F90 b/util/shr_log_mod.F90 deleted file mode 100644 index e3b2992f6..000000000 --- a/util/shr_log_mod.F90 +++ /dev/null @@ -1,26 +0,0 @@ -!BOP =========================================================================== -! -! !MODULE: shr_log_mod -- variables and methods for logging -! -! !DESCRIPTION: -! Low-level shared variables for logging. -! -! Also, routines for generating log file messages. -! -! !INTERFACE: ------------------------------------------------------------------ -module shr_log_mod - - use shr_kind_mod - use, intrinsic :: iso_fortran_env, only: output_unit - - implicit none - private - - public :: shr_log_Level - public :: shr_log_Unit - - ! low-level shared variables for logging, these may not be parameters - integer(SHR_KIND_IN) :: shr_log_Level = 0 - integer(SHR_KIND_IN) :: shr_log_Unit = output_unit - -end module shr_log_mod diff --git a/util/shr_mem_mod.F90 b/util/shr_mem_mod.F90 deleted file mode 100644 index e8d2fc7d6..000000000 --- a/util/shr_mem_mod.F90 +++ /dev/null @@ -1,17 +0,0 @@ -module shr_mem_mod - - use shr_kind_mod, only : shr_kind_r8 - - implicit none - public - -contains - - subroutine shr_mem_getusage(r_msize, r_mrss, prt) - real(shr_kind_r8) :: r_msize,r_mrss - logical, optional :: prt - ! For now does nothing - - end subroutine shr_mem_getusage - -end module shr_mem_mod diff --git a/util/shr_mpi_mod.F90 b/util/shr_mpi_mod.F90 deleted file mode 100644 index ab872a270..000000000 --- a/util/shr_mpi_mod.F90 +++ /dev/null @@ -1,2217 +0,0 @@ -Module shr_mpi_mod - - !------------------------------------------------------------------------------- - ! PURPOSE: general layer on MPI functions - !------------------------------------------------------------------------------- - - use shr_kind_mod - use shr_log_mod, only: s_loglev => shr_log_Level - use shr_log_mod, only: s_logunit => shr_log_Unit - - implicit none - private - - ! PUBLIC: Public interfaces - - public :: shr_mpi_chkerr - public :: shr_mpi_send - public :: shr_mpi_recv - public :: shr_mpi_bcast - public :: shr_mpi_gathScatVInit - public :: shr_mpi_gatherV - public :: shr_mpi_scatterV - public :: shr_mpi_sum - public :: shr_mpi_min - public :: shr_mpi_max - public :: shr_mpi_commsize - public :: shr_mpi_commrank - public :: shr_mpi_initialized - public :: shr_mpi_abort - public :: shr_mpi_barrier - public :: shr_mpi_init - public :: shr_mpi_finalize - - interface shr_mpi_send ; module procedure & - shr_mpi_sendi0, & - shr_mpi_sendi1, & - shr_mpi_sendr0, & - shr_mpi_sendr1, & - shr_mpi_sendr3 - end interface shr_mpi_send - interface shr_mpi_recv ; module procedure & - shr_mpi_recvi0, & - shr_mpi_recvi1, & - shr_mpi_recvr0, & - shr_mpi_recvr1, & - shr_mpi_recvr3 - end interface shr_mpi_recv - interface shr_mpi_bcast ; module procedure & - shr_mpi_bcastc0, & - shr_mpi_bcastc1, & - shr_mpi_bcastl0, & - shr_mpi_bcastl1, & - shr_mpi_bcasti0, & - shr_mpi_bcasti1, & - shr_mpi_bcasti80, & - shr_mpi_bcasti81, & - shr_mpi_bcasti2, & - shr_mpi_bcastr0, & - shr_mpi_bcastr1, & - shr_mpi_bcastr2, & - shr_mpi_bcastr3 - end interface shr_mpi_bcast - interface shr_mpi_gathScatVInit ; module procedure & - shr_mpi_gathScatVInitr1 - end interface shr_mpi_gathScatVInit - interface shr_mpi_gatherv ; module procedure & - shr_mpi_gatherVr1 - end interface shr_mpi_gatherv - interface shr_mpi_scatterv ; module procedure & - shr_mpi_scatterVr1 - end interface shr_mpi_scatterv - interface shr_mpi_sum ; module procedure & - shr_mpi_sumi0, & - shr_mpi_sumi1, & - shr_mpi_sumb0, & - shr_mpi_sumb1, & - shr_mpi_sumr0, & - shr_mpi_sumr1, & - shr_mpi_sumr2, & - shr_mpi_sumr3 - end interface shr_mpi_sum - interface shr_mpi_min ; module procedure & - shr_mpi_mini0, & - shr_mpi_mini1, & - shr_mpi_minr0, & - shr_mpi_minr1 - end interface shr_mpi_min - interface shr_mpi_max ; module procedure & - shr_mpi_maxi0, & - shr_mpi_maxi1, & - shr_mpi_maxr0, & - shr_mpi_maxr1 - end interface shr_mpi_max - -#include ! mpi library include file - - !=============================================================================== -CONTAINS - !=============================================================================== - - SUBROUTINE shr_mpi_chkerr(rcode,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: rcode ! input MPI error code - character(*), intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_chkerr) ' - character(MPI_MAX_ERROR_STRING) :: lstring - integer(SHR_KIND_IN) :: len - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: layer on MPI error checking - !------------------------------------------------------------------------------- - - if (rcode /= MPI_SUCCESS) then - call MPI_ERROR_STRING(rcode,lstring,len,ierr) - write(s_logunit,*) trim(subName),":",lstring(1:len) - call shr_mpi_abort(string,rcode) - endif - - END SUBROUTINE shr_mpi_chkerr - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendi0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! send value - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendi0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a single integer - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendi1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendi1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a vector of integers - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendr0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendr0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a real scalar - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendr1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendr1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendr3(array,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real (SHR_KIND_R8), intent(in) :: array(:,:,:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendr3) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(array) - - call MPI_SEND(array,lsize,MPI_REAL8,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvi0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(out):: lvec ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvi0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvi1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(out):: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvi1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvr0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(out):: lvec ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvr0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvr1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(out):: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvr1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvr3(array,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real (SHR_KIND_R8), intent(out):: array(:,:,:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvr3) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(array) - - call MPI_RECV(array,lsize,MPI_REAL8,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcasti0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast an integer - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti0 - - SUBROUTINE shr_mpi_bcasti80(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast an integer - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti80 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastl0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - logical, intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastl0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a logical - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastl0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastc0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - character(len=*), intent(inout) :: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastc0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a character string - !------------------------------------------------------------------------------- - - lsize = len(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastc0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastc1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - character(len=*), intent(inout) :: vec(:) ! 1D vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastc1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a character string - !------------------------------------------------------------------------------- - - lsize = size(vec)*len(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastc1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastr0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a real - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcasti1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(inout):: vec(:) ! vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a vector of integers - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti1 - - SUBROUTINE shr_mpi_bcasti81(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(inout):: vec(:) ! vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a vector of integers - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti81 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastl1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - logical, intent(inout):: vec(:) ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastl1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a logical - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastl1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(inout):: vec(:) ! vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastr1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr2(arr,comm,string,pebcast) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(inout):: arr(:,:) ! array, 2d - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local ----- - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_bcastr2) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a 2d array of reals - !------------------------------------------------------------------------------- - - lsize = size(arr) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr2 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcasti2(arr,comm,string,pebcast) - - IMPLICIT none - - !----- arguments ----- - integer, intent(inout):: arr(:,:) ! array, 2d - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local ----- - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_bcasti2) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a 2d array of integers - !------------------------------------------------------------------------------- - - lsize = size(arr) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(arr,lsize,MPI_INTEGER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti2 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr3(arr,comm,string,pebcast) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(inout):: arr(:,:,:) ! array, 3d - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local ----- - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_bcastr3) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a 3d array of reals - !------------------------------------------------------------------------------- - - lsize = size(arr) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_gathScatvInitr1(comm, rootid, locArr, glob1DArr, globSize, & - displs, string ) - - IMPLICIT none - - !----- arguments ----- - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather/scatter on - real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array of distributed data - real(SHR_KIND_R8), pointer :: glob1DArr(:) ! Global 1D array of gathered data - integer(SHR_KIND_IN), pointer :: globSize(:) ! Size of each distributed piece - integer(SHR_KIND_IN), pointer :: displs(:) ! Displacements for receive - character(*),optional,intent(in) :: string ! message - - !----- local ----- - integer(SHR_KIND_IN) :: npes ! Number of MPI tasks - integer(SHR_KIND_IN) :: locSize ! Size of local distributed data - integer(SHR_KIND_IN), pointer :: sendSize(:) ! Size to send for initial gather - integer(SHR_KIND_IN) :: i ! Index - integer(SHR_KIND_IN) :: rank ! Rank of this MPI task - integer(SHR_KIND_IN) :: nSize ! Maximum size to send - integer(SHR_KIND_IN) :: ierr ! Error code - integer(SHR_KIND_IN) :: nSiz1D ! Size of 1D global array - integer(SHR_KIND_IN) :: maxSize ! Maximum size - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_gathScatvInitr1) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Setup arrays for a gatherv/scatterv operation - !------------------------------------------------------------------------------- - - locSize = size(locarr) - call shr_mpi_commsize( comm, npes ) - call shr_mpi_commrank( comm, rank ) - allocate( globSize(npes) ) - ! - ! --- Gather the send global sizes from each MPI task ----------------------- - ! - allocate( sendSize(npes) ) - sendSize(:) = 1 - globSize(:) = 1 - call MPI_GATHER( locSize, 1, MPI_INTEGER, globSize, sendSize, & - MPI_INTEGER, rootid, comm, ierr ) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - deallocate( sendSize ) - ! - ! --- Prepare the displacement and allocate arrays ------------------------- - ! - allocate( displs(npes) ) - displs(1) = 0 - if ( rootid /= rank )then - maxSize = 1 - globSize = 1 - else - maxSize = maxval(globSize) - end if - nsiz1D = min(maxSize,globSize(1)) - do i = 2, npes - nSize = min(maxSize,globSize(i-1)) - displs(i) = displs(i-1) + nSize - nsiz1D = nsiz1D + min(maxSize,globSize(i)) - end do - allocate( glob1DArr(nsiz1D) ) - !----- Do some error checking for the root task arrays computed ---- - if ( rootid == rank )then - if ( nsiz1D /= sum(globSize) ) & - call shr_mpi_abort( subName//" : Error, size of global array not right" ) - if ( any(displs < 0) .or. any(displs >= nsiz1D) ) & - call shr_mpi_abort( subName//" : Error, displacement array not right" ) - if ( (displs(npes)+globSize(npes)) /= nsiz1D ) & - call shr_mpi_abort( subName//" : Error, displacement array values too big" ) - end if - - END SUBROUTINE shr_mpi_gathScatvInitr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, & - comm, string ) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array - real(SHR_KIND_R8), intent(inout):: glob1DArr(:) ! Global 1D array to receive in on - integer(SHR_KIND_IN), intent(in) :: locSize ! Number to send this PE - integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to receive each PE - integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for receive - integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather on - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local ----- - integer(SHR_KIND_IN) :: ierr ! Error code - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_gathervr1) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Gather a 1D array of reals - !------------------------------------------------------------------------------- - - call MPI_GATHERV( locarr, locSize, MPI_REAL8, glob1Darr, globSize, displs, & - MPI_REAL8, rootid, comm, ierr ) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_gathervr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, & - comm, string ) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(out) :: locarr(:) ! Local array - real(SHR_KIND_R8), intent(in) :: glob1Darr(:) ! Global 1D array to send from - integer(SHR_KIND_IN), intent(in) :: locSize ! Number to receive this PE - integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to send to each PE - integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for send - integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to scatter on - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local ----- - integer(SHR_KIND_IN) :: ierr ! Error code - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_scattervr1) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Scatter a 1D array of reals - !------------------------------------------------------------------------------- - - - call MPI_SCATTERV( glob1Darr, globSize, displs, MPI_REAL8, locarr, locSize, & - MPI_REAL8, rootid, comm, ierr ) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_scattervr1 - - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumi0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumi0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumi1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumi1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumb0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_I8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumb0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumb0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumb1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_I8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumb1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumb1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr2(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:,:)! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:,:)! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr2) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr2 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr3(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:,:,:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:,:,:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr3) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_mini0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_mini0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_mini0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_mini1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_mini1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_mini1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_minr0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_minr0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_minr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_minr1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_minr1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_minr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxi0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxi0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxi1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxi1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxr0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxr0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxr1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxr1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_commsize(comm,size,string) - - IMPLICIT none - - !----- arguments --- - integer,intent(in) :: comm - integer,intent(out) :: size - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_commsize) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI commsize - !------------------------------------------------------------------------------- - - call MPI_COMM_SIZE(comm,size,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_commsize - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_commrank(comm,rank,string) - - IMPLICIT none - - !----- arguments --- - integer,intent(in) :: comm - integer,intent(out) :: rank - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_commrank) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI commrank - !------------------------------------------------------------------------------- - - call MPI_COMM_RANK(comm,rank,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_commrank - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_initialized(flag,string) - - IMPLICIT none - - !----- arguments --- - logical,intent(out) :: flag - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_initialized) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI initialized - !------------------------------------------------------------------------------- - - call MPI_INITIALIZED(flag,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_initialized - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_abort(string,rcode) - - IMPLICIT none - - !----- arguments --- - character(*),optional,intent(in) :: string ! message - integer,optional,intent(in) :: rcode ! optional code - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_abort) ' - integer(SHR_KIND_IN) :: ierr - integer :: rc ! return code - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI abort - !------------------------------------------------------------------------------- - - if ( present(string) .and. present(rcode) ) then - write(s_logunit,*) trim(subName),":",trim(string),rcode - endif - if ( present(rcode) )then - rc = rcode - else - rc = 1001 - end if - call MPI_ABORT(MPI_COMM_WORLD,rc,ierr) - - END SUBROUTINE shr_mpi_abort - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_barrier(comm,string) - - IMPLICIT none - - !----- arguments --- - integer,intent(in) :: comm - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_barrier) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI barrier - !------------------------------------------------------------------------------- - - call MPI_BARRIER(comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_barrier - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_init(string) - - IMPLICIT none - - !----- arguments --- - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_init) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI init - !------------------------------------------------------------------------------- - - call MPI_INIT(ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_init - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_finalize(string) - - IMPLICIT none - - !----- arguments --- - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_finalize) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI finalize - !------------------------------------------------------------------------------- - - call MPI_BARRIER(MPI_COMM_WORLD,ierr) - call MPI_FINALIZE(ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_finalize - - !=============================================================================== - !=============================================================================== - -END MODULE shr_mpi_mod diff --git a/util/shr_sys_mod.F90 b/util/shr_sys_mod.F90 deleted file mode 100644 index 5a04d6653..000000000 --- a/util/shr_sys_mod.F90 +++ /dev/null @@ -1,320 +0,0 @@ -!=============================================================================== -! SVN $Id: shr_sys_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ -! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_sys_mod.F90 $ -!=============================================================================== - -! Currently supported by all compilers -#define HAVE_GET_ENVIRONMENT -#define HAVE_SLEEP - -! Except this combination? -#if defined CPRPGI && defined CNL -#undef HAVE_GET_ENVIRONMENT -#endif - -#if defined CPRNAG -#define HAVE_EXECUTE -#endif - -MODULE shr_sys_mod - - use shr_kind_mod ! defines real & integer kinds - use shr_log_mod, only: s_loglev => shr_log_Level - use shr_log_mod, only: s_logunit => shr_log_Unit - use shr_abort_mod, only: shr_sys_abort => shr_abort_abort - use shr_abort_mod, only: shr_sys_backtrace => shr_abort_backtrace - -#ifdef CPRNAG - ! NAG does not provide these as intrinsics, but it does provide modules - ! that implement commonly used POSIX routines. - use f90_unix_dir, only: chdir - use f90_unix_proc, only: abort, sleep -#endif - - implicit none - -! PUBLIC: Public interfaces - - private - - public :: shr_sys_system ! make a system call - public :: shr_sys_chdir ! change current working dir - public :: shr_sys_getenv ! get an environment variable - public :: shr_sys_irtc ! returns real-time clock tick - public :: shr_sys_sleep ! have program sleep for a while - public :: shr_sys_flush ! flush an i/o buffer - - ! Imported from shr_abort_mod and republished with renames. Other code that wishes to - ! use these routines should use these shr_sys names rather than directly using the - ! routines from shr_abort_abort. (This is for consistency with older code, from when - ! these routines were defined in shr_sys_mod.) - public :: shr_sys_abort ! abort a program - public :: shr_sys_backtrace ! print a backtrace, if possible - -!=============================================================================== -CONTAINS -!=============================================================================== - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_system(str,rcode) - - IMPLICIT none - - !----- arguments --- - character(*) ,intent(in) :: str ! system/shell command string - integer(SHR_KIND_IN),intent(out) :: rcode ! function return error code - - !----- functions ----- -#if (defined LINUX && !defined CPRGNU) - integer(SHR_KIND_IN),external :: system ! function to envoke shell command -#endif - - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_system) ' - character(*),parameter :: F00 = "('(shr_sys_system) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -!------------------------------------------------------------------------------- - rcode = 0 -#ifdef HAVE_EXECUTE - call execute_command_line(str,exitstat=rcode) ! Intrinsic as of F2008 -#else -#if (defined AIX) - - call system(str,rcode) - -#elif (defined CPRGNU || defined LINUX) - - rcode = system(str) - -#else - - write(s_logunit,F00) 'ERROR: no implementation of system call for this architecture' - call shr_sys_abort(subName//'no implementation of system call for this architecture') -#endif -#endif - -END SUBROUTINE shr_sys_system - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_chdir(path, rcode) - - IMPLICIT none - - !----- arguments ----- - character(*) ,intent(in) :: path ! chdir to this dir - integer(SHR_KIND_IN),intent(out) :: rcode ! return code - - !----- local ----- - integer(SHR_KIND_IN) :: lenpath ! length of path -#if (defined AIX || (defined LINUX && !defined CPRGNU && !defined CPRNAG) || defined CPRINTEL) - integer(SHR_KIND_IN),external :: chdir ! AIX system call -#endif - - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_chdir) ' - character(*),parameter :: F00 = "('(shr_sys_chdir) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -!------------------------------------------------------------------------------- - - lenpath=len_trim(path) - -#if (defined AIX) - - rcode = chdir(%ref(path(1:lenpath)//'\0')) - -#elif (defined Darwin || (defined LINUX && !defined CPRNAG)) - - rcode=chdir(path(1:lenpath)) - -#elif (defined CPRNAG) - - call chdir(path(1:lenpath), errno=rcode) - -#else - - write(s_logunit,F00) 'ERROR: no implementation of chdir for this architecture' - call shr_sys_abort(subname//'no implementation of chdir for this machine') - -#endif - -END SUBROUTINE shr_sys_chdir - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_getenv(name, val, rcode) - - IMPLICIT none - - !----- arguments ----- - character(*) ,intent(in) :: name ! env var name - character(*) ,intent(out) :: val ! env var value - integer(SHR_KIND_IN),intent(out) :: rcode ! return code - - !----- local ----- -#ifndef HAVE_GET_ENVIRONMENT - integer(SHR_KIND_IN) :: lenname ! length of env var name - integer(SHR_KIND_IN) :: lenval ! length of env var value - character(SHR_KIND_CL) :: tmpval ! temporary env var value -#endif - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_getenv) ' - character(*),parameter :: F00 = "('(shr_sys_getenv) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -!------------------------------------------------------------------------------- - -!$OMP master - - -#ifdef HAVE_GET_ENVIRONMENT - call get_environment_variable(name=name,value=val,status=rcode) ! Intrinsic in F2003 -#else - lenname=len_trim(name) -#if (defined AIX || defined LINUX) - - call getenv(trim(name),tmpval) - val=trim(tmpval) - rcode = 0 - if (len_trim(val) == 0 ) rcode = 1 - if (len_trim(val) > SHR_KIND_CL) rcode = 2 - -#else - - write(s_logunit,F00) 'ERROR: no implementation of getenv for this architecture' - call shr_sys_abort(subname//'no implementation of getenv for this machine') - -#endif -#endif -!$OMP end master - -END SUBROUTINE shr_sys_getenv - -!=============================================================================== -!=============================================================================== - -integer(SHR_KIND_I8) FUNCTION shr_sys_irtc( rate ) - - IMPLICIT none - - !----- arguments ----- - integer(SHR_KIND_I8), optional :: rate - - !----- local ----- - integer(SHR_KIND_IN) :: count - integer(SHR_KIND_IN) :: count_rate - integer(SHR_KIND_IN) :: count_max - integer(SHR_KIND_IN),save :: last_count = -1 - integer(SHR_KIND_I8),save :: count_offset = 0 - - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_irtc) ' - character(*),parameter :: F00 = "('(shr_sys_irtc) ',4a)" - -!------------------------------------------------------------------------------- -! emulates Cray/SGI irtc function (returns clock tick since last reboot) -!------------------------------------------------------------------------------- - - call system_clock(count=count,count_rate=count_rate, count_max=count_max) - if ( present(rate) ) rate = count_rate - shr_sys_irtc = count - - !--- adjust for clock wrap-around --- - if ( last_count /= -1 ) then - if ( count < last_count ) count_offset = count_offset + count_max - end if - shr_sys_irtc = shr_sys_irtc + count_offset - last_count = count - -END FUNCTION shr_sys_irtc - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_sleep(sec) - - IMPLICIT none - - !----- arguments ----- - real (SHR_KIND_R8),intent(in) :: sec ! number of seconds to sleep - - !----- local ----- - integer(SHR_KIND_IN) :: isec ! integer number of seconds -#ifndef HAVE_SLEEP - integer(SHR_KIND_IN) :: rcode ! return code - character(90) :: str ! system call string -#endif - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_sleep) ' - character(*),parameter :: F00 = "('(shr_sys_sleep) ',4a)" - character(*),parameter :: F10 = "('sleep ',i8 )" - -!------------------------------------------------------------------------------- -! PURPOSE: Sleep for approximately sec seconds -!------------------------------------------------------------------------------- - - isec = nint(sec) - - if (isec < 0) then - if (s_loglev > 0) write(s_logunit,F00) 'ERROR: seconds must be > 0, sec=',sec - else if (isec == 0) then - ! Don't consider this an error and don't call system sleep - else -#ifdef HAVE_SLEEP - call sleep(isec) -#else - write(str,FMT=F10) isec - call shr_sys_system( str, rcode ) -#endif - endif - -END SUBROUTINE shr_sys_sleep - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_flush(unit) - - IMPLICIT none - - !----- arguments ----- - integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit - - !----- local ----- - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_flush) ' - character(*),parameter :: F00 = "('(shr_sys_flush) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -! -! This is probably no longer needed; the "flush" statement is supported by -! all compilers that CESM supports for years now. -! -!------------------------------------------------------------------------------- - flush(unit) -! -! The following code was originally present, but there's an obvious issue. -! Since shr_sys_flush is usually used to flush output to a log, when it -! returns an error, does it do any good to print that error to the log? -! -! if (ierr > 0) then -! write(s_logunit,*) subname,' Flush reports error: ',ierr -! endif -! - -END SUBROUTINE shr_sys_flush - -!=============================================================================== -!=============================================================================== - -END MODULE shr_sys_mod From b873989ae5e037ac217aaa30077a3a1f677fcd34 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Tue, 21 Dec 2021 16:57:30 -0700 Subject: [PATCH 12/31] change Sw_zo to Sw_z0 for hafs --- mediator/esmFldsExchange_hafs_mod.F90 | 4 ++-- mediator/esmFldsExchange_nems_mod.F90 | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/mediator/esmFldsExchange_hafs_mod.F90 b/mediator/esmFldsExchange_hafs_mod.F90 index 5f8537221..40b8cdea0 100644 --- a/mediator/esmFldsExchange_hafs_mod.F90 +++ b/mediator/esmFldsExchange_hafs_mod.F90 @@ -172,7 +172,7 @@ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%wav_present) then allocate(S_flds(1)) - S_flds = (/'Sw_zo'/) ! wave_z0_roughness_length + S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length do n = 1,size(S_flds) fldname = trim(S_flds(n)) call addfld(fldListFr(compwav)%flds, trim(fldname)) @@ -385,7 +385,7 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%wav_present) then allocate(S_flds(1)) - S_flds = (/'Sw_zo'/) ! wave_z0_roughness_length + S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length do n = 1,size(S_flds) fldname = trim(S_flds(n)) if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 29029623b..00d1cfc8e 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -162,7 +162,6 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to atm: surface roughness length from wav call addfld(fldListFr(compwav)%flds, 'Sw_z0') call addfld(fldListTo(compatm)%flds, 'Sw_z0') - !call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, maptype, 'wfrac', 'unset') call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') From 5fb8561c9614e1df1c426d45cca7fcca7853e9fd Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Thu, 23 Dec 2021 06:43:04 -0700 Subject: [PATCH 13/31] switch src/dst masks for wave --- mediator/med_map_mod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 7f0729e51..adb2fa990 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -439,14 +439,16 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, srcMaskValue = 0 dstMaskValue = ispval_mask elseif (n1 == compatm .and. n2 == compwav) then - dstMaskValue = 1 + !dstMaskValue = 1 + dstMaskValue = 0 elseif (n1 == compwav .and. n2 == compatm) then - srcMaskValue = 1 + !srcMaskValue = 1 + srcMaskValue = 0 dstMaskValue = ispval_mask endif end if - write(string,'(a,i4,a,i4)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & + write(string,'(a,i10,a,i10)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & srcMaskValue,' dstMask = ',dstMaskValue call ESMF_LogWrite(trim(string), ESMF_LOGMSG_INFO) From 84a17b750eaf52a0dbf42b1078c3e2feed5d6023 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Mon, 27 Dec 2021 16:35:00 -0500 Subject: [PATCH 14/31] tidy up, remove commented out code blocks --- mediator/med_map_mod.F90 | 2 -- mediator/med_phases_post_atm_mod.F90 | 13 ------------- mediator/med_phases_post_ocn_mod.F90 | 13 ------------- 3 files changed, 28 deletions(-) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index adb2fa990..cc8438c9e 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -439,10 +439,8 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, srcMaskValue = 0 dstMaskValue = ispval_mask elseif (n1 == compatm .and. n2 == compwav) then - !dstMaskValue = 1 dstMaskValue = 0 elseif (n1 == compwav .and. n2 == compatm) then - !srcMaskValue = 1 srcMaskValue = 0 dstMaskValue = ispval_mask endif diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index b2e7f15c0..4e317a407 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -96,19 +96,6 @@ subroutine med_phases_post_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_atm2lnd') end if - ! map atm->wav - !if (is_local%wrap%med_coupling_active(compatm,compwav)) then - ! call t_startf('MED:'//trim(subname)//' map_atm2wav') - ! call med_map_field_packed( & - ! FBSrc=is_local%wrap%FBImp(compatm,compatm), & - ! FBDst=is_local%wrap%FBImp(compatm,compwav), & - ! FBFracSrc=is_local%wrap%FBFrac(compatm), & - ! field_normOne=is_local%wrap%field_normOne(compatm,compwav,:), & - ! packed_data=is_local%wrap%packed_data(compatm,compwav,:), & - ! routehandles=is_local%wrap%RH(compatm,compwav,:), rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! call t_stopf('MED:'//trim(subname)//' map_atm2wav') - !end if ! Write atm inst, avg or aux if requested in mediator attributes call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index 4fc82cbdb..85432b554 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -71,19 +71,6 @@ subroutine med_phases_post_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_ocn2ice') end if - ! Map ocn->wav - ! if (is_local%wrap%med_coupling_active(compocn,compwav)) then - ! call t_startf('MED:'//trim(subname)//' map_ocn2wav') - ! call med_map_field_packed( & - ! FBSrc=is_local%wrap%FBImp(compocn,compocn), & - ! FBDst=is_local%wrap%FBImp(compocn,compwav), & - ! FBFracSrc=is_local%wrap%FBFrac(compocn), & - ! field_normOne=is_local%wrap%field_normOne(compocn,compwav,:), & - ! packed_data=is_local%wrap%packed_data(compocn,compwav,:), & - ! routehandles=is_local%wrap%RH(compocn,compwav,:), rc=rc) - ! if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! call t_stopf('MED:'//trim(subname)//' map_ocn2wav') - ! end if ! Accumulate ocn input for glc if there is ocn->glc coupling if (first_call) then From 94ead4a9a112066305826f2311a2ee21c8e04b8d Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Fri, 31 Dec 2021 12:05:46 -0500 Subject: [PATCH 15/31] initial commit for waves in slow loop --- mediator/med_internalstate_mod.F90 | 6 +- mediator/med_phases_post_atm_mod.F90 | 16 ++- mediator/med_phases_prep_wav_mod.F90 | 186 ++++++++++++++++++--------- mediator/med_phases_restart_mod.F90 | 11 ++ 4 files changed, 156 insertions(+), 63 deletions(-) diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index bc5287a61..3a2fc1d11 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -91,8 +91,10 @@ module med_internalstate_mod type(ESMF_FieldBundle) :: FBfrac(ncomps) ! Fraction data for various components, on their grid ! Accumulators for export field bundles - type(ESMF_FieldBundle) :: FBExpAccumOcn ! Accumulator for various components export on their grid - integer :: ExpAccumOcnCnt = 0 ! Accumulator counter for each FBExpAccum + type(ESMF_FieldBundle) :: FBExpAccumOcn ! Accumulator for Ocn export on Ocn grid + integer :: ExpAccumOcnCnt = 0 ! Accumulator counter for FBExpAccumOcn + type(ESMF_FieldBundle) :: FBExpAccumWav ! Accumulator for Wav export on Wav grid + integer :: ExpAccumWavCnt = 0 ! Accumulator counter for FBExpAccumWav ! Component Mesh info type(mesh_info_type) :: mesh_info(ncomps) diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index 4e317a407..b07be3754 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -1,7 +1,8 @@ module med_phases_post_atm_mod !----------------------------------------------------------------------------- - ! Mediator phase for post atm calculations, maps atm->ice, atm->lnd and atm->ocn + ! Mediator phase for post atm calculations, maps atm->ice, atm->lnd, atm->ocn + ! and atm->wav !----------------------------------------------------------------------------- implicit none @@ -96,6 +97,19 @@ subroutine med_phases_post_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_atm2lnd') end if + ! map atm to wav + if (is_local%wrap%med_coupling_active(compatm,compwav)) then + call t_startf('MED:'//trim(subname)//' map_atm2wav') + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(compatm,compatm), & + FBDst=is_local%wrap%FBImp(compatm,compwav), & + FBFracSrc=is_local%wrap%FBFrac(compatm), & + field_normOne=is_local%wrap%field_normOne(compatm,compwav,:), & + packed_data=is_local%wrap%packed_data(compatm,compwav,:), & + routehandles=is_local%wrap%RH(compatm,compwav,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf('MED:'//trim(subname)//' map_atm2wav') + end if ! Write atm inst, avg or aux if requested in mediator attributes call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 14153a16e..304b1af69 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -8,17 +8,22 @@ 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_accum => med_methods_FB_accum + use med_methods_mod , only : FB_average => med_methods_FB_average + use med_methods_mod , only : FB_reset => med_methods_FB_reset use med_merge_mod , only : med_merge_auto 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 : compwav, compatm, compice use esmFlds , only : fldListFr, fldListTo use perf_mod , only : t_startf, t_stopf implicit none private - public :: med_phases_prep_wav + public :: med_phases_prep_wav_init ! called from med.F90 + public :: med_phases_prep_wav_accum ! called from run sequence + public :: med_phases_prep_wav_avg ! called from run sequence character(*), parameter :: u_FILE_u = & __FILE__ @@ -27,12 +32,46 @@ module med_phases_prep_wav_mod contains !----------------------------------------------------------------------------- - subroutine med_phases_prep_wav(gcomp, rc) + subroutine med_phases_prep_wav_init(gcomp, rc) + use ESMF , only : ESMF_GridComp, ESMF_SUCCESS + use med_methods_mod , only : FB_Init => med_methods_FB_init + use med_methods_mod , only : FB_Reset => med_methods_FB_Reset + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + character(len=*),parameter :: subname=' (med_phases_prep_wav_init) ' + !--------------------------------------- + + rc = ESMF_SUCCESS + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return + + if (mastertask) then + write(logunit,'(a)') trim(subname)//' initializing wave export accumulation FB for ' + end if + call FB_init(is_local%wrap%FBExpAccumWav, is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateExp(compwav), STflds=is_local%wrap%NStateExp(compwav), & + name='FBExpAccumWav', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_reset(is_local%wrap%FBExpAccumWav, value=czero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + end subroutine med_phases_prep_wav_init + + !----------------------------------------------------------------------------- + subroutine med_phases_prep_wav_accum(gcomp, rc) + + use ESMF , only : ESMF_GridComp, ESMF_FieldBundleGet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time - use ESMF , only : ESMF_GridCompGet, ESMF_FieldBundleGet, ESMF_ClockGet, ESMF_TimeGet - use ESMF , only : ESMF_ClockPrint + use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR ! input/output variables type(ESMF_GridComp) :: gcomp @@ -40,86 +79,113 @@ subroutine med_phases_prep_wav(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: i,j,n,n1,ncnt - character(len=*),parameter :: subname='(med_phases_prep_wav)' + integer :: n, ncnt + character(len=*), parameter :: subname='(med_phases_prep_wav_accum)' !--------------------------------------- call t_startf('MED:'//subname) - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + if (dbug_flag > 20) then + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) end if rc = ESMF_SUCCESS + call memcheck(subname, 5, mastertask) + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! auto merges to wav + call med_merge_auto(& + is_local%wrap%med_coupling_active(:,compwav), & + is_local%wrap%FBExp(compwav), & + is_local%wrap%FBFrac(compwav), & + is_local%wrap%FBImp(:,compwav), & + fldListTo(compwav), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! wave accumulator + call FB_accum(is_local%wrap%FBExpAccumWav, is_local%wrap%FBExp(compwav), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + is_local%wrap%ExpAccumWavCnt = is_local%wrap%ExpAccumWavCnt + 1 + + ! diagnose output + if (dbug_flag > 1) then + call FB_diagnose(is_local%wrap%FBExpAccumWav, string=trim(subname)//' FBExpAccumWav accumulation ', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + end if + call t_stopf('MED:'//subname) + + end subroutine med_phases_prep_wav_accum + + !----------------------------------------------------------------------------- + subroutine med_phases_prep_wav_avg(gcomp, rc) + + ! Prepare the wav 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 + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + integer :: ncnt + character(len=*),parameter :: subname='(med_phases_prep_wav_avg)' !--------------------------------------- - ! --- Get the internal state - !--------------------------------------- + rc = ESMF_SUCCESS + + call t_startf('MED:'//subname) + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + endif + + ! 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 - ! 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 ESMF_FieldBundleGet(is_local%wrap%FBExp(compwav), fieldCount=ncnt, rc=rc) + call ESMF_FieldBundleGet(is_local%wrap%FBExpAccumWav, fieldCount=ncnt, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ncnt > 0) then - ! map to create FBimp(:,compwav) - do n1 = 1,ncomps - if (is_local%wrap%med_coupling_active(n1,compwav)) then - call ESMF_LogWrite(trim(subname)//": "//compname(n1)//" to "//compname(compwav), ESMF_LOGMSG_INFO) - 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), & - 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 - end if - end do - - ! auto merges to create FBExp(compwav) - call med_merge_auto(& - is_local%wrap%med_coupling_active(:,compwav), & - is_local%wrap%FBExp(compwav), & - is_local%wrap%FBFrac(compwav), & - is_local%wrap%FBImp(:,compwav), & - fldListTo(compwav), rc=rc) + ! average wav accumulator + if (dbug_flag > 1) then + call FB_diagnose(is_local%wrap%FBExpAccumWav, & + string=trim(subname)//' FBExpAccumWav before avg ', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call FB_average(is_local%wrap%FBExpAccumWav, is_local%wrap%ExpAccumWavCnt, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - !--------------------------------------- - !--- diagnose output - !--------------------------------------- - if (dbug_flag > 1) then - call FB_diagnose(is_local%wrap%FBExp(compwav), & - string=trim(subname)//' FBexp(compwav) ', rc=rc) + call FB_diagnose(is_local%wrap%FBExpAccumWav, & + string=trim(subname)//' FBExpAccumWav after avg ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - !--------------------------------------- - !--- custom calculations - !--------------------------------------- - - !--------------------------------------- - !--- update local scalar data - !--------------------------------------- - - !is_local%wrap%scalar_data(1) = + ! copy to FBExp(compwav) + call FB_copy(is_local%wrap%FBExp(compwav), is_local%wrap%FBExpAccumWav, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - !--- clean up - !--------------------------------------- + ! zero accumulator + is_local%wrap%ExpAccumWavCnt = 0 + call FB_reset(is_local%wrap%FBExpAccumWav, value=czero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + end if - if (dbug_flag > 5) then + if (dbug_flag > 20) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if call t_stopf('MED:'//subname) - end subroutine med_phases_prep_wav - + end subroutine med_phases_prep_wav_avg end module med_phases_prep_wav_mod diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index d87cfba80..9473f7317 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -381,6 +381,17 @@ subroutine med_phases_restart_write(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + ! Write export accumulation to wav + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccumWav)) then + nx = is_local%wrap%nx(compocn) + ny = is_local%wrap%ny(compocn) + call med_io_write(restart_file, is_local%wrap%FBExpAccumWav, whead(m), wdata(m), nx, ny, & + nt=1, pre='ocnExpAccum', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_write(restart_file, is_local%wrap%ExpAccumWavCnt, 'wavExpAccum_cnt', whead(m), wdata(m), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + ! Write accumulation from lnd to rof if lnd->rof coupling is on if (ESMF_FieldBundleIsCreated(FBlndAccum2rof_l)) then nx = is_local%wrap%nx(complnd) From 1a2764569e5f3668a52694506c6539e4996d6f20 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Fri, 31 Dec 2021 11:32:27 -0700 Subject: [PATCH 16/31] compile fixes --- mediator/med.F90 | 28 +++++++++++++++++++++++++--- mediator/med_phases_post_atm_mod.F90 | 4 ++-- mediator/med_phases_post_ice_mod.F90 | 6 +++--- mediator/med_phases_post_ocn_mod.F90 | 13 +++++++++++++ mediator/med_phases_post_wav_mod.F90 | 6 +++--- mediator/med_phases_prep_wav_mod.F90 | 13 ++++++++----- mediator/med_phases_restart_mod.F90 | 2 +- 7 files changed, 55 insertions(+), 17 deletions(-) diff --git a/mediator/med.F90 b/mediator/med.F90 index 8e8c4fdf1..bc8e160e3 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -109,7 +109,8 @@ subroutine SetServices(gcomp, rc) use med_phases_prep_atm_mod , only: med_phases_prep_atm use med_phases_prep_ice_mod , only: med_phases_prep_ice use med_phases_prep_lnd_mod , only: med_phases_prep_lnd - use med_phases_prep_wav_mod , only: med_phases_prep_wav + use med_phases_prep_wav_mod , only: med_phases_prep_wav_accum + use med_phases_prep_wav_mod , only: med_phases_prep_wav_avg use med_phases_prep_glc_mod , only: med_phases_prep_glc use med_phases_prep_rof_mod , only: med_phases_prep_rof use med_phases_prep_ocn_mod , only: med_phases_prep_ocn_accum @@ -351,10 +352,20 @@ subroutine SetServices(gcomp, rc) !------------------ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & - phaseLabelList=(/"med_phases_prep_wav"/), userRoutine=mediator_routine_Run, rc=rc) + phaseLabelList=(/"med_phases_prep_wav_accum"/), userRoutine=mediator_routine_Run, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & - specPhaseLabel="med_phases_prep_wav", specRoutine=med_phases_prep_wav, rc=rc) + specPhaseLabel="med_phases_prep_wav_accum", specRoutine=med_phases_prep_wav_accum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & + specPhaselabel="med_phases_prep_wav_accum", specRoutine=NUOPC_NoOp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & + phaseLabelList=(/"med_phases_prep_wav_avg"/), userRoutine=mediator_routine_Run, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & + specPhaseLabel="med_phases_prep_wav_avg", specRoutine=med_phases_prep_wav_avg, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & @@ -1627,6 +1638,7 @@ subroutine DataInitialize(gcomp, rc) use med_fraction_mod , only : med_fraction_init, med_fraction_set use med_phases_restart_mod , only : med_phases_restart_read use med_phases_prep_ocn_mod , only : med_phases_prep_ocn_init + use med_phases_prep_wav_mod , only : med_phases_prep_wav_init use med_phases_prep_rof_mod , only : med_phases_prep_rof_init use med_phases_prep_glc_mod , only : med_phases_prep_glc_init use med_phases_prep_atm_mod , only : med_phases_prep_atm @@ -2068,6 +2080,16 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if + !--------------------------------------- + ! Initialize wav export accumulation field bundle + !--------------------------------------- + if ( is_local%wrap%comp_present(compwav) .and. & + ESMF_StateIsCreated(is_local%wrap%NStateImp(compwav),rc=rc) .and. & + ESMF_StateIsCreated(is_local%wrap%NStateExp(compwav),rc=rc)) then + call med_phases_prep_wav_init(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + !--------------------------------------- ! Initialize glc module field bundles here if appropriate !--------------------------------------- diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index b07be3754..afa70c98d 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -58,7 +58,7 @@ subroutine med_phases_post_atm(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map atm to ocn + ! map atm->ocn if (is_local%wrap%med_coupling_active(compatm,compocn)) then call t_startf('MED:'//trim(subname)//' map_atm2ocn') call med_map_field_packed( & @@ -97,7 +97,7 @@ subroutine med_phases_post_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_atm2lnd') end if - ! map atm to wav + ! map atm->wav if (is_local%wrap%med_coupling_active(compatm,compwav)) then call t_startf('MED:'//trim(subname)//' map_atm2wav') call med_map_field_packed( & diff --git a/mediator/med_phases_post_ice_mod.F90 b/mediator/med_phases_post_ice_mod.F90 index 2daa4c358..50d3c2de4 100644 --- a/mediator/med_phases_post_ice_mod.F90 +++ b/mediator/med_phases_post_ice_mod.F90 @@ -59,7 +59,7 @@ subroutine med_phases_post_ice(gcomp, rc) call med_fraction_set(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map ice to atm - scaling by updated ice fraction + ! map ice->atm - scaling by updated ice fraction if (is_local%wrap%med_coupling_active(compice,compatm)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compice,compice), & @@ -71,7 +71,7 @@ subroutine med_phases_post_ice(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! map ice to ocn + ! map ice->ocn if (is_local%wrap%med_coupling_active(compice,compocn)) then call t_startf('MED:'//trim(subname)//' map_ice2ocn') call med_map_field_packed( & @@ -84,7 +84,7 @@ subroutine med_phases_post_ice(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_ice2ocn') end if - ! map ice to wav + ! map ice->wav if (is_local%wrap%med_coupling_active(compice,compwav)) then call t_startf('MED:'//trim(subname)//' map_ice2wav') call med_map_field_packed( & diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index 85432b554..78609d459 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -71,6 +71,19 @@ subroutine med_phases_post_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_ocn2ice') end if + ! Map ocn->wav + if (is_local%wrap%med_coupling_active(compocn,compwav)) then + call t_startf('MED:'//trim(subname)//' map_ocn2wav') + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(compocn,compocn), & + FBDst=is_local%wrap%FBImp(compocn,compwav), & + FBFracSrc=is_local%wrap%FBFrac(compocn), & + field_normOne=is_local%wrap%field_normOne(compocn,compwav,:), & + packed_data=is_local%wrap%packed_data(compocn,compwav,:), & + routehandles=is_local%wrap%RH(compocn,compwav,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf('MED:'//trim(subname)//' map_ocn2wav') + end if ! Accumulate ocn input for glc if there is ocn->glc coupling if (first_call) then diff --git a/mediator/med_phases_post_wav_mod.F90 b/mediator/med_phases_post_wav_mod.F90 index a1bf805ef..1807d2d3b 100644 --- a/mediator/med_phases_post_wav_mod.F90 +++ b/mediator/med_phases_post_wav_mod.F90 @@ -50,7 +50,7 @@ subroutine med_phases_post_wav(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map wav to atm + ! map wav->atm if (is_local%wrap%med_coupling_active(compwav,compatm)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compwav,compwav), & @@ -61,7 +61,7 @@ subroutine med_phases_post_wav(gcomp, rc) routehandles=is_local%wrap%RH(compwav,compatm,:), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! map wav to ocn + ! map wav->ocn if (is_local%wrap%med_coupling_active(compwav,compocn)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compwav,compwav), & @@ -72,7 +72,7 @@ subroutine med_phases_post_wav(gcomp, rc) routehandles=is_local%wrap%RH(compwav,compocn,:), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! map wav to ice + ! map wav->ice if (is_local%wrap%med_coupling_active(compwav,compice)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compwav,compwav), & diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 304b1af69..7cc716fda 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -5,17 +5,20 @@ module med_phases_prep_wav_mod !----------------------------------------------------------------------------- use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 - 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 : 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_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_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 med_merge_mod , only : med_merge_auto - use med_map_mod , only : med_map_field_packed - use med_internalstate_mod , only : InternalState, mastertask use esmFlds , only : compwav, compatm, compice - use esmFlds , only : fldListFr, fldListTo + use esmFlds , only : fldListTo use perf_mod , only : t_startf, t_stopf implicit none diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index 9473f7317..8569b6996 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -386,7 +386,7 @@ subroutine med_phases_restart_write(gcomp, rc) nx = is_local%wrap%nx(compocn) ny = is_local%wrap%ny(compocn) call med_io_write(restart_file, is_local%wrap%FBExpAccumWav, whead(m), wdata(m), nx, ny, & - nt=1, pre='ocnExpAccum', rc=rc) + nt=1, pre='wavExpAccum', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call med_io_write(restart_file, is_local%wrap%ExpAccumWavCnt, 'wavExpAccum_cnt', whead(m), wdata(m), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return From 5cfe6c237cd5977cb0ec87d951709c8f2e50ad21 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Mon, 3 Jan 2022 09:55:27 -0700 Subject: [PATCH 17/31] add retrieval of wav accum values on restart --- mediator/med_phases_post_ice_mod.F90 | 1 - mediator/med_phases_restart_mod.F90 | 6 ++++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/mediator/med_phases_post_ice_mod.F90 b/mediator/med_phases_post_ice_mod.F90 index 50d3c2de4..00616d713 100644 --- a/mediator/med_phases_post_ice_mod.F90 +++ b/mediator/med_phases_post_ice_mod.F90 @@ -69,7 +69,6 @@ subroutine med_phases_post_ice(gcomp, rc) packed_data=is_local%wrap%packed_data(compice,compatm,:), & routehandles=is_local%wrap%RH(compice,compatm,:), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if ! map ice->ocn if (is_local%wrap%med_coupling_active(compice,compocn)) then diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index 8569b6996..0eba8bfd0 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -595,6 +595,12 @@ subroutine med_phases_restart_read(gcomp, rc) call med_io_read(restart_file, vm, is_local%wrap%ExpAccumOcnCnt, 'ocnExpAccum_cnt', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccumWav,rc=rc)) then + call med_io_read(restart_file, vm, is_local%wrap%FBExpAccumWav, pre='wavExpAccum', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_read(restart_file, vm, is_local%wrap%ExpAccumWavCnt, 'wavExpAccum_cnt', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif ! If lnd->rof, read accumulation from lnd to rof (CESM only) if (ESMF_FieldBundleIsCreated(FBlndAccum2rof_l)) then call med_io_read(restart_file, vm, FBlndAccum2rof_l, pre='lndImpAccum2rof', rc=rc) From 907a966944bad355011fe4e3710b018156c8f220 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 12 Jan 2022 14:47:10 -0500 Subject: [PATCH 18/31] remove extra ice->atm mapping in post ice * mapping is done in prep-atm; this mapping is unneeded --- mediator/med_phases_post_ice_mod.F90 | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/mediator/med_phases_post_ice_mod.F90 b/mediator/med_phases_post_ice_mod.F90 index cee157e80..0a04c571b 100644 --- a/mediator/med_phases_post_ice_mod.F90 +++ b/mediator/med_phases_post_ice_mod.F90 @@ -59,17 +59,6 @@ subroutine med_phases_post_ice(gcomp, rc) call med_fraction_set(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map ice->atm - scaling by updated ice fraction - if (is_local%wrap%med_coupling_active(compice,compatm)) then - call med_map_field_packed( & - FBSrc=is_local%wrap%FBImp(compice,compice), & - FBDst=is_local%wrap%FBImp(compice,compatm), & - FBFracSrc=is_local%wrap%FBFrac(compice), & - field_NormOne=is_local%wrap%field_normOne(compice,compatm,:), & - packed_data=is_local%wrap%packed_data(compice,compatm,:), & - routehandles=is_local%wrap%RH(compice,compatm,:), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if ! map ice->ocn if (is_local%wrap%med_coupling_active(compice,compocn)) then call t_startf('MED:'//trim(subname)//' map_ice2ocn') From e4425046b766c35d09e6e7352f3251fdf79108de Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Mon, 17 Jan 2022 10:25:13 -0700 Subject: [PATCH 19/31] fix compile errors tidy up; changes for hafs tests to work. switch dst/src masking back for hafs mode. This is not required if wmesmf can read correct values (water=1,land=0) from config file revert extraneous changes --- mediator/esmFldsExchange_nems_mod.F90 | 2 +- mediator/med.F90 | 8 ++++---- mediator/med_map_mod.F90 | 4 ++-- mediator/med_methods_mod.F90 | 2 +- mediator/med_phases_post_atm_mod.F90 | 4 ++-- mediator/med_phases_post_ice_mod.F90 | 4 ++-- mediator/med_phases_post_ocn_mod.F90 | 2 +- mediator/med_phases_post_wav_mod.F90 | 6 +++--- mediator/med_phases_prep_ocn_mod.F90 | 1 - mediator/med_phases_prep_wav_mod.F90 | 14 +++++++------- 10 files changed, 23 insertions(+), 24 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 29b90ae81..3915c23dd 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -25,7 +25,7 @@ subroutine esmFldsExchange_nems(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_internalstate_mod , only : mastertask, logunit - use med_internalstate_mod , only : compmed, compatm, compocn, compice, comprof, ncomps + use med_internalstate_mod , only : compmed, compatm, compocn, compice, comprof, compwav, ncomps use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch use med_internalstate_mod , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf use med_internalstate_mod , only : mapconsf_aofrac diff --git a/mediator/med.F90 b/mediator/med.F90 index 6b65678a6..4ac79c4cf 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -2081,12 +2081,12 @@ subroutine DataInitialize(gcomp, rc) ! Call post routines as part of initialization !--------------------------------------- if (is_local%wrap%comp_present(compatm)) then - ! map atm->ocn, atm->ice, atm->lnd + ! map atm->ocn, atm->ice, atm->lnd, atm->wav call med_phases_post_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (is_local%wrap%comp_present(compice)) then - ! call set ice_frac and map ice->atm and ice->ocn + ! call set ice_frac and map ice->ocn and ice->wav call med_phases_post_ice(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -2101,7 +2101,7 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (is_local%wrap%comp_present(compocn)) then - ! map initial ocn->ice + ! map initial ocn->ice, ocn->wav call med_phases_post_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -2111,7 +2111,7 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (is_local%wrap%comp_present(compwav)) then - ! map initial wav->ocn and wav->ice + ! map initial wav->ocn, wav->ice, wav->atm call med_phases_post_wav(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 17ebcf628..776569052 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -440,9 +440,9 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, srcMaskValue = 0 dstMaskValue = ispval_mask elseif (n1 == compatm .and. n2 == compwav) then - dstMaskValue = 0 + dstMaskValue = 1 elseif (n1 == compwav .and. n2 == compatm) then - srcMaskValue = 0 + srcMaskValue = 1 dstMaskValue = ispval_mask endif end if diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index b24418fef..f25b024cd 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -1863,7 +1863,7 @@ subroutine med_methods_Field_GeomPrint(field, string, rc) 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_Print(lmesh, string, rc) + call med_methods_Mesh_Print(lmesh, string, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return endif diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index 0e7681541..ab6f65e2b 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -33,7 +33,7 @@ subroutine med_phases_post_atm(gcomp, rc) use med_map_mod , only : med_map_field_packed 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 : compocn, compatm, compice, complnd + use med_internalstate_mod , only : compocn, compatm, compice, complnd, compwav use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -58,7 +58,7 @@ subroutine med_phases_post_atm(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map atm->ocn + ! map atm to ocn if (is_local%wrap%med_coupling_active(compatm,compocn)) then call t_startf('MED:'//trim(subname)//' map_atm2ocn') call med_map_field_packed( & diff --git a/mediator/med_phases_post_ice_mod.F90 b/mediator/med_phases_post_ice_mod.F90 index 0a04c571b..d081448e4 100644 --- a/mediator/med_phases_post_ice_mod.F90 +++ b/mediator/med_phases_post_ice_mod.F90 @@ -59,7 +59,7 @@ subroutine med_phases_post_ice(gcomp, rc) call med_fraction_set(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map ice->ocn + ! map ice to ocn if (is_local%wrap%med_coupling_active(compice,compocn)) then call t_startf('MED:'//trim(subname)//' map_ice2ocn') call med_map_field_packed( & @@ -72,7 +72,7 @@ subroutine med_phases_post_ice(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_ice2ocn') end if - ! map ice->wav + ! map ice to wav if (is_local%wrap%med_coupling_active(compice,compwav)) then call t_startf('MED:'//trim(subname)//' map_ice2wav') call med_map_field_packed( & diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index c11550a31..abf766211 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -27,7 +27,7 @@ subroutine med_phases_post_ocn(gcomp, rc) use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_map_mod , only : med_map_field_packed use med_internalstate_mod , only : InternalState, logunit, mastertask - use med_internalstate_mod , only : compice, compocn + use med_internalstate_mod , only : compice, compocn, compwav use med_phases_history_mod , only : med_phases_history_write_comp use med_phases_prep_glc_mod , only : med_phases_prep_glc_accum_ocn use perf_mod , only : t_startf, t_stopf diff --git a/mediator/med_phases_post_wav_mod.F90 b/mediator/med_phases_post_wav_mod.F90 index ffef8559a..31abf004c 100644 --- a/mediator/med_phases_post_wav_mod.F90 +++ b/mediator/med_phases_post_wav_mod.F90 @@ -50,7 +50,7 @@ subroutine med_phases_post_wav(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map wav->atm + ! map wav to atm if (is_local%wrap%med_coupling_active(compwav,compatm)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compwav,compwav), & @@ -61,7 +61,7 @@ subroutine med_phases_post_wav(gcomp, rc) routehandles=is_local%wrap%RH(compwav,compatm,:), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! map wav->ocn + ! map wav to ocn if (is_local%wrap%med_coupling_active(compwav,compocn)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compwav,compwav), & @@ -72,7 +72,7 @@ subroutine med_phases_post_wav(gcomp, rc) routehandles=is_local%wrap%RH(compwav,compocn,:), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! map wav->ice + ! map wav to ice if (is_local%wrap%med_coupling_active(compwav,compice)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compwav,compwav), & diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90 index 611f42879..0858462bc 100644 --- a/mediator/med_phases_prep_ocn_mod.F90 +++ b/mediator/med_phases_prep_ocn_mod.F90 @@ -44,7 +44,6 @@ subroutine med_phases_prep_ocn_init(gcomp, rc) use ESMF , only : ESMF_GridComp, ESMF_SUCCESS use med_methods_mod , only : FB_Init => med_methods_FB_init - use med_methods_mod , only : FB_Reset => med_methods_FB_Reset ! input/output variables type(ESMF_GridComp) :: gcomp diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 00d9913b6..a1bd85c1b 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -13,11 +13,12 @@ module med_phases_prep_wav_mod 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_merge_mod , only : med_merge_auto - use med_map_mod , only : med_map_field_packed - use med_internalstate_mod , only : InternalState, mastertask - use med_internalstate_mod , only : compwav, ncomps, compname - use esmFlds , only : fldListFr, fldListTo + 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 : fldListTo + use med_internalstate_mod , only : compwav use perf_mod , only : t_startf, t_stopf implicit none @@ -38,7 +39,6 @@ subroutine med_phases_prep_wav_init(gcomp, rc) use ESMF , only : ESMF_GridComp, ESMF_SUCCESS use med_methods_mod , only : FB_Init => med_methods_FB_init - use med_methods_mod , only : FB_Reset => med_methods_FB_Reset ! input/output variables type(ESMF_GridComp) :: gcomp @@ -59,7 +59,7 @@ subroutine med_phases_prep_wav_init(gcomp, rc) if (mastertask) then write(logunit,'(a)') trim(subname)//' initializing wave export accumulation FB for ' end if - call FB_init(is_local%wrap%FBExpAccumWav, is_local%wrap%flds_scalar_name, & + call FB_Init(is_local%wrap%FBExpAccumWav, is_local%wrap%flds_scalar_name, & STgeom=is_local%wrap%NStateExp(compwav), STflds=is_local%wrap%NStateExp(compwav), & name='FBExpAccumWav', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return From 40be8c3325ab1e897d4f687a51f3f369887c6368 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Fri, 21 Jan 2022 08:22:24 -0700 Subject: [PATCH 20/31] simplify src/dst masking for nems --- mediator/med_map_mod.F90 | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 776569052..5921d927e 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -403,24 +403,19 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, polemethod = ESMF_POLEMETHOD_NONE ! todo: remove this when ESMF tripolar mapping fix is in place. endif else if (coupling_mode(1:4) == 'nems') then - if (n1 == compatm .and. (n2 == compocn .or. n2 == compice .or. n2 == compwav)) then + if ( (n1 == compocn .or. n1 == compice .or. n1 == compwav) .and. & + (n2 == compocn .or. n2 == compice .or. n2 == compwav) ) then + srcMaskValue = 0 + dstMaskValue = 0 + else if (n1 == compatm .and. (n2 == compocn .or. n2 == compice .or. n2 == compwav)) then srcMaskValue = 1 dstMaskValue = 0 if (atm_name(1:4).eq.'datm') then - srcMaskValue = 0 + srcMaskValue = 0 endif else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice .or. n1 == compwav)) then srcMaskValue = 0 dstMaskValue = 1 - else if ((n1 == compocn .and. n2 == compice) .or. (n1 == compice .and. n2 == compocn)) then - srcMaskValue = 0 - dstMaskValue = 0 - else if ((n1 == compocn .and. n2 == compwav) .or. (n1 == compice .and. n2 == compwav)) then - srcMaskValue = 0 - dstMaskValue = 0 - else if ((n1 == compwav .and. n2 == compocn) .or. (n1 == compwav .and. n2 == compice)) then - srcMaskValue = 0 - dstMaskValue = 0 else ! TODO: what should the condition be here? dstMaskValue = ispval_mask @@ -440,9 +435,9 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, srcMaskValue = 0 dstMaskValue = ispval_mask elseif (n1 == compatm .and. n2 == compwav) then - dstMaskValue = 1 + dstMaskValue = 0 elseif (n1 == compwav .and. n2 == compatm) then - srcMaskValue = 1 + srcMaskValue = 0 dstMaskValue = ispval_mask endif end if From 963557d4d9e4914c2ecc4f993bdec3e7d81af9e1 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sat, 22 Jan 2022 06:24:13 -0700 Subject: [PATCH 21/31] fix nx,ny for compwav for writing accumWav --- mediator/med_phases_restart_mod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index 9ec9fc5fa..5affb149a 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -8,7 +8,7 @@ module med_phases_restart_mod 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 : mastertask, logunit, InternalState - use med_internalstate_mod , only : ncomps, compname, compocn, complnd + use med_internalstate_mod , only : ncomps, compname, compocn, complnd, compwav use perf_mod , only : t_startf, t_stopf use med_phases_prep_glc_mod , only : FBlndAccum2glc_l, lndAccum2glc_cnt use med_phases_prep_glc_mod , only : FBocnAccum2glc_o, ocnAccum2glc_cnt @@ -383,8 +383,8 @@ subroutine med_phases_restart_write(gcomp, rc) ! Write export accumulation to wav if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccumWav)) then - nx = is_local%wrap%nx(compocn) - ny = is_local%wrap%ny(compocn) + nx = is_local%wrap%nx(compwav) + ny = is_local%wrap%ny(compwav) call med_io_write(restart_file, is_local%wrap%FBExpAccumWav, whead(m), wdata(m), nx, ny, & nt=1, pre='wavExpAccum', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return From 7f8ae7ff923b0ab2e5854b2a5981dba76942b89d Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sat, 22 Jan 2022 12:06:28 -0500 Subject: [PATCH 22/31] refactor FldsExchange_nems for phases call FldsExchange_nems twice, once for advertise and once for initialize --- mediator/esmFldsExchange_nems_mod.F90 | 480 +++++++++++++++++--------- mediator/med.F90 | 5 +- 2 files changed, 323 insertions(+), 162 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 3915c23dd..77bee6122 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -24,7 +24,8 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) 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_internalstate_mod , only : mastertask, logunit + use med_methods_mod , only : fldchk => med_methods_FB_FldChk + use med_internalstate_mod , only : InternalState,logunit, mastertask use med_internalstate_mod , only : compmed, compatm, compocn, compice, comprof, compwav, ncomps use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch use med_internalstate_mod , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf @@ -42,6 +43,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) integer , intent(inout) :: rc ! local variables: + type(InternalState) :: is_local integer :: i, n, maptype character(len=CX) :: msgString character(len=CL) :: cvalue @@ -52,6 +54,14 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) rc = ESMF_SUCCESS + !--------------------------------------- + ! Get the internal state + !--------------------------------------- + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Set maptype according to coupling_mode if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then maptype = mapnstod_consf @@ -65,59 +75,75 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! 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 + 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 !===================================================================== ! Mediator fields !===================================================================== - ! masks from components - call addfld(fldListFr(compice)%flds, 'Si_imask') - call addfld(fldListFr(compocn)%flds, 'So_omask') - call addmap(fldListFr(compocn)%flds, 'So_omask', compice, mapfcopy, 'unset', 'unset') - - if ( trim(coupling_mode) == 'nems_orig_data') then - ! atm and ocn fields required for atm/ocn flux calculation' - allocate(flds(10)) - flds = (/'Sa_u ','Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', 'Sa_shum', & - 'Sa_u10m','Sa_v10m', 'Sa_t2m ', 'Sa_q2m '/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') - end do - deallocate(flds) - - ! unused fields needed by the atm/ocn flux computation - allocate(flds(13)) - flds = (/'So_tref ', 'So_qref ','So_u10 ', 'So_ustar ','So_ssq ', & - 'So_re ', 'So_duu10n','Faox_lwup', 'Faox_sen ','Faox_lat ', & - 'Faox_evap', 'Faox_taux','Faox_tauy'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListMed_aoflux%flds, trim(fldname)) - end do - deallocate(flds) + if (phase == 'advertise') then + ! masks from components + call addfld(fldListFr(compice)%flds, 'Si_imask') + call addfld(fldListFr(compocn)%flds, 'So_omask') + + if ( trim(coupling_mode) == 'nems_orig_data') then + ! atm and ocn fields required for atm/ocn flux calculation' + allocate(flds(10)) + flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', & + 'Sa_shum', 'Sa_u10m', 'Sa_v10m', 'Sa_t2m ', 'Sa_q2m '/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListFr(compatm)%flds, trim(fldname)) + end do + deallocate(flds) + + ! unused fields needed by the atm/ocn flux computation + allocate(flds(13)) + flds = (/'So_tref ', 'So_qref ', 'So_u10 ', 'So_ustar ','So_ssq ', & + 'So_re ', 'So_duu10n', 'Faox_lwup', 'Faox_sen ','Faox_lat ', & + 'Faox_evap', 'Faox_taux', 'Faox_tauy'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListMed_aoflux%flds, trim(fldname)) + end do + deallocate(flds) + end if + ! unused fields from ice - but that are needed to be realized by the cice cap + call addfld(fldListFr(compice)%flds, 'Faii_evap') + call addfld(fldListFr(compice)%flds, 'mean_sw_pen_to_ocn') + else + call addmap(fldListFr(compocn)%flds, 'So_omask', compice, mapfcopy, 'unset', 'unset') + + if ( trim(coupling_mode) == 'nems_orig_data') then + allocate(flds(10)) + flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', & + 'Sa_shum', 'Sa_u10m', 'Sa_v10m', 'Sa_t2m ', 'Sa_q2m '/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') + end do + deallocate(flds) + end if end if - ! unused fields from ice - but that are needed to be realized by the cice cap - call addfld(fldListFr(compice)%flds, 'Faii_evap') - call addfld(fldListFr(compice)%flds, 'mean_sw_pen_to_ocn') - !===================================================================== ! FIELDS TO ATMOSPHERE (compatm) !===================================================================== ! to atm: fractions (computed in med_phases_prep_atm) - call addfld(fldListFr(compice)%flds, 'Si_ifrac') - call addfld(fldListTo(compatm)%flds, 'Si_ifrac') - ! ofrac used by atm - call addfld(fldListFr(compatm)%flds, 'Sa_ofrac') + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Si_ifrac') + call addfld(fldListTo(compatm)%flds, 'Si_ifrac') + ! ofrac used by atm + call addfld(fldListFr(compatm)%flds, 'Sa_ofrac') + end if ! to atm: unmerged from ice ! - zonal surface stress, meridional surface stress @@ -129,51 +155,76 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! - mean snow volume per unit area ! - surface temperatures allocate(flds(9)) - flds = (/'Faii_taux', 'Faii_tauy', 'Faii_lat ', & - 'Faii_sen ', 'Faii_lwup', 'Faii_evap', & - 'Si_vice ', 'Si_vsno ', 'Si_t '/) + flds = (/'Faii_taux', 'Faii_tauy', 'Faii_lat ', 'Faii_sen ', 'Faii_lwup', & + 'Faii_evap', 'Si_vice ', 'Si_vsno ', 'Si_t '/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compice)%flds, trim(fldname), compatm, maptype, 'ifrac', 'unset') - call addmrg(fldListTo(compatm)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, trim(fldname)) + call addfld(fldListTo(compatm)%flds, trim(fldname)) + else + if ( fldchk(is_local%wrap%FBexp(compatm) , trim(fldname), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), trim(fldname), rc=rc)) then + call addmap(fldListFr(compice)%flds, trim(fldname), compatm, maptype, 'ifrac', 'unset') + call addmrg(fldListTo(compatm)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if end do deallocate(flds) allocate(flds(4)) - flds = (/'avsdr ', 'avsdf ', & - 'anidr ', 'anidf '/) + flds = (/'Si_avsdr', 'Si_avsdf', 'Si_anidr', 'Si_anidf'/) do n = 1,size(flds) - fldname = 'Si_'//trim(flds(n)) - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compice)%flds, trim(fldname), compatm, maptype, 'ifrac', 'unset') - call addmrg(fldListTo(compatm)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') + fldname = trim(flds(n)) + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, trim(fldname)) + call addfld(fldListTo(compatm)%flds, trim(fldname)) + else + if ( fldchk(is_local%wrap%FBexp(compatm) , trim(fldname), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), trim(fldname), rc=rc)) then + call addmap(fldListFr(compice)%flds, trim(fldname), compatm, maptype, 'ifrac', 'unset') + call addmrg(fldListTo(compatm)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') + end if end do deallocate(flds) ! to atm: unmerged surface temperatures from ocn - call addfld(fldListFr(compocn)%flds, 'So_t') - call addfld(fldListTo(compatm)%flds, 'So_t') - call addmap(fldListFr(compocn)%flds, 'So_t', compatm, maptype, 'ofrac', 'unset') - call addmrg(fldListTo(compatm)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, 'So_t') + call addfld(fldListTo(compatm)%flds, 'So_t') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'So_t', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_t', rc=rc)) then + call addmap(fldListFr(compocn)%flds, 'So_t', compatm, maptype, 'ofrac', 'unset') + call addmrg(fldListTo(compatm)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + end if + end if ! to atm: surface roughness length from wav - call addfld(fldListFr(compwav)%flds, 'Sw_z0') - call addfld(fldListTo(compatm)%flds, 'Sw_z0') - call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_z0') + call addfld(fldListTo(compatm)%flds, 'Sw_z0') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Sw_z0', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav,compwav), 'Sw_z0', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + endif !===================================================================== ! FIELDS TO OCEAN (compocn) !===================================================================== ! to ocn: sea level pressure from atm - call addfld(fldListTo(compocn)%flds, 'Sa_pslv') - call addfld(fldListFr(compatm)%flds, 'Sa_pslv') - call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, maptype, 'one', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Sa_pslv') + call addfld(fldListTo(compocn)%flds, 'Sa_pslv') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Sa_pslv', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_pslv', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, maptype, 'one', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') + end if ! to ocn: from atm (custom merge in med_phases_prep_ocn) ! - downward direct near-infrared incident solar radiation @@ -184,9 +235,15 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) flds = (/'Faxa_swndr', 'Faxa_swndf', 'Faxa_swvdr', 'Faxa_swvdf'/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListTo(compocn)%flds, trim(fldname)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') + 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, maptype, 'one', 'unset') + end if + end if end do deallocate(flds) @@ -198,9 +255,15 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) allocate(flds(4)) flds = (/'vdr', 'vdf', 'idr', 'idf'/) do n = 1,size(flds) - call addfld(fldListTo(compocn)%flds, 'Foxx_swnet_'//trim(flds(n))) - call addfld(fldListFr(compice)%flds, 'Fioi_swpen_'//trim(flds(n))) - call addmap(fldListFr(compice)%flds, 'Fioi_swpen_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Fioi_swpen_'//trim(flds(n))) + call addfld(fldListTo(compocn)%flds, 'Foxx_swnet_'//trim(flds(n))) + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_swnet_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_'//trim(flds(n)), rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_swpen_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + end if + end if end do deallocate(flds) @@ -209,11 +272,17 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) flds = (/'Faxa_rain', 'Faxa_snow'/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListTo(compocn)%flds, trim(fldname)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') - call addmrg(fldListTo(compocn)%flds, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='ofrac') + 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, maptype, 'one', 'unset') + call addmrg(fldListTo(compocn)%flds, trim(fldname), & + mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if end do deallocate(flds) @@ -222,64 +291,112 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) allocate(flds(2)) flds = (/'taux', 'tauy'/) do n = 1,size(flds) - call addfld(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n))) - call addfld(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n))) - call addfld(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n))) - call addmap(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n)), compocn, mapconsf_aofrac, 'aofrac', 'unset') - call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n))) + call addfld(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n))) + call addfld(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n))) + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_'//trim(flds(n)), rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + call addmap(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n)), compocn, mapconsf_aofrac, 'aofrac', 'unset') + end if end do deallocate(flds) ! to ocn: net long wave via auto merge - call addfld(fldListTo(compocn)%flds, 'Faxa_lwnet') - call addfld(fldListFr(compatm)%flds, 'Faxa_lwnet') - call addmap(fldListFr(compatm)%flds, 'Faxa_lwnet', compocn, mapconsf_aofrac, 'aofrac', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Faxa_lwnet', & - mrg_from=compatm, mrg_fld='Faxa_lwnet', mrg_type='copy_with_weights', mrg_fracname='ofrac') + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_lwnet') + call addfld(fldListTo(compocn)%flds, 'Faxa_lwnet') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_lwnet', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwnet', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_lwnet', compocn, mapconsf_aofrac, 'aofrac', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Faxa_lwnet', & + mrg_from=compatm, mrg_fld='Faxa_lwnet', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if ! to ocn: merged sensible heat flux (custom merge in med_phases_prep_ocn) - call addfld(fldListTo(compocn)%flds, 'Faxa_sen') - call addfld(fldListFr(compatm)%flds, 'Faxa_sen') - call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, mapconsf_aofrac, 'aofrac', 'unset') + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_sen') + call addfld(fldListTo(compocn)%flds, 'Faxa_sen') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_sen', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_sen', rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, mapconsf_aofrac, 'aofrac', 'unset') + end if ! to ocn: evaporation water flux (custom merge in med_phases_prep_ocn) - call addfld(fldListTo(compocn)%flds, 'Faxa_evap') - call addfld(fldListFr(compatm)%flds, 'Faxa_lat') - call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, mapconsf_aofrac, 'aofrac', 'unset') + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_lat') + call addfld(fldListTo(compocn)%flds, 'Faxa_evap') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_evap', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lat' , rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, mapconsf_aofrac, 'aofrac', 'unset') + end if else ! nems_orig_data ! to ocn: surface stress from mediator and ice stress via auto merge allocate(flds(2)) flds = (/'taux', 'tauy'/) do n = 1,size(flds) - call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(flds(n))) + if (phase == 'advertise') then call addfld(fldListFr(compice)%flds , 'Fioi_'//trim(flds(n))) - call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & - mrg_from=compmed, mrg_fld='Faox_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ofrac') - call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & - mrg_from=compice, mrg_fld='Fioi_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ifrac') + call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(flds(n))) + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_'//trim(flds(n)), rc=rc) .and. & + call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & + mrg_from=compmed, mrg_fld='Faox_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ofrac') + call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & + mrg_from=compice, mrg_fld='Fioi_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ifrac') + end if + end if end do deallocate(flds) ! to ocn: long wave net via auto merge - call addfld(fldListTo(compocn)%flds, 'Foxx_lwnet') - call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') - call addmap(fldListFr(compatm)%flds, 'Faxa_lwdn', compocn, maptype, 'one', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', & - mrg_from=compmed, mrg_fld='Faox_lwup', mrg_type='merge', mrg_fracname='ofrac') - call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', & - mrg_from=compatm, mrg_fld='Faxa_lwdn', mrg_type='merge', mrg_fracname='ofrac') + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') + call addfld(fldListTo(compocn)%flds, 'Foxx_lwnet') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_lwnet', rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup' , rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwdn' , rc=rc)) then + call addmap(fldListFr(compatm)%flds, 'Faxa_lwdn', compocn, maptype, 'one', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', & + mrg_from=compmed, mrg_fld='Faox_lwup', mrg_type='merge', mrg_fracname='ofrac') + call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', & + mrg_from=compatm, mrg_fld='Faxa_lwdn', mrg_type='merge', mrg_fracname='ofrac') + end if + end if ! to ocn: sensible heat flux from mediator via auto merge - call addfld(fldListTo(compocn)%flds, 'Faox_sen') - call addmrg(fldListTo(compocn)%flds, 'Faox_sen', & - mrg_from=compmed, mrg_fld='Faox_sen', mrg_type='copy_with_weights', mrg_fracname='ofrac') + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds, 'Faox_sen') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_sen', rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_sen' , rc=rc) .and. & + call addmrg(fldListTo(compocn)%flds, 'Faox_sen', & + mrg_from=compmed, mrg_fld='Faox_sen', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if ! to ocn: evaporation water flux from mediator via auto merge - call addfld(fldListTo(compocn)%flds, 'Faox_evap') - call addmrg(fldListTo(compocn)%flds, 'Faox_evap', & - mrg_from=compmed, mrg_fld='Faox_evap', mrg_type='copy_with_weights', mrg_fracname='ofrac') + if (phase == 'advertise') then + call addfld(fldListTo(compocn)%flds, 'Faox_evap') + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_evap', rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_evap' , rc=rc) .and. & + call addmrg(fldListTo(compocn)%flds, 'Faox_evap', & + mrg_from=compmed, mrg_fld='Faox_evap', mrg_type='copy_with_weights', mrg_fracname='ofrac') + end if + end if end if ! to ocn: water flux due to melting ice from ice @@ -289,11 +406,17 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) flds = (/'Fioi_meltw', 'Fioi_melth', 'Fioi_salt '/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addfld(fldListTo(compocn)%flds, trim(fldname)) - call addmap(fldListFr(compice)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, trim(fldname), & - mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='ifrac') + if (phase == 'advertise') then + call addfld(fldListFr(compice)%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(compice,compice), trim(fldname), rc=rc)) then + call addmap(fldListFr(compice)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, trim(fldname), & + mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy_with_weights', mrg_fracname='ifrac') + end if + end if end do deallocate(flds) @@ -303,10 +426,16 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) 'Sw_vstokes1', 'Sw_vstokes2', 'Sw_vstokes3'/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListTo(compocn)%flds, trim(fldname)) - call addfld(fldListFr(compwav)%flds, trim(fldname)) - call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%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(compwav,compwav), trim(fldname), rc=rc)) then + call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if end do deallocate(flds) @@ -324,14 +453,20 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ice: snow from atm allocate(flds(7)) - flds = (/'Faxa_lwdn ' , 'Faxa_swndr ' , 'Faxa_swvdr ' , 'Faxa_swndf ' , 'Faxa_swvdf ', & - 'Faxa_rain ' , 'Faxa_snow '/) + flds = (/'Faxa_lwdn ', 'Faxa_swndr', 'Faxa_swvdr', 'Faxa_swndf', 'Faxa_swvdf', & + 'Faxa_rain ', 'Faxa_snow '/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(compice)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, maptype, 'one', 'unset') - call addmrg(fldListTo(compice)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + 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, maptype, 'one', 'unset') + call addmrg(fldListTo(compice)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if end do deallocate(flds) @@ -343,13 +478,20 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ice: meridional wind at the lowest model level from atm ! to ice: specific humidity at the lowest model level from atm allocate(flds(6)) - flds = (/'Sa_z ', 'Sa_pbot ', 'Sa_tbot ','Sa_u ','Sa_v ','Sa_shum '/) + flds = (/'Sa_z ', 'Sa_pbot', 'Sa_tbot', 'Sa_u ', 'Sa_v ', & + 'Sa_shum'/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListTo(compice)%flds, trim(fldname)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, maptype, 'one', 'unset') - call addmrg(fldListTo(compice)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + 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, maptype, 'one', 'unset') + call addmrg(fldListTo(compice)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if end do deallocate(flds) @@ -362,13 +504,20 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ice: meridional sea surface slope from ocn ! to ice: ocean melt and freeze potential from ocn allocate(flds(7)) - flds = (/'So_t ', 'So_s ', 'So_u ', 'So_v ','So_dhdx', 'So_dhdy', 'Fioo_q '/) + flds = (/'So_t ', 'So_s ', 'So_u ', 'So_v ','So_dhdx', & + 'So_dhdy', 'Fioo_q '/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListTo(compice)%flds, trim(fldname)) - call addfld(fldListFr(compocn)%flds, trim(fldname)) - call addmap(fldListFr(compocn)%flds, trim(fldname), compice, mapfcopy , 'unset', 'unset') - call addmrg(fldListTo(compice)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + 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_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if end do deallocate(flds) @@ -376,30 +525,35 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! FIELDS TO WAV (compwav) !===================================================================== - ! to wav - 10m winds from atm + ! to wav - 10m winds and bottom temperature from atm allocate(flds(3)) flds = (/'Sa_u10m', 'Sa_v10m', 'Sa_tbot'/) - - do n = 1,size(flds) + do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + else + if ( fldchk(is_local%wrap%FBexp(compwav) , trim(fldname), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), trim(fldname), rc=rc)) then + call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if end do deallocate(flds) ! to wav: sea ice fraction - allocate(flds(1)) - flds = (/'Si_ifrac'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') - end do - deallocate(flds) + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'Si_ifrac') + call addfld(fldListTo(compwav)%flds, 'Si_ifrac') + else + if ( fldchk(is_local%wrap%FBexp(compwav) , 'Si_ifrac', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Si_ifrac', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_ifrac', compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, 'Si_ifrac', mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') + end if + end if ! to wav: zonal sea water velocity from ocn ! to wav: meridional sea water velocity from ocn @@ -407,10 +561,16 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) flds = (/'So_u', 'So_v', 'So_t'/) do n = 1,size(flds) fldname = trim(flds(n)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - call addfld(fldListFr(compocn)%flds, trim(fldname)) - call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + if (phase == 'advertise') then + call addfld(fldListFr(compocn)%flds, trim(fldname)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + else + if ( fldchk(is_local%wrap%FBexp(compwav) , trim(fldname), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), trim(fldname), rc=rc)) then + call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if end do deallocate(flds) diff --git a/mediator/med.F90 b/mediator/med.F90 index 4ac79c4cf..e8d18c514 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -778,8 +778,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) if (trim(coupling_mode) == 'cesm') then call esmFldsExchange_cesm(gcomp, phase='advertise', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - else if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_frac' & - .or. trim(coupling_mode) == 'nems_orig_data') then + else if (trim(coupling_mode(1:4)) == 'nems') then call esmFldsExchange_nems(gcomp, phase='advertise', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return else if (trim(coupling_mode(1:4)) == 'hafs') then @@ -1741,6 +1740,8 @@ subroutine DataInitialize(gcomp, rc) if (trim(coupling_mode) == 'cesm') then call esmFldsExchange_cesm(gcomp, phase='initialize', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + else if (trim(coupling_mode(1:4)) == 'nems') then + call esmFldsExchange_nems(gcomp, phase='initialize', rc=rc) else if (trim(coupling_mode) == 'hafs') then call esmFldsExchange_hafs(gcomp, phase='initialize', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return From 27aee0bffdcb1f2f98f7328cec5e612177ad3853 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sat, 22 Jan 2022 10:26:37 -0700 Subject: [PATCH 23/31] fix compile errors --- mediator/esmFldsExchange_nems_mod.F90 | 60 +++++++++++++++------------ 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 77bee6122..cdb72eb54 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -185,6 +185,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addmap(fldListFr(compice)%flds, trim(fldname), compatm, maptype, 'ifrac', 'unset') call addmrg(fldListTo(compatm)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') end if + end if end do deallocate(flds) @@ -207,9 +208,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compatm) , 'Sw_z0', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav,compwav), 'Sw_z0', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') - endif + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + end if + end if !===================================================================== ! FIELDS TO OCEAN (compocn) @@ -222,8 +224,9 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Sa_pslv', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_pslv', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, maptype, 'one', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') + call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, maptype, 'one', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') + end if end if ! to ocn: from atm (custom merge in med_phases_prep_ocn) @@ -296,11 +299,12 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addfld(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n))) call addfld(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n))) else - if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_'//trim(flds(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_'//trim(flds(n)), rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') - call addmap(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n)), compocn, mapconsf_aofrac, 'aofrac', 'unset') + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_'//trim(flds(n)), rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + call addmap(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n)), compocn, mapconsf_aofrac, 'aofrac', 'unset') + end if end if end do deallocate(flds) @@ -325,7 +329,8 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_sen', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_sen', rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, mapconsf_aofrac, 'aofrac', 'unset') + call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, mapconsf_aofrac, 'aofrac', 'unset') + end if end if ! to ocn: evaporation water flux (custom merge in med_phases_prep_ocn) @@ -335,7 +340,8 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_evap', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lat' , rc=rc)) then - call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, mapconsf_aofrac, 'aofrac', 'unset') + call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, mapconsf_aofrac, 'aofrac', 'unset') + end if end if else ! nems_orig_data @@ -343,20 +349,20 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) allocate(flds(2)) flds = (/'taux', 'tauy'/) do n = 1,size(flds) - if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds , 'Fioi_'//trim(flds(n))) - call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(flds(n))) - else - if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_'//trim(flds(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_'//trim(flds(n)), rc=rc) .and. & - call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & - mrg_from=compmed, mrg_fld='Faox_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ofrac') - call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & - mrg_from=compice, mrg_fld='Fioi_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ifrac') + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds , 'Fioi_'//trim(flds(n))) + call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(flds(n))) + else + if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_'//trim(flds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_'//trim(flds(n)), rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & + mrg_from=compmed, mrg_fld='Faox_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ofrac') + call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n)), & + mrg_from=compice, mrg_fld='Fioi_'//trim(flds(n)), mrg_type='merge', mrg_fracname='ifrac') + end if end if - end if end do deallocate(flds) @@ -381,7 +387,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addfld(fldListTo(compocn)%flds, 'Faox_sen') else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_sen', rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_sen' , rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_sen' , rc=rc)) then call addmrg(fldListTo(compocn)%flds, 'Faox_sen', & mrg_from=compmed, mrg_fld='Faox_sen', mrg_type='copy_with_weights', mrg_fracname='ofrac') end if @@ -392,7 +398,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addfld(fldListTo(compocn)%flds, 'Faox_evap') else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_evap', rc=rc) .and. & - fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_evap' , rc=rc) .and. & + fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_evap' , rc=rc)) then call addmrg(fldListTo(compocn)%flds, 'Faox_evap', & mrg_from=compmed, mrg_fld='Faox_evap', mrg_type='copy_with_weights', mrg_fracname='ofrac') end if From 6066d5012cb60a30efdc910284ec7add1ddc6d55 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sat, 22 Jan 2022 14:44:32 -0700 Subject: [PATCH 24/31] insert conditional for waves in nems * prevent field advertising conflicts when running waves with connectors. The added conditional can be removed when s2sw is updated to use cmeps --- mediator/esmFldsExchange_nems_mod.F90 | 118 ++++++++++++++------------ 1 file changed, 65 insertions(+), 53 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 3915c23dd..81def7650 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -24,6 +24,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) 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_internalstate_mod , only : InternalState use med_internalstate_mod , only : mastertask, logunit use med_internalstate_mod , only : compmed, compatm, compocn, compice, comprof, compwav, ncomps use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch @@ -42,6 +43,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) integer , intent(inout) :: rc ! local variables: + type(InternalState) :: is_local integer :: i, n, maptype character(len=CX) :: msgString character(len=CL) :: cvalue @@ -52,6 +54,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) rc = ESMF_SUCCESS + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Set maptype according to coupling_mode if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then maptype = mapnstod_consf @@ -159,11 +165,15 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addmap(fldListFr(compocn)%flds, 'So_t', compatm, maptype, 'ofrac', 'unset') call addmrg(fldListTo(compatm)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') - ! to atm: surface roughness length from wav - call addfld(fldListFr(compwav)%flds, 'Sw_z0') - call addfld(fldListTo(compatm)%flds, 'Sw_z0') - call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + ! temporary conditional to avoid conflicts of advertised fields + ! when waves are passing through connectors + if (is_local%wrap%comp_present(compwav)) then + ! to atm: surface roughness length from wav + call addfld(fldListFr(compwav)%flds, 'Sw_z0') + call addfld(fldListTo(compatm)%flds, 'Sw_z0') + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + end if !===================================================================== ! FIELDS TO OCEAN (compocn) @@ -297,18 +307,22 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end do deallocate(flds) - ! to ocn: partitioned stokes drift from wav - allocate(flds(6)) - flds = (/'Sw_ustokes1', 'Sw_ustokes2', 'Sw_ustokes3', & - 'Sw_vstokes1', 'Sw_vstokes2', 'Sw_vstokes3'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListTo(compocn)%flds, trim(fldname)) - call addfld(fldListFr(compwav)%flds, trim(fldname)) - call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') - end do - deallocate(flds) + ! temporary conditional to avoid conflicts of advertised fields + ! when waves are passing through connectors + if (is_local%wrap%comp_present(compwav)) then + ! to ocn: partitioned stokes drift from wav + allocate(flds(6)) + flds = (/'Sw_ustokes1', 'Sw_ustokes2', 'Sw_ustokes3', & + 'Sw_vstokes1', 'Sw_vstokes2', 'Sw_vstokes3'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListTo(compocn)%flds, trim(fldname)) + call addfld(fldListFr(compwav)%flds, trim(fldname)) + call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + end if !===================================================================== ! FIELDS TO ICE (compice) @@ -376,43 +390,41 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! FIELDS TO WAV (compwav) !===================================================================== - ! to wav - 10m winds from atm - allocate(flds(3)) - flds = (/'Sa_u10m', 'Sa_v10m', 'Sa_tbot'/) - - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end do - deallocate(flds) - - ! to wav: sea ice fraction - allocate(flds(1)) - flds = (/'Si_ifrac'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addmap(fldListFr(compice)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compice, mrg_fld=trim(fldname), mrg_type='copy') - end do - deallocate(flds) + ! temporary conditional to avoid conflicts of advertised fields + ! when waves are passing through connectors + if (is_local%wrap%comp_present(compwav)) then + ! to wav - 10m winds and bottom temperature from atm + allocate(flds(3)) + flds = (/'Sa_u10m', 'Sa_v10m', 'Sa_tbot'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) - ! to wav: zonal sea water velocity from ocn - ! to wav: meridional sea water velocity from ocn - allocate(flds(3)) - flds = (/'So_u', 'So_v', 'So_t'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - call addfld(fldListFr(compocn)%flds, trim(fldname)) - call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end do - deallocate(flds) + ! to wav: sea ice fraction + call addfld(fldListTo(compwav)%flds, 'Si_ifrac') + call addfld(fldListFr(compice)%flds, 'Si_ifrac') + call addmap(fldListFr(compice)%flds, 'Si_ifrac', compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, 'Si_ifrac', mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') + + ! to wav: zonal sea water velocity from ocn + ! to wav: meridional sea water velocity from ocn + ! to wav: surface temperature from ocn + allocate(flds(3)) + flds = (/'So_u', 'So_v', 'So_t'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + call addfld(fldListFr(compocn)%flds, trim(fldname)) + call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + end if end subroutine esmFldsExchange_nems From 892917836d2272aba902dce5926d083f808f8cbc Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Mon, 24 Jan 2022 11:23:48 -0700 Subject: [PATCH 25/31] fix sw fields * create specific ocean,ice and atm field names for SW fields to specify mapping and exchanges --- mediator/esmFldsExchange_nems_mod.F90 | 57 +++++++++++++-------------- 1 file changed, 27 insertions(+), 30 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index a8e90333d..e21c407b9 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -49,7 +49,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) character(len=CX) :: msgString character(len=CL) :: cvalue character(len=CS) :: fldname - character(len=CS), allocatable :: flds(:) + character(len=CS), allocatable :: flds(:), oflds(:), aflds(:), iflds(:) character(len=*) , parameter :: subname='(esmFldsExchange_nems)' !-------------------------------------- @@ -234,46 +234,43 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end if end if - ! to ocn: from atm (custom merge in med_phases_prep_ocn) - ! - downward direct near-infrared incident solar radiation - ! - downward diffuse near-infrared incident solar radiation - ! - downward dirrect visible incident solar radiation - ! - downward diffuse visible incident solar radiation - allocate(flds(4)) - flds = (/'Faxa_swndr', 'Faxa_swndf', 'Faxa_swvdr', 'Faxa_swvdf'/) - do n = 1,size(flds) - fldname = trim(flds(n)) + ! to ocn: from sw from atm and sw net from ice (custom merge in med_phases_prep_ocn) + ! - downward direct near-infrared ("n" or "i") incident solar radiation + ! - downward diffuse near-infrared ("n" or "i") incident solar radiation + ! - downward direct visible ("v") incident solar radiation + ! - downward diffuse visible ("v") incident solar radiation + allocate(oflds(4)) + allocate(aflds(4)) + allocate(iflds(4)) + oflds = (/'Foxx_swnet_idr', 'Foxx_swnet_idf', 'Foxx_swnet_vdr', 'Foxx_swnet_vdf'/) + aflds = (/'Faxa_swndr' , 'Faxa_swndf' , 'Faxa_swvdr' , 'Faxa_swvdf'/) + iflds = (/'Fioi_swpen_idr', 'Fioi_swpen_idf', 'Fioi_swpen_vdr', 'Fioi_swpen_vdf'/) + do n = 1,size(oflds) if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addfld(fldListTo(compocn)%flds, trim(fldname)) + call addfld(fldListFr(compatm)%flds, trim(aflds(n))) + call addfld(fldListTo(compocn)%flds, trim(oflds(n))) 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, maptype, 'one', 'unset') + if ( fldchk(is_local%wrap%FBexp(compocn) , trim(oflds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), trim(aflds(n)), rc=rc)) then + call addmap(fldListFr(compatm)%flds, trim(aflds(n)), compocn, maptype, 'one', 'unset') end if end if end do - deallocate(flds) - ! to ocn: from ice net shortwave radiation (custom merge in med_phases_prep_ocn) - ! - downward direct near-infrared incident solar radiation - ! - downward diffuse near-infrared incident solar radiation - ! - downward dirrect visible incident solar radiation - ! - downward diffuse visible incident solar radiation - allocate(flds(4)) - flds = (/'vdr', 'vdf', 'idr', 'idf'/) - do n = 1,size(flds) + do n = 1,size(oflds) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, 'Fioi_swpen_'//trim(flds(n))) - call addfld(fldListTo(compocn)%flds, 'Foxx_swnet_'//trim(flds(n))) + call addfld(fldListFr(compice)%flds, trim(iflds(n))) + call addfld(fldListTo(compocn)%flds, trim(oflds(n))) else - if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_swnet_'//trim(flds(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_'//trim(flds(n)), rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Fioi_swpen_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') + if ( fldchk(is_local%wrap%FBexp(compocn) , trim(oflds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), trim(iflds(n)), rc=rc)) then + call addmap(fldListFr(compice)%flds, trim(iflds(n)), compocn, mapfcopy, 'unset', 'unset') end if end if end do - deallocate(flds) + deallocate(oflds) + deallocate(aflds) + deallocate(iflds) ! to ocn: rain and snow via auto merge allocate(flds(2)) From 2f69013e5adaa8c690db3616ba706647821dfcdb Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 26 Jan 2022 13:29:37 -0700 Subject: [PATCH 26/31] refactor data mode in flds exchange nems --- mediator/esmFldsExchange_nems_mod.F90 | 108 ++++++++++++++------------ mediator/med_map_mod.F90 | 3 +- 2 files changed, 59 insertions(+), 52 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index e21c407b9..2832f90e7 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -30,7 +30,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) use med_internalstate_mod , only : compmed, compatm, compocn, compice, comprof, compwav, ncomps use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch use med_internalstate_mod , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf - use med_internalstate_mod , only : mapconsf_aofrac + use med_internalstate_mod , only : mapconsf_aofrac, mapbilnr_nstod use med_internalstate_mod , only : coupling_mode, mapnames use esmFlds , only : med_fldList_type use esmFlds , only : addfld => med_fldList_AddFld @@ -89,49 +89,44 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! Mediator fields !===================================================================== + ! masks from components if (phase == 'advertise') then - ! masks from components call addfld(fldListFr(compice)%flds, 'Si_imask') call addfld(fldListFr(compocn)%flds, 'So_omask') - - if ( trim(coupling_mode) == 'nems_orig_data') then - ! atm and ocn fields required for atm/ocn flux calculation' - allocate(flds(10)) - flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', & - 'Sa_shum', 'Sa_u10m', 'Sa_v10m', 'Sa_t2m ', 'Sa_q2m '/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - end do - deallocate(flds) - - ! unused fields needed by the atm/ocn flux computation - allocate(flds(13)) - flds = (/'So_tref ', 'So_qref ', 'So_u10 ', 'So_ustar ','So_ssq ', & - 'So_re ', 'So_duu10n', 'Faox_lwup', 'Faox_sen ','Faox_lat ', & - 'Faox_evap', 'Faox_taux', 'Faox_tauy'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListMed_aoflux%flds, trim(fldname)) - end do - deallocate(flds) - end if - ! unused fields from ice - but that are needed to be realized by the cice cap - call addfld(fldListFr(compice)%flds, 'Faii_evap') - call addfld(fldListFr(compice)%flds, 'mean_sw_pen_to_ocn') else call addmap(fldListFr(compocn)%flds, 'So_omask', compice, mapfcopy, 'unset', 'unset') + end if - if ( trim(coupling_mode) == 'nems_orig_data') then - allocate(flds(10)) - flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', & - 'Sa_shum', 'Sa_u10m', 'Sa_v10m', 'Sa_t2m ', 'Sa_q2m '/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') - end do - deallocate(flds) - end if + if ( trim(coupling_mode) == 'nems_orig_data') then + ! atm fields required for atm/ocn flux calculation + allocate(flds(10)) + flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', & + 'Sa_shum', 'Sa_u10m', 'Sa_v10m', 'Sa_t2m ', 'Sa_q2m '/) + do n = 1,size(flds) + fldname = trim(flds(n)) + if (phase == 'advertise') then + call addfld(fldListFr(compatm)%flds, trim(fldname)) + else + call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') + end if + end do + deallocate(flds) + + ! fields returned by the atm/ocn flux computation which are otherwise unadvertised + allocate(flds(8)) + flds = (/'So_tref ', 'So_qref ', 'So_ustar ', 'So_re ','So_ssq ', & + 'So_u10 ', 'So_duu10n', 'Faox_lat '/) + do n = 1,size(flds) + fldname = trim(flds(n)) + if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds, trim(fldname)) + end if + end do + deallocate(flds) + + ! unused fields from ice - but that are needed to be realized by the cice cap + !call addfld(fldListFr(compice)%flds, 'Faii_evap') + !call addfld(fldListFr(compice)%flds, 'mean_sw_pen_to_ocn') end if !===================================================================== @@ -230,6 +225,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) if ( fldchk(is_local%wrap%FBexp(compocn) , 'Sa_pslv', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_pslv', rc=rc)) then call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, maptype, 'one', 'unset') + !call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, mapbilnr_nstod, 'one', 'unset') call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') end if end if @@ -293,23 +289,29 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_frac') then ! to ocn: merge surface stress (custom merge calculation in med_phases_prep_ocn) - allocate(flds(2)) - flds = (/'taux', 'tauy'/) - do n = 1,size(flds) + allocate(oflds(2)) + allocate(aflds(2)) + allocate(iflds(2)) + oflds = (/'Foxx_taux', 'Foxx_tauy'/) + aflds = (/'Faxa_taux', 'Faxa_tauy'/) + iflds = (/'Fioi_taux', 'Fioi_tauy'/) + do n = 1,size(oflds) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n))) - call addfld(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n))) - call addfld(fldListTo(compocn)%flds, 'Foxx_'//trim(flds(n))) + call addfld(fldListFr(compice)%flds, trim(iflds(n))) + call addfld(fldListFr(compatm)%flds, trim(aflds(n))) + call addfld(fldListTo(compocn)%flds, trim(oflds(n))) else - if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_'//trim(flds(n)), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_'//trim(flds(n)), rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Fioi_'//trim(flds(n)), compocn, mapfcopy, 'unset', 'unset') - call addmap(fldListFr(compatm)%flds, 'Faxa_'//trim(flds(n)), compocn, mapconsf_aofrac, 'aofrac', 'unset') + if ( fldchk(is_local%wrap%FBexp(compocn) , trim(oflds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), trim(iflds(n)), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), trim(aflds(n)), rc=rc)) then + call addmap(fldListFr(compice)%flds, trim(iflds(n)), compocn, mapfcopy, 'unset', 'unset') + call addmap(fldListFr(compatm)%flds, trim(aflds(n)), compocn, mapconsf_aofrac, 'aofrac', 'unset') end if end if end do - deallocate(flds) + deallocate(oflds) + deallocate(aflds) + deallocate(iflds) ! to ocn: net long wave via auto merge if (phase == 'advertise') then @@ -352,6 +354,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) flds = (/'taux', 'tauy'/) do n = 1,size(flds) if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'Faox_'//trim(flds(n))) call addfld(fldListFr(compice)%flds , 'Fioi_'//trim(flds(n))) call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(flds(n))) else @@ -370,6 +373,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: long wave net via auto merge if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'Faox_lwup') call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') call addfld(fldListTo(compocn)%flds, 'Foxx_lwnet') else @@ -386,6 +390,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: sensible heat flux from mediator via auto merge if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'Faox_sen') call addfld(fldListTo(compocn)%flds, 'Faox_sen') else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_sen', rc=rc) .and. & @@ -397,6 +402,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: evaporation water flux from mediator via auto merge if (phase == 'advertise') then + call addfld(fldListMed_aoflux%flds , 'Faox_evap') call addfld(fldListTo(compocn)%flds, 'Faox_evap') else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_evap', rc=rc) .and. & @@ -490,7 +496,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ice: meridional wind at the lowest model level from atm ! to ice: specific humidity at the lowest model level from atm allocate(flds(6)) - flds = (/'Sa_z ', 'Sa_pbot', 'Sa_tbot', 'Sa_u ', 'Sa_v ', & + flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', & 'Sa_shum'/) do n = 1,size(flds) fldname = trim(flds(n)) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 5921d927e..6b1690aec 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -415,7 +415,8 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, endif else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice .or. n1 == compwav)) then srcMaskValue = 0 - dstMaskValue = 1 + !dstMaskValue = 1 + dstMaskValue = ispval_mask else ! TODO: what should the condition be here? dstMaskValue = ispval_mask From 3c8a031bc20073d342401d2a90c59ad14aa620f6 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Wed, 26 Jan 2022 18:50:06 -0700 Subject: [PATCH 27/31] tested against baseline using updcmeps_wavcpl * field iceImp_mean_sw_pen_to_ocn is no longer in restart files, otherwise all files are b4b w/ baseline --- mediator/med_map_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 6b1690aec..19e1a69de 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -415,8 +415,8 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, endif else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice .or. n1 == compwav)) then srcMaskValue = 0 - !dstMaskValue = 1 - dstMaskValue = ispval_mask + dstMaskValue = 1 + !dstMaskValue = ispval_mask else ! TODO: what should the condition be here? dstMaskValue = ispval_mask From 959c64ea27f95429381caef8d0e5d1375e18ee0e Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 3 Feb 2022 08:39:56 -0500 Subject: [PATCH 28/31] Update CMEPS for wave slow loop coupling and provide hooks for S2SW coupling through CMEPS (#61) * Add Wave slow loop coupling and Field Exchanges for waves in nems * Updates CMEPS for dynamic allocation in med_internalstate --- .github/pull_request_template.md | 23 +- cesm/nuopc_cap_share/shr_fire_emis_mod.F90 | 19 +- cime_config/buildexe | 3 +- cime_config/buildnml | 26 +- cime_config/config_component.xml | 16 +- cime_config/config_component_ufs.xml | 567 ------------------- cime_config/namelist_definition_drv.xml | 50 +- cime_config/runseq/runseq_general.py | 3 +- mediator/esmFlds.F90 | 165 ++---- mediator/esmFldsExchange_cesm_mod.F90 | 99 ++-- mediator/esmFldsExchange_hafs_mod.F90 | 40 +- mediator/esmFldsExchange_nems_mod.F90 | 85 ++- mediator/med.F90 | 510 ++++------------- mediator/med_diag_mod.F90 | 16 +- mediator/med_fraction_mod.F90 | 51 +- mediator/med_internalstate_mod.F90 | 541 ++++++++++++++++-- mediator/med_map_mod.F90 | 119 ++-- mediator/med_merge_mod.F90 | 3 +- mediator/med_phases_aofluxes_mod.F90 | 616 ++++++++++++++------- mediator/med_phases_history_mod.F90 | 27 +- mediator/med_phases_ocnalb_mod.F90 | 2 +- mediator/med_phases_post_atm_mod.F90 | 18 +- mediator/med_phases_post_glc_mod.F90 | 34 +- mediator/med_phases_post_ice_mod.F90 | 14 +- mediator/med_phases_post_lnd_mod.F90 | 7 +- mediator/med_phases_post_ocn_mod.F90 | 30 +- mediator/med_phases_post_rof_mod.F90 | 2 +- mediator/med_phases_post_wav_mod.F90 | 2 +- mediator/med_phases_prep_atm_mod.F90 | 21 +- mediator/med_phases_prep_glc_mod.F90 | 41 +- mediator/med_phases_prep_ice_mod.F90 | 4 +- mediator/med_phases_prep_lnd_mod.F90 | 2 +- mediator/med_phases_prep_ocn_mod.F90 | 4 +- mediator/med_phases_prep_rof_mod.F90 | 2 +- mediator/med_phases_prep_wav_mod.F90 | 197 ++++--- mediator/med_phases_restart_mod.F90 | 19 +- 36 files changed, 1661 insertions(+), 1717 deletions(-) delete mode 100644 cime_config/config_component_ufs.xml diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md index 36cc6403f..438a2f450 100644 --- a/.github/pull_request_template.md +++ b/.github/pull_request_template.md @@ -6,16 +6,13 @@ Contributors other than yourself, if any: CMEPS Issues Fixed (include github issue #): -Are changes expected to change answers? - - [ ] bit for bit - - [ ] different at roundoff level - - [ ] more substantial +Are changes expected to change answers? (specify if bfb, different at roundoff, more substantial) Any User Interface Changes (namelist or namelist defaults changes)? - - [ ] Yes - - [ ] No -Testing performed if application target is CESM:(either UFS-S2S or CESM testing is required): +### Testing performed + +Testing performed if application target is CESM: - [ ] (recommended) CIME_DRIVER=nuopc scripts_regression_tests.py - machines: - details (e.g. failed tests): @@ -39,16 +36,14 @@ Testing performed if application target is UFS-HAFS: - description: - details (e.g. failed tests): -Hashes used for testing: +### Hashes used for testing: + - [ ] CESM: - repository to check out: https://github.com/ESCOMP/CESM.git - - branch: - - hash: + - branch/hash: - [ ] UFS-coupled, then umbrella repostiory to check out and associated hash: - repository to check out: - - branch: - - hash: + - branch/hash: - [ ] UFS-HAFS, then umbrella repostiory to check out and associated hash: - repository to check out: - - branch: - - hash: + - branch/hash: diff --git a/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 b/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 index 30931271e..47e9cf117 100644 --- a/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 +++ b/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 @@ -42,7 +42,6 @@ module shr_fire_emis_mod character(len=name_len) :: name ! emissions component name (in fire emissions input table) integer :: index real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) - real(r8) :: coeff ! emissions component coeffecient real(r8) :: molec_weight ! molecular weight of the fire emissions compound (g/mole) type(shr_fire_emis_comp_t), pointer :: next_emiscomp ! points to next member in the linked list endtype shr_fire_emis_comp_t @@ -55,6 +54,7 @@ module shr_fire_emis_mod type shr_fire_emis_mechcomp_t character(len=16) :: name ! compound name type(shr_fire_emis_comp_ptr), pointer :: emis_comps(:) ! an array of pointers to fire emis components + real(r8), pointer :: coeffs(:) ! coeffecients to emissions components integer :: n_emis_comps ! number of fire emis compounds that make up the emissions for this mechanis compound end type shr_fire_emis_mechcomp_t @@ -96,7 +96,7 @@ subroutine shr_fire_emis_readnl( NLFileName, emis_nflds ) ! corresponding chemical tracers. ! !------------------------------------------------------------------------- - + ! input/output variables character(len=*), intent(in) :: NLFileName ! name of namelist file integer , intent(out) :: emis_nflds @@ -125,12 +125,12 @@ subroutine shr_fire_emis_readnl( NLFileName, emis_nflds ) ! If other processes have already initialized megan - then the info will just be re-initialized call ESMF_VMGetCurrent(vm, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective ! call on all the pes of mpicom if (localPet==0) then inquire( file=trim(NLFileName), exist=exists) @@ -205,9 +205,12 @@ subroutine shr_fire_emis_init( specifier ) endif shr_fire_emis_mechcomps(i)%n_emis_comps = item%n_terms allocate(shr_fire_emis_mechcomps(i)%emis_comps(item%n_terms)) + allocate(shr_fire_emis_mechcomps(i)%coeffs(item%n_terms)) + + shr_fire_emis_mechcomps(i)%coeffs(:) = item%coeffs(:) do j = 1,item%n_terms - shr_fire_emis_mechcomps(i)%emis_comps(j)%ptr => add_emis_comp( item%vars(j), item%coeffs(j) ) + shr_fire_emis_mechcomps(i)%emis_comps(j)%ptr => add_emis_comp( item%vars(j) ) enddo shr_fire_emis_mechcomps_n = shr_fire_emis_mechcomps_n+1 @@ -224,10 +227,9 @@ end subroutine shr_fire_emis_init !------------------------------------------------------------------------- - function add_emis_comp( name, coeff ) result(emis_comp) + function add_emis_comp( name ) result(emis_comp) character(len=*), intent(in) :: name - real(r8), intent(in) :: coeff type(shr_fire_emis_comp_t), pointer :: emis_comp emis_comp => get_emis_comp_by_name(shr_fire_emis_linkedlist, name) @@ -245,7 +247,6 @@ function add_emis_comp( name, coeff ) result(emis_comp) emis_comp%index = shr_fire_emis_comps_n+1 emis_comp%name = trim(name) - emis_comp%coeff = coeff nullify(emis_comp%next_emiscomp) call add_emis_comp_to_list(emis_comp) diff --git a/cime_config/buildexe b/cime_config/buildexe index f02d0a399..f2a0c905c 100755 --- a/cime_config/buildexe +++ b/cime_config/buildexe @@ -37,7 +37,6 @@ def _main_func(): cime_model = case.get_value("MODEL") num_esp = case.get_value("NUM_COMP_INST_ESP") ocn_model = case.get_value("COMP_OCN") - atm_model = case.get_value("COMP_ATM") gmake_args = get_standard_makefile_args(case) esmf_aware_threading = case.get_value("ESMF_AWARE_THREADING") @@ -63,7 +62,7 @@ def _main_func(): else: skip_mediator = False - if ocn_model == 'mom' or atm_model == "ufsatm": + if ocn_model == 'mom': gmake_args += "USE_FMS=TRUE" comp_classes = case.get_values("COMP_CLASSES") diff --git a/cime_config/buildnml b/cime_config/buildnml index 11c20e276..2bc7c82b9 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -223,21 +223,21 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): # End if pause is active #-------------------------------- - # (1) Specify input data list file + # Specify input data list file #-------------------------------- data_list_path = os.path.join(case.get_case_root(), "Buildconf", "cpl.input_data_list") if os.path.exists(data_list_path): os.remove(data_list_path) #-------------------------------- - # (2) Write namelist file drv_in and initial input dataset list. + # Write namelist file drv_in and initial input dataset list. #-------------------------------- namelist_file = os.path.join(confdir, "drv_in") drv_namelist_groups = ["papi_inparm", "pio_default_inparm", "prof_inparm", "debug_inparm"] nmlgen.write_output_file(namelist_file, data_list_path=data_list_path, groups=drv_namelist_groups) #-------------------------------- - # (3) Write nuopc.runconfig file and add to input dataset list. + # Write nuopc.runconfig file and add to input dataset list. #-------------------------------- # Determine valid components @@ -291,7 +291,7 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): nmlgen.write_nuopc_config_file(nuopc_config_file, data_list_path=data_list_path) #-------------------------------- - # (3.1) Update nuopc.runconfig file if component needs it + # Update nuopc.runconfig file if component needs it #-------------------------------- # Read nuopc.runconfig @@ -330,12 +330,12 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): f.write(line) #-------------------------------- - # (4) Write nuopc.runseq + # Write nuopc.runseq #-------------------------------- _create_runseq(case, coupling_times, valid_comps) #-------------------------------- - # (5) Write drv_flds_in + # Write drv_flds_in #-------------------------------- # In thte following, all values come simply from the infiles - no default values need to be added # FIXME - do want to add the possibility that will use a user definition file for drv_flds_in @@ -567,7 +567,6 @@ def buildnml(case, caseroot, component): files.set_value("COMP_ROOT_DIR_CPL", comp_root_dir_cpl) definition_file = [files.get_value("NAMELIST_DEFINITION_FILE", {"component": "cpl"})] - fd_dir = os.path.dirname(definition_file[0]) user_definition = os.path.join(user_xml_dir, "namelist_definition_drv.xml") if os.path.isfile(user_definition): definition_file = [user_definition] @@ -606,15 +605,12 @@ def buildnml(case, caseroot, component): for filename in glob.glob(os.path.join(confdir, "*modelio*")): shutil.copy(filename, rundir) - # copy fd_cesm.yaml to rundir - 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 'nems' in coupling_mode or coupling_mode == 'hafs': - filename = os.path.join(fd_dir,"fd_nems.yaml") + # copy fd_cesm.yaml to rundir - look in user_xml_dir first + user_yaml_file = os.path.join(user_xml_dir, "fd_cesm.yaml") + if os.path.isfile(user_yaml_file): + filename = user_yaml_file else: - expect(False, "coupling mode currently only supports cesm") + filename = os.path.join(os.path.dirname(__file__), os.pardir, "mediator", "fd_cesm.yaml") shutil.copy(filename, os.path.join(rundir, "fd.yaml")) ############################################################################### diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 49bc7d0d8..aeb7770fc 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -28,7 +28,7 @@ char - cesm,nems_orig,nems_orig_data,nems_frac,hafs + cesm cesm run_coupling env_run.xml @@ -1685,6 +1685,20 @@ $CIMEROOT/machines/config_machines.xml + + char + UNSET + run_din + env_run.xml + + On some systems the filesystem of DIN_LOC_ROOT is not available on compute nodes and + data must be staged to a temporary location. If this variable is defined it will + be used as the root directory of an inputdata staging area. + Default values for the target machine are in the + $CIMEROOT/machines/config_machines.xml + + + char UNSET diff --git a/cime_config/config_component_ufs.xml b/cime_config/config_component_ufs.xml deleted file mode 100644 index bb32df7b5..000000000 --- a/cime_config/config_component_ufs.xml +++ /dev/null @@ -1,567 +0,0 @@ - - - - - - - - - 1972-2004 - 2002-2003 - Historic transient - Twentieth century transient - - CMIP5 rcp 2.6 forcing - CMIP5 rcp 4.5 forcing - CMIP5 rcp 6.0 forcing - CMIP5 rcp 8.5 forcing - Biogeochemistry intercomponent - with diagnostic CO2 - with prognostic CO2 - - - - char - https://doi.org/10.5065/D67H1H0V - run_metadata - env_case.xml - run DOI - - - - logical - TRUE,FALSE - FALSE - run_flags - env_run.xml - logical to save timing files in rundir - - - - integer - 0 - run_flags - env_run.xml - Determines number of times profiler is called over the model run period. - This sets values for tprof_option and tprof_n that determine the timing output file frequency - - - - - integer - 2 - run_flags - env_run.xml - - integer indicating maximum detail level to profile. This xml - variable is used to set the namelist variable - timing_detail_limit. This namelist variable is used by perf_mod - (in $CIMEROOT/src/share/timing/perf_mod.F90) to turn timers off - and on depending on calls to the routine t_adj_detailf. If in the - code a statement appears like t_adj_detailf(+1), then the current - timer detail level is incremented by 1 and compared to the - time_detail_limit obtained from the namelist. If the limit is - exceeded then the timer is turned off. - - - - - integer - 4 - run_flags - env_run.xml - Maximum code stack depth of enabled timers. - - - - logical - TRUE,FALSE - FALSE - run_data_archive - env_run.xml - Logical to archive all interim restart files, not just those at eor - If TRUE, perform short term archiving on all interim restart files, - not just those at the end of the run. By default, this value is TRUE. - The restart files are saved under the specific component directory - ($DOUT_S_ROOT/$CASE/$COMPONENT/rest rather than the top-level $DOUT_S_ROOT/$CASE/rest directory). - Interim restart files are created using the REST_N and REST_OPTION variables. - This is for expert users ONLY and requires expert knowledge. - We will not document this further in this guide. - - - - logical - TRUE,FALSE - FALSE - run_flags - env_run.xml - turns on coupler bit-for-bit reproducibility with varying pe counts - - - - char - none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end - never - - ndays - - run_begin_stop_restart - env_run.xml - - sets frequency of full model barrier (same options as STOP_OPTION) for synchronization with BARRIER_N and BARRIER_DATE - - - - - char - none,CO2A,CO2B,CO2C - none - - CO2A - none - CO2A - CO2A - CO2A - CO2C - CO2C - - run_coupling - env_run.xml - Activates additional CO2-related fields to be exchanged between components. Possible values are: - - CO2A: sets the driver namelist variable flds_co2a = .true.; this adds - prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from - the atmosphere to the land and ocean. - - CO2B: sets the driver namelist variable flds_co2b = .true.; this adds - prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from - the atmosphere just to the land, and the surface upward flux of CO2 to be - sent from the land back to the atmosphere - - CO2C: sets the driver namelist variable flds_co2c = .true.; this adds - prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from - the atmosphere to the land and ocean, and the surface upward flux of CO2 - to be sent from the land and the open ocean back to the atmosphere. - - The namelist variables flds_co2a, flds_co2b and flds_co2c are in the - namelist group cpl_flds_inparm. - - - - - char - - - - - - run_component_cpl - env_case.xml - User mods to apply to specific compset matches. - - - - char - hour,day,year,decade - run_coupling - env_run.xml - day - - year - hour - - Base period associated with NCPL coupling frequency. - This xml variable is only used to set the driver namelist variables, - atm_cpl_dt, lnd_cpl_dt, ocn_cpl_dt, ice_cpl_dt, glc_cpl_dt, rof_cpl_dt, wav_cpl_dt, and esp_dt. - - - - integer - 48 - - 144 - 288 - 288 - 72 - 48 - - - 24 - 24 - 24 - 24 - 24 - 24 - 48 - 48 - 1 - 96 - 96 - 96 - 96 - 192 - 192 - 192 - 192 - 384 - 384 - 384 - 144 - 72 - 144 - 288 - 48 - 48 - 24 - 24 - 1 - - - - run_coupling - env_run.xml - Number of atm coupling intervals per NCPL_BASE_PERIOD. - This is used to set the driver namelist atm_cpl_dt, equal to basedt/ATM_NCPL, - where basedt is equal to NCPL_BASE_PERIOD in seconds. - - - - integer - $ATM_NCPL - - 1 - - run_coupling - env_run.xml - Number of land coupling intervals per NCPL_BASE_PERIOD. - This is used to set the driver namelist atm_cpl_dt, equal to basedt/LND_NCPL, - where basedt is equal to NCPL_BASE_PERIOD in seconds. - - - - integer - $ATM_NCPL - - 1 - - run_coupling - env_run.xml - Number of ice coupling intervals per NCPL_BASE_PERIOD. - This is used to set the driver namelist ice_cpl_dt, equal to basedt/ICE_NCPL - where basedt is equal to NCPL_BASE_PERIOD in seconds. - - - - integer - $ATM_NCPL - - 24 - 24 - 4 - 24 - 24 - - - - - 1 - - run_coupling - env_run.xml - Number of ocn coupling intervals per NCPL_BASE_PERIOD. - Thisn is used to set the driver namelist ocn_cpl_dt, equal to basedt/OCN_NCPL - where basedt is equal to NCPL_BASE_PERIOD in seconds. - - - - integer - 1 - - 1 - $ATM_NCPL - $ATM_NCPL - 1 - - run_coupling - env_run.xml - Number of glc coupling intervals per NCPL_BASE_PERIOD. - - - - char - glc_coupling_period,yearly - yearly - run_coupling - env_run.xml - Period at which coupler averages fields sent to GLC. - This supports doing the averaging to GLC less frequently than GLC is called - (i.e., separating the averaging frequency from the calling frequency). - This is useful because there are benefits to only averaging the GLC inputs - as frequently as they are really needed (yearly for CISM), but GLC needs to - still be called more frequently than that in order to support mid-year restarts. - - Setting GLC_AVG_PERIOD to 'glc_coupling_period' means that the averaging is - done exactly when the GLC is called (governed by GLC_NCPL). - - IMPORTANT: In order to restart mid-year when running with CISM, you MUST specify GLC_AVG_PERIOD = 'yearly'. - If using GLC_AVG_PERIOD = 'glc_coupling_period' with CISM, you can only restart on year boundaries. - - - - - integer - 8 - - $ATM_NCPL - $ATM_NCPL - $ATM_NCPL - $ATM_NCPL - 8 - 8 - $ATM_NCPL - 1 - $ATM_NCPL - - run_coupling - env_run.xml - Number of rof coupling intervals per NCPL_BASE_PERIOD. - This is used to set the driver namelist rof_cpl_dt, equal to basedt/ROF_NCPL - where basedt is equal to NCPL_BASE_PERIOD in seconds. - - - - integer - $ATM_NCPL - run_coupling - env_run.xml - Number of wav coupling intervals per NCPL_BASE_PERIOD. - This is used to set the driver namelist wav_cpl_dt, equal to basedt/WAV_NCPL - where basedt is equal to NCPL_BASE_PERIOD in seconds. - - - - - - logical - TRUE,FALSE - FALSE - - TRUE - TRUE - TRUE - FALSE - - run_component_cpl - env_run.xml - - Only used for compsets with DATM and POP (currently C, G and J): - If true, compute albedos to work with daily avg SW down - If false (default), albedos are computed with the assumption that downward - solar radiation from the atm component has a diurnal cycle and zenith-angle - dependence. This is normally the case when using an active atm component - If true, albedos are computed with the assumption that downward - solar radiation from the atm component is a daily average quantity and - does not have a zenith-angle dependence. This is often the case when - using a data atm component. Only used for compsets with DATM and POP (currently C, G and J). - NOTE: This should really depend on the datm forcing and not the compset per se. - So, for example, whether it is set in a J compset should depend on - what datm forcing is used. - - - - - char - off,ocn - off - - ocn - off - - run_component_cpl - env_run.xml - - Only used for compsets with DATM and POP (currently C, G and J): - If ocn, ocn provides EP balance factor for precipitation. - Provides EP balance factor for precip for POP. A factor computed by - POP is applied to precipitation so that precipitation balances - evaporation and ocn global salinity does not drift. This is intended - for use when coupling POP to a DATM. Only used for C, G and J compsets. - Default is off - - - - - char - TIGHT,RASM - TIGHT - - RASM - RASM - RASM - RASM - RASM - RASM - RASM - RASM - - run_coupling - env_run.xml - - RASM runs prep ocean before the ocean coupling reducing - most of the lags and field inconsistency but still allowing the ocean to run - concurrently with the ice and atmosphere. - TIGHT are consistent with the old variables ocean_tight_coupling = true in the driver. - - - - - char - none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end - never - run_drv_history - env_run.xml - Sets driver snapshot history file frequency (like REST_OPTION) - - - integer - - -999 - run_drv_history - env_run.xml - Sets driver snapshot history file frequency (like REST_N) - - - - integer - - -999 - run_drv_history - env_run.xml - yyyymmdd format, sets coupler snapshot history date (like REST_DATE) - - - - char - none,never,nsteps,nstep,nseconds,nsecond,nminutes,nminute,nhours,nhour,ndays,nday,nmonths,nmonth,nyears,nyear,date,ifdays0,end - never - - nmonths - - run_drv_history - env_run.xml - Sets driver average history file frequency (like REST_OPTION) - - - char - - -999 - - 1 - - run_drv_history - env_run.xml - Sets driver average history file frequency (like REST_N) - - - integer - - -999 - run_drv_history - env_run.xml - yyyymmdd format, sets driver average history date (like REST_DATE) - - - - logical - TRUE,FALSE - FALSE - - TRUE - TRUE - TRUE - - run_budgets - env_run.xml - logical that turns on diagnostic budgets for driver - - - - real - - 284.7 - - 367.0 - 284.7 - - run_co2 - env_run.xml - - Mechanism for setting the CO2 value in ppmv for - CLM if CLM_CO2_TYPE is constant or for - POP if OCN_CO2_TYPE is constant. - - - - - logical - TRUE,FALSE - FALSE - - TRUE - TRUE - - run_flags - env_run.xml - Turn on the passing of water isotope fields through the coupler - - - - integer - 1,3,5,10,36 - 10 - run_glc - env_run.xml - Number of glacier elevation classes used in CLM. - Used by both CLM and the coupler (even if CISM is not running, and only SGLC is used). - - - - logical - TRUE,FALSE - FALSE - - TRUE - - TRUE - - run_glc - env_run.xml - Whether the glacier component feeds back to the rest of the system - This affects: - (1) Whether CLM updates its areas based on glacier areas sent from GLC - (2) Whether GLC sends fluxes (e.g., calving fluxes) to the coupler - Note that this is set to TRUE by default for TG compsets - even though there are - no feedbacks for TG compsets, this enables extra coupler diagnostics for these - compsets. - - - - char - minus1p8,linear_salt,mushy - mushy - run_physics - env_run.xml - Freezing point calculation for salt water. - - - - diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index a38cfed1c..02c8f44ce 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -40,11 +40,10 @@ char expdef DRIVER_attributes - cesm,ufs + cesm cime model - cesm - ufs + cesm @@ -346,6 +345,7 @@ char mapping + abs ALLCOMP_attributes MESH for model mask (used to create masks and fractions at run time if different than model mesh) @@ -2270,11 +2270,9 @@ flds ALLCOMP_attributes - Previously, new fields that were needed to be passed between components - for certain compsets were specified by cpp-variables. This has been - modified to now be use cases. This use cases are specified in the - namelist cpl_flds_inparm and are currently triggered by the xml variable CCSM_BGC. - If CCSM_BGC is set to 'CO2A', then flds_co2a will be set to .true. + Pass CO2 from ATM to surface components + Set this by setting the xml variable BGC_MODE. + If BGC_MODE is set to 'CO2A', then flds_co2a will be set to .true. .false. @@ -2287,11 +2285,9 @@ flds ALLCOMP_attributes - Previously, new fields that were needed to be passed between components - for certain compsets were specified by cpp-variables. This has been - modified to now be use cases. This use cases are specified in the - namelist cpl_flds_inparm and are currently triggered by the xml variable CCSM_BGC. - If CCSM_BGC is set to 'CO2B', then flds_co2b will be set to .true. + Pass CO2 from ATM to LND and back from LND to ATM + Set this by setting the xml variable BGC_MODE. + If BGC_MODE is set to 'CO2B', then flds_co2b will be set to .true. .false. @@ -2304,11 +2300,9 @@ flds ALLCOMP_attributes - Previously, new fields that were needed to be passed between components - for certain compsets were specified by cpp-variables. This has been - modified to now be use cases. This use cases are specified in the - namelist cpl_flds_inparm and are currently triggered by the xml variable CCSM_BGC. - If CCSM_BGC is set to 'CO2C', then flds_co2c will be set to .true. + Pass CO2 from ATM to surface (OCN/LND) and back from them to ATM + Set this by setting the xml variable BGC_MODE. + If BGC_MODE is set to 'CO2C', then flds_co2c will be set to .true. .false. @@ -2343,6 +2337,19 @@ + + logical + flds + ALLCOMP_attributes + + Pass channel depths from river component to land component. This is needed for the hillslope + model in CTSM. + + + .false. + + + integer flds @@ -3813,6 +3820,7 @@ char mapping + abs ATM_attributes MESH description of atm grid @@ -3872,6 +3880,7 @@ char mapping + abs ICE_attributes MESH description of ice grid @@ -3898,6 +3907,7 @@ char mapping + abs ALLCOMP_attributes MESH description of glc grid @@ -3924,6 +3934,7 @@ char mapping + abs LND_attributes MESH description of lnd grid @@ -3950,6 +3961,7 @@ char mapping + abs OCN_attributes MESH description of ocn grid @@ -3976,6 +3988,7 @@ char mapping + abs ROF_attributes MESH description of rof grid @@ -4002,6 +4015,7 @@ char mapping + abs WAV_attributes MESH description of wav grid diff --git a/cime_config/runseq/runseq_general.py b/cime_config/runseq/runseq_general.py index 7bfa3aaa6..2b7f0cc0a 100644 --- a/cime_config/runseq/runseq_general.py +++ b/cime_config/runseq/runseq_general.py @@ -110,7 +110,8 @@ def gen_runseq(case, coupling_times): 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_prep_wav" , med_to_wav) + runseq.add_action("MED med_phases_prep_wav_accum" , med_to_wav) + runseq.add_action("MED med_phases_prep_wav_avg" , med_to_wav) runseq.add_action("MED -> WAV :remapMethod=redist" , med_to_wav) runseq.add_action("MED med_phases_prep_rof" , med_to_rof and not rof_outer_loop) diff --git a/mediator/esmFlds.F90 b/mediator/esmFlds.F90 index c2bc91c5b..36dda2519 100644 --- a/mediator/esmFlds.F90 +++ b/mediator/esmFlds.F90 @@ -1,111 +1,17 @@ module esmflds 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 : ncomps, compname, compocn, compatm + use med_internalstate_mod, only : mapfcopy, mapnames, mapunset implicit none private - !----------------------------------------------- - ! Set components - !----------------------------------------------- - - integer, public, parameter :: compmed = 1 - integer, public, parameter :: compatm = 2 - integer, public, parameter :: complnd = 3 - integer, public, parameter :: compocn = 4 - integer, public, parameter :: compice = 5 - integer, public, parameter :: comprof = 6 - integer, public, parameter :: compwav = 7 - integer, public, parameter :: compglc1 = 8 - integer, public, parameter :: compglc2 = 9 - integer, public, parameter :: ncomps = 9 - - character(len=*), public, parameter :: compname(ncomps) = & - (/'med ',& - 'atm ',& - 'lnd ',& - 'ocn ',& - 'ice ',& - 'rof ',& - 'wav ',& - 'glc1',& - 'glc2'/) - - integer, public, parameter :: max_icesheets = 2 - integer, public :: compglc(max_icesheets) = (/compglc1,compglc2/) - integer, public :: num_icesheets ! obtained from attribute - logical, public :: ocn2glc_coupling ! obtained from attribute - logical, public :: lnd2glc_coupling ! obtained in med.F90 - logical, public :: accum_lnd2glc ! obtained in med.F90 (this can be true even if lnd2glc_coupling is false) - - logical, public :: dststatus_print = .false. - - !----------------------------------------------- - ! 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 :: mappatch_uv3d = 9 ! rotate u,v to 3d cartesian space, map from src->dest, then rotate back - integer , public, parameter :: mapbilnr_uv3d = 10 ! rotate u,v to 3d cartesian space, map from src->dest, then rotate back - integer , public, parameter :: map_rof2ocn_ice = 11 ! custom smoothing map to map ice from rof->ocn (cesm only) - integer , public, parameter :: map_rof2ocn_liq = 12 ! custom smoothing map to map liq from rof->ocn (cesm only) - integer , public, parameter :: map_glc2ocn_liq = 13 ! custom smoothing map to map liq from glc->ocn (cesm only) - integer , public, parameter :: map_glc2ocn_ice = 14 ! custom smoothing map to map ice from glc->ocn (cesm only) - integer , public, parameter :: mapfillv_bilnr = 15 ! fill value followed by bilinear - integer , public, parameter :: mapbilnr_nstod = 16 ! bilinear with nstod extrapolation - integer , public, parameter :: mapconsf_aofrac = 17 ! conservative with aofrac normalization (ufs only) - integer , public, parameter :: nmappers = 17 - - character(len=*) , public, parameter :: mapnames(nmappers) = & - (/'bilnr ',& - 'consf ',& - 'consd ',& - 'patch ',& - 'fcopy ',& - 'nstod ',& - 'nstod_consd ',& - 'nstod_consf ',& - 'patch_uv3d ',& - 'bilnr_uv3d ',& - 'rof2ocn_ice ',& - 'rof2ocn_liq ',& - 'glc2ocn_ice ',& - 'glc2ocn_liq ',& - 'fillv_bilnr ',& - 'bilnr_nstod ',& - 'consf_aofrac'/) - - !----------------------------------------------- - ! Set coupling mode - !----------------------------------------------- - - character(len=CS), public :: coupling_mode ! valid values are [cesm,nems_orig,nems_frac,nems_orig_data,hafs] - - !----------------------------------------------- - ! Name of model components - !----------------------------------------------- - - character(len=CS), public :: med_name = '' - character(len=CS), public :: atm_name = '' - character(len=CS), public :: lnd_name = '' - character(len=CS), public :: ocn_name = '' - character(len=CS), public :: ice_name = '' - character(len=CS), public :: rof_name = '' - character(len=CS), public :: wav_name = '' - character(len=CS), public :: glc_name = '' - !----------------------------------------------- ! PUblic methods !----------------------------------------------- + public :: med_fldList_init1 public :: med_fldList_AddFld public :: med_fldList_AddMap public :: med_fldList_AddMrg @@ -125,14 +31,14 @@ module esmflds character(CS) :: shortname ! Mapping fldsFr data - for mediator import fields - integer :: mapindex(ncomps) = mapunset - character(CS) :: mapnorm(ncomps) = 'unset' - character(CX) :: mapfile(ncomps) = 'unset' + integer , allocatable :: mapindex(:) + character(CS), allocatable :: mapnorm(:) + character(CX), allocatable :: mapfile(:) ! Merging fldsTo data - for mediator export fields - character(CS) :: merge_fields(ncomps) = 'unset' - character(CS) :: merge_types(ncomps) = 'unset' - character(CS) :: merge_fracnames(ncomps) = 'unset' + character(CS), allocatable :: merge_fields(:) + character(CS), allocatable :: merge_types(:) + character(CS), allocatable :: merge_fracnames(:) end type med_fldList_entry_type ! The above would be the field name to merge from @@ -154,8 +60,8 @@ module esmflds !----------------------------------------------- ! Instantiate derived types !----------------------------------------------- - type (med_fldList_type), public :: fldListTo(ncomps) ! advertise fields to components - type (med_fldList_type), public :: fldListFr(ncomps) ! advertise fields from components + type (med_fldList_type), allocatable, public :: fldListTo(:) ! advertise fields to components + type (med_fldList_type), allocatable, public :: fldListFr(:) ! advertise fields from components type (med_fldList_type), public :: fldListMed_aoflux type (med_fldList_type), public :: fldListMed_ocnalb @@ -169,8 +75,13 @@ module esmflds contains !================================================================================ - subroutine med_fldList_AddFld(flds, stdname, shortname) + subroutine med_fldlist_init1() + allocate(fldlistTo(ncomps)) + allocate(fldlistFr(ncomps)) + end subroutine med_fldlist_init1 + !================================================================================ + subroutine med_fldList_AddFld(flds, stdname, shortname) ! ---------------------------------------------- ! Add an entry to to the flds array ! Use pointers to create an extensible allocatable array. @@ -190,6 +101,7 @@ subroutine med_fldList_AddFld(flds, stdname, shortname) ! local variables integer :: n,oldsize,id logical :: found + integer :: mapsize, mrgsize type(med_fldList_entry_type), pointer :: newflds(:) character(len=*), parameter :: subname='(med_fldList_AddFld)' ! ---------------------------------------------- @@ -211,6 +123,9 @@ subroutine med_fldList_AddFld(flds, stdname, shortname) ! create new entry if fldname is not in original list + mapsize = ncomps + mrgsize = ncomps + if (.not. found) then ! 1) allocate newfld to be size (one element larger than input flds) @@ -220,12 +135,27 @@ subroutine med_fldList_AddFld(flds, stdname, shortname) do n = 1,oldsize newflds(n)%stdname = flds(n)%stdname newflds(n)%shortname = flds(n)%shortname + + allocate(newflds(n)%mapindex(mapsize)) + allocate(newflds(n)%mapnorm(mapsize)) + allocate(newflds(n)%mapfile(mapsize)) + allocate(newflds(n)%merge_fields(mrgsize)) + allocate(newflds(n)%merge_types(mrgsize)) + allocate(newflds(n)%merge_fracnames(mrgsize)) + newflds(n)%mapindex(:) = flds(n)%mapindex(:) newflds(n)%mapnorm(:) = flds(n)%mapnorm(:) newflds(n)%mapfile(:) = flds(n)%mapfile(:) newflds(n)%merge_fields(:) = flds(n)%merge_fields(:) newflds(n)%merge_types(:) = flds(n)%merge_types(:) newflds(n)%merge_fracnames(:) = flds(n)%merge_fracnames(:) + + deallocate(flds(n)%mapindex) + deallocate(flds(n)%mapnorm) + deallocate(flds(n)%mapfile) + deallocate(flds(n)%merge_fields) + deallocate(flds(n)%merge_types) + deallocate(flds(n)%merge_fracnames) end do ! 3) deallocate / nullify flds @@ -244,6 +174,18 @@ subroutine med_fldList_AddFld(flds, stdname, shortname) else flds(id)%shortname = trim(stdname) end if + allocate(flds(id)%mapindex(mapsize)) + allocate(flds(id)%mapnorm(mapsize)) + allocate(flds(id)%mapfile(mapsize)) + allocate(flds(id)%merge_fields(mrgsize)) + allocate(flds(id)%merge_types(mrgsize)) + allocate(flds(id)%merge_fracnames(mrgsize)) + flds(id)%mapindex(:) = mapunset + flds(id)%mapnorm(:) = 'unset' + flds(id)%mapfile(:) = 'unset' + flds(id)%merge_fields(:) = 'unset' + flds(id)%merge_types(:) = 'unset' + flds(id)%merge_fracnames(:) = 'unset' end if end subroutine med_fldList_AddFld @@ -639,11 +581,11 @@ subroutine med_fldList_GetFldInfo_merging(fldList, fldindex, compsrc, merge_fiel ! Get field merge info ! ---------------------------------------------- type(med_fldList_type) , intent(in) :: fldList - integer , intent(in) :: fldindex - integer , intent(in) :: compsrc - character(len=*) , intent(out) :: merge_field - character(len=*) , intent(out) :: merge_type - character(len=*) , intent(out) :: merge_fracname + integer , intent(in) :: fldindex + integer , intent(in) :: compsrc + character(len=*) , intent(out) :: merge_field + character(len=*) , intent(out) :: merge_type + character(len=*) , intent(out) :: merge_fracname ! local variables character(len=*), parameter :: subname='(med_fldList_GetFldInfo_merging)' @@ -652,6 +594,7 @@ subroutine med_fldList_GetFldInfo_merging(fldList, fldindex, compsrc, merge_fiel merge_field = fldList%flds(fldindex)%merge_fields(compsrc) merge_type = fldList%flds(fldindex)%merge_types(compsrc) merge_fracname = fldList%flds(fldindex)%merge_fracnames(compsrc) + end subroutine med_fldList_GetFldInfo_merging !================================================================================ diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index 2bb45a90d..a1b1a4897 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -49,12 +49,13 @@ module esmFldsExchange_cesm_mod character(len=CX) :: rof2lnd_map='unset' character(len=CX) :: atm2wav_map='unset' - logical :: mapuv_with_cart3d - logical :: flds_i2o_per_cat - logical :: flds_co2a - logical :: flds_co2b - logical :: flds_co2c - logical :: flds_wiso + logical :: mapuv_with_cart3d ! Map U/V vector wind fields from ATM to OCN/ICE by rotating in Cartesian 3D space and then back + logical :: flds_i2o_per_cat ! Ice thickness category fields passed to OCN + logical :: flds_co2a ! Pass CO2 from ATM to surface components + logical :: flds_co2b ! Pass CO2 from ATM to LND and back from LND to ATM + logical :: flds_co2c ! Pass CO2 from ATM to surface (OCN/LND) and back from them to ATM + logical :: flds_wiso ! Pass water isotop fields + logical :: flds_r2l_stream_channel_depths ! Pass channel depths from ROF to LND character(*), parameter :: u_FILE_u = & __FILE__ @@ -71,17 +72,16 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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, logunit, mastertask + use med_internalstate_mod , only : compmed, compatm, complnd, compocn + use med_internalstate_mod , only : compice, comprof, compwav, compglc, ncomps + use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d, mapbilnr_nstod + use med_internalstate_mod , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf + use med_internalstate_mod , only : coupling_mode + use med_internalstate_mod , only : map_glc2ocn_ice, map_glc2ocn_liq, map_rof2ocn_ice, map_rof2ocn_liq 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, ncomps - use esmflds , only : compglc, num_icesheets, ocn2glc_coupling ! compglc is an array of integers - use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d, mapbilnr_nstod - use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf - use esmflds , only : map_glc2ocn_ice, map_glc2ocn_liq, map_rof2ocn_ice, map_rof2ocn_liq use esmflds , only : fldListTo, fldListFr, fldListMed_aoflux, fldListMed_ocnalb - use esmFlds , only : coupling_mode ! input/output parameters: type(ESMF_GridComp) :: gcomp @@ -102,11 +102,9 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! Get the internal state !--------------------------------------- - 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 + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return if (phase == 'advertise') then @@ -200,25 +198,24 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) flds_i2o_per_cat - ! are multiple ocean depths for temperature and salinity sent from the ocn to glc? - call NUOPC_CompAttributeGet(gcomp, name='ocn2glc_coupling', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) ocn2glc_coupling - ! are water isotope exchanges enabled? call NUOPC_CompAttributeGet(gcomp, name='flds_wiso', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) flds_wiso + ! are water isotope exchanges enabled? + call NUOPC_CompAttributeGet(gcomp, name='flds_r2l_stream_channel_depths', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) flds_r2l_stream_channel_depths ! write diagnostic output if (mastertask) then - write(logunit,'(a,l7)') trim(subname)//' flds_co2a = ',flds_co2a - write(logunit,'(a,l7)') trim(subname)//' flds_co2b = ',flds_co2b - write(logunit,'(a,l7)') trim(subname)//' flds_co2c = ',flds_co2b - write(logunit,'(a,l7)') trim(subname)//' flds_wiso = ',flds_wiso - write(logunit,'(a,l7)') trim(subname)//' flds_i2o_per_cat = ',flds_i2o_per_cat - write(logunit,'(a,l7)') trim(subname)//' ocn2glc_coupling = ',ocn2glc_coupling - write(logunit,'(a,l7)') trim(subname)//' mapuv_with_cart3d = ',mapuv_with_cart3d + write(logunit,'(a,l7)') trim(subname)//' flds_co2a = ',flds_co2a + write(logunit,'(a,l7)') trim(subname)//' flds_co2b = ',flds_co2b + write(logunit,'(a,l7)') trim(subname)//' flds_co2c = ',flds_co2c + write(logunit,'(a,l7)') trim(subname)//' flds_wiso = ',flds_wiso + write(logunit,'(a,l7)') trim(subname)//' flds_i2o_per_cat = ',flds_i2o_per_cat + write(logunit,'(a,l7)') trim(subname)//' flds_r2l_stream_channel_depths = ',flds_r2l_stream_channel_depths + write(logunit,'(a,l7)') trim(subname)//' mapuv_with_cart3d = ',mapuv_with_cart3d end if end if @@ -247,7 +244,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListFr(complnd)%flds, 'Sl_lfrin') call addfld(fldListFr(compocn)%flds, 'So_omask') call addfld(fldListFr(compice)%flds, 'Si_imask') - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call addfld(fldlistFr(compglc(ns))%flds, 'Sg_area') end do else @@ -716,7 +713,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! fields from med->lnd are in multiple elevation classes if (phase == 'advertise') then - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets call addfld(fldListFr(compglc(ns))%flds, 'Sg_icemask') ! ice sheet grid coverage call addfld(fldListFr(compglc(ns))%flds, 'Sg_icemask_coupled_fluxes') call addfld(fldListFr(compglc(ns))%flds, 'Sg_ice_covered') ! fraction of glacier area @@ -732,7 +729,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! custom merge in med_phases_prep_lnd for Sg_icemask and Sg_icemask_coupled_fluxes ! custom map merge in med_phases_prep_lnd for Sg_ice_covered_elev, Sg_topo_elev and Flgg_hflx_elev if ( fldchk(is_local%wrap%FBExp(complnd), 'Sg_icemask', rc=rc)) then - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Sg_icemask', rc=rc)) then call addmap(fldListFr(compglc(ns))%flds, 'Sg_icemask', & complnd, mapconsd, 'one', 'unset') @@ -740,7 +737,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end do end if if ( fldchk(is_local%wrap%FBExp(complnd), 'Sg_icemask_coupled_fluxes', rc=rc)) then - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Sg_icemask_coupled_fluxes', rc=rc)) then call addmap(fldListFr(compglc(ns))%flds, 'Sg_icemask_coupled_fluxes', & complnd, mapconsd, 'one', 'unset') @@ -2098,13 +2095,13 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! 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 - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofl') end do call addfld(fldListFr(comprof)%flds, 'Forr_rofl') call addfld(fldListTo(compocn)%flds, 'Foxx_rofl') call addfld(fldListTo(compocn)%flds, 'Flrr_flood') - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofi') end do call addfld(fldListFr(comprof)%flds, 'Forr_rofi') @@ -2126,7 +2123,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if ! liquid from glc to ocean - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofl' , rc=rc)) then ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofl', compocn, map_glc2ocn_liq, 'one' , glc2ocn_liq_rmap) @@ -2145,7 +2142,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi', mrg_from=comprof, mrg_fld='Forr_rofi', mrg_type='sum') end if ! ice from glc to ocean - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofi' , rc=rc)) then ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofi', compocn, map_glc2ocn_ice, 'one', glc2ocn_ice_rmap) @@ -2157,13 +2154,13 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if (flds_wiso) then if (phase == 'advertise') then - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofl_wiso') end do call addfld(fldListFr(comprof)%flds, 'Forr_rofl_wiso') call addfld(fldListTo(compocn)%flds, 'Foxx_rofl_wiso') call addfld(fldListTo(compocn)%flds, 'Flrr_flood_wiso') - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets call addfld(fldListFr(compglc(ns))%flds, 'Fogg_rofi_wiso') end do call addfld(fldListFr(comprof)%flds, 'Forr_rofi_wiso') @@ -2187,7 +2184,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if ! liquid from glc to ocean - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofl_wiso' , rc=rc)) then ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofl_wiso', compocn, map_glc2ocn_liq, 'one' , glc2ocn_liq_rmap) @@ -2207,7 +2204,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi_wiso', mrg_from=comprof, mrg_fld='Forr_rofi', mrg_type='sum') end if ! ice from glc to ocean - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fogg_rofi_wiso' , rc=rc)) then ! TODO: this custom map needs to be different for every ice sheet - how will this be handled? call addmap(fldListFr(compglc(ns))%flds, 'Fogg_rofi_wiso', compocn, map_glc2ocn_ice, 'one', glc2ocn_ice_rmap) @@ -2741,7 +2738,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! --------------------------------------------------------------------- if (phase == 'advertise') then call addfld(fldListFr(comprof)%flds, 'Firr_rofi') ! water flux into sea ice due to runoff (frozen) - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets call addfld(fldListFr(compglc(ns))%flds, 'Figg_rofi') ! glc frozen runoff_iceberg flux to ice end do call addfld(fldListTo(compice)%flds, 'Fixx_rofi') ! total frozen water flux into sea ice @@ -2751,7 +2748,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmap(fldListFr(comprof)%flds, 'Forr_rofi', compice, mapconsf, 'none', rof2ocn_ice_rmap) call addmrg(fldListTo(compice)%flds, 'Fixx_rofi', mrg_from=comprof, mrg_fld='Firr_rofi', mrg_type='sum') end if - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Figg_rofi', rc=rc)) then call addmap(fldListFr(compglc(ns))%flds, 'Figg_rofi', compice, mapconsf, 'one' , glc2ice_rmap) call addmrg(fldListTo(compice)%flds, 'Fixx_rofi', mrg_from=compglc(ns), mrg_fld='Figg_rofi', mrg_type='sum') @@ -2762,7 +2759,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if (flds_wiso) then if (phase == 'advertise') then call addfld(fldListFr(comprof)%flds, 'Firr_rofi_wiso') ! water flux into sea ice due to runoff (frozen) - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets call addfld(fldListFr(compglc(ns))%flds, 'Figg_rofi_wiso') ! glc frozen runoff_iceberg flux to ice end do call addfld(fldListTo(compice)%flds, 'Fixx_rofi_wiso') ! total frozen water flux into sea ice @@ -2773,7 +2770,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg(fldListTo(compice)%flds, 'Fixx_rofi_wiso', & mrg_from=comprof, mrg_fld='Firr_rofi_wiso', mrg_type='sum') end if - do ns = 1, num_icesheets + do ns = 1, is_local%wrap%num_icesheets if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Figg_rofi_wiso', rc=rc)) then call addmap(fldListFr(compglc(ns))%flds, 'Figg_rofi_wiso', compice, mapconsf, 'one' , glc2ice_rmap) call addmrg(fldListTo(compice)%flds, 'Fixx_rofi_wiso', & @@ -2994,13 +2991,13 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListFr(complnd)%flds, 'Sl_tsrf_elev') ! surface temperature of glacier (1->glc_nec+1) call addfld(fldListFr(complnd)%flds, 'Sl_topo_elev') ! surface heights of glacier (1->glc_nec+1) call addfld(fldListFr(complnd)%flds, 'Flgl_qice_elev') ! glacier ice flux (1->glc_nec+1) - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call addfld(fldListTo(compglc(ns))%flds, 'Sl_tsrf') call addfld(fldListTo(compglc(ns))%flds, 'Flgl_qice') end do else ! custom mapping, accumulation and merging will be done in prep_glc_mod.F90 - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if ( fldchk(is_local%wrap%FBImp(complnd,complnd) , 'Flgl_qice_elev', rc=rc)) then call addmap(FldListFr(complnd)%flds, 'Flgl_qice_elev', compglc(ns), mapbilnr, 'lfrac', 'unset') end if @@ -3017,18 +3014,18 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) !----------------------------- ! to glc: from ocn !----------------------------- - if (ocn2glc_coupling) then + if (is_local%wrap%ocn2glc_coupling) then if (phase == 'advertise') then call addfld(fldListFr(compocn)%flds, 'So_t_depth') call addfld(fldListFr(compocn)%flds, 'So_s_depth') - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call addfld(fldListTo(compglc(ns))%flds, 'So_t_depth') call addfld(fldListTo(compglc(ns))%flds, 'So_s_depth') end do else ! custom mapping, accumulation and merging will be done in prep_glc_mod.F90 ! the following is used to create the route handle - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if ( fldchk(is_local%wrap%FBImp(compocn,compocn) , 'So_t_depth', rc=rc)) then call addmap(FldListFr(compocn)%flds, 'So_t_depth', compglc(ns), mapbilnr, 'none', 'unset') end if diff --git a/mediator/esmFldsExchange_hafs_mod.F90 b/mediator/esmFldsExchange_hafs_mod.F90 index 5f8537221..bfa23dc25 100644 --- a/mediator/esmFldsExchange_hafs_mod.F90 +++ b/mediator/esmFldsExchange_hafs_mod.F90 @@ -2,19 +2,19 @@ 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 : compwav - use esmflds, only : ncomps - use esmflds, only : fldListTo - use esmflds, only : fldListFr - use esmFlds, only : coupling_mode + 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 med_internalstate_mod , only : compmed + use med_internalstate_mod , only : compatm + use med_internalstate_mod , only : compocn + use med_internalstate_mod , only : compwav + use med_internalstate_mod , only : ncomps + use med_internalstate_mod , only : coupling_mode + use esmflds , only : fldListTo + use esmflds , only : fldListFr !--------------------------------------------------------------------- ! This is a mediator specific routine that determines ALL possible @@ -88,7 +88,7 @@ end subroutine esmFldsExchange_hafs subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) - use esmFlds , only : addfld => med_fldList_AddFld + use esmFlds, only : addfld => med_fldList_AddFld ! input/output parameters: type(ESMF_GridComp) :: gcomp @@ -172,7 +172,7 @@ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%wav_present) then allocate(S_flds(1)) - S_flds = (/'Sw_zo'/) ! wave_z0_roughness_length + S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length do n = 1,size(S_flds) fldname = trim(S_flds(n)) call addfld(fldListFr(compwav)%flds, trim(fldname)) @@ -294,13 +294,13 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) use med_methods_mod , only : fldchk => med_methods_FB_FldChk use med_internalstate_mod , only : InternalState + use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch + use med_internalstate_mod , only : mapfcopy, mapnstod, mapnstod_consd + use med_internalstate_mod , only : mapfillv_bilnr + use med_internalstate_mod , only : mapnstod_consf 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 : mapfillv_bilnr - use esmflds , only : mapnstod_consf ! input/output parameters: type(ESMF_GridComp) :: gcomp @@ -385,7 +385,7 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%wav_present) then allocate(S_flds(1)) - S_flds = (/'Sw_zo'/) ! wave_z0_roughness_length + S_flds = (/'Sw_z0'/) ! wave_z0_roughness_length do n = 1,size(S_flds) fldname = trim(S_flds(n)) if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index f6d88ab46..81def7650 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -24,17 +24,18 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) 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_internalstate_mod , only : InternalState + use med_internalstate_mod , only : mastertask, logunit + use med_internalstate_mod , only : compmed, compatm, compocn, compice, comprof, compwav, ncomps + use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch + use med_internalstate_mod , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf + use med_internalstate_mod , only : mapconsf_aofrac + use med_internalstate_mod , only : coupling_mode, mapnames use esmFlds , only : med_fldList_type 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, comprof, ncomps - use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch - use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf - use esmflds , only : mapconsf_aofrac - use esmflds , only : coupling_mode, mapnames use esmflds , only : fldListTo, fldListFr, fldListMed_aoflux, fldListMed_ocnalb - use med_internalstate_mod , only : mastertask, logunit ! input/output parameters: type(ESMF_GridComp) :: gcomp @@ -42,6 +43,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) integer , intent(inout) :: rc ! local variables: + type(InternalState) :: is_local integer :: i, n, maptype character(len=CX) :: msgString character(len=CL) :: cvalue @@ -52,6 +54,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) rc = ESMF_SUCCESS + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Set maptype according to coupling_mode if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then maptype = mapnstod_consf @@ -159,6 +165,16 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addmap(fldListFr(compocn)%flds, 'So_t', compatm, maptype, 'ofrac', 'unset') call addmrg(fldListTo(compatm)%flds, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + ! temporary conditional to avoid conflicts of advertised fields + ! when waves are passing through connectors + if (is_local%wrap%comp_present(compwav)) then + ! to atm: surface roughness length from wav + call addfld(fldListFr(compwav)%flds, 'Sw_z0') + call addfld(fldListTo(compatm)%flds, 'Sw_z0') + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + end if + !===================================================================== ! FIELDS TO OCEAN (compocn) !===================================================================== @@ -291,6 +307,23 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end do deallocate(flds) + ! temporary conditional to avoid conflicts of advertised fields + ! when waves are passing through connectors + if (is_local%wrap%comp_present(compwav)) then + ! to ocn: partitioned stokes drift from wav + allocate(flds(6)) + flds = (/'Sw_ustokes1', 'Sw_ustokes2', 'Sw_ustokes3', & + 'Sw_vstokes1', 'Sw_vstokes2', 'Sw_vstokes3'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListTo(compocn)%flds, trim(fldname)) + call addfld(fldListFr(compwav)%flds, trim(fldname)) + call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + end if + !===================================================================== ! FIELDS TO ICE (compice) !===================================================================== @@ -353,6 +386,46 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end do deallocate(flds) + !===================================================================== + ! FIELDS TO WAV (compwav) + !===================================================================== + + ! temporary conditional to avoid conflicts of advertised fields + ! when waves are passing through connectors + if (is_local%wrap%comp_present(compwav)) then + ! to wav - 10m winds and bottom temperature from atm + allocate(flds(3)) + flds = (/'Sa_u10m', 'Sa_v10m', 'Sa_tbot'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + + ! to wav: sea ice fraction + call addfld(fldListTo(compwav)%flds, 'Si_ifrac') + call addfld(fldListFr(compice)%flds, 'Si_ifrac') + call addmap(fldListFr(compice)%flds, 'Si_ifrac', compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, 'Si_ifrac', mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') + + ! to wav: zonal sea water velocity from ocn + ! to wav: meridional sea water velocity from ocn + ! to wav: surface temperature from ocn + allocate(flds(3)) + flds = (/'So_u', 'So_v', 'So_t'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + call addfld(fldListFr(compocn)%flds, trim(fldname)) + call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end do + deallocate(flds) + end if + end subroutine esmFldsExchange_nems end module esmFldsExchange_nems_mod diff --git a/mediator/med.F90 b/mediator/med.F90 index 8e8c4fdf1..4ac79c4cf 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -41,24 +41,19 @@ module MED use med_methods_mod , only : clock_timeprint => med_methods_clock_timeprint use med_utils_mod , only : memcheck => med_memcheck use med_time_mod , only : med_time_alarmInit - use med_internalstate_mod , only : InternalState - use med_internalstate_mod , only : med_coupling_allowed, logunit, mastertask - use med_phases_profile_mod , only : med_phases_profile_finalize - use esmFlds , only : ncomps, compname - use esmFlds , only : fldListFr, fldListTo, med_fldList_Realize - use esmFlds , only : ncomps, compname, ncomps - use esmFlds , only : compmed, compatm, compocn, compice, complnd, comprof, compwav ! not arrays - use esmFlds , only : num_icesheets, max_icesheets, compglc ! compglc is an array - use esmFlds , only : ocn2glc_coupling, lnd2glc_coupling, accum_lnd2glc + use med_internalstate_mod , only : InternalState, med_internalstate_init, med_internalstate_coupling + use med_internalstate_mod , only : logunit, mastertask + use med_internalstate_mod , only : ncomps, compname + use med_internalstate_mod , only : compmed, compatm, compocn, compice, complnd, comprof, compwav, compglc + use med_internalstate_mod , only : coupling_mode use esmFlds , only : fldListMed_ocnalb use esmFlds , only : med_fldList_GetNumFlds, med_fldList_GetFldNames, med_fldList_GetFldInfo use esmFlds , only : med_fldList_Document_Mapping, med_fldList_Document_Merging - use esmFlds , only : coupling_mode - use esmFlds , only : med_name, atm_name, lnd_name, ocn_name - use esmFlds , only : ice_name, rof_name, wav_name, glc_name + use esmFlds , only : fldListFr, fldListTo, med_fldList_Realize use esmFldsExchange_nems_mod , only : esmFldsExchange_nems use esmFldsExchange_cesm_mod , only : esmFldsExchange_cesm use esmFldsExchange_hafs_mod , only : esmFldsExchange_hafs + use med_phases_profile_mod , only : med_phases_profile_finalize implicit none private @@ -76,15 +71,12 @@ module MED private med_grid_write private med_finalize - character(len=*), parameter :: grid_arbopt = "grid_reg" ! grid_reg or grid_arb character(len=*), parameter :: u_FILE_u = & __FILE__ + logical :: profile_memory = .false. - character(len=8) :: atm_present, lnd_present - character(len=8) :: ice_present, rof_present - character(len=8) :: glc_present, med_present - character(len=8) :: ocn_present, wav_present + logical, allocatable :: compDone(:) ! component done flag !----------------------------------------------------------------------------- contains @@ -109,7 +101,8 @@ subroutine SetServices(gcomp, rc) use med_phases_prep_atm_mod , only: med_phases_prep_atm use med_phases_prep_ice_mod , only: med_phases_prep_ice use med_phases_prep_lnd_mod , only: med_phases_prep_lnd - use med_phases_prep_wav_mod , only: med_phases_prep_wav + use med_phases_prep_wav_mod , only: med_phases_prep_wav_accum + use med_phases_prep_wav_mod , only: med_phases_prep_wav_avg use med_phases_prep_glc_mod , only: med_phases_prep_glc use med_phases_prep_rof_mod , only: med_phases_prep_rof use med_phases_prep_ocn_mod , only: med_phases_prep_ocn_accum @@ -351,10 +344,20 @@ subroutine SetServices(gcomp, rc) !------------------ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & - phaseLabelList=(/"med_phases_prep_wav"/), userRoutine=mediator_routine_Run, rc=rc) + phaseLabelList=(/"med_phases_prep_wav_accum"/), userRoutine=mediator_routine_Run, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & - specPhaseLabel="med_phases_prep_wav", specRoutine=med_phases_prep_wav, rc=rc) + specPhaseLabel="med_phases_prep_wav_accum", specRoutine=med_phases_prep_wav_accum, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & + specPhaselabel="med_phases_prep_wav_accum", specRoutine=NUOPC_NoOp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & + phaseLabelList=(/"med_phases_prep_wav_avg"/), userRoutine=mediator_routine_Run, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, & + specPhaseLabel="med_phases_prep_wav_avg", specRoutine=med_phases_prep_wav_avg, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, & @@ -547,7 +550,6 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) 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, diagunit - use esmFlds, only : dststatus_print type(ESMF_GridComp) :: gcomp type(ESMF_State) :: importState, exportState @@ -630,13 +632,6 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(msgString,'(A,i6)') trim(subname)//': Mediator dbug_flag is ',dbug_flag call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) - ! Obtain dststatus_print setting if present - call NUOPC_CompAttributeGet(gcomp, name='dststatus_print', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) dststatus_print=(trim(cvalue)=="true") - write(msgString,*) trim(subname)//': Mediator dststatus_print is ',dststatus_print - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) - ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, acceptStringList=(/"IPDv03p"/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -659,6 +654,8 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) use ESMF , only : ESMF_END_ABORT, ESMF_Finalize, ESMF_MAXSTR use NUOPC , only : NUOPC_AddNamespace, NUOPC_Advertise, NUOPC_AddNestedState use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd + use esmFlds, only : med_fldlist_init1 + use med_phases_history_mod, only : med_phases_history_init ! input/output variables type(ESMF_GridComp) :: gcomp @@ -675,9 +672,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) character(len=8) :: cnum type(InternalState) :: is_local integer :: stat - character(len=CS) :: attrList(8) - character(len=ESMF_MAXSTR) :: mesh_glc - character(len=*),parameter :: subname=' (InitializeIPDv03p1) ' + character(len=*),parameter :: subname=' (Advertise Fields) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -685,7 +680,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) if (profile_memory) call ESMF_VMLogMemInfo("Entering "//trim(subname)) !------------------ - ! Allocate memory for the internal state and set it in the Component. + ! Allocate memory for the internal state !------------------ allocate(is_local%wrap, stat=stat) @@ -697,6 +692,14 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) call ESMF_GridCompSetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_internalstate_init(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !------------------ + ! Allocate memory for history module variables + !------------------ + call med_phases_history_init() + !------------------ ! add a namespace (i.e. nested state) for each import and export component state in the mediator's InternalState !------------------ @@ -735,23 +738,8 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) call NUOPC_AddNamespace(exportState, namespace="WAV", nestedStateName="WavExp", & nestedState=is_local%wrap%NStateExp(compwav), rc=rc) - ! Only create nested states for active ice sheets - call NUOPC_CompAttributeGet(gcomp, name='mesh_glc', value=mesh_glc, isPresent=isPresent, isSet=isSet, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - num_icesheets = 0 - if (isPresent .and. isSet) then - ! determine number of ice sheets - search in mesh_glc for colon deliminted strings - if (len_trim(cvalue) > 0) then - do n = 1, len_trim(mesh_glc) - if (mesh_glc(n:n) == ':') num_icesheets = num_icesheets + 1 - end do - num_icesheets = num_icesheets + 1 - endif - if (mastertask) then - write(logunit,'(a,i8)') trim(subname)//' number of ice sheets is ',num_icesheets - end if - end if - do ns = 1,num_icesheets + ! Only create nested states for active land-ice sheets + do ns = 1,is_local%wrap%num_icesheets write(cnum,'(i0)') ns call NUOPC_AddNestedState(importState, CplSet="GLC"//trim(cnum), & nestedState=is_local%wrap%NStateImp(compglc(ns)), rc=rc) @@ -783,6 +771,10 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) write(logunit,*) end if + ! Initialize memory for fldlistTo and fldlistFr - this is need for the calls below for the + ! advertise phase + call med_fldlist_init1() + if (trim(coupling_mode) == 'cesm') then call esmFldsExchange_cesm(gcomp, phase='advertise', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -802,112 +794,6 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) ! Determine component present indices !------------------ - call NUOPC_CompAttributeAdd(gcomp, & - attrList=(/'atm_present','lnd_present','ocn_present','ice_present',& - 'rof_present','wav_present','glc_present','med_present'/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - med_present = "false" - atm_present = "false" - lnd_present = "false" - ocn_present = "false" - ice_present = "false" - rof_present = "false" - wav_present = "false" - glc_present = "false" - - ! Note that the present flag is set to true if the component is not stub - call NUOPC_CompAttributeGet(gcomp, name='ATM_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) /= 'satm') atm_present = "true" - atm_name = trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='LND_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) /= 'slnd') lnd_present = "true" - lnd_name = trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='OCN_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) /= 'socn') ocn_present = "true" - ocn_name = trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='ICE_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) /= 'sice') ice_present = "true" - ice_name = trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='ROF_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) /= 'srof') rof_present = "true" - rof_name = trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='WAV_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) /= 'swav') wav_present = "true" - wav_name = trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='GLC_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - if (trim(cvalue) /= 'sglc') glc_present = "true" - glc_name = trim(cvalue) - end if - - call NUOPC_CompAttributeGet(gcomp, name='MED_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - med_name = trim(cvalue) - 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) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name="ocn_present", value=ocn_present, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name="ice_present", value=ice_present, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name="rof_present", value=rof_present, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name="wav_present", value=trim(wav_present), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name="glc_present", value=trim(glc_present), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name="med_present", value=med_present, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (mastertask) then - write(logunit,*) - if (trim(atm_present).eq."true") write(logunit,*) "atm_name="//trim(atm_name) - if (trim(lnd_present).eq."true") write(logunit,*) "lnd_name="//trim(lnd_name) - if (trim(ocn_present).eq."true") write(logunit,*) "ocn_name="//trim(ocn_name) - if (trim(ice_present).eq."true") write(logunit,*) "ice_name="//trim(ice_name) - if (trim(rof_present).eq."true") write(logunit,*) "rof_name="//trim(rof_name) - if (trim(wav_present).eq."true") write(logunit,*) "wav_name="//trim(wav_name) - if (trim(glc_present).eq."true") write(logunit,*) "glc_name="//trim(glc_name) - if (trim(med_present).eq."true") write(logunit,*) "med_name="//trim(med_name) - write(logunit,*) - end if - call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return is_local%wrap%flds_scalar_name = trim(cvalue) @@ -948,44 +834,40 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) do ncomp = 1,ncomps if (ncomp /= compmed) then if (mastertask) write(logunit,*) - if (ESMF_StateIsCreated(is_local%wrap%NStateImp(ncomp))) then - nflds = med_fldList_GetNumFlds(fldListFr(ncomp)) - do n = 1,nflds - call med_fldList_GetFldInfo(fldListFr(ncomp), n, stdname, shortname) - if (mastertask) then - write(logunit,'(a)') trim(subname)//':Fr_'//trim(compname(ncomp))//': '//trim(shortname) - end if - if (trim(shortname) == is_local%wrap%flds_scalar_name) then - transferOffer = 'will provide' - else - transferOffer = 'cannot provide' - end if - call NUOPC_Advertise(is_local%wrap%NStateImp(ncomp), & - standardName=stdname, shortname=shortname, name=shortname, & - TransferOfferGeomObject=transferOffer, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(subname//':Fr_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) - end do - end if - if (ESMF_StateIsCreated(is_local%wrap%NStateExp(ncomp))) then - nflds = med_fldList_GetNumFlds(fldListTo(ncomp)) - do n = 1,nflds - call med_fldList_GetFldInfo(fldListTo(ncomp), n, stdname, shortname) - if (mastertask) then - write(logunit,'(a)') trim(subname)//':To_'//trim(compname(ncomp))//': '//trim(shortname) - end if - if (trim(shortname) == is_local%wrap%flds_scalar_name) then - transferOffer = 'will provide' - else - transferOffer = 'cannot provide' - end if - call NUOPC_Advertise(is_local%wrap%NStateExp(ncomp), & - standardName=stdname, shortname=shortname, name=shortname, & - TransferOfferGeomObject=transferOffer, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(subname//':To_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) - end do - end if + nflds = med_fldList_GetNumFlds(fldListFr(ncomp)) + do n = 1,nflds + call med_fldList_GetFldInfo(fldListFr(ncomp), n, stdname, shortname) + if (mastertask) then + write(logunit,'(a)') trim(subname)//':Fr_'//trim(compname(ncomp))//': '//trim(shortname) + end if + if (trim(shortname) == is_local%wrap%flds_scalar_name) then + transferOffer = 'will provide' + else + transferOffer = 'cannot provide' + end if + call NUOPC_Advertise(is_local%wrap%NStateImp(ncomp), & + standardName=stdname, shortname=shortname, name=shortname, & + TransferOfferGeomObject=transferOffer, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//':Fr_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) + end do + nflds = med_fldList_GetNumFlds(fldListTo(ncomp)) + do n = 1,nflds + call med_fldList_GetFldInfo(fldListTo(ncomp), n, stdname, shortname) + if (mastertask) then + write(logunit,'(a)') trim(subname)//':To_'//trim(compname(ncomp))//': '//trim(shortname) + end if + if (trim(shortname) == is_local%wrap%flds_scalar_name) then + transferOffer = 'will provide' + else + transferOffer = 'cannot provide' + end if + call NUOPC_Advertise(is_local%wrap%NStateExp(ncomp), & + standardName=stdname, shortname=shortname, name=shortname, & + TransferOfferGeomObject=transferOffer, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//':To_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) + end do end if end do ! end of ncomps loop @@ -1016,7 +898,7 @@ subroutine InitializeIPDv03p3(gcomp, importState, exportState, clock, rc) type(InternalState) :: is_local type(ESMF_VM) :: vm integer :: n - character(len=*),parameter :: subname=' (InitializeIPDv03p3) ' + character(len=*),parameter :: subname=' (Realize Fields with Transfer Provide) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1077,7 +959,7 @@ subroutine InitializeIPDv03p4(gcomp, importState, exportState, clock, rc) ! local variables type(InternalState) :: is_local integer :: n1,n2 - character(len=*),parameter :: subname=' (InitalizeIPDv03p4) ' + character(len=*),parameter :: subname=' (Modify Decomp of Mesh/Grid) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1405,7 +1287,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=' (Realize Fields with Transfer Accept) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1477,7 +1359,7 @@ subroutine completeFieldInitialization(State,rc) integer, allocatable :: ungriddedLBound(:), ungriddedUBound(:) logical :: isPresent logical :: meshcreated - character(len=*),parameter :: subname=' (module_MED:completeFieldInitialization) ' + character(len=*),parameter :: subname=' (Complete Field Initialization) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1627,6 +1509,7 @@ subroutine DataInitialize(gcomp, rc) use med_fraction_mod , only : med_fraction_init, med_fraction_set use med_phases_restart_mod , only : med_phases_restart_read use med_phases_prep_ocn_mod , only : med_phases_prep_ocn_init + use med_phases_prep_wav_mod , only : med_phases_prep_wav_init use med_phases_prep_rof_mod , only : med_phases_prep_rof_init use med_phases_prep_glc_mod , only : med_phases_prep_glc_init use med_phases_prep_atm_mod , only : med_phases_prep_atm @@ -1665,16 +1548,14 @@ subroutine DataInitialize(gcomp, rc) character(ESMF_MAXSTR),allocatable :: fieldNameList(:) character(CL), pointer :: fldnames(:) character(CL) :: cvalue - character(CL) :: cname character(CL) :: start_type logical :: read_restart logical :: isPresent, isSet logical :: allDone = .false. - logical,save :: compDone(ncomps) logical,save :: first_call = .true. real(r8) :: real_nx, real_ny character(len=CX) :: msgString - character(len=*), parameter :: subname=' (DataInitialize) ' + character(len=*), parameter :: subname=' (Data Initialization) ' !----------------------------------------------------------- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1703,168 +1584,12 @@ subroutine DataInitialize(gcomp, rc) if (first_call) then - !---------------------------------------------------------- - ! Initialize mediator present flags - !---------------------------------------------------------- + ! Allocate module variable + allocate(compDone(ncomps)) - if (mastertask) then - write(logunit,'(a)') trim(subname) // "Initializing present flags" - end if - - do n1 = 1,ncomps - cname = trim(compname(n1)) - if (cname(1:3) == 'glc') then - ! Special logic for glc since there can be multiple ice sheets - call ESMF_AttributeGet(gcomp, name="glc_present", value=cvalue, & - convention="NUOPC", purpose="Instance", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - do ns = 1,max_icesheets - if (ns <= num_icesheets) then - if (trim(cvalue) == 'true') then - is_local%wrap%comp_present(compglc(ns)) = .true. - else - is_local%wrap%comp_present(compglc(ns)) = .false. - end if - end if - end do - else - call ESMF_AttributeGet(gcomp, name=trim(compname(n1))//"_present", value=cvalue, & - convention="NUOPC", purpose="Instance", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (trim(cvalue) == "true") then - is_local%wrap%comp_present(n1) = .true. - else - is_local%wrap%comp_present(n1) = .false. - end if - end if - if (mastertask) then - write(msgString,'(A,L4)') trim(subname)//' comp_present(comp'//trim(compname(n1))//') = ',& - is_local%wrap%comp_present(n1) - write(logunit,'(a)') trim(subname) // trim(msgString) - end if - end do - - !---------------------------------------------------------- - ! Check for active coupling interactions - ! must be allowed, bundles created, and both sides have some fields - !---------------------------------------------------------- - - ! This defines the med_coupling_allowed is a starting point for what is - ! allowed in this coupled system. It will be revised further after the system - ! starts, but any coupling set to false will never be allowed. - ! are allowed, just update the table below. - - if (mastertask) then - write(logunit,'(a)') trim(subname) // "Initializing active coupling flags" - end if - - ! Initialize med_coupling_allowed - med_coupling_allowed(:,:) = .false. - - ! to atmosphere - med_coupling_allowed(complnd,compatm) = .true. - med_coupling_allowed(compice,compatm) = .true. - med_coupling_allowed(compocn,compatm) = .true. - med_coupling_allowed(compwav,compatm) = .true. - - ! to land - med_coupling_allowed(compatm,complnd) = .true. - med_coupling_allowed(comprof,complnd) = .true. - do ns = 1,num_icesheets - med_coupling_allowed(compglc(ns),complnd) = .true. - end do - - ! to ocean - med_coupling_allowed(compatm,compocn) = .true. - med_coupling_allowed(compice,compocn) = .true. - med_coupling_allowed(comprof,compocn) = .true. - med_coupling_allowed(compwav,compocn) = .true. - do ns = 1,num_icesheets - med_coupling_allowed(compglc(ns),compocn) = .true. - end do - - ! to ice - med_coupling_allowed(compatm,compice) = .true. - med_coupling_allowed(compocn,compice) = .true. - med_coupling_allowed(comprof,compice) = .true. - med_coupling_allowed(compwav,compice) = .true. - do ns = 1,num_icesheets - med_coupling_allowed(compglc(ns),compice) = .true. - end do - - ! to river - med_coupling_allowed(complnd,comprof) = .true. - - ! to wave - med_coupling_allowed(compatm,compwav) = .true. - med_coupling_allowed(compocn,compwav) = .true. - med_coupling_allowed(compice,compwav) = .true. - - ! to land-ice - do ns = 1,num_icesheets - med_coupling_allowed(complnd,compglc(ns)) = .true. - med_coupling_allowed(compocn,compglc(ns)) = .true. - end do - - ! initialize med_coupling_active table - is_local%wrap%med_coupling_active(:,:) = .false. - do n1 = 1,ncomps - if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then - call State_GetNumFields(is_local%wrap%NStateImp(n1), cntn1, rc=rc) ! Import Field Count - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (cntn1 > 0) then - do n2 = 1,ncomps - if (is_local%wrap%comp_present(n2) .and. ESMF_StateIsCreated(is_local%wrap%NStateExp(n2),rc=rc) .and. & - med_coupling_allowed(n1,n2)) then - call State_GetNumFields(is_local%wrap%NStateExp(n2), cntn2, rc=rc) ! Import Field Count - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (cntn2 > 0) then - is_local%wrap%med_coupling_active(n1,n2) = .true. - endif - endif - enddo - end if - endif - enddo - - ! Reset ocn2glc active coupling based in input attribute - if (.not. ocn2glc_coupling) then - do ns = 1,num_icesheets - is_local%wrap%med_coupling_active(compocn,compglc(ns)) = .false. - end do - end if - - ! create tables of allowed and active coupling flags - ! - the rows are the destination of coupling - ! - the columns are the source of coupling - ! - So, the second column indicates which models the atm is coupled to. - ! - And the second row indicates which models are coupled to the atm. - if (mastertask) then - write(logunit,*) ' ' - write(logunit,'(A)') trim(subname)//' Allowed coupling flags' - write(logunit,'(2x,A10,20(A5))') '|from to->',(compname(n2),n2=1,ncomps) - do n1 = 1,ncomps - write(msgString,'(2x,a1,A,5x,20(L5))') '|',trim(compname(n1)), & - (med_coupling_allowed(n1,n2),n2=1,ncomps) - do n2 = 1,len_trim(msgString) - if (msgString(n2:n2) == 'F') msgString(n2:n2)='-' - enddo - write(logunit,'(A)') trim(msgString) - enddo - - write(logunit,*) ' ' - write(logunit,'(A)') subname//' Active coupling flags' - write(logunit,'(2x,A10,20(A5))') '|from to->',(compname(n2),n2=1,ncomps) - do n1 = 1,ncomps - write(msgString,'(2x,a1,A,5x,20(L5))') '|',trim(compname(n1)), & - (is_local%wrap%med_coupling_active(n1,n2),n2=1,ncomps) - do n2 = 1,len_trim(msgString) - if (msgString(n2:n2) == 'F') msgString(n2:n2)='-' - enddo - write(logunit,'(A)') trim(msgString) - enddo - write(logunit,*) ' ' - endif + ! Determine active coupling logical flags + call med_internalstate_coupling(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------- ! Create field bundles FBImp, FBExp @@ -2010,6 +1735,9 @@ subroutine DataInitialize(gcomp, rc) ! Determine mapping and merging info for field exchanges in mediator !--------------------------------------- + ! Initialize memory for fldlistFr(:)%flds(:) and fldlistTo(:)%flds(:) - this is needed for + ! call below for the initialize phase + if (trim(coupling_mode) == 'cesm') then call esmFldsExchange_cesm(gcomp, phase='initialize', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2069,29 +1797,19 @@ subroutine DataInitialize(gcomp, rc) end if !--------------------------------------- - ! Initialize glc module field bundles here if appropriate + ! Initialize wav export accumulation field bundle !--------------------------------------- - do ns = 1,num_icesheets - if (is_local%wrap%med_coupling_active(complnd,compglc(ns))) then - lnd2glc_coupling = .true. - exit - end if - end do - if (lnd2glc_coupling) then - accum_lnd2glc = .true. - else - ! Determine if will create auxiliary history file that contains - ! lnd2glc data averaged over the year - call NUOPC_CompAttributeGet(gcomp, name="histaux_l2x1yrg", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) + if ( is_local%wrap%comp_present(compwav) .and. & + ESMF_StateIsCreated(is_local%wrap%NStateImp(compwav),rc=rc) .and. & + ESMF_StateIsCreated(is_local%wrap%NStateExp(compwav),rc=rc)) then + call med_phases_prep_wav_init(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) accum_lnd2glc - else - accum_lnd2glc = .false. - end if end if - if (lnd2glc_coupling .or. ocn2glc_coupling .or. accum_lnd2glc) then + + !--------------------------------------- + ! Initialize glc module field bundles here if appropriate + !--------------------------------------- + if (is_local%wrap%lnd2glc_coupling .or. is_local%wrap%ocn2glc_coupling .or. is_local%wrap%accum_lnd2glc) then call med_phases_prep_glc_init(gcomp, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -2107,7 +1825,6 @@ subroutine DataInitialize(gcomp, rc) !--------------------------------------- ! Set the data initialize flag to false !--------------------------------------- - call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="false", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2226,7 +1943,7 @@ subroutine DataInitialize(gcomp, rc) deallocate(fieldNameList) if (.not. compDone(compatm)) then ! atmdone is not true - if (trim(lnd_present) == 'true') then + if (is_local%wrap%comp_present(complnd)) then ! map initial lnd->atm call med_phases_post_lnd(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2363,44 +2080,45 @@ subroutine DataInitialize(gcomp, rc) !--------------------------------------- ! Call post routines as part of initialization !--------------------------------------- - if (trim(atm_present) == 'true') then - ! map atm->ocn, atm->ice, atm->lnd + if (is_local%wrap%comp_present(compatm)) then + ! map atm->ocn, atm->ice, atm->lnd, atm->wav call med_phases_post_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (trim(ice_present) == 'true') then - ! call set ice_frac and map ice->atm and ice->ocn + if (is_local%wrap%comp_present(compice)) then + ! call set ice_frac and map ice->ocn and ice->wav call med_phases_post_ice(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (trim(glc_present) == 'true') then + if (allocated(compglc)) then ! map initial glc->lnd, glc->ocn and glc->ice call med_phases_post_glc(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (trim(lnd_present) == 'true') then + if (is_local%wrap%comp_present(complnd)) then ! map initial lnd->atm call med_phases_post_lnd(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (trim(ocn_present) == 'true') then - ! map initial ocn->ice + if (is_local%wrap%comp_present(compocn)) then + ! map initial ocn->ice, ocn->wav call med_phases_post_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (trim(rof_present) == 'true') then + if (is_local%wrap%comp_present(comprof)) then ! map initial rof->lnd, rof->ocn and rof->ice call med_phases_post_rof(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (trim(wav_present) == 'true') then - ! map initial wav->ocn and wav->ice + if (is_local%wrap%comp_present(compwav)) then + ! map initial wav->ocn, wav->ice, wav->atm call med_phases_post_wav(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if call med_phases_profile(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + else ! Not all done call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="false", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2444,7 +2162,7 @@ subroutine SetRunClock(gcomp, rc) logical, save :: stopalarmcreated=.false. integer :: alarmcount - character(len=*),parameter :: subname=' (module_MED:SetRunClock) ' + character(len=*),parameter :: subname=' (Set Run Clock) ' !----------------------------------------------------------- rc = ESMF_SUCCESS @@ -2602,7 +2320,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=' (Grid Write) ' !------------------------------------------------------------------------------- rc = ESMF_SUCCESS diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index 8f15f625e..ca8583803 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -617,7 +617,7 @@ subroutine med_phases_diag_atm(gcomp, rc) ! Compute global atm input/output flux diagnostics ! ------------------------------------------------------------------ - use esmFlds, only : compatm + use med_internalstate_mod, only : compatm ! input/output variables type(ESMF_GridComp) :: gcomp @@ -946,7 +946,7 @@ subroutine med_phases_diag_lnd( gcomp, rc) ! Compute global lnd input/output flux diagnostics ! ------------------------------------------------------------------ - use esmFlds, only : complnd + use med_internalstate_mod, only : complnd ! intput/output variables type(ESMF_GridComp) :: gcomp @@ -1147,7 +1147,7 @@ subroutine med_phases_diag_rof( gcomp, rc) ! Compute global river input/output ! ------------------------------------------------------------------ - use esmFlds, only : comprof + use med_internalstate_mod, only : comprof ! input/output variables type(ESMF_GridComp) :: gcomp @@ -1308,7 +1308,7 @@ subroutine med_phases_diag_glc( gcomp, rc) ! Compute global glc output ! ------------------------------------------------------------------ - use esmFlds, only : compglc, num_icesheets + use med_internalstate_mod, only : compglc ! input/output variables type(ESMF_GridComp) :: gcomp @@ -1337,7 +1337,7 @@ subroutine med_phases_diag_glc( gcomp, rc) ic = c_glc_recv ip = period_inst - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets areas => is_local%wrap%mesh_info(compglc(ns))%areas call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Fogg_rofl', f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1389,7 +1389,7 @@ subroutine med_phases_diag_ocn( gcomp, rc) ! Compute global ocn input from mediator ! ------------------------------------------------------------------ - use esmFlds, only : compocn, compatm + use med_internalstate_mod, only : compocn, compatm ! input/output variables type(ESMF_GridComp) :: gcomp @@ -1627,7 +1627,7 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) ! Compute global ice input/output flux diagnostics ! ------------------------------------------------------------------ - use esmFlds, only : compice + use med_internalstate_mod, only : compice ! input/output variables type(ESMF_GridComp) :: gcomp @@ -1825,7 +1825,7 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) ! Compute global ice input/output flux diagnostics ! ------------------------------------------------------------------ - use esmFlds, only : compice + use med_internalstate_mod, only : compice ! input/output variables type(ESMF_GridComp) :: gcomp diff --git a/mediator/med_fraction_mod.F90 b/mediator/med_fraction_mod.F90 index 7b7b7ca4d..5b7944c7d 100644 --- a/mediator/med_fraction_mod.F90 +++ b/mediator/med_fraction_mod.F90 @@ -97,19 +97,19 @@ module med_fraction_mod ! !----------------------------------------------------------------------------- - use med_kind_mod , only : CX =>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 - 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 : fldbun_diagnose => med_methods_FB_diagnose - use med_methods_mod , only : fldbun_fldchk => med_methods_FB_fldchk - use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh - use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d - use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d - use med_methods_mod , only : fldbun_init => med_methods_FB_init - use med_methods_mod , only : fldbun_reset => med_methods_FB_reset - use med_map_mod , only : med_map_field - use esmFlds , only : ncomps, max_icesheets, num_icesheets + use med_kind_mod , only : CX =>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + 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 : fldbun_diagnose => med_methods_FB_diagnose + use med_methods_mod , only : fldbun_fldchk => med_methods_FB_fldchk + use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh + use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d + use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d + use med_methods_mod , only : fldbun_init => med_methods_FB_init + use med_methods_mod , only : fldbun_reset => med_methods_FB_reset + use med_map_mod , only : med_map_field + use med_internalstate_mod , only : ncomps implicit none private @@ -119,7 +119,7 @@ module med_fraction_mod public med_fraction_set integer, parameter :: nfracs = 5 - character(len=6) :: fraclist(nfracs,ncomps) + character(len=6),allocatable :: fraclist(:,:) character(len=6),parameter,dimension(4) :: fraclist_a = (/'ifrac ','ofrac ','lfrac ','aofrac'/) character(len=6),parameter,dimension(4) :: fraclist_o = (/'ifrac ','ofrac ','ifrad ','ofrad '/) character(len=6),parameter,dimension(2) :: fraclist_i = (/'ifrac ','ofrac '/) @@ -148,13 +148,13 @@ subroutine med_fraction_init(gcomp, rc) 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 : mapfcopy, mapconsd, mapnstod_consd + use med_internalstate_mod , only : coupling_mode + use med_internalstate_mod , only : compatm, compocn, compice, complnd + use med_internalstate_mod , only : comprof, compglc, compwav, compname + use med_internalstate_mod , only : mapfcopy, mapconsd, mapnstod_consd + use med_internalstate_mod , only : InternalState, logunit, mastertask use med_map_mod , only : med_map_routehandles_init, med_map_rh_is_created use med_methods_mod , only : State_getNumFields => med_methods_State_getNumFields - use med_internalstate_mod , only : InternalState, logunit, mastertask use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -198,6 +198,9 @@ subroutine med_fraction_init(gcomp, rc) if (first_call) then + ! allocate module variable + allocate(fraclist(nfracs,ncomps)) + !--------------------------------------- ! Initialize the fraclist arrays !--------------------------------------- @@ -209,7 +212,7 @@ subroutine med_fraction_init(gcomp, rc) fraclist(1:size(fraclist_l),complnd) = fraclist_l fraclist(1:size(fraclist_r),comprof) = fraclist_r fraclist(1:size(fraclist_w),compwav) = fraclist_w - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets fraclist(1:size(fraclist_g),compglc(ns)) = fraclist_g end do @@ -523,7 +526,7 @@ subroutine med_fraction_init(gcomp, rc) ! Set 'gfrac' and 'lfrac' for FBFrac(compglc) !--------------------------------------- - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%comp_present(compglc(ns))) then ! Set 'gfrac' in FBFrac(compglc(ns)) @@ -643,9 +646,9 @@ subroutine med_fraction_set(gcomp, rc) 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 esmFlds , only : compatm, compocn, compice, compname - use esmFlds , only : mapfcopy, mapconsd, mapnstod_consd - use esmFlds , only : coupling_mode + use med_internalstate_mod , only : compatm, compocn, compice, compname + use med_internalstate_mod , only : mapfcopy, mapconsd, mapnstod_consd + use med_internalstate_mod , only : coupling_mode use med_internalstate_mod , only : InternalState use med_map_mod , only : med_map_RH_is_created use perf_mod , only : t_startf, t_stopf diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index bc5287a61..8286118a9 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -4,28 +4,88 @@ module med_internalstate_mod ! Mediator Internal State Datatype. !----------------------------------------------------------------------------- - use ESMF , only : ESMF_RouteHandle, ESMF_FieldBundle, ESMF_State, ESMF_Field - use ESMF , only : ESMF_VM - use esmFlds , only : ncomps, nmappers + use ESMF , only : ESMF_RouteHandle, ESMF_FieldBundle, ESMF_State, ESMF_Field, ESMF_VM + use ESMF , only : ESMF_GridComp, ESMF_MAXSTR, ESMF_LOGMSG_INFO, ESMF_LOGWRITE 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 implicit none private + ! public routines + public :: med_internalstate_init + public :: med_internalstate_coupling + integer, public :: logunit ! logunit for mediator log output integer, public :: diagunit ! diagunit for budget output (med master only) - integer, public :: loglevel ! loglevel for mediator log output logical, public :: mastertask=.false. ! is this the mastertask integer, public :: med_id ! needed currently in med_io_mod and set in esm.F90 - ! Active coupling definitions (will be initialize in med.F90) - logical, public :: med_coupling_allowed(ncomps, ncomps) + ! Components + integer, public :: compmed = 1 + integer, public :: compatm = 2 + integer, public :: complnd = 3 + integer, public :: compocn = 4 + integer, public :: compice = 5 + integer, public :: comprof = 6 + integer, public :: compwav = 7 + integer, public :: ncomps = 7 ! this will be incremented if the size of compglc is > 0 + integer, public, allocatable :: compglc(:) - 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 + ! Generic component name (e.g. atm, ocn...) + character(len=CS), public, allocatable :: compname(:) + + ! Specific component name (e.g. datm, mom6, etc...) + character(len=CS), public :: med_name = '' + character(len=CS), public :: atm_name = '' + character(len=CS), public :: lnd_name = '' + character(len=CS), public :: ocn_name = '' + character(len=CS), public :: ice_name = '' + character(len=CS), public :: rof_name = '' + character(len=CS), public :: wav_name = '' + character(len=CS), public :: glc_name = '' + + ! Coupling mode + character(len=CS), public :: coupling_mode ! valid values are [cesm,nems_orig,nems_frac,nems_orig_data,hafs] + + ! Mapping + 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 :: mapbilnr_uv3d = 10 ! rotate u,v to 3d cartesian space, map from src->dest, then rotate back + integer , public, parameter :: map_rof2ocn_ice = 11 ! custom smoothing map to map ice from rof->ocn (cesm only) + integer , public, parameter :: map_rof2ocn_liq = 12 ! custom smoothing map to map liq from rof->ocn (cesm only) + integer , public, parameter :: map_glc2ocn_liq = 13 ! custom smoothing map to map liq from glc->ocn (cesm only) + integer , public, parameter :: map_glc2ocn_ice = 14 ! custom smoothing map to map ice from glc->ocn (cesm only) + integer , public, parameter :: mapfillv_bilnr = 15 ! fill value followed by bilinear + integer , public, parameter :: mapbilnr_nstod = 16 ! bilinear with nstod extrapolation + integer , public, parameter :: mapconsf_aofrac = 17 ! conservative with aofrac normalization (ufs only) + integer , public, parameter :: nmappers = 17 + character(len=*) , public, parameter :: mapnames(nmappers) = & + (/'bilnr ',& + 'consf ',& + 'consd ',& + 'patch ',& + 'fcopy ',& + 'nstod ',& + 'nstod_consd ',& + 'nstod_consf ',& + 'patch_uv3d ',& + 'bilnr_uv3d ',& + 'rof2ocn_ice ',& + 'rof2ocn_liq ',& + 'glc2ocn_ice ',& + 'glc2ocn_liq ',& + 'fillv_bilnr ',& + 'bilnr_nstod ',& + 'consf_aofrac'/) type, public :: packed_data_type integer, allocatable :: fldindex(:) ! size of number of packed fields @@ -36,67 +96,81 @@ module med_internalstate_mod type(ESMF_Field) :: field_fracdst end type packed_data_type + logical, public :: dststatus_print = .false. + + ! Mesh info + 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 + ! private internal state to keep instance data type InternalStateStruct - ! NState_Imp and NState_Exp are the standard NUOPC coupling datatypes - ! FBImp and FBExp are the internal mediator datatypes - ! NState_Exp(n) = FBExp(n), copied in the connector prep phase - ! FBImp(n,n) = NState_Imp(n), copied in connector post phase - ! FBImp(n,k) is the FBImp(n,n) interpolated to grid k - ! RH(n,k,m) is a RH from grid n to grid k, map type m - - ! Present/Active logical flags - logical :: comp_present(ncomps) ! comp present flag - logical :: med_coupling_active(ncomps,ncomps) ! computes the active coupling + ! Present/allowed coupling/active coupling logical flags + logical, pointer :: comp_present(:) ! comp present flag + logical, pointer :: med_coupling_active(:,:) ! computes the active coupling + integer :: num_icesheets ! obtained from attribute + logical :: ocn2glc_coupling = .false. ! obtained from attribute + logical :: lnd2glc_coupling = .false. + logical :: accum_lnd2glc = .false. ! 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, pointer :: nx(:), ny(:) ! 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 - real(r8) :: flds_scalar_precip_factor = 1._r8 ! actual value of precip factor from ocn + 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 + real(r8) :: flds_scalar_precip_factor = 1._r8 ! actual value of precip factor from ocn + ! NState_Imp and NState_Exp are the standard NUOPC coupling datatypes + ! FBImp and FBExp are the internal mediator datatypes + ! NState_Exp(n) = FBExp(n), copied in the connector prep phase + ! FBImp(n,n) = NState_Imp(n), copied in connector post phase + ! FBImp(n,k) is the FBImp(n,n) interpolated to grid k ! 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 - type(ESMF_State) :: NStateExp(ncomps) ! Export data to various component, on their grid - type(ESMF_FieldBundle) :: FBImp(ncomps,ncomps) ! Import data from various components interpolated to various grids - type(ESMF_FieldBundle) :: FBExp(ncomps) ! Export data for various components, on their grid + type(ESMF_State) , pointer :: NStateImp(:) ! Import data from various component, on their grid + type(ESMF_State) , pointer :: NStateExp(:) ! Export data to various component, on their grid + type(ESMF_FieldBundle) , pointer :: FBImp(:,:) ! Import data from various components interpolated to various grids + type(ESMF_FieldBundle) , pointer :: FBExp(:) ! Export data for various components, on their grid ! Mediator field bundles for ocean albedo - 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_ocnalb_o ! Ocn albedo on ocn grid + type(ESMF_FieldBundle) :: FBMed_ocnalb_a ! Ocn albedo on atm grid + type(packed_data_type), pointer :: packed_data_ocnalb_o2a(:) ! packed data for mapping ocn->atm ! Mediator field bundles and other info for atm/ocn flux computation + character(len=CS) :: aoflux_grid ! 'ogrid', 'agrid' or 'xgrid' type(ESMF_FieldBundle) :: FBMed_aoflux_a ! Ocn/Atm flux output fields on atm grid type(ESMF_FieldBundle) :: FBMed_aoflux_o ! Ocn/Atm flux output fields on ocn grid - type(packed_data_type) :: packed_data_aoflux_o2a(nmappers) ! packed data for mapping ocn->atm - character(len=CS) :: aoflux_grid ! 'ogrid', 'agrid' or 'xgrid' + type(packed_data_type), pointer :: packed_data_aoflux_o2a(:) ! packed data for mapping ocn->atm ! Mapping - 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 + ! RH(n,k,m) is a RH from grid n to grid k, map type m + type(ESMF_RouteHandle) , pointer :: RH(:,:,:) ! Routehandles for pairs of components and different mappers + type(ESMF_Field) , pointer :: field_NormOne(:,:,:) ! Unity static normalization + type(packed_data_type) , pointer :: packed_data(:,:,:) ! Packed data structure needed to efficiently map field bundles ! Fractions - type(ESMF_FieldBundle) :: FBfrac(ncomps) ! Fraction data for various components, on their grid + type(ESMF_FieldBundle), pointer :: FBfrac(:) ! Fraction data for various components, on their grid ! Accumulators for export field bundles - type(ESMF_FieldBundle) :: FBExpAccumOcn ! Accumulator for various components export on their grid - integer :: ExpAccumOcnCnt = 0 ! Accumulator counter for each FBExpAccum + type(ESMF_FieldBundle) :: FBExpAccumOcn ! Accumulator for Ocn export on Ocn grid + integer :: ExpAccumOcnCnt = 0 ! Accumulator counter for FBExpAccumOcn + type(ESMF_FieldBundle) :: FBExpAccumWav ! Accumulator for Wav export on Wav grid + integer :: ExpAccumWavCnt = 0 ! Accumulator counter for FBExpAccumWav ! Component Mesh info - type(mesh_info_type) :: mesh_info(ncomps) - type(ESMF_FieldBundle) :: FBArea(ncomps) ! needed for mediator history writes + type(mesh_info_type) , pointer :: mesh_info(:) + type(ESMF_FieldBundle) , pointer :: FBArea(:) ! needed for mediator history writes end type InternalStateStruct @@ -104,4 +178,377 @@ module med_internalstate_mod type(InternalStateStruct), pointer :: wrap end type InternalState + character(len=*), parameter :: u_FILE_u = & + __FILE__ + +!===================================================================== +contains +!===================================================================== + + subroutine med_internalstate_init(gcomp, rc) + + use ESMF , only : ESMF_LogFoundAllocError, ESMF_AttributeGet + use NUOPC_Comp , only : NUOPC_CompAttributeGet + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer , intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + logical :: ispresent, isset + integer :: n, ns, n1, n2 + integer :: stat + logical :: glc_present + character(len=8) :: cnum + character(len=CS) :: cvalue + character(len=CL) :: cname + character(len=ESMF_MAXSTR) :: mesh_glc + character(len=CX) :: msgString + character(len=3) :: name + integer :: num_icesheets + character(len=*),parameter :: subname=' (internalstate init) ' + !----------------------------------------------------------- + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Determine if glc is present + call NUOPC_CompAttributeGet(gcomp, name='GLC_model', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + num_icesheets = 0 + if (isPresent .and. isSet) then + if (trim(cvalue) /= 'sglc') then + call NUOPC_CompAttributeGet(gcomp, name='mesh_glc', value=mesh_glc, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + glc_name = trim(cvalue) + if (isPresent .and. isSet) then + ! determine number of ice sheets - search in mesh_glc for colon deliminted strings + if (len_trim(cvalue) > 0) then + do n = 1, len_trim(mesh_glc) + if (mesh_glc(n:n) == ':') num_icesheets = num_icesheets + 1 + end do + num_icesheets = num_icesheets + 1 + endif + if (mastertask) then + write(logunit,'(a,i8)') trim(subname)//' number of ice sheets is ',num_icesheets + end if + end if + ! now determing the number of multiple ice sheets and increment ncomps accordingly + allocate(compglc(num_icesheets)) + compglc(:) = 0 + do ns = 1,num_icesheets + ncomps = ncomps + 1 + compglc(ns) = ncomps + end do + end if + end if + + ! Determine present flags starting with glc component + allocate(is_local%wrap%comp_present(ncomps)) + is_local%wrap%comp_present(:) = .false. + if (num_icesheets > 0) then + do ns = 1,num_icesheets + is_local%wrap%comp_present(compglc(ns)) = .true. + end do + end if + is_local%wrap%num_icesheets = num_icesheets + + 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 + read(cvalue,*) is_local%wrap%comp_present(compmed) + end if + call NUOPC_CompAttributeGet(gcomp, name='MED_model', value=med_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name='ATM_model', value=atm_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(atm_name) /= 'satm') is_local%wrap%comp_present(compatm) = .true. + end if + call NUOPC_CompAttributeGet(gcomp, name='LND_model', value=lnd_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(lnd_name) /= 'slnd') is_local%wrap%comp_present(complnd) = .true. + end if + call NUOPC_CompAttributeGet(gcomp, name='OCN_model', value=ocn_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(ocn_name) /= 'socn') is_local%wrap%comp_present(compocn) = .true. + end if + call NUOPC_CompAttributeGet(gcomp, name='ICE_model', value=ice_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(ice_name) /= 'sice') is_local%wrap%comp_present(compice) = .true. + end if + call NUOPC_CompAttributeGet(gcomp, name='ROF_model', value=rof_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(rof_name) /= 'srof') is_local%wrap%comp_present(comprof) = .true. + end if + call NUOPC_CompAttributeGet(gcomp, name='WAV_model', value=wav_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(wav_name) /= 'swav') is_local%wrap%comp_present(compwav) = .true. + end if + + ! Allocate memory now that ncomps is determined + allocate(is_local%wrap%med_coupling_active(ncomps,ncomps)) + allocate(is_local%wrap%nx(ncomps)) + allocate(is_local%wrap%ny(ncomps)) + allocate(is_local%wrap%NStateImp(ncomps)) + allocate(is_local%wrap%NStateExp(ncomps)) + allocate(is_local%wrap%FBImp(ncomps,ncomps)) + allocate(is_local%wrap%FBExp(ncomps)) + allocate(is_local%wrap%packed_data_ocnalb_o2a(nmappers)) + allocate(is_local%wrap%packed_data_aoflux_o2a(nmappers)) + allocate(is_local%wrap%RH(ncomps,ncomps,nmappers)) + allocate(is_local%wrap%field_NormOne(ncomps,ncomps,nmappers)) + allocate(is_local%wrap%packed_data(ncomps,ncomps,nmappers)) + allocate(is_local%wrap%FBfrac(ncomps)) + allocate(is_local%wrap%FBArea(ncomps)) + allocate(is_local%wrap%mesh_info(ncomps)) + + ! Determine component names + allocate(compname(ncomps)) + compname(compmed) = 'med' + compname(compatm) = 'atm' + compname(complnd) = 'lnd' + compname(compocn) = 'ocn' + compname(compice) = 'ice' + compname(comprof) = 'rof' + compname(compwav) = 'wav' + do ns = 1,is_local%wrap%num_icesheets + write(cnum,'(i0)') ns + compname(compglc(ns)) = 'glc' // trim(cnum) + end do + + if (mastertask) then + ! Write out present flags + write(logunit,*) + do n1 = 1,ncomps + name = trim(compname(n1)) ! this trims the ice sheets index from the glc name + write(msgString,'(A,L4)') trim(subname)//' comp_present(comp'//name//') = ',& + is_local%wrap%comp_present(n1) + write(logunit,'(a)') trim(msgString) + end do + + ! Write out model names if they are present + write(logunit,*) + if (is_local%wrap%comp_present(compatm)) write(logunit,'(a)') trim(subname) // " atm model= "//trim(atm_name) + if (is_local%wrap%comp_present(complnd)) write(logunit,'(a)') trim(subname) // " lnd model= "//trim(lnd_name) + if (is_local%wrap%comp_present(compocn)) write(logunit,'(a)') trim(subname) // " ocn model= "//trim(ocn_name) + if (is_local%wrap%comp_present(compice)) write(logunit,'(a)') trim(subname) // " ice model= "//trim(ice_name) + if (is_local%wrap%comp_present(comprof)) write(logunit,'(a)') trim(subname) // " rof model= "//trim(rof_name) + if (is_local%wrap%comp_present(compwav)) write(logunit,'(a)') trim(subname) // " wav model= "//trim(wav_name) + if (is_local%wrap%comp_present(compmed)) write(logunit,'(a)') trim(subname) // " med model= "//trim(med_name) + if (is_local%wrap%num_icesheets > 0) then + if (is_local%wrap%comp_present(compglc(1))) write(logunit,'(a)') trim(subname) // " glc model= "//trim(glc_name) + end if + write(logunit,*) + end if + + ! Obtain dststatus_print setting if present + call NUOPC_CompAttributeGet(gcomp, name='dststatus_print', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) dststatus_print=(trim(cvalue)=="true") + write(msgString,*) trim(subname)//': Mediator dststatus_print is ',dststatus_print + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + end subroutine med_internalstate_init + + !===================================================================== + subroutine med_internalstate_coupling(gcomp, rc) + + !---------------------------------------------------------- + ! Check for active coupling interactions + ! must be allowed, bundles created, and both sides have some fields + ! This is called from med.F90 in the DataInitialize routine + !---------------------------------------------------------- + + use ESMF , only : ESMF_StateIsCreated + use NUOPC , only : NUOPC_CompAttributeGet + use med_methods_mod , only : State_getNumFields => med_methods_State_getNumFields + + ! input/output variables + type(ESMF_GridComp) , intent(inout) :: gcomp + integer , intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + integer :: n1, n2, ns + integer :: cntn1, cntn2 + logical, allocatable :: med_coupling_allowed(:,:) + character(len=CL) :: cvalue + character(len=CX) :: msgString + logical :: isPresent, isSet + character(len=*),parameter :: subname=' (internalstate allowed coupling) ' + !----------------------------------------------------------- + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! This defines the med_coupling_allowed a starting point for what is + ! allowed in this coupled system. It will be revised further after the system + ! starts, but any coupling set to false will never be allowed. + ! are allowed, just update the table below. + + if (mastertask) then + write(logunit,'(a)') trim(subname) // "Initializing active coupling flags" + end if + + ! Initialize med_coupling_allowed + allocate(med_coupling_allowed(ncomps,ncomps)) + med_coupling_allowed(:,:) = .false. + is_local%wrap%med_coupling_active(:,:) = .false. + + ! to atmosphere + med_coupling_allowed(complnd,compatm) = .true. + med_coupling_allowed(compice,compatm) = .true. + med_coupling_allowed(compocn,compatm) = .true. + med_coupling_allowed(compwav,compatm) = .true. + + ! to land + med_coupling_allowed(compatm,complnd) = .true. + med_coupling_allowed(comprof,complnd) = .true. + do ns = 1,is_local%wrap%num_icesheets + med_coupling_allowed(compglc(ns),complnd) = .true. + end do + + ! to ocean + med_coupling_allowed(compatm,compocn) = .true. + med_coupling_allowed(compice,compocn) = .true. + med_coupling_allowed(comprof,compocn) = .true. + med_coupling_allowed(compwav,compocn) = .true. + do ns = 1,is_local%wrap%num_icesheets + med_coupling_allowed(compglc(ns),compocn) = .true. + end do + + ! to ice + med_coupling_allowed(compatm,compice) = .true. + med_coupling_allowed(compocn,compice) = .true. + med_coupling_allowed(comprof,compice) = .true. + med_coupling_allowed(compwav,compice) = .true. + do ns = 1,is_local%wrap%num_icesheets + med_coupling_allowed(compglc(ns),compice) = .true. + end do + + ! to river + med_coupling_allowed(complnd,comprof) = .true. + + ! to wave + med_coupling_allowed(compatm,compwav) = .true. + med_coupling_allowed(compocn,compwav) = .true. + med_coupling_allowed(compice,compwav) = .true. + + ! to land-ice + call NUOPC_CompAttributeGet(gcomp, name='ocn2glc_coupling', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + ! are multiple ocean depths for temperature and salinity sent from the ocn to glc? + read(cvalue,*) is_local%wrap%ocn2glc_coupling + else + is_local%wrap%ocn2glc_coupling = .false. + end if + do ns = 1,is_local%wrap%num_icesheets + med_coupling_allowed(complnd,compglc(ns)) = .true. + med_coupling_allowed(compocn,compglc(ns)) = is_local%wrap%ocn2glc_coupling + end do + + ! initialize med_coupling_active table + is_local%wrap%med_coupling_active(:,:) = .false. + do n1 = 1,ncomps + if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then + call State_GetNumFields(is_local%wrap%NStateImp(n1), cntn1, rc=rc) ! Import Field Count + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (cntn1 > 0) then + do n2 = 1,ncomps + if (is_local%wrap%comp_present(n2) .and. ESMF_StateIsCreated(is_local%wrap%NStateExp(n2),rc=rc) .and. & + med_coupling_allowed(n1,n2)) then + call State_GetNumFields(is_local%wrap%NStateExp(n2), cntn2, rc=rc) ! Import Field Count + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (cntn2 > 0) is_local%wrap%med_coupling_active(n1,n2) = .true. + endif + enddo + end if + endif + enddo + + ! create tables of allowed and active coupling flags + ! - the rows are the destination of coupling + ! - the columns are the source of coupling + ! - So, the second column indicates which models the atm is coupled to. + ! - And the second row indicates which models are coupled to the atm. + if (mastertask) then + write(logunit,*) ' ' + write(logunit,'(A)') trim(subname)//' Allowed coupling flags' + write(logunit,'(2x,A10,20(A5))') '|from to -> ',(compname(n2),n2=1,ncomps) + do n1 = 1,ncomps + write(msgString,'(2x,a1,A,5x,20(L5))') '|',trim(compname(n1)), & + (med_coupling_allowed(n1,n2),n2=1,ncomps) + do n2 = 1,len_trim(msgString) + if (msgString(n2:n2) == 'F') msgString(n2:n2)='-' + enddo + write(logunit,'(A)') trim(msgString) + enddo + + write(logunit,*) ' ' + write(logunit,'(A)') subname//' Active coupling flags' + write(logunit,'(2x,A10,20(A5))') '|from to -> ',(compname(n2),n2=1,ncomps) + do n1 = 1,ncomps + write(msgString,'(2x,a1,A,5x,20(L5))') '|',trim(compname(n1)), & + (is_local%wrap%med_coupling_active(n1,n2),n2=1,ncomps) + do n2 = 1,len_trim(msgString) + if (msgString(n2:n2) == 'F') msgString(n2:n2)='-' + enddo + write(logunit,'(A)') trim(msgString) + enddo + write(logunit,*) ' ' + endif + + ! Determine lnd2glc_coupling flag + do ns = 1,is_local%wrap%num_icesheets + if (is_local%wrap%med_coupling_active(complnd,compglc(ns))) then + is_local%wrap%lnd2glc_coupling = .true. + exit + end if + end do + + ! Determine accum_lnd2glc flag + if (is_local%wrap%lnd2glc_coupling) then + is_local%wrap%accum_lnd2glc = .true. + else + ! Determine if will create auxiliary history file that contains + ! lnd2glc data averaged over the year + call NUOPC_CompAttributeGet(gcomp, name="histaux_l2x1yrg", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) is_local%wrap%accum_lnd2glc + end if + end if + + ! Determine ocn2glc_coupling flag + do ns = 1,is_local%wrap%num_icesheets + if (is_local%wrap%med_coupling_active(compocn,compglc(ns))) then + is_local%wrap%ocn2glc_coupling = .true. + exit + end if + end do + if (.not. is_local%wrap%ocn2glc_coupling) then + ! Reset ocn2glc active coupling based in input attribute + do ns = 1,is_local%wrap%num_icesheets + is_local%wrap%med_coupling_active(compocn,compglc(ns)) = .false. + end do + end if + + ! Dealloate memory + deallocate(med_coupling_allowed) + + end subroutine med_internalstate_coupling + end module med_internalstate_mod diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 6b713398a..5921d927e 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -75,16 +75,17 @@ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, flds_scalar_name, llogun ! for the field !--------------------------------------------- - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush - use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_Field - 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 ESMF , only : ESMF_Mesh, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT - use med_methods_mod , only : med_methods_FB_getFieldN, med_methods_FB_getNameN - use med_constants_mod , only : czero => med_constants_czero - use esmFlds , only : fldListFr, ncomps, mapunset, compname, compocn, compatm - use esmFlds , only : ncomps, nmappers, compname, mapnames, mapfcopy + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_Field + 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 ESMF , only : ESMF_Mesh, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT + use med_methods_mod , only : med_methods_FB_getFieldN, med_methods_FB_getNameN + use med_constants_mod , only : czero => med_constants_czero + use esmFlds , only : fldListFr + use med_internalstate_mod , only : mapunset, compname, compocn, compatm + use med_internalstate_mod , only : ncomps, nmappers, compname, mapnames, mapfcopy ! input/output variables type(ESMF_GridComp) :: gcomp @@ -324,25 +325,25 @@ 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, ESMF_POLEMETHOD_NONE - use ESMF , only : ESMF_FieldSMMStore, ESMF_FieldRedistStore, ESMF_FieldRegridStore - use ESMF , only : ESMF_RouteHandleIsCreated, ESMF_RouteHandleCreate - use ESMF , only : ESMF_REGRIDMETHOD_BILINEAR, ESMF_REGRIDMETHOD_PATCH - use ESMF , only : ESMF_REGRIDMETHOD_CONSERVE, ESMF_NORMTYPE_DSTAREA, ESMF_NORMTYPE_FRACAREA - use ESMF , only : ESMF_UNMAPPEDACTION_IGNORE, ESMF_REGRIDMETHOD_NEAREST_STOD - use ESMF , only : ESMF_EXTRAPMETHOD_NEAREST_STOD - use ESMF , only : ESMF_Mesh, ESMF_MeshLoc, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_I4 - use ESMF , only : ESMF_MeshGet, ESMF_DistGridGet, ESMF_DistGrid, ESMF_TYPEKIND_R8 - use ESMF , only : ESMF_FieldGet, ESMF_FieldCreate, ESMF_FieldWrite, ESMF_FieldDestroy - use esmFlds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d, mapbilnr_uv3d, mapfcopy - use esmFlds , only : mapunset, mapnames, nmappers - use esmFlds , only : mapnstod, mapnstod_consd, mapnstod_consf, mapnstod_consd - use esmFlds , only : mapfillv_bilnr, mapbilnr_nstod, mapconsf_aofrac - use esmFlds , only : ncomps, compatm, compice, compocn, compwav, compname - use esmFlds , only : coupling_mode, dststatus_print - use esmFlds , only : atm_name - use med_constants_mod , only : ispval_mask => med_constants_ispval_mask + use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandlePrint, ESMF_Field, ESMF_MAXSTR + use ESMF , only : ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG, ESMF_POLEMETHOD_NONE + use ESMF , only : ESMF_FieldSMMStore, ESMF_FieldRedistStore, ESMF_FieldRegridStore + use ESMF , only : ESMF_RouteHandleIsCreated, ESMF_RouteHandleCreate + use ESMF , only : ESMF_REGRIDMETHOD_BILINEAR, ESMF_REGRIDMETHOD_PATCH + use ESMF , only : ESMF_REGRIDMETHOD_CONSERVE, ESMF_NORMTYPE_DSTAREA, ESMF_NORMTYPE_FRACAREA + use ESMF , only : ESMF_UNMAPPEDACTION_IGNORE, ESMF_REGRIDMETHOD_NEAREST_STOD + use ESMF , only : ESMF_EXTRAPMETHOD_NEAREST_STOD + use ESMF , only : ESMF_Mesh, ESMF_MeshLoc, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_I4 + use ESMF , only : ESMF_MeshGet, ESMF_DistGridGet, ESMF_DistGrid, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_FieldGet, ESMF_FieldCreate, ESMF_FieldWrite, ESMF_FieldDestroy + use med_internalstate_mod , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d, mapbilnr_uv3d, mapfcopy + use med_internalstate_mod , only : mapunset, mapnames, nmappers + use med_internalstate_mod , only : mapnstod, mapnstod_consd, mapnstod_consf, mapnstod_consd + use med_internalstate_mod , only : mapfillv_bilnr, mapbilnr_nstod, mapconsf_aofrac + use med_internalstate_mod , only : ncomps, compatm, compice, compocn, compwav, compname + use med_internalstate_mod , only : coupling_mode, dststatus_print + use med_internalstate_mod , only : atm_name + use med_constants_mod , only : ispval_mask => med_constants_ispval_mask ! input/output variables integer , intent(in) :: n1 @@ -402,18 +403,19 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, polemethod = ESMF_POLEMETHOD_NONE ! todo: remove this when ESMF tripolar mapping fix is in place. endif else if (coupling_mode(1:4) == 'nems') then - if (n1 == compatm .and. (n2 == compocn .or. n2 == compice)) then + if ( (n1 == compocn .or. n1 == compice .or. n1 == compwav) .and. & + (n2 == compocn .or. n2 == compice .or. n2 == compwav) ) then + srcMaskValue = 0 + dstMaskValue = 0 + else if (n1 == compatm .and. (n2 == compocn .or. n2 == compice .or. n2 == compwav)) then srcMaskValue = 1 dstMaskValue = 0 if (atm_name(1:4).eq.'datm') then - srcMaskValue = 0 + srcMaskValue = 0 endif - else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice)) then + else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice .or. n1 == compwav)) 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 @@ -433,14 +435,16 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, srcMaskValue = 0 dstMaskValue = ispval_mask elseif (n1 == compatm .and. n2 == compwav) then - dstMaskValue = 1 + dstMaskValue = 0 elseif (n1 == compwav .and. n2 == compatm) then - srcMaskValue = 1 + srcMaskValue = 0 dstMaskValue = ispval_mask endif end if - write(string,'(a)') trim(compname(n1))//' to '//trim(compname(n2)) + write(string,'(a,i10,a,i10)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & + srcMaskValue,' dstMask = ',dstMaskValue + call ESMF_LogWrite(trim(string), ESMF_LOGMSG_INFO) ! Create route handle if (mapindex == mapfcopy) then @@ -680,9 +684,9 @@ 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 esmFlds , only : mapconsd, mapconsf, mapnstod - use esmFlds , only : mapnstod_consd, mapnstod_consf + use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandleIsCreated + use med_internalstate_mod , only : mapconsd, mapconsf, mapnstod + use med_internalstate_mod , only : mapnstod_consd, mapnstod_consf ! input/output varaibes type(ESMF_RouteHandle) , intent(in) :: RHs(:) @@ -730,8 +734,9 @@ subroutine med_map_packed_field_create(destcomp, flds_scalar_name, & fldsSrc, FBSrc, FBDst, packed_data, rc) use ESMF - use esmFlds , only : med_fldList_entry_type, nmappers - use esmFlds , only : ncomps, compatm, compice, compocn, compname, mapnames + use esmFlds , only : med_fldList_entry_type + use med_internalstate_mod , only : nmappers + use med_internalstate_mod , only : ncomps, compatm, compice, compocn, compname, mapnames use med_internalstate_mod , only : packed_data_type ! input/output variables @@ -933,8 +938,8 @@ subroutine med_map_field_packed(FBSrc, FBDst, FBFracSrc, field_normOne, packed_d use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet use ESMF , only : ESMF_FieldBundleIsCreated use ESMF , only : ESMF_FieldRedist, ESMF_RouteHandle - use esmFlds , only : nmappers, mapfcopy - use esmFlds , only : mappatch_uv3d, mappatch, mapbilnr_uv3d, mapbilnr + use med_internalstate_mod , only : nmappers, mapfcopy + use med_internalstate_mod , only : mappatch_uv3d, mappatch, mapbilnr_uv3d, mapbilnr use med_internalstate_mod , only : packed_data_type ! input/output variables @@ -1262,18 +1267,18 @@ subroutine med_map_field(field_src, field_dst, routehandles, maptype, fldname, r ! 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_KIND_R8 - use ESMF , only : ESMF_Field, ESMF_FieldRegrid - use ESMF , only : ESMF_FieldFill - 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 esmFlds , only : mapfillv_bilnr - use med_methods_mod , only : Field_diagnose => med_methods_Field_diagnose + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_MAXSTR + use ESMF , only : ESMF_KIND_R8 + use ESMF , only : ESMF_Field, ESMF_FieldRegrid + use ESMF , only : ESMF_FieldFill + use ESMF , only : ESMF_TERMORDER_SRCSEQ, ESMF_Region_Flag, ESMF_REGION_TOTAL + use ESMF , only : ESMF_REGION_SELECT + use ESMF , only : ESMF_RouteHandle + use med_internalstate_mod , only : mapnstod_consd, mapnstod_consf, mapnstod_consd, mapnstod + use med_internalstate_mod , only : mapconsd, mapconsf + use med_internalstate_mod , only : mapfillv_bilnr + use med_methods_mod , only : Field_diagnose => med_methods_Field_diagnose ! input/output variables type(ESMF_Field) , intent(in) :: field_src diff --git a/mediator/med_merge_mod.F90 b/mediator/med_merge_mod.F90 index c226b1ab9..bd1aa4f80 100644 --- a/mediator/med_merge_mod.F90 +++ b/mediator/med_merge_mod.F90 @@ -5,13 +5,12 @@ module med_merge_mod !----------------------------------------------------------------------------- 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 : logunit + use med_internalstate_mod , only : logunit, compmed, compname 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_FldChk => med_methods_FB_FldChk use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr - use esmFlds , only : compmed, compname use esmFlds , only : med_fldList_type use esmFlds , only : med_fldList_GetNumFlds use esmFlds , only : med_fldList_GetFldInfo diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index d8aa7acdd..2b28164ac 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -16,7 +16,8 @@ module med_phases_aofluxes_mod use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet use ESMF , only : ESMF_FieldBundleCreate, ESMF_FieldBundleAdd use ESMF , only : ESMF_RouteHandle, ESMF_FieldRegrid, ESMF_FieldRegridStore - use ESMF , only : ESMF_REGRIDMETHOD_CONSERVE_2ND + use ESMF , only : ESMF_REGRIDMETHOD_CONSERVE_2ND, ESMF_REGRIDMETHOD_CONSERVE + use ESMF , only : ESMF_REGRIDMETHOD_PATCH, ESMF_REGRIDMETHOD_BILINEAR use ESMF , only : ESMF_TERMORDER_SRCSEQ, ESMF_REGION_TOTAL, ESMF_MESHLOC_ELEMENT, ESMF_MAXSTR use ESMF , only : ESMF_XGRIDSIDE_B, ESMF_XGRIDSIDE_A, ESMF_END_ABORT, ESMF_LOGERR_PASSTHRU use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_XGrid, ESMF_XGridCreate, ESMF_TYPEKIND_R8 @@ -24,10 +25,10 @@ module med_phases_aofluxes_mod use ESMF , only : ESMF_Finalize, ESMF_LogFoundError 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, mastertask, logunit + use med_internalstate_mod , only : compatm, compocn, coupling_mode, mapconsd, mapconsf, mapfcopy 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 esmFlds , only : compatm, compocn, coupling_mode, mapconsd, mapconsf, mapfcopy use perf_mod , only : t_startf, t_stopf implicit none @@ -39,6 +40,10 @@ module med_phases_aofluxes_mod public :: med_phases_aofluxes_init_fldbuns public :: med_phases_aofluxes_run + public :: med_aofluxes_map_ogrid2agrid_output + public :: med_aofluxes_map_xgrid2agrid_output + public :: med_aofluxes_map_xgrid2ogrid_output + public :: med_aofluxes_map_agrid2ogrid_output !-------------------------------------------------------------------------- ! Private routines @@ -48,6 +53,9 @@ module med_phases_aofluxes_mod private :: med_aofluxes_init_ogrid private :: med_aofluxes_init_agrid private :: med_aofluxes_init_xgrid + private :: med_aofluxes_map_ogrid2xgrid_input + private :: med_aofluxes_map_agrid2xgrid_input + private :: med_aofluxes_map_ogrid2agrid_input private :: med_aofluxes_update private :: set_aoflux_in_pointers private :: set_aoflux_out_pointers @@ -79,8 +87,11 @@ module med_phases_aofluxes_mod type(ESMF_RouteHandle) :: rh_xgrid2agrid ! xgrid->atm mapping type(ESMF_RouteHandle) :: rh_ogrid2xgrid_2ndord ! ocn->xgrid mapping 2nd order conservative type(ESMF_RouteHandle) :: rh_agrid2xgrid_2ndord ! atm->xgrid mapping 2nd order conservative - type(ESMF_Field) :: field_ogrid2xgrid_normone - type(ESMF_Field) :: field_xgrid2agrid_normone + type(ESMF_RouteHandle) :: rh_agrid2xgrid_bilinr ! atm->xgrid mapping bilinear + type(ESMF_RouteHandle) :: rh_agrid2xgrid_patch ! atm->xgrid mapping patch + type(ESMF_XGrid) :: xgrid + type(ESMF_Field) :: field_o + type(ESMF_Field) :: field_x type aoflux_in_type ! input: ocn @@ -139,9 +150,11 @@ module med_phases_aofluxes_mod subroutine med_phases_aofluxes_init_fldbuns(gcomp, rc) use ESMF , only : ESMF_FieldBundleIsCreated - use esmFlds , only : med_fldList_GetNumFlds, med_fldList_GetFldNames, compname + use esmFlds , only : med_fldList_GetNumFlds + use esmFlds , only : med_fldList_GetFldNames use esmFlds , only : fldListMed_aoflux use med_methods_mod , only : FB_init => med_methods_FB_init + use med_internalstate_mod, only : compname ! input/output variables type(ESMF_GridComp) :: gcomp @@ -310,13 +323,13 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) use ESMF , only : ESMF_SUCCESS, ESMF_LOGERR_PASSTHRU use ESMF , only : ESMF_GridComp, ESMF_GridCompGet use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldBundle - use esmFlds , only : coupling_mode use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk #ifdef CESMCOUPLED use shr_flux_mod , only : shr_flux_adjust_constants #else use flux_atmocn_mod , only : flux_adjust_constants #endif + !----------------------------------------------------------------------- ! Initialize pointers to the module variables !----------------------------------------------------------------------- @@ -655,7 +668,7 @@ subroutine med_aofluxes_init_agrid(gcomp, aoflux_in, aoflux_out, rc) routehandles=is_local%wrap%RH(compocn,compatm,:), maptype=maptype, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldDestroy(field_src, rc=rc, noGarbage=.true.) + call ESMF_FieldDestroy(field_src, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if @@ -679,20 +692,13 @@ subroutine med_aofluxes_init_xgrid(gcomp, aoflux_in, aoflux_out, rc) integer :: n integer :: lsize type(InternalState) :: is_local - type(ESMF_Field) :: lfield_a - type(ESMF_Field) :: lfield_o - type(ESMF_Field) :: lfield_x + type(ESMF_Field) :: field_a + type(ESMF_Field) :: field_o type(ESMF_Field) :: lfield integer :: elementCount type(ESMF_Mesh) :: ocn_mesh type(ESMF_Mesh) :: atm_mesh - integer, allocatable :: ocn_mask(:) - type(ESMF_XGrid) :: xgrid - type(ESMF_Field) :: field_src ! needed for normalization - type(ESMF_Field) :: field_dst ! needed for normalization - type(ESMF_Mesh) :: mesh_src ! needed for normalization - type(ESMF_Mesh) :: mesh_dst ! needed for normalization - real(r8), pointer :: dataptr1d(:) + real(r8), pointer :: dataptr(:) integer :: fieldcount character(ESMF_MAXSTR),allocatable :: fieldNameList(:) character(len=*),parameter :: subname=' (med_aofluxes_init_xgrid) ' @@ -726,6 +732,13 @@ subroutine med_aofluxes_init_xgrid(gcomp, aoflux_in, aoflux_out, rc) storeOverlay=.true., rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ! create module field on exchange grid and set its initial value to 1 + field_x = ESMF_FieldCreate(xgrid, typekind=ESMF_TYPEKIND_R8, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_x, farrayptr=dataptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + dataptr(:) = 1.0_r8 + ! ------------------------ ! input fields from atm and ocn on xgrid ! ------------------------ @@ -763,17 +776,33 @@ subroutine med_aofluxes_init_xgrid(gcomp, aoflux_in, aoflux_out, rc) ! create the routehandles atm->xgrid and xgrid->atm ! ------------------------ - call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), trim(fldnames_atm_in(1)), field=lfield_a, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldBundleGet(FBatm_x, trim(fldnames_atm_in(1)), field=lfield_x, rc=rc) + ! create temporary field + field_a = ESMF_FieldCreate(atm_mesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridStore(xgrid, lfield_a, lfield_x, routehandle=rh_agrid2xgrid, rc=rc) + call ESMF_FieldGet(field_a, farrayptr=dataptr, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridStore(xgrid, lfield_x, lfield_a, routehandle=rh_xgrid2agrid, rc=rc) + dataptr(:) = 1.0_r8 + + ! create agrid->xgrid route handles + call ESMF_FieldRegridStore(xgrid, field_a, field_x, routehandle=rh_agrid2xgrid, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridStore(xgrid, lfield_a, lfield_x, routehandle=rh_agrid2xgrid_2ndord, & + call ESMF_FieldRegridStore(xgrid, field_a, field_x, routehandle=rh_agrid2xgrid_2ndord, & regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridStore(field_a, field_x, routehandle=rh_agrid2xgrid_bilinr, & + regridmethod=ESMF_REGRIDMETHOD_BILINEAR, dstMaskValues=(/0/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridStore(field_a, field_x, routehandle=rh_agrid2xgrid_patch, & + regridmethod=ESMF_REGRIDMETHOD_PATCH, dstMaskValues=(/0/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! create xgrid->zgrid route handle + call ESMF_FieldRegridStore(xgrid, field_x, field_a, routehandle=rh_xgrid2agrid, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! destroy temporary field + call ESMF_FieldDestroy(field_a, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! ------------------------ ! create the routehandles ocn->xgrid and xgrid->ocn @@ -781,17 +810,20 @@ subroutine med_aofluxes_init_xgrid(gcomp, aoflux_in, aoflux_out, rc) ! TODO: the second order conservative route handle below error out in its creation - call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), trim(fldnames_ocn_in(1)), field=lfield_o, rc=rc) + field_o = ESMF_FieldCreate(ocn_mesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldBundleGet(FBocn_x, trim(fldnames_ocn_in(1)), field=lfield_x, rc=rc) + call ESMF_FieldGet(field_o, farrayptr=dataptr, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridStore(xgrid, lfield_o, lfield_x, routehandle=rh_ogrid2xgrid, rc=rc) + dataptr(:) = 1.0_r8 + call ESMF_FieldRegridStore(xgrid, field_o, field_x, routehandle=rh_ogrid2xgrid, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridStore(xgrid, lfield_x, lfield_o, routehandle=rh_xgrid2ogrid, rc=rc) + call ESMF_FieldRegridStore(xgrid, field_x, field_o, routehandle=rh_xgrid2ogrid, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - ! call ESMF_FieldRegridStore(xgrid, lfield_o, lfield_x, routehandle=rh_ogrid2xgrid_2ndord, & + ! call ESMF_FieldRegridStore(xgrid, field_o, field_x, routehandle=rh_ogrid2xgrid_2ndord, & ! regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, rc=rc) ! if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldDestroy(field_o, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! ------------------------ ! setup the compute mask - default compute everywhere for exchange grid @@ -800,58 +832,6 @@ subroutine med_aofluxes_init_xgrid(gcomp, aoflux_in, aoflux_out, rc) allocate(aoflux_in%mask(lsize)) aoflux_in%mask(:) = 1 - ! ------------------------ - ! determine one normalization field for ocn->xgrid - ! ------------------------ - - ! Create temporary source field on ocn mesh and set its value to 1. - call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), 'So_t', field=lfield_o, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield_o, mesh=ocn_mesh, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - lfield_o = ESMF_FieldCreate(ocn_mesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield_o, farrayptr=dataPtr1d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr1d(:) = 1.0_R8 - - ! Create field_ogrid2xgrid_normone (module variable) - field_ogrid2xgrid_normone = ESMF_FieldCreate(xgrid, ESMF_TYPEKIND_R8, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegrid(lfield_o, field_ogrid2xgrid_normone, routehandle=rh_ogrid2xgrid, & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! Destroy temporary field - call ESMF_FieldDestroy(lfield_o, rc=rc, noGarbage=.true.) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! ------------------------ - ! Determine one normalization field for xgrid->atm - ! ------------------------ - - ! Create temporary field on xgrid and set its value to 1. - lfield_x = ESMF_FieldCreate(xgrid, typekind=ESMF_TYPEKIND_R8, name='Sa_z', rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield_x, farrayptr=dataPtr1d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr1d(:) = 1.0_R8 - - ! Create field_xgrid2agrid_normone (module variable) - on the atm mesh - call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), 'Sa_z', field=lfield_a, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield_a, mesh=atm_mesh, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - field_xgrid2agrid_normone = ESMF_FieldCreate(atm_mesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegrid(lfield_x, field_xgrid2agrid_normone, routehandle=rh_xgrid2agrid, & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! Destroy temporary field on xgrid - call ESMF_FieldDestroy(lfield_x, rc=rc, noGarbage=.true.) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end subroutine med_aofluxes_init_xgrid !=============================================================================== @@ -888,7 +868,6 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) integer :: n,i,nf ! indices real(r8), pointer :: data_normdst(:) real(r8), pointer :: data_dst(:) - integer :: maptype character(*),parameter :: subName = '(med_aofluxes_update) ' !----------------------------------------------------------------------- @@ -910,86 +889,16 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) else if (is_local%wrap%aoflux_grid == 'agrid') then - ! Map input ocn to agrid - do nf = 1,size(fldnames_ocn_in) - ! Create source field - call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fldnames_ocn_in(nf), field=field_src, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! Create destination field - call ESMF_FieldBundleGet(FBocn_a, fldnames_ocn_in(nf), field=field_dst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! Determine maptype from ocn->atm - if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapfcopy, rc=rc)) then - maptype = mapfcopy - else if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapconsd, rc=rc)) then - maptype = mapconsd - else - call ESMF_LogWrite(trim(subname)//& - ": maptype for atm->ocn mapping of aofluxes from atm->ocn either mapfcopy or mapconsd", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - end if - - ! Map ocn->atm conservatively without fractions - call ESMF_FieldRegrid(field_src, field_dst, routehandle=is_local%wrap%RH(compocn,compatm, maptype), & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - - ! Normalization of map by 'one' - if (maptype /= mapfcopy) then - call ESMF_FieldGet(is_local%wrap%field_normOne(compocn,compatm,maptype), farrayPtr=data_normdst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(field_dst, farrayptr=data_dst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - do n = 1,size(data_dst) - if (data_normdst(n) == 0.0_r8) then - data_dst(n) = 0.0_r8 - else - data_dst(n) = data_dst(n)/data_normdst(n) - end if - end do - end if - end do + call med_aofluxes_map_ogrid2agrid_input(gcomp, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return else if (is_local%wrap%aoflux_grid == 'xgrid') then - ! Map input atm to xgrid - do nf = 1,size(fldnames_atm_in) - ! Get the source field - call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), fldnames_atm_in(nf), field=field_src, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Get the destination field - call ESMF_FieldBundleGet(FBatm_x, fldnames_atm_in(nf), field=field_dst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Map atm->xgrid conservatively - if (trim(fldnames_atm_in(nf)) == 'Sa_u' .or. (trim(fldnames_atm_in(nf)) == 'Sa_v')) then - call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_agrid2xgrid_2ndord, & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - else - call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_agrid2xgrid, & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - end if - end do + call med_aofluxes_map_agrid2xgrid_input(gcomp, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call med_aofluxes_map_ogrid2xgrid_input(gcomp, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - ! map input ocn to xgrid - do nf = 1,size(fldnames_ocn_in) - ! Create source field - call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fldnames_ocn_in(nf), field=field_src, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Create destination field - call ESMF_FieldBundleGet(FBocn_x, fldnames_ocn_in(nf), field=field_dst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Map ocn->xgrid conservatively without fractions - if (trim(fldnames_atm_in(nf)) == 'So_u' .or. (trim(fldnames_atm_in(nf)) == 'So_v')) then - call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_ogrid2xgrid, & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - else - call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_ogrid2xgrid, & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - end if - end do end if !---------------------------------- @@ -1057,53 +966,87 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) if (is_local%wrap%aoflux_grid == 'ogrid') then - ! mapping aoflux from ogrid to agrid is done in med_phases_prep_atm using updated ocean fractions - ! on the atm grid + ! mapping aoflux from ogrid to agrid is done in med_phases_prep_atm + ! which is called from med_phases_prep_atm (since need to use updated ocean fractions) else if (is_local%wrap%aoflux_grid == 'agrid') then if (is_local%wrap%med_coupling_active(compatm,compocn)) then - ! map aoflux from agrid to ogrid - do nf = 1,size(fldnames_aof_out) - ! Create source field - call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_a, fldnames_aof_out(nf), field=field_src, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Create destination field - call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_o, fldnames_aof_out(nf), field=field_dst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Map atm->ocn conservatively WITHOUT fractions - if (med_map_RH_is_created(is_local%wrap%RH(compatm,compocn,:), mapfcopy, rc=rc)) then - maptype = mapfcopy - else if (med_map_RH_is_created(is_local%wrap%RH(compatm,compocn,:), mapconsf, rc=rc)) then - maptype = mapconsf - else - call ESMF_LogWrite(trim(subname)//& - ": maptype for atm->ocn mapping of aofluxes from atm->ocn either mapfcopy or mapconsf", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - end if - call ESMF_FieldRegrid(field_src, field_dst, & - routehandle=is_local%wrap%RH(compatm, compocn, maptype), & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - end do + call med_aofluxes_map_agrid2ogrid_output(gcomp, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return end if else if (is_local%wrap%aoflux_grid == 'xgrid') then - do nf = 1,size(fldnames_aof_out) + ! mapping aoflux from xgrid to agrid is done in med_aofluxes_map_xgrid2agrid_output + ! which is called from med_phases_prep_atm (since need to use updated ocean fractions) + call med_aofluxes_map_xgrid2ogrid_output(gcomp, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Get the source field - call ESMF_FieldBundleGet(FBaof_x, fldnames_aof_out(nf), field=field_src, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + end if - ! map aoflux from xgrid to agrid followed by normalization by 'one' - call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_a, fldnames_aof_out(nf), field=field_dst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_xgrid2agrid, & - termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - ! normalization by 'one' - call ESMF_FieldGet(field_xgrid2agrid_normone, farrayPtr=data_normdst, rc=rc) + call t_stopf('MED:'//subname) + + end subroutine med_aofluxes_update + + !================================================================================ + subroutine med_aofluxes_map_ogrid2agrid_input(gcomp, rc) + + ! aoflux is on agrid and this maps the ogrid input to the agrid + + use med_map_mod, only : med_map_RH_is_created + + ! Arguments + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + real(r8), pointer :: data_normdst(:) + real(r8), pointer :: data_dst(:) + integer :: nf,n + integer :: maptype + character(*),parameter :: subName = '(med_aofluxes_map_ogrid2agrid_output) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Map input ocn to agrid + do nf = 1,size(fldnames_ocn_in) + ! Create source field + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fldnames_ocn_in(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Create destination field + call ESMF_FieldBundleGet(FBocn_a, fldnames_ocn_in(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Determine maptype from ocn->atm + if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapfcopy, rc=rc)) then + maptype = mapfcopy + else if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:), mapconsd, rc=rc)) then + maptype = mapconsd + else + call ESMF_LogWrite(trim(subname)//& + ": maptype for atm->ocn mapping of aofluxes from atm->ocn either mapfcopy or mapconsd", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + end if + + ! Map ocn->atm conservatively without fractions + call ESMF_FieldRegrid(field_src, field_dst, routehandle=is_local%wrap%RH(compocn,compatm, maptype), & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + + ! Normalization of map by 'one' + if (maptype /= mapfcopy) then + call ESMF_FieldGet(is_local%wrap%field_normOne(compocn,compatm,maptype), farrayPtr=data_normdst, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldGet(field_dst, farrayptr=data_dst, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -1114,19 +1057,290 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) data_dst(n) = data_dst(n)/data_normdst(n) end if end do + end if + end do - ! map aoflx from xgrid->ogrid conservatively - call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_o, fldnames_aof_out(nf), field=field_dst, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_xgrid2ogrid, & + end subroutine med_aofluxes_map_ogrid2agrid_input + + !================================================================================ + subroutine med_aofluxes_map_agrid2xgrid_input(gcomp, rc) + + ! Map input atm to xgrid + + ! Arguments + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + integer :: nf + character(*),parameter :: subName = '(med_aofluxes_map_ogrid2agrid_output) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do nf = 1,size(fldnames_atm_in) + ! Get the source field + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compatm,compatm), fldnames_atm_in(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Get the destination field + call ESMF_FieldBundleGet(FBatm_x, fldnames_atm_in(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Map atm->xgrid + if (trim(fldnames_atm_in(nf)) == 'Sa_u' .or. (trim(fldnames_atm_in(nf)) == 'Sa_v')) then + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_agrid2xgrid_patch, & termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) - end do + else + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_agrid2xgrid_bilinr, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end if + end do + + end subroutine med_aofluxes_map_agrid2xgrid_input + + !================================================================================ + subroutine med_aofluxes_map_ogrid2xgrid_input(gcomp, rc) + + ! Map input ocn to xgrid + + ! Arguments + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + integer :: nf + character(*),parameter :: subName = '(med_aofluxes_map_ogrid2agrid_output) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do nf = 1,size(fldnames_ocn_in) + ! Create source field + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fldnames_ocn_in(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Create destination field + call ESMF_FieldBundleGet(FBocn_x, fldnames_ocn_in(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Map ocn->xgrid conservatively without fractions + if (trim(fldnames_atm_in(nf)) == 'So_u' .or. (trim(fldnames_atm_in(nf)) == 'So_v')) then + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_ogrid2xgrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + else + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_ogrid2xgrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end if + end do + +end subroutine med_aofluxes_map_ogrid2xgrid_input + + !================================================================================ + subroutine med_aofluxes_map_ogrid2agrid_output(gcomp, rc) + + use med_map_mod, only : med_map_field_packed + + ! Arguments + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + character(*),parameter :: subName = '(med_aofluxes_map_ogrid2agrid_output) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + 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), & + 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 + + end subroutine med_aofluxes_map_ogrid2agrid_output + + !================================================================================ + subroutine med_aofluxes_map_agrid2ogrid_output(gcomp, rc) + + ! map aoflux from agrid to ogrid + use med_map_mod , only : med_map_field_packed, med_map_rh_is_created + + ! Arguments + type(ESMF_GridComp) :: gcomp + integer , intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + integer :: nf ! indices + integer :: maptype + character(*),parameter :: subName = '(med_aofluxes_map_agrid2ogrid_output) ' + !----------------------------------------------------------------------- + + do nf = 1,size(fldnames_aof_out) + ! Create source field + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_a, fldnames_aof_out(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Create destination field + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_o, fldnames_aof_out(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! Map atm->ocn conservatively WITHOUT fractions + if (med_map_RH_is_created(is_local%wrap%RH(compatm,compocn,:), mapfcopy, rc=rc)) then + maptype = mapfcopy + else if (med_map_RH_is_created(is_local%wrap%RH(compatm,compocn,:), mapconsf, rc=rc)) then + maptype = mapconsf + else + call ESMF_LogWrite(trim(subname)//& + ": maptype for atm->ocn mapping of aofluxes from atm->ocn either mapfcopy or mapconsf", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + end if + call ESMF_FieldRegrid(field_src, field_dst, & + routehandle=is_local%wrap%RH(compatm, compocn, maptype), & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end do + + end subroutine med_aofluxes_map_agrid2ogrid_output + +!================================================================================ + subroutine med_aofluxes_map_xgrid2agrid_output(gcomp, rc) + + use ESMF, only : ESMF_FieldBundleIsCreated + + ! Arguments + type(ESMF_GridComp) :: gcomp + integer , intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + type(ESMF_Field) :: lfield + integer :: n,i,nf ! indices + real(r8), pointer :: data_src(:) + real(r8), pointer :: data_src_save(:) + real(r8), pointer :: data_dst(:) + real(r8), pointer :: ofrac_x(:) + real(r8), pointer :: ofrac_a(:) + character(*),parameter :: subName = '(med_aofluxes_map_xgrid2agrid_output) ' + !----------------------------------------------------------------------- + rc = ESMF_SUCCESS + + if (.not. ESMF_FieldBundleIsCreated(FBaof_x)) then + RETURN end if - call t_stopf('MED:'//subname) + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - end subroutine med_aofluxes_update + ! Map ocn fraction on ocn mesh to xgrid + call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compocn), 'ofrac', field=field_o, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegrid(field_o, field_x, routehandle=rh_ogrid2xgrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + call ESMF_FieldGet(field_x, farrayptr=ofrac_x, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do nf = 1,size(fldnames_aof_out) + + ! Get the source field + call ESMF_FieldBundleGet(FBaof_x, fldnames_aof_out(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! map aoflux from xgrid to agrid followed by normalization by 'one' + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_a, fldnames_aof_out(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field_src, farrayptr=data_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(data_src_save(size(data_src))) + data_src_save(:) = data_src(:) + do n = 1,size(data_src) + data_src(n) = data_src(n) * ofrac_x(n) + end do + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_xgrid2agrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + data_src(:) = data_src_save(:) + deallocate(data_src_save) + call ESMF_FieldGet(field_dst, farrayptr=data_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! normalization by '1./ofrac_a' + 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_a, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(ofrac_a) + if (ofrac_a(n) == 0.0_r8) then + data_dst(n) = 0.0_r8 + else + data_dst(n) = data_dst(n)/ofrac_a(n) + end if + end do + + end do + + end subroutine med_aofluxes_map_xgrid2agrid_output + +!================================================================================ + subroutine med_aofluxes_map_xgrid2ogrid_output(gcomp, rc) + + ! map aoflx output from xgrid->ogrid + + ! Arguments + type(ESMF_GridComp) :: gcomp + integer , intent(out) :: rc + ! + ! Local variables + type(InternalState) :: is_local + integer :: n,i,nf ! indices + type(ESMF_Field) :: field_src + type(ESMF_Field) :: field_dst + character(*),parameter :: subName = '(med_aofluxes_map_xgrid2ogrid_output) ' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do nf = 1,size(fldnames_aof_out) + ! Get the source field + call ESMF_FieldBundleGet(FBaof_x, fldnames_aof_out(nf), field=field_src, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! map aoflx from xgrid->ogrid conservatively + call ESMF_FieldBundleGet(is_local%wrap%FBMed_aoflux_o, fldnames_aof_out(nf), field=field_dst, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegrid(field_src, field_dst, routehandle=rh_xgrid2ogrid, & + termorderflag=ESMF_TERMORDER_SRCSEQ, zeroregion=ESMF_REGION_TOTAL, rc=rc) + end do + + end subroutine med_aofluxes_map_xgrid2ogrid_output !================================================================================ subroutine set_aoflux_in_pointers(fldbun_a, fldbun_o, aoflux_in, lsize, xgrid, rc) diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 5bf3c3a53..7cfc6fc89 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -18,8 +18,8 @@ module med_phases_history_mod use ESMF , only : operator(-), operator(+) use NUOPC , only : NUOPC_CompAttributeGet use NUOPC_Model , only : NUOPC_ModelGet - use esmFlds , only : ncomps, compname use med_utils_mod , only : chkerr => med_utils_ChkErr + use med_internalstate_mod , only : ncomps, compname use med_internalstate_mod , only : InternalState, mastertask, logunit use med_time_mod , only : med_time_alarmInit use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef, med_io_close @@ -28,6 +28,9 @@ module med_phases_history_mod implicit none private + ! Public routine called from med_internal_state_init + public :: med_phases_history_init + ! Public routine called from the run sequence public :: med_phases_history_write ! inst only - for all variables @@ -65,7 +68,7 @@ module med_phases_history_mod logical :: is_clockset = .false. logical :: is_active = .false. end type instfile_type - type(instfile_type) , public :: instfiles(ncomps) + type(instfile_type) , allocatable, public :: instfiles(:) ! ---------------------------- ! Time averaging history files @@ -84,7 +87,7 @@ module med_phases_history_mod logical :: is_clockset = .false. logical :: is_active = .false. end type avgfile_type - type(avgfile_type) :: avgfiles(ncomps) + type(avgfile_type), allocatable :: avgfiles(:) ! ---------------------------- ! Auxiliary history files @@ -109,9 +112,7 @@ module med_phases_history_mod integer :: num_auxfiles = 0 ! actual number of auxiliary files logical :: init_auxfiles = .false. ! if auxfile initial has occured end type auxcomp_type - type(auxcomp_type) , public :: auxcomp(ncomps) - - !logical :: init_auxfiles(ncomps) = .false. ! if true, auxfiles has been initialized for the component + type(auxcomp_type), allocatable, public :: auxcomp(:) ! ---------------------------- ! Other private module variables @@ -130,6 +131,14 @@ module med_phases_history_mod contains !=============================================================================== + subroutine med_phases_history_init() + ! allocate module memory + allocate(instfiles(ncomps)) + allocate(avgfiles(ncomps)) + allocate(auxcomp(ncomps)) + end subroutine med_phases_history_init + + !=============================================================================== subroutine med_phases_history_write(gcomp, rc) ! -------------------------------------- @@ -139,7 +148,7 @@ subroutine med_phases_history_write(gcomp, rc) use med_io_mod, only : med_io_write_time, med_io_define_time use ESMF , only : ESMF_Alarm, ESMF_AlarmSet use ESMF , only : ESMF_FieldBundleIsCreated - use esmflds , only : compocn, compatm + use med_internalstate_mod, only : compocn, compatm ! input/output variables type(ESMF_GridComp) :: gcomp @@ -369,7 +378,7 @@ subroutine med_phases_history_write_med(gcomp, rc) use ESMF , only : ESMF_FieldBundleIsCreated use med_io_mod, only : med_io_write_time, med_io_define_time - use esmFlds , only : compmed, compocn, compatm + use med_internalstate_mod, only : compmed, compocn, compatm ! input/output variables type(ESMF_GridComp) :: gcomp @@ -506,7 +515,7 @@ subroutine med_phases_history_write_lnd2glc(gcomp, fldbun, rc) ! Write yearly average of lnd -> glc fields - use esmFlds , only : complnd + use med_internalstate_mod, only : complnd use med_constants_mod , only : SecPerDay => med_constants_SecPerDay use med_io_mod , only : med_io_write_time, med_io_define_time use med_io_mod , only : med_io_date2yyyymmdd, med_io_sec2hms, med_io_ymd2date diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90 index ce3ef2a82..1fe8fb502 100644 --- a/mediator/med_phases_ocnalb_mod.F90 +++ b/mediator/med_phases_ocnalb_mod.F90 @@ -6,7 +6,7 @@ module med_phases_ocnalb_mod 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 med_internalstate_mod , only : mapconsf, mapnames, compatm, compocn use perf_mod , only : t_startf, t_stopf #ifdef CESMCOUPLED use shr_orb_mod , only : shr_orb_cosz, shr_orb_decl diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index acf1c2298..ab6f65e2b 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -1,7 +1,8 @@ module med_phases_post_atm_mod !----------------------------------------------------------------------------- - ! Mediator phase for post atm calculations, maps atm->ice, atm->lnd and atm->ocn + ! Mediator phase for post atm calculations, maps atm->ice, atm->lnd, atm->ocn + ! and atm->wav !----------------------------------------------------------------------------- implicit none @@ -32,7 +33,7 @@ subroutine med_phases_post_atm(gcomp, rc) use med_map_mod , only : med_map_field_packed use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_utils_mod , only : chkerr => med_utils_ChkErr - use esmFlds , only : compocn, compatm, compice, complnd + use med_internalstate_mod , only : compocn, compatm, compice, complnd, compwav use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -96,6 +97,19 @@ subroutine med_phases_post_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_atm2lnd') end if + ! map atm->wav + if (is_local%wrap%med_coupling_active(compatm,compwav)) then + call t_startf('MED:'//trim(subname)//' map_atm2wav') + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(compatm,compatm), & + FBDst=is_local%wrap%FBImp(compatm,compwav), & + FBFracSrc=is_local%wrap%FBFrac(compatm), & + field_normOne=is_local%wrap%field_normOne(compatm,compwav,:), & + packed_data=is_local%wrap%packed_data(compatm,compwav,:), & + routehandles=is_local%wrap%RH(compatm,compwav,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf('MED:'//trim(subname)//' map_atm2wav') + end if ! Write atm inst, avg or aux if requested in mediator attributes call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) diff --git a/mediator/med_phases_post_glc_mod.F90 b/mediator/med_phases_post_glc_mod.F90 index 5987ee355..14610e710 100644 --- a/mediator/med_phases_post_glc_mod.F90 +++ b/mediator/med_phases_post_glc_mod.F90 @@ -14,9 +14,9 @@ module med_phases_post_glc_mod use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8 use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandleIsCreated - use esmFlds , only : compatm, compice, complnd, comprof, compocn, ncomps, compname - use esmFlds , only : max_icesheets, num_icesheets, compglc - use esmFlds , only : mapbilnr, mapconsd, compname + use med_internalstate_mod , only : compatm, compice, complnd, comprof, compocn, compname, compglc + use med_internalstate_mod , only : mapbilnr, mapconsd, compname + use med_internalstate_mod , only : InternalState, mastertask, logunit use esmFlds , only : fldListTo use med_methods_mod , only : fldbun_diagnose => med_methods_FB_diagnose use med_methods_mod , only : fldbun_fldchk => med_methods_FB_fldchk @@ -27,7 +27,6 @@ module med_phases_post_glc_mod use med_methods_mod , only : field_getdata2d => med_methods_Field_getdata2d 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, 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 glc_elevclass_mod , only : glc_mean_elevation_virtual, glc_get_fractional_icecov @@ -58,7 +57,7 @@ module med_phases_post_glc_mod type(ESMF_Field) :: field_topo_x_icemask_g_ec ! elevation classes type(ESMF_Mesh) :: mesh_g end type ice_sheet_tolnd_type - type(ice_sheet_tolnd_type) :: ice_sheet_tolnd(max_icesheets) + type(ice_sheet_tolnd_type), allocatable :: ice_sheet_tolnd(:) type(ESMF_field) :: field_icemask_l ! no elevation classes type(ESMF_Field) :: field_frac_l_ec ! elevation classes @@ -116,21 +115,21 @@ subroutine med_phases_post_glc(gcomp, rc) if (first_call) then ! determine if there will be any glc to lnd coupling - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),complnd)) then glc2lnd_coupling = .true. exit end if end do ! determine if there will be any glc to ocn coupling - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),compocn)) then glc2ocn_coupling = .true. exit end if end do ! determine if there will be any glc to ice coupling - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),compice)) then glc2ice_coupling = .true. exit @@ -160,7 +159,7 @@ subroutine med_phases_post_glc(gcomp, rc) ! merging with rof->ocn fields is done in med_phases_prep_ocn !--------------------------------------- if (glc2ocn_coupling) then - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),compocn)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compglc(ns),compglc(ns)), & @@ -187,7 +186,7 @@ subroutine med_phases_post_glc(gcomp, rc) if (glc2lnd_coupling) then ! The will following will map and merge Sg_frac and Sg_topo (and in the future Flgg_hflx) call t_startf('MED:'//trim(subname)//' glc2lnd ') - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),complnd)) then call med_map_field_packed( & FBSrc=is_local%wrap%FBImp(compglc(ns),compglc(ns)), & @@ -219,7 +218,7 @@ subroutine med_phases_post_glc(gcomp, rc) call NUOPC_MediatorGet(gcomp, driverClock=dClock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ESMF_ClockIsCreated(dclock)) then - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call med_phases_history_write_comp(gcomp, compglc(ns), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end do @@ -298,7 +297,10 @@ subroutine map_glc2lnd_init(gcomp, rc) ! create module fields on glc mesh !--------------------------------------- - do ns = 1,max_icesheets + ! allocate module variable + allocate(ice_sheet_tolnd(is_local%wrap%num_icesheets)) + + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),complnd)) then call fldbun_getmesh(is_local%wrap%FBImp(compglc(ns),compglc(ns)), ice_sheet_tolnd(ns)%mesh_g, rc) @@ -415,7 +417,7 @@ subroutine map_glc2lnd( gcomp, rc) !--------------------------------- ! Map Sg_icemask and Sg_icemask_coupled_fluxes (no elevation classes) - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),complnd)) then call t_startf('MED:'//trim(subname)//' glc2lnd ') call med_map_field_packed( & @@ -433,7 +435,7 @@ subroutine map_glc2lnd( gcomp, rc) ! Get Sg_icemask on land as sum of all ice sheets (no elevation classes) call fldbun_getdata1d(is_local%wrap%FBExp(complnd), Sg_icemask, dataptr1d_dst, rc) dataptr1d_dst(:) = 0._r8 - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),complnd)) then call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),complnd), Sg_icemask, dataptr1d_src, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -445,7 +447,7 @@ subroutine map_glc2lnd( gcomp, rc) call fldbun_getdata1d(is_local%wrap%FBExp(complnd), Sg_icemask_coupled_fluxes, dataptr1d_dst, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return dataptr1d_dst(:) = 0._r8 - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),complnd)) then call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),complnd), Sg_icemask_coupled_fluxes, dataptr1d_src, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -453,7 +455,7 @@ subroutine map_glc2lnd( gcomp, rc) end if end do - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (is_local%wrap%med_coupling_active(compglc(ns),complnd)) then ! Set (fractional ice coverage for each elevation class on the glc grid) diff --git a/mediator/med_phases_post_ice_mod.F90 b/mediator/med_phases_post_ice_mod.F90 index 2daa4c358..d081448e4 100644 --- a/mediator/med_phases_post_ice_mod.F90 +++ b/mediator/med_phases_post_ice_mod.F90 @@ -30,7 +30,7 @@ subroutine med_phases_post_ice(gcomp, rc) use med_fraction_mod , only : med_fraction_set use med_internalstate_mod , only : InternalState, mastertask use med_phases_history_mod, only : med_phases_history_write_comp - use esmFlds , only : compice, compatm, compocn, compwav + use med_internalstate_mod , only : compice, compatm, compocn, compwav use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -59,18 +59,6 @@ subroutine med_phases_post_ice(gcomp, rc) call med_fraction_set(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! map ice to atm - scaling by updated ice fraction - if (is_local%wrap%med_coupling_active(compice,compatm)) then - call med_map_field_packed( & - FBSrc=is_local%wrap%FBImp(compice,compice), & - FBDst=is_local%wrap%FBImp(compice,compatm), & - FBFracSrc=is_local%wrap%FBFrac(compice), & - field_NormOne=is_local%wrap%field_normOne(compice,compatm,:), & - packed_data=is_local%wrap%packed_data(compice,compatm,:), & - routehandles=is_local%wrap%RH(compice,compatm,:), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - end if ! map ice to ocn if (is_local%wrap%med_coupling_active(compice,compocn)) then call t_startf('MED:'//trim(subname)//' map_ice2ocn') diff --git a/mediator/med_phases_post_lnd_mod.F90 b/mediator/med_phases_post_lnd_mod.F90 index 1bd416c77..559e67345 100644 --- a/mediator/med_phases_post_lnd_mod.F90 +++ b/mediator/med_phases_post_lnd_mod.F90 @@ -27,8 +27,7 @@ subroutine med_phases_post_lnd(gcomp, rc) use med_phases_prep_rof_mod , only : med_phases_prep_rof_accum use med_phases_prep_glc_mod , only : med_phases_prep_glc_accum_lnd, med_phases_prep_glc_avg use med_phases_history_mod , only : med_phases_history_write_comp - use esmFlds , only : complnd, compatm, comprof, compglc, num_icesheets - use esmFlds , only : lnd2glc_coupling, accum_lnd2glc + use med_internalstate_mod , only : complnd, compatm, comprof use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -78,12 +77,12 @@ subroutine med_phases_post_lnd(gcomp, rc) end if ! accumulate lnd input for glc (note that lnd2glc_coupling and accum_lnd2glc is determined in med.F90) - if (lnd2glc_coupling) then + if (is_local%wrap%lnd2glc_coupling) then call med_phases_prep_glc_accum_lnd(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Note that in this case med_phases_prep_glc_avg is called ! from med_phases_prep_glc in the run sequence - else if (accum_lnd2glc) then + else if (is_local%wrap%accum_lnd2glc) then call med_phases_prep_glc_accum_lnd(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call med_phases_prep_glc_avg(gcomp, rc) diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index c51f9eecf..abf766211 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -9,8 +9,6 @@ module med_phases_post_ocn_mod public :: med_phases_post_ocn - logical :: ocn2glc_coupling - character(*), parameter :: u_FILE_u = & __FILE__ @@ -29,9 +27,9 @@ subroutine med_phases_post_ocn(gcomp, rc) use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_map_mod , only : med_map_field_packed use med_internalstate_mod , only : InternalState, logunit, mastertask + use med_internalstate_mod , only : compice, compocn, compwav use med_phases_history_mod , only : med_phases_history_write_comp use med_phases_prep_glc_mod , only : med_phases_prep_glc_accum_ocn - use esmFlds , only : compice, compglc, compocn, num_icesheets use perf_mod , only : t_startf, t_stopf ! input/output variables @@ -40,9 +38,7 @@ subroutine med_phases_post_ocn(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: ns type(ESMF_Clock) :: dClock - logical :: first_call = .true. character(len=*),parameter :: subname='(med_phases_post_ocn)' !--------------------------------------- @@ -71,18 +67,22 @@ subroutine med_phases_post_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call t_stopf('MED:'//trim(subname)//' map_ocn2ice') end if + ! Map ocn->wav + if (is_local%wrap%med_coupling_active(compocn,compwav)) then + call t_startf('MED:'//trim(subname)//' map_ocn2wav') + call med_map_field_packed( & + FBSrc=is_local%wrap%FBImp(compocn,compocn), & + FBDst=is_local%wrap%FBImp(compocn,compwav), & + FBFracSrc=is_local%wrap%FBFrac(compocn), & + field_normOne=is_local%wrap%field_normOne(compocn,compwav,:), & + packed_data=is_local%wrap%packed_data(compocn,compwav,:), & + routehandles=is_local%wrap%RH(compocn,compwav,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call t_stopf('MED:'//trim(subname)//' map_ocn2wav') + end if ! Accumulate ocn input for glc if there is ocn->glc coupling - if (first_call) then - do ns = 1,num_icesheets - if (is_local%wrap%med_coupling_active(compocn,compglc(ns))) then - ocn2glc_coupling = .true. - exit - end if - end do - first_call = .false. - end if - if (ocn2glc_coupling) then + if (is_local%wrap%ocn2glc_coupling) then call med_phases_prep_glc_accum_ocn(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if diff --git a/mediator/med_phases_post_rof_mod.F90 b/mediator/med_phases_post_rof_mod.F90 index 10ca7bfc7..ea478b0cc 100644 --- a/mediator/med_phases_post_rof_mod.F90 +++ b/mediator/med_phases_post_rof_mod.F90 @@ -21,7 +21,7 @@ subroutine med_phases_post_rof(gcomp, rc) use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR, ESMF_SUCCESS, ESMF_FAILURE use ESMF , only : ESMF_GridComp, ESMF_GridCompGet use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 - use esmFlds , only : complnd, compocn, compice, compatm, comprof, ncomps, compname + use med_internalstate_mod , only : complnd, compocn, compice, compatm, comprof, compname 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, mastertask, logunit diff --git a/mediator/med_phases_post_wav_mod.F90 b/mediator/med_phases_post_wav_mod.F90 index a1bf805ef..31abf004c 100644 --- a/mediator/med_phases_post_wav_mod.F90 +++ b/mediator/med_phases_post_wav_mod.F90 @@ -24,8 +24,8 @@ subroutine med_phases_post_wav(gcomp, rc) use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose use med_map_mod , only : med_map_field_packed use med_internalstate_mod , only : InternalState, mastertask + use med_internalstate_mod , only : compwav, compatm, compocn, compice use med_phases_history_mod, only : med_phases_history_write_comp - use esmFlds , only : compwav, compatm, compocn, compice use perf_mod , only : t_startf, t_stopf ! input/output variables diff --git a/mediator/med_phases_prep_atm_mod.F90 b/mediator/med_phases_prep_atm_mod.F90 index 76c8b1e83..d3af6163d 100644 --- a/mediator/med_phases_prep_atm_mod.F90 +++ b/mediator/med_phases_prep_atm_mod.F90 @@ -16,9 +16,11 @@ module med_phases_prep_atm_mod use med_merge_mod , only : med_merge_auto use med_map_mod , only : med_map_field_packed use med_internalstate_mod , only : InternalState, mastertask - use esmFlds , only : compatm, compocn, compice, ncomps, compname - use esmFlds , only : fldListTo, fldListMed_aoflux, coupling_mode + use med_internalstate_mod , only : compatm, compocn, compice, compname, coupling_mode + use esmFlds , only : fldListTo, fldListMed_aoflux use perf_mod , only : t_startf, t_stopf + use med_phases_aofluxes_mod, only : med_aofluxes_map_xgrid2agrid_output + use med_phases_aofluxes_mod, only : med_aofluxes_map_ogrid2agrid_output implicit none private @@ -109,18 +111,13 @@ subroutine med_phases_prep_atm(gcomp, rc) !--------------------------------------- if (trim(coupling_mode) == 'cesm' .or. trim(coupling_mode) == 'hafs') then if (is_local%wrap%aoflux_grid == 'ogrid') then - 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), & - 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 + call med_aofluxes_map_ogrid2agrid_output(gcomp, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return else if (is_local%wrap%aoflux_grid == 'agrid') then - ! do nothing - is_local%wrap%FBMed_aoflux_a has been computed in med_aofluxes_init_agrid + ! Do nothing - fluxes are alread being computed on the agrid else if (is_local%wrap%aoflux_grid == 'xgrid') then - ! do nothing - is_local%wrap%FBMed_aoflux_a has been computed in med_aofluxes_init_agrid + call med_aofluxes_map_xgrid2agrid_output(gcomp, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return end if endif diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index 8098d4106..d47bbf46c 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -4,8 +4,6 @@ module med_phases_prep_glc_mod ! Mediator phases for preparing glc export from mediator !----------------------------------------------------------------------------- - ! TODO: determine the number of ice sheets that are present - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 use NUOPC , only : NUOPC_CompAttributeGet use NUOPC_Model , only : NUOPC_ModelGet @@ -23,9 +21,7 @@ module med_phases_prep_glc_mod use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8, ESMF_KIND_R8 use ESMF , only : ESMF_DYNAMICMASK, ESMF_DynamicMaskSetR8R8R8, ESMF_DYNAMICMASKELEMENTR8R8R8 use ESMF , only : ESMF_FieldRegrid - use esmFlds , only : complnd, compocn, mapbilnr, mapconsd, compname - use esmFlds , only : max_icesheets, num_icesheets, compglc - use esmFlds , only : ocn2glc_coupling, lnd2glc_coupling, accum_lnd2glc + use med_internalstate_mod , only : complnd, compocn, mapbilnr, mapconsd, compname, compglc use med_internalstate_mod , only : InternalState, mastertask, logunit 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 @@ -88,7 +84,7 @@ module med_phases_prep_glc_mod type(ESMF_Field) :: field_lfrac_g type(ESMF_Mesh) :: mesh_g end type toglc_frlnd_type - type(toglc_frlnd_type) :: toglc_frlnd(max_icesheets) ! TODO: make this allocatable for number of actual ice sheets + type(toglc_frlnd_type), allocatable :: toglc_frlnd(:) type(ESMF_Field) :: field_normdst_l type(ESMF_Field) :: field_icemask_l @@ -165,11 +161,14 @@ subroutine med_phases_prep_glc_init(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return + ! allocate module variables + allocate(toglc_frlnd(is_local%wrap%num_icesheets)) + ! ------------------------------- ! If will accumulate lnd2glc input on land grid ! ------------------------------- - if (accum_lnd2glc) then + if (is_local%wrap%accum_lnd2glc) then ! Create field bundles for the fldnames_fr_lnd that have an ! undistributed dimension corresponding to elevation classes (including bare land) call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fldnames_fr_lnd(1), field=lfield, rc=rc) @@ -203,11 +202,11 @@ subroutine med_phases_prep_glc_init(gcomp, rc) ! If lnd->glc couplng is active ! ------------------------------- - if (lnd2glc_coupling) then + if (is_local%wrap%lnd2glc_coupling) then ! Create accumulation field bundles from land on each glc ice sheet mesh ! Determine glc mesh from the mesh from the first export field to glc ! However FBlndAccum2glc_g has the fields fldnames_fr_lnd BUT ON the glc grid - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets ! get mesh on glc grid call fldbun_getmesh(is_local%wrap%FBExp(compglc(ns)), toglc_frlnd(ns)%mesh_g, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -293,7 +292,7 @@ subroutine med_phases_prep_glc_init(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Loop over ice sheets - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets ! ice mask without elevation classes on glc toglc_frlnd(ns)%field_icemask_g = ESMF_FieldCreate(toglc_frlnd(ns)%mesh_g, & ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) @@ -333,7 +332,7 @@ subroutine med_phases_prep_glc_init(gcomp, rc) ! If ocn->glc couplng is active ! ------------------------------- - if (ocn2glc_coupling) then + if (is_local%wrap%ocn2glc_coupling) then ! Get ocean mesh call fldbun_getmesh(is_local%wrap%FBImp(compocn,compocn), mesh_o, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -354,7 +353,7 @@ subroutine med_phases_prep_glc_init(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! create route handle if it has not been created - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (.not. med_map_RH_is_created(is_local%wrap%RH(compocn,compglc(ns),:),mapbilnr,rc=rc)) then call ESMF_LogWrite(trim(subname)//" mapbilnr is not created for ocn->glc mapping", & ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) @@ -661,7 +660,7 @@ subroutine med_phases_prep_glc_avg(gcomp, rc) end if end if - if (ocn2glc_coupling) then + if (is_local%wrap%ocn2glc_coupling) then ! Average import from accumulated ocn import data do n = 1, size(fldnames_fr_ocn) call fldbun_getdata2d(FBocnAccum2glc_o, fldnames_fr_ocn(n), data2d, rc) @@ -687,7 +686,7 @@ subroutine med_phases_prep_glc_avg(gcomp, rc) do n = 1,size(fldnames_fr_ocn) call ESMF_FieldBundleGet(FBocnAccum2glc_o, fldnames_fr_ocn(n), field=lfield_src, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc(ns)), fldnames_fr_ocn(n), field=lfield_dst, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return ! Do mapping of ocn to glc with dynamic masking @@ -701,7 +700,7 @@ subroutine med_phases_prep_glc_avg(gcomp, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if - if (lnd2glc_coupling) then + if (is_local%wrap%lnd2glc_coupling) then ! Map accumulated field bundle from land grid (with elevation classes) to glc grid (without elevation classes) ! and set FBExp(compglc(ns)) data ! Zero land accumulator and accumulated field bundles on land grid @@ -713,7 +712,7 @@ subroutine med_phases_prep_glc_avg(gcomp, rc) end if if (dbug_flag > 1) then - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call fldbun_diagnose(is_local%wrap%FBExp(compglc(ns)), string=trim(subname)//' FBexp(compglc) ', rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end do @@ -786,7 +785,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! ------------------------------------------------------------------------ ! Initialize accumulated field bundle on the glc grid to zero before doing the mapping - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call fldbun_reset(toglc_frlnd(ns)%FBlndAccum2glc_g, value=0.0_r8, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end do @@ -810,11 +809,11 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! map accumlated land fields to each ice sheet (normalize by the land fraction in the mapping) - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call fldbun_reset(toglc_frlnd(ns)%FBlndAccum2glc_g, value=0.0_r8, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end do - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call ESMF_FieldBundleGet(toglc_frlnd(ns)%FBlndAccum2glc_g, fieldlist=fieldlist_glc, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do nfld = 1,fieldcount @@ -837,7 +836,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return call fldbun_diagnose(is_local%wrap%FBfrac(complnd), string=trim(subname)//' FBFrac ', rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets call fldbun_diagnose(toglc_frlnd(ns)%FBlndAccum2glc_g, string=trim(subname)//& ' FBlndAccum2glc_glc '//compname(compglc(ns)), rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return @@ -849,7 +848,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! ------------------------------------------------------------------------ ! Loop over ice sheets - do ns = 1,num_icesheets + do ns = 1,is_local%wrap%num_icesheets if (dbug_flag > 1) then write(cnum,'(a3)') ns call fldbun_diagnose(is_local%wrap%FBImp(compglc(ns),compglc(ns)), & diff --git a/mediator/med_phases_prep_ice_mod.F90 b/mediator/med_phases_prep_ice_mod.F90 index 1f6424bf1..0d78bbed0 100644 --- a/mediator/med_phases_prep_ice_mod.F90 +++ b/mediator/med_phases_prep_ice_mod.F90 @@ -37,9 +37,9 @@ subroutine med_phases_prep_ice(gcomp, rc) use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_merge_mod , only : med_merge_auto use med_internalstate_mod , only : InternalState, logunit, mastertask - use esmFlds , only : compatm, compice, compocn, comprof, compglc, ncomps, compname + use med_internalstate_mod , only : compatm, compice, compocn, comprof + use med_internalstate_mod , only : coupling_mode use esmFlds , only : fldListTo - use esmFlds , only : coupling_mode use perf_mod , only : t_startf, t_stopf ! input/output variables diff --git a/mediator/med_phases_prep_lnd_mod.F90 b/mediator/med_phases_prep_lnd_mod.F90 index d60ac6dcf..81114c1bf 100644 --- a/mediator/med_phases_prep_lnd_mod.F90 +++ b/mediator/med_phases_prep_lnd_mod.F90 @@ -26,11 +26,11 @@ subroutine med_phases_prep_lnd(gcomp, rc) use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field, ESMF_FieldGet use ESMF , only : ESMF_GridComp, ESMF_GridCompGet use ESMF , only : ESMF_StateGet, ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND - use esmFlds , only : complnd, compatm, ncomps use esmFlds , only : fldListTo use med_methods_mod , only : fldbun_diagnose => med_methods_FB_diagnose 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 : complnd, compatm use med_internalstate_mod , only : InternalState, mastertask, logunit use med_merge_mod , only : med_merge_auto use perf_mod , only : t_startf, t_stopf diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90 index ffa029b37..0858462bc 100644 --- a/mediator/med_phases_prep_ocn_mod.F90 +++ b/mediator/med_phases_prep_ocn_mod.F90 @@ -20,8 +20,7 @@ module med_phases_prep_ocn_mod 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 : fldListTo - use esmFlds , only : compocn, compatm, compice - use esmFlds , only : coupling_mode + use med_internalstate_mod , only : compocn, compatm, compice, coupling_mode use perf_mod , only : t_startf, t_stopf implicit none @@ -45,7 +44,6 @@ subroutine med_phases_prep_ocn_init(gcomp, rc) use ESMF , only : ESMF_GridComp, ESMF_SUCCESS use med_methods_mod , only : FB_Init => med_methods_FB_init - use med_methods_mod , only : FB_Reset => med_methods_FB_Reset ! input/output variables type(ESMF_GridComp) :: gcomp diff --git a/mediator/med_phases_prep_rof_mod.F90 b/mediator/med_phases_prep_rof_mod.F90 index f54da223b..e64eea43b 100644 --- a/mediator/med_phases_prep_rof_mod.F90 +++ b/mediator/med_phases_prep_rof_mod.F90 @@ -12,7 +12,7 @@ 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, ESMF_Field - use esmFlds , only : ncomps, complnd, comprof, compname, mapconsf, mapconsd, mapfcopy + use med_internalstate_mod , only : complnd, comprof, mapconsf, mapconsd, mapfcopy use med_internalstate_mod , only : InternalState, mastertask, logunit use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_constants_mod , only : czero => med_constants_czero diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 8ff29e432..a1bd85c1b 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -5,20 +5,28 @@ module med_phases_prep_wav_mod !----------------------------------------------------------------------------- use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 - 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 : 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_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_merge_mod , only : med_merge_auto - 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 + 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 : fldListTo + use med_internalstate_mod , only : compwav use perf_mod , only : t_startf, t_stopf implicit none private - public :: med_phases_prep_wav + public :: med_phases_prep_wav_init ! called from med.F90 + public :: med_phases_prep_wav_accum ! called from run sequence + public :: med_phases_prep_wav_avg ! called from run sequence character(*), parameter :: u_FILE_u = & __FILE__ @@ -27,12 +35,45 @@ module med_phases_prep_wav_mod contains !----------------------------------------------------------------------------- - subroutine med_phases_prep_wav(gcomp, rc) + subroutine med_phases_prep_wav_init(gcomp, rc) + + use ESMF , only : ESMF_GridComp, ESMF_SUCCESS + use med_methods_mod , only : FB_Init => med_methods_FB_init + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + character(len=*),parameter :: subname=' (med_phases_prep_wav_init) ' + !--------------------------------------- + + rc = ESMF_SUCCESS + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return + + if (mastertask) then + write(logunit,'(a)') trim(subname)//' initializing wave export accumulation FB for ' + end if + call FB_Init(is_local%wrap%FBExpAccumWav, is_local%wrap%flds_scalar_name, & + STgeom=is_local%wrap%NStateExp(compwav), STflds=is_local%wrap%NStateExp(compwav), & + name='FBExpAccumWav', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_reset(is_local%wrap%FBExpAccumWav, value=czero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end subroutine med_phases_prep_wav_init + + !----------------------------------------------------------------------------- + subroutine med_phases_prep_wav_accum(gcomp, rc) + + use ESMF , only : ESMF_GridComp, ESMF_FieldBundleGet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time - use ESMF , only : ESMF_GridCompGet, ESMF_FieldBundleGet, ESMF_ClockGet, ESMF_TimeGet - use ESMF , only : ESMF_ClockPrint + use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR ! input/output variables type(ESMF_GridComp) :: gcomp @@ -40,85 +81,113 @@ subroutine med_phases_prep_wav(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: i,j,n,n1,ncnt - character(len=*),parameter :: subname='(med_phases_prep_wav)' + integer :: n, ncnt + character(len=*), parameter :: subname='(med_phases_prep_wav_accum)' !--------------------------------------- call t_startf('MED:'//subname) - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + if (dbug_flag > 20) then + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) end if rc = ESMF_SUCCESS + call memcheck(subname, 5, mastertask) + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! auto merges to wav + call med_merge_auto(& + is_local%wrap%med_coupling_active(:,compwav), & + is_local%wrap%FBExp(compwav), & + is_local%wrap%FBFrac(compwav), & + is_local%wrap%FBImp(:,compwav), & + fldListTo(compwav), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! wave accumulator + call FB_accum(is_local%wrap%FBExpAccumWav, is_local%wrap%FBExp(compwav), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + is_local%wrap%ExpAccumWavCnt = is_local%wrap%ExpAccumWavCnt + 1 + + ! diagnose output + if (dbug_flag > 1) then + call FB_diagnose(is_local%wrap%FBExpAccumWav, string=trim(subname)//' FBExpAccumWav accumulation ', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + end if + call t_stopf('MED:'//subname) + + end subroutine med_phases_prep_wav_accum + + !----------------------------------------------------------------------------- + subroutine med_phases_prep_wav_avg(gcomp, rc) + + ! Prepare the wav 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 + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + integer :: ncnt + character(len=*),parameter :: subname='(med_phases_prep_wav_avg)' !--------------------------------------- - ! --- Get the internal state - !--------------------------------------- + rc = ESMF_SUCCESS + + call t_startf('MED:'//subname) + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + endif + + ! 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 - ! 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 ESMF_FieldBundleGet(is_local%wrap%FBExp(compwav), fieldCount=ncnt, rc=rc) + call ESMF_FieldBundleGet(is_local%wrap%FBExpAccumWav, fieldCount=ncnt, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ncnt > 0) then - ! map to create FBimp(:,compwav) - do n1 = 1,ncomps - if (is_local%wrap%med_coupling_active(n1,compwav)) then - 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), & - 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 - end if - end do - - ! auto merges to create FBExp(compwav) - call med_merge_auto(& - is_local%wrap%med_coupling_active(:,compwav), & - is_local%wrap%FBExp(compwav), & - is_local%wrap%FBFrac(compwav), & - is_local%wrap%FBImp(:,compwav), & - fldListTo(compwav), rc=rc) + ! average wav accumulator + if (dbug_flag > 1) then + call FB_diagnose(is_local%wrap%FBExpAccumWav, & + string=trim(subname)//' FBExpAccumWav before avg ', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + call FB_average(is_local%wrap%FBExpAccumWav, is_local%wrap%ExpAccumWavCnt, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - !--------------------------------------- - !--- diagnose output - !--------------------------------------- - if (dbug_flag > 1) then - call FB_diagnose(is_local%wrap%FBExp(compwav), & - string=trim(subname)//' FBexp(compwav) ', rc=rc) + call FB_diagnose(is_local%wrap%FBExpAccumWav, & + string=trim(subname)//' FBExpAccumWav after avg ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - !--------------------------------------- - !--- custom calculations - !--------------------------------------- - - !--------------------------------------- - !--- update local scalar data - !--------------------------------------- - - !is_local%wrap%scalar_data(1) = + ! copy to FBExp(compwav) + call FB_copy(is_local%wrap%FBExp(compwav), is_local%wrap%FBExpAccumWav, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - !--- clean up - !--------------------------------------- + ! zero accumulator + is_local%wrap%ExpAccumWavCnt = 0 + call FB_reset(is_local%wrap%FBExpAccumWav, value=czero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + end if - if (dbug_flag > 5) then + if (dbug_flag > 20) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if call t_stopf('MED:'//subname) - end subroutine med_phases_prep_wav - + end subroutine med_phases_prep_wav_avg end module med_phases_prep_wav_mod diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index d87cfba80..5affb149a 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -8,7 +8,7 @@ module med_phases_restart_mod 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 : mastertask, logunit, InternalState - use esmFlds , only : ncomps, compname, compocn, complnd + use med_internalstate_mod , only : ncomps, compname, compocn, complnd, compwav use perf_mod , only : t_startf, t_stopf use med_phases_prep_glc_mod , only : FBlndAccum2glc_l, lndAccum2glc_cnt use med_phases_prep_glc_mod , only : FBocnAccum2glc_o, ocnAccum2glc_cnt @@ -381,6 +381,17 @@ subroutine med_phases_restart_write(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + ! Write export accumulation to wav + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccumWav)) then + nx = is_local%wrap%nx(compwav) + ny = is_local%wrap%ny(compwav) + call med_io_write(restart_file, is_local%wrap%FBExpAccumWav, whead(m), wdata(m), nx, ny, & + nt=1, pre='wavExpAccum', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_write(restart_file, is_local%wrap%ExpAccumWavCnt, 'wavExpAccum_cnt', whead(m), wdata(m), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + ! Write accumulation from lnd to rof if lnd->rof coupling is on if (ESMF_FieldBundleIsCreated(FBlndAccum2rof_l)) then nx = is_local%wrap%nx(complnd) @@ -584,6 +595,12 @@ subroutine med_phases_restart_read(gcomp, rc) call med_io_read(restart_file, vm, is_local%wrap%ExpAccumOcnCnt, 'ocnExpAccum_cnt', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + if (ESMF_FieldBundleIsCreated(is_local%wrap%FBExpAccumWav,rc=rc)) then + call med_io_read(restart_file, vm, is_local%wrap%FBExpAccumWav, pre='wavExpAccum', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_io_read(restart_file, vm, is_local%wrap%ExpAccumWavCnt, 'wavExpAccum_cnt', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif ! If lnd->rof, read accumulation from lnd to rof (CESM only) if (ESMF_FieldBundleIsCreated(FBlndAccum2rof_l)) then call med_io_read(restart_file, vm, FBlndAccum2rof_l, pre='lndImpAccum2rof', rc=rc) From bb5487a660b7b22c1fc8288c161402840668f97d Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Mon, 4 Apr 2022 09:21:36 -0400 Subject: [PATCH 29/31] Squashed commit of the following: commit 3a5f1a7df8083ebeeb099e197ef868952948d68c Author: Denise Worthen Date: Mon Apr 4 09:05:51 2022 -0400 remove commented out line commit 30d59e3860c5553008390f00dacf8ee28cc9daa9 Author: Denise Worthen Date: Mon Apr 4 08:47:38 2022 -0400 move pole method default setting commit 20d730b5f6be726e53a7e6844cee29b4f9b05f2d Author: Denise Worthen Date: Mon Apr 4 08:41:48 2022 -0400 move polemethod setting out of mask loop * cleanup whitespace commit 36cf04b076c2f2c45ee4128530e389566c66dce2 Merge: 15e4b41 a332fc8 Author: Denise Worthen Date: Mon Apr 4 08:33:46 2022 -0400 Merge remote-tracking branch 'escomp/master' into feature/defaultMasks commit 15e4b4121efb90d46ff8da59c0929a2608f8f236 Author: denise.worthen Date: Sat Feb 26 12:17:15 2022 -0700 move initialization of masks out of med.F90 * initialize masks in med_internalstate_mod commit 6e01bd9af77fc13ccdc2a00cdbe4218791e81e01 Merge: 0dba6b2 df272f1 Author: Denise Worthen Date: Thu Feb 3 10:50:49 2022 -0500 Merge branch 'NOAA-EMC:emc/develop' into feature/defaultMasks commit 0dba6b264c7c6f003701f6aff05b32f630c9fabf Author: denise.worthen Date: Wed Feb 2 08:01:39 2022 -0700 remove ispval_mask in internalstate commit 26d2e561b8c2521ca64c4e9bc11e8b8bf2635ba3 Author: denise.worthen Date: Wed Feb 2 07:41:41 2022 -0700 add field to allow B4B comparisons * temporarily add the swpen field to maintain reprodcibilty for all tests. All CMEPS tests now pass for ufs commit 5a11ef52eef14676136c7fadc1e316cb04c58385 Author: denise.worthen Date: Tue Feb 1 18:26:12 2022 -0700 tests pass except for missing field * move setting of masks to med.F90 after coupling_mode is set * missing field iceImp_mean_sw_pen_to_ocn in mediator restart files for nems s2s and cdeps applications breaks baselines, but all other fields are b4b commit 9278e5c96e76076398e4916af9824f8c4b4defd8 Author: Denise Worthen Date: Tue Feb 1 12:31:59 2022 -0500 fix compile error commit 6d93ad886fbc4dc9b690cd98d4a514edd88c506b Merge: 98a8a82 e1560df Author: Denise Worthen Date: Tue Feb 1 12:28:36 2022 -0500 Merge branch 'feature/refac_fldxch_nems' into feature/defaultMasks commit 98a8a82de745bc244957ac8ae6cfc566d77202f9 Author: denise.worthen Date: Tue Feb 1 07:24:56 2022 -0700 set up default masking in internalstate --- mediator/esmFldsExchange_nems_mod.F90 | 8 ++-- mediator/med.F90 | 10 +++-- mediator/med_internalstate_mod.F90 | 56 +++++++++++++++++++++--- mediator/med_map_mod.F90 | 63 +++++++-------------------- mediator/med_phases_post_lnd_mod.F90 | 2 +- mediator/med_phases_prep_atm_mod.F90 | 8 ++-- mediator/med_time_mod.F90 | 4 +- 7 files changed, 84 insertions(+), 67 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index c53f1b306..9a30c9c03 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -123,10 +123,11 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end if end do deallocate(flds) + end if - ! unused fields from ice - but that are needed to be realized by the cice cap - !call addfld(fldListFr(compice)%flds, 'Faii_evap') - !call addfld(fldListFr(compice)%flds, 'mean_sw_pen_to_ocn') + ! TODO: unused, but required to maintain B4B repro for mediator restarts; should be removed + if (phase == 'advertise') then + call addfld(fldListFr(compice)%flds, 'mean_sw_pen_to_ocn') end if !===================================================================== @@ -235,7 +236,6 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) if ( fldchk(is_local%wrap%FBexp(compocn) , 'Sa_pslv', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_pslv', rc=rc)) then call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, maptype, 'one', 'unset') - !call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, mapbilnr_nstod, 'one', 'unset') call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') end if end if diff --git a/mediator/med.F90 b/mediator/med.F90 index 1ea22b450..d4eeefc9d 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -25,7 +25,6 @@ module MED use med_constants_mod , only : spval_init => med_constants_spval_init use med_constants_mod , only : spval => med_constants_spval use med_constants_mod , only : czero => med_constants_czero - use med_constants_mod , only : ispval_mask => med_constants_ispval_mask 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 @@ -41,7 +40,7 @@ module MED use med_utils_mod , only : memcheck => med_memcheck use med_time_mod , only : med_time_alarmInit use med_internalstate_mod , only : InternalState, med_internalstate_init, med_internalstate_coupling - use med_internalstate_mod , only : logunit, mastertask + use med_internalstate_mod , only : med_internalstate_defaultmasks, logunit, mastertask use med_internalstate_mod , only : ncomps, compname use med_internalstate_mod , only : compmed, compatm, compocn, compice, complnd, comprof, compwav, compglc use med_internalstate_mod , only : coupling_mode @@ -648,13 +647,14 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) ! TransferOfferGeomObject Attribute. use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Clock, ESMF_SUCCESS, ESMF_LogFoundAllocError - use ESMF , only : ESMF_StateIsCreated + use ESMF , only : ESMF_StateIsCreated use ESMF , only : ESMF_LogMsg_Info, ESMF_LogWrite use ESMF , only : ESMF_END_ABORT, ESMF_Finalize, ESMF_MAXSTR use NUOPC , only : NUOPC_AddNamespace, NUOPC_Advertise, NUOPC_AddNestedState use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd use esmFlds, only : med_fldlist_init1 use med_phases_history_mod, only : med_phases_history_init + use med_internalstate_mod , only : atm_name ! input/output variables type(ESMF_GridComp) :: gcomp @@ -788,6 +788,10 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) call ESMF_Finalize(endflag=ESMF_END_ABORT) end if + ! Set default masking for mapping + call med_internalstate_defaultmasks(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + !------------------ ! Determine component present indices !------------------ diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index 8286118a9..b9b61e85e 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -15,6 +15,7 @@ module med_internalstate_mod ! public routines public :: med_internalstate_init public :: med_internalstate_coupling + public :: med_internalstate_defaultmasks integer, public :: logunit ! logunit for mediator log output integer, public :: diagunit ! diagunit for budget output (med master only) @@ -48,6 +49,9 @@ module med_internalstate_mod ! Coupling mode character(len=CS), public :: coupling_mode ! valid values are [cesm,nems_orig,nems_frac,nems_orig_data,hafs] + ! Default src and destination masks for mapping + integer, public, allocatable :: defaultMasks(:,:) + ! Mapping integer , public, parameter :: mapunset = 0 integer , public, parameter :: mapbilnr = 1 @@ -113,7 +117,7 @@ module med_internalstate_mod logical, pointer :: med_coupling_active(:,:) ! computes the active coupling integer :: num_icesheets ! obtained from attribute logical :: ocn2glc_coupling = .false. ! obtained from attribute - logical :: lnd2glc_coupling = .false. + logical :: lnd2glc_coupling = .false. logical :: accum_lnd2glc = .false. ! Mediator vm @@ -187,8 +191,8 @@ module med_internalstate_mod subroutine med_internalstate_init(gcomp, rc) - use ESMF , only : ESMF_LogFoundAllocError, ESMF_AttributeGet - use NUOPC_Comp , only : NUOPC_CompAttributeGet + use ESMF , only : ESMF_LogFoundAllocError, ESMF_AttributeGet + use NUOPC_Comp , only : NUOPC_CompAttributeGet ! input/output variables type(ESMF_GridComp) :: gcomp @@ -205,7 +209,7 @@ subroutine med_internalstate_init(gcomp, rc) character(len=CL) :: cname character(len=ESMF_MAXSTR) :: mesh_glc character(len=CX) :: msgString - character(len=3) :: name + character(len=3) :: name integer :: num_icesheets character(len=*),parameter :: subname=' (internalstate init) ' !----------------------------------------------------------- @@ -329,7 +333,7 @@ subroutine med_internalstate_init(gcomp, rc) ! Write out present flags write(logunit,*) do n1 = 1,ncomps - name = trim(compname(n1)) ! this trims the ice sheets index from the glc name + name = trim(compname(n1)) ! this trims the ice sheets index from the glc name write(msgString,'(A,L4)') trim(subname)//' comp_present(comp'//name//') = ',& is_local%wrap%comp_present(n1) write(logunit,'(a)') trim(msgString) @@ -353,7 +357,7 @@ subroutine med_internalstate_init(gcomp, rc) ! Obtain dststatus_print setting if present call NUOPC_CompAttributeGet(gcomp, name='dststatus_print', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) dststatus_print=(trim(cvalue)=="true") + if (isPresent .and. isSet) dststatus_print=(trim(cvalue) == "true") write(msgString,*) trim(subname)//': Mediator dststatus_print is ',dststatus_print call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) @@ -551,4 +555,44 @@ subroutine med_internalstate_coupling(gcomp, rc) end subroutine med_internalstate_coupling + subroutine med_internalstate_defaultmasks(gcomp, rc) + + use med_constants_mod , only : ispval_mask => med_constants_ispval_mask + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer , intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + + !---------------------------------------------------------- + ! Default masking: for each component, the first element is + ! when it is the src and the second element is when it is + ! the destination + !---------------------------------------------------------- + + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(defaultMasks(ncomps,2)) + defaultMasks(:,:) = ispval_mask + if (is_local%wrap%comp_present(compocn)) defaultMasks(compocn,:) = 0 + if (is_local%wrap%comp_present(compice)) defaultMasks(compice,:) = 0 + if (is_local%wrap%comp_present(compwav)) defaultMasks(compwav,:) = 0 + if ( trim(coupling_mode(1:4)) == 'nems') then + if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,:) = 1 + endif + if ( trim(coupling_mode) == 'hafs') then + if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 + endif + if ( trim(coupling_mode) /= 'cesm') then + if (is_local%wrap%comp_present(compatm) .and. trim(atm_name(1:4)) == 'datm') then + defaultMasks(compatm,1) = 0 + end if + end if + + end subroutine med_internalstate_defaultmasks + end module med_internalstate_mod diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 19e1a69de..3717f5cba 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -342,7 +342,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, use med_internalstate_mod , only : mapfillv_bilnr, mapbilnr_nstod, mapconsf_aofrac use med_internalstate_mod , only : ncomps, compatm, compice, compocn, compwav, compname use med_internalstate_mod , only : coupling_mode, dststatus_print - use med_internalstate_mod , only : atm_name + use med_internalstate_mod , only : defaultMasks use med_constants_mod , only : ispval_mask => med_constants_ispval_mask ! input/output variables @@ -389,64 +389,33 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, ! set local flag to false ldstprint = .false. - polemethod=ESMF_POLEMETHOD_ALLAVG + ! set src and dst masking using defaults + srcMaskValue = defaultMasks(n1,1) + dstMaskValue = defaultMasks(n2,2) + + ! override defaults for specific cases if (trim(coupling_mode) == 'cesm') then - dstMaskValue = ispval_mask - srcMaskValue = ispval_mask - if (n1 == compocn .or. n1 == compice) srcMaskValue = 0 - if (n2 == compocn .or. n2 == compice) dstMaskValue = 0 if (n1 == compwav .and. n2 == compocn) then srcMaskValue = 0 dstMaskValue = ispval_mask endif - if (n1 == compwav .or. n2 == compwav) then - polemethod = ESMF_POLEMETHOD_NONE ! todo: remove this when ESMF tripolar mapping fix is in place. - endif - else if (coupling_mode(1:4) == 'nems') then - if ( (n1 == compocn .or. n1 == compice .or. n1 == compwav) .and. & - (n2 == compocn .or. n2 == compice .or. n2 == compwav) ) then - srcMaskValue = 0 - dstMaskValue = 0 - else if (n1 == compatm .and. (n2 == compocn .or. n2 == compice .or. n2 == compwav)) then - srcMaskValue = 1 - dstMaskValue = 0 - if (atm_name(1:4).eq.'datm') then - srcMaskValue = 0 - endif - else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice .or. n1 == compwav)) then - srcMaskValue = 0 - dstMaskValue = 1 - !dstMaskValue = ispval_mask - else - ! TODO: what should the condition be here? - dstMaskValue = ispval_mask + end if + if (trim(coupling_mode) == 'hafs') then + if (n1 == compatm .and. n2 == compwav) then 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 - if (n1 == compatm .and. n2 == compocn) then - if (trim(atm_name).ne.'datm') then - srcMaskValue = 1 - endif - dstMaskValue = 0 - elseif (n1 == compocn .and. n2 == compatm) then - srcMaskValue = 0 - dstMaskValue = ispval_mask - elseif (n1 == compatm .and. n2 == compwav) then - dstMaskValue = 0 - elseif (n1 == compwav .and. n2 == compatm) then - srcMaskValue = 0 - dstMaskValue = ispval_mask - endif end if - write(string,'(a,i10,a,i10)') trim(compname(n1))//' to '//trim(compname(n2))//' srcMask = ', & srcMaskValue,' dstMask = ',dstMaskValue call ESMF_LogWrite(trim(string), ESMF_LOGMSG_INFO) + polemethod=ESMF_POLEMETHOD_ALLAVG + if (trim(coupling_mode) == 'cesm') then + if (n1 == compwav .or. n2 == compwav) then + polemethod = ESMF_POLEMETHOD_NONE ! todo: remove this when ESMF tripolar mapping fix is in place. + endif + end if + ! Create route handle if (mapindex == mapfcopy) then if (mastertask) then diff --git a/mediator/med_phases_post_lnd_mod.F90 b/mediator/med_phases_post_lnd_mod.F90 index 559e67345..d057506af 100644 --- a/mediator/med_phases_post_lnd_mod.F90 +++ b/mediator/med_phases_post_lnd_mod.F90 @@ -80,7 +80,7 @@ subroutine med_phases_post_lnd(gcomp, rc) if (is_local%wrap%lnd2glc_coupling) then call med_phases_prep_glc_accum_lnd(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Note that in this case med_phases_prep_glc_avg is called + ! Note that in this case med_phases_prep_glc_avg is called ! from med_phases_prep_glc in the run sequence else if (is_local%wrap%accum_lnd2glc) then call med_phases_prep_glc_accum_lnd(gcomp, rc) diff --git a/mediator/med_phases_prep_atm_mod.F90 b/mediator/med_phases_prep_atm_mod.F90 index c2e9b4ef5..485cdaf9b 100644 --- a/mediator/med_phases_prep_atm_mod.F90 +++ b/mediator/med_phases_prep_atm_mod.F90 @@ -242,17 +242,17 @@ subroutine med_phases_prep_atm(gcomp, rc) end subroutine med_phases_prep_atm !----------------------------------------------------------------------------- - subroutine med_phases_prep_atm_enthalpy_correction (gcomp, hcorr, rc) + subroutine med_phases_prep_atm_enthalpy_correction (gcomp, hcorr, rc) - ! Enthalpy correction term calculation called by med_phases_prep_ocn_accum in + ! Enthalpy correction term calculation called by med_phases_prep_ocn_accum in ! med_phases_prep_ocn_mod ! Note that this is only called if the following fields are in FBExp(compocn) ! 'Faxa_rain','Foxx_hrain','Faxa_snow' ,'Foxx_hsnow', - ! 'Foxx_evap','Foxx_hevap','Foxx_hcond','Foxx_rofl', + ! 'Foxx_evap','Foxx_hevap','Foxx_hcond','Foxx_rofl', ! 'Foxx_hrofl','Foxx_rofi','Foxx_hrofi' use ESMF , only : ESMF_VMAllreduce, ESMF_GridCompGet, ESMF_REDUCE_SUM - use ESMF , only : ESMF_VM + use ESMF , only : ESMF_VM ! input/output variables type(ESMF_GridComp) , intent(in) :: gcomp diff --git a/mediator/med_time_mod.F90 b/mediator/med_time_mod.F90 index 51e4db6e4..14cd7464b 100644 --- a/mediator/med_time_mod.F90 +++ b/mediator/med_time_mod.F90 @@ -73,7 +73,7 @@ subroutine med_time_alarmInit( clock, alarm, option, & integer , optional , intent(in) :: opt_tod ! alarm tod (sec) type(ESMF_Time) , optional , intent(in) :: reftime ! reference time character(len=*) , optional , intent(in) :: alarmname ! alarm name - logical , optional , intent(in) :: advance_clock ! advance clock to trigger alarm + logical , optional , intent(in) :: advance_clock ! advance clock to trigger alarm integer , intent(out) :: rc ! Return code ! local variables @@ -264,7 +264,7 @@ subroutine med_time_alarmInit( clock, alarm, option, & if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Advance model clock to trigger alarm then reset model clock back to currtime - if (present(advance_clock)) then + if (present(advance_clock)) then if (advance_clock) then call ESMF_AlarmSet(alarm, clock=clock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return From 40ac4ed889093b6000b0e51b96934aeff035c0d3 Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Sun, 17 Apr 2022 13:24:59 -0600 Subject: [PATCH 30/31] add explicit check for avail components * add check that both components at field advertise are present --- mediator/esmFldsExchange_nems_mod.F90 | 301 ++++++++++++++------------ 1 file changed, 168 insertions(+), 133 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 9a30c9c03..a5bea6365 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -91,8 +91,12 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! masks from components if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, 'Si_imask') - call addfld(fldListFr(compocn)%flds, 'So_omask') + if (is_local%wrap%comp_present(compice) )then + call addfld(fldListFr(compice)%flds, 'Si_imask') + end if + if (is_local%wrap%comp_present(compocn) )then + call addfld(fldListFr(compocn)%flds, 'So_omask') + end if else call addmap(fldListFr(compocn)%flds, 'So_omask', compice, mapfcopy, 'unset', 'unset') end if @@ -136,10 +140,14 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to atm: fractions (computed in med_phases_prep_atm) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, 'Si_ifrac') - call addfld(fldListTo(compatm)%flds, 'Si_ifrac') + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compatm)) then + call addfld(fldListFr(compice)%flds, 'Si_ifrac') + call addfld(fldListTo(compatm)%flds, 'Si_ifrac') + end if ! ofrac used by atm - call addfld(fldListFr(compatm)%flds, 'Sa_ofrac') + if (is_local%wrap%comp_present(compocn) .and. is_local%wrap%comp_present(compatm)) then + call addfld(fldListFr(compatm)%flds, 'Sa_ofrac') + end if end if ! to atm: unmerged from ice @@ -157,8 +165,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) do n = 1,size(flds) fldname = trim(flds(n)) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compatm)) then + call addfld(fldListFr(compice)%flds, trim(fldname)) + call addfld(fldListTo(compatm)%flds, trim(fldname)) + end if else if ( fldchk(is_local%wrap%FBexp(compatm) , trim(fldname), rc=rc) .and. & fldchk(is_local%wrap%FBImp(compice,compice), trim(fldname), rc=rc)) then @@ -174,8 +184,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) do n = 1,size(flds) fldname = trim(flds(n)) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addfld(fldListTo(compatm)%flds, trim(fldname)) + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compatm)) then + call addfld(fldListFr(compice)%flds, trim(fldname)) + call addfld(fldListTo(compatm)%flds, trim(fldname)) + end if else if ( fldchk(is_local%wrap%FBexp(compatm) , trim(fldname), rc=rc) .and. & fldchk(is_local%wrap%FBImp(compice,compice), trim(fldname), rc=rc)) then @@ -188,8 +200,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to atm: unmerged surface temperatures from ocn if (phase == 'advertise') then - call addfld(fldListFr(compocn)%flds, 'So_t') - call addfld(fldListTo(compatm)%flds, 'So_t') + if (is_local%wrap%comp_present(compocn) .and. is_local%wrap%comp_present(compatm)) then + call addfld(fldListFr(compocn)%flds, 'So_t') + call addfld(fldListTo(compatm)%flds, 'So_t') + end if else if ( fldchk(is_local%wrap%FBexp(compatm) , 'So_t', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compocn,compocn), 'So_t', rc=rc)) then @@ -198,30 +212,18 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end if end if - ! temporary conditional to avoid conflicts of advertised fields - ! when waves are passing through connectors - if (is_local%wrap%comp_present(compwav)) then - ! to atm: surface roughness length from wav - if (phase == 'advertise') then + ! to atm: surface roughness length from wav + if (phase == 'advertise') then + if (is_local%wrap%comp_present(compwav) .and. is_local%wrap%comp_present(compatm)) then call addfld(fldListFr(compwav)%flds, 'Sw_z0') call addfld(fldListTo(compatm)%flds, 'Sw_z0') - else - if ( fldchk(is_local%wrap%FBexp(compatm) , 'Sw_z0', rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compwav,compwav), 'Sw_z0', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') - end if end if - end if - - ! temporary conditional to avoid conflicts of advertised fields - ! when waves are passing through connectors - if (is_local%wrap%comp_present(compwav)) then - ! to atm: surface roughness length from wav - call addfld(fldListFr(compwav)%flds, 'Sw_z0') - call addfld(fldListTo(compatm)%flds, 'Sw_z0') - call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Sw_z0', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav,compwav), 'Sw_z0', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_z0', compatm, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compatm)%flds, 'Sw_z0', mrg_from=compwav, mrg_fld='Sw_z0', mrg_type='copy') + end if end if !===================================================================== @@ -230,8 +232,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: sea level pressure from atm if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, 'Sa_pslv') - call addfld(fldListTo(compocn)%flds, 'Sa_pslv') + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compatm)%flds, 'Sa_pslv') + call addfld(fldListTo(compocn)%flds, 'Sa_pslv') + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Sa_pslv', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_pslv', rc=rc)) then @@ -253,8 +257,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) iflds = (/'Fioi_swpen_idr', 'Fioi_swpen_idf', 'Fioi_swpen_vdr', 'Fioi_swpen_vdf'/) do n = 1,size(oflds) if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, trim(aflds(n))) - call addfld(fldListTo(compocn)%flds, trim(oflds(n))) + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compatm)%flds, trim(aflds(n))) + call addfld(fldListTo(compocn)%flds, trim(oflds(n))) + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , trim(oflds(n)), rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), trim(aflds(n)), rc=rc)) then @@ -265,8 +271,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) do n = 1,size(oflds) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, trim(iflds(n))) - call addfld(fldListTo(compocn)%flds, trim(oflds(n))) + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compice)%flds, trim(iflds(n))) + call addfld(fldListTo(compocn)%flds, trim(oflds(n))) + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , trim(oflds(n)), rc=rc) .and. & fldchk(is_local%wrap%FBImp(compice,compice), trim(iflds(n)), rc=rc)) then @@ -284,8 +292,10 @@ subroutine esmFldsExchange_nems(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)) + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addfld(fldListTo(compocn)%flds, trim(fldname)) + end if 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 @@ -307,9 +317,12 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) iflds = (/'Fioi_taux', 'Fioi_tauy'/) do n = 1,size(oflds) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, trim(iflds(n))) - call addfld(fldListFr(compatm)%flds, trim(aflds(n))) - call addfld(fldListTo(compocn)%flds, trim(oflds(n))) + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compatm) & + .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compice)%flds, trim(iflds(n))) + call addfld(fldListFr(compatm)%flds, trim(aflds(n))) + call addfld(fldListTo(compocn)%flds, trim(oflds(n))) + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , trim(oflds(n)), rc=rc) .and. & fldchk(is_local%wrap%FBImp(compice,compice), trim(iflds(n)), rc=rc) .and. & @@ -325,8 +338,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: net long wave via auto merge if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, 'Faxa_lwnet') - call addfld(fldListTo(compocn)%flds, 'Faxa_lwnet') + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compatm)%flds, 'Faxa_lwnet') + call addfld(fldListTo(compocn)%flds, 'Faxa_lwnet') + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_lwnet', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwnet', rc=rc)) then @@ -338,8 +353,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: merged sensible heat flux (custom merge in med_phases_prep_ocn) if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, 'Faxa_sen') - call addfld(fldListTo(compocn)%flds, 'Faxa_sen') + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compatm)%flds, 'Faxa_sen') + call addfld(fldListTo(compocn)%flds, 'Faxa_sen') + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_sen', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_sen', rc=rc)) then @@ -349,8 +366,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: evaporation water flux (custom merge in med_phases_prep_ocn) if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, 'Faxa_lat') - call addfld(fldListTo(compocn)%flds, 'Faxa_evap') + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compatm)%flds, 'Faxa_lat') + call addfld(fldListTo(compocn)%flds, 'Faxa_evap') + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faxa_evap', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lat' , rc=rc)) then @@ -364,9 +383,11 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) flds = (/'taux', 'tauy'/) do n = 1,size(flds) if (phase == 'advertise') then - call addfld(fldListMed_aoflux%flds , 'Faox_'//trim(flds(n))) - call addfld(fldListFr(compice)%flds , 'Fioi_'//trim(flds(n))) - call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(flds(n))) + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListMed_aoflux%flds , 'Faox_'//trim(flds(n))) + call addfld(fldListFr(compice)%flds , 'Fioi_'//trim(flds(n))) + call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(flds(n))) + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_'//trim(flds(n)), rc=rc) .and. & fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_'//trim(flds(n)), rc=rc) .and. & @@ -383,9 +404,11 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: long wave net via auto merge if (phase == 'advertise') then - call addfld(fldListMed_aoflux%flds , 'Faox_lwup') - call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') - call addfld(fldListTo(compocn)%flds, 'Foxx_lwnet') + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListMed_aoflux%flds , 'Faox_lwup') + call addfld(fldListFr(compatm)%flds, 'Faxa_lwdn') + call addfld(fldListTo(compocn)%flds, 'Foxx_lwnet') + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_lwnet', rc=rc) .and. & fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup' , rc=rc) .and. & @@ -400,8 +423,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: sensible heat flux from mediator via auto merge if (phase == 'advertise') then - call addfld(fldListMed_aoflux%flds , 'Faox_sen') - call addfld(fldListTo(compocn)%flds, 'Faox_sen') + if (is_local%wrap%comp_present(compocn)) then + call addfld(fldListMed_aoflux%flds , 'Faox_sen') + call addfld(fldListTo(compocn)%flds, 'Faox_sen') + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_sen', rc=rc) .and. & fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_sen' , rc=rc)) then @@ -412,8 +437,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to ocn: evaporation water flux from mediator via auto merge if (phase == 'advertise') then - call addfld(fldListMed_aoflux%flds , 'Faox_evap') - call addfld(fldListTo(compocn)%flds, 'Faox_evap') + if (is_local%wrap%comp_present(compocn)) then + call addfld(fldListMed_aoflux%flds , 'Faox_evap') + call addfld(fldListTo(compocn)%flds, 'Faox_evap') + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Faox_evap', rc=rc) .and. & fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_evap' , rc=rc)) then @@ -431,8 +458,10 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) do n = 1,size(flds) fldname = trim(flds(n)) if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, trim(fldname)) - call addfld(fldListTo(compocn)%flds, trim(fldname)) + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compocn)) then + call addfld(fldListFr(compice)%flds, trim(fldname)) + call addfld(fldListTo(compocn)%flds, trim(fldname)) + end if else if ( fldchk(is_local%wrap%FBexp(compocn) , trim(fldname), rc=rc) .and. & fldchk(is_local%wrap%FBImp(compice,compice), trim(fldname), rc=rc)) then @@ -444,28 +473,26 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) end do deallocate(flds) - ! temporary conditional to avoid conflicts of advertised fields - ! when waves are passing through connectors - if (is_local%wrap%comp_present(compwav)) then - ! to ocn: partitioned stokes drift from wav - allocate(flds(6)) - flds = (/'Sw_ustokes1', 'Sw_ustokes2', 'Sw_ustokes3', & - 'Sw_vstokes1', 'Sw_vstokes2', 'Sw_vstokes3'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then + ! to ocn: partitioned stokes drift from wav + allocate(flds(6)) + flds = (/'Sw_ustokes1', 'Sw_ustokes2', 'Sw_ustokes3', & + 'Sw_vstokes1', 'Sw_vstokes2', 'Sw_vstokes3'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + if (phase == 'advertise') then + if (is_local%wrap%comp_present(compwav) .and. is_local%wrap%comp_present(compocn)) then call addfld(fldListFr(compwav)%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(compwav,compwav), trim(fldname), rc=rc)) then - call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') - end if end if - end do - deallocate(flds) - end if + else + if ( fldchk(is_local%wrap%FBexp(compocn) , trim(fldname), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav,compwav), trim(fldname), rc=rc)) then + call addmap(fldListFr(compwav)%flds, trim(fldname), compocn, mapfcopy, 'unset', 'unset') + call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from=compwav, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if + end do + deallocate(flds) !===================================================================== ! FIELDS TO ICE (compice) @@ -486,8 +513,10 @@ subroutine esmFldsExchange_nems(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)) + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compice)) then + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addfld(fldListTo(compice)%flds, trim(fldname)) + end if 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 @@ -511,8 +540,10 @@ subroutine esmFldsExchange_nems(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)) + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compice)) then + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addfld(fldListTo(compice)%flds, trim(fldname)) + endif 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 @@ -537,8 +568,10 @@ subroutine esmFldsExchange_nems(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)) + if (is_local%wrap%comp_present(compocn) .and. is_local%wrap%comp_present(compice)) then + call addfld(fldListFr(compocn)%flds, trim(fldname)) + call addfld(fldListTo(compice)%flds, trim(fldname)) + endif 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 @@ -553,59 +586,61 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! FIELDS TO WAV (compwav) !===================================================================== - ! temporary conditional to avoid conflicts of advertised fields - ! when waves are passing through connectors - if (is_local%wrap%comp_present(compwav)) then - ! to wav - 10m winds and bottom temperature from atm - allocate(flds(3)) - flds = (/'Sa_u10m', 'Sa_v10m', 'Sa_tbot'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then + ! to wav - 10m winds and bottom temperature from atm + allocate(flds(3)) + flds = (/'Sa_u10m', 'Sa_v10m', 'Sa_tbot'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + if (phase == 'advertise') then + if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%comp_present(compwav)) then call addfld(fldListFr(compatm)%flds, trim(fldname)) call addfld(fldListTo(compwav)%flds, trim(fldname)) - else - if ( fldchk(is_local%wrap%FBexp(compwav) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm), trim(fldname), rc=rc)) then - call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if end if - end do - deallocate(flds) - - ! to wav: sea ice fraction - if (phase == 'advertise') then - call addfld(fldListFr(compice)%flds, 'Si_ifrac') - call addfld(fldListTo(compwav)%flds, 'Si_ifrac') else - if ( fldchk(is_local%wrap%FBexp(compwav) , 'Si_ifrac', rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compice,compice), 'Si_ifrac', rc=rc)) then - call addmap(fldListFr(compice)%flds, 'Si_ifrac', compwav, mapfcopy , 'unset', 'unset') - call addmrg(fldListTo(compwav)%flds, 'Si_ifrac', mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') + if ( fldchk(is_local%wrap%FBexp(compwav) , trim(fldname), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm), trim(fldname), rc=rc)) then + call addmap(fldListFr(compatm)%flds, trim(fldname), compwav, mapnstod_consf, 'one', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') end if end if - - ! to wav: zonal sea water velocity from ocn - ! to wav: meridional sea water velocity from ocn - ! to wav: surface temperature from ocn - allocate(flds(3)) - flds = (/'So_u', 'So_v', 'So_t'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - if (phase == 'advertise') then - call addfld(fldListFr(compocn)%flds, trim(fldname)) - call addfld(fldListTo(compwav)%flds, trim(fldname)) - else - if ( fldchk(is_local%wrap%FBexp(compwav) , trim(fldname), rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compocn,compocn), trim(fldname), rc=rc)) then - call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') - call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end if - end if - end do - deallocate(flds) - end if + end do + deallocate(flds) + + ! to wav: sea ice fraction + if (phase == 'advertise') then + if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compwav)) then + call addfld(fldListFr(compice)%flds, 'Si_ifrac') + call addfld(fldListTo(compwav)%flds, 'Si_ifrac') + end if + else + if ( fldchk(is_local%wrap%FBexp(compwav) , 'Si_ifrac', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Si_ifrac', rc=rc)) then + call addmap(fldListFr(compice)%flds, 'Si_ifrac', compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, 'Si_ifrac', mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') + end if + end if + + ! to wav: zonal sea water velocity from ocn + ! to wav: meridional sea water velocity from ocn + ! to wav: surface temperature from ocn + allocate(flds(3)) + flds = (/'So_u', 'So_v', 'So_t'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + if (phase == 'advertise') then + if (is_local%wrap%comp_present(compocn) .and. is_local%wrap%comp_present(compwav)) then + call addfld(fldListFr(compocn)%flds, trim(fldname)) + call addfld(fldListTo(compwav)%flds, trim(fldname)) + end if + else + if ( fldchk(is_local%wrap%FBexp(compwav) , trim(fldname), rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), trim(fldname), rc=rc)) then + call addmap(fldListFr(compocn)%flds, trim(fldname), compwav, mapfcopy , 'unset', 'unset') + call addmrg(fldListTo(compwav)%flds, trim(fldname), mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end if + end if + end do + deallocate(flds) end subroutine esmFldsExchange_nems From 1dc336dbfff88677755476a9bb34e6d8e7de5b6a Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Mon, 18 Apr 2022 19:23:12 -0600 Subject: [PATCH 31/31] add checks for nems_orig_data --- mediator/esmFldsExchange_nems_mod.F90 | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index a5bea6365..436232652 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -91,14 +91,13 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! masks from components if (phase == 'advertise') then - if (is_local%wrap%comp_present(compice) )then - call addfld(fldListFr(compice)%flds, 'Si_imask') - end if - if (is_local%wrap%comp_present(compocn) )then - call addfld(fldListFr(compocn)%flds, 'So_omask') - end if + if (is_local%wrap%comp_present(compice)) call addfld(fldListFr(compice)%flds, 'Si_imask') + if (is_local%wrap%comp_present(compocn)) call addfld(fldListFr(compocn)%flds, 'So_omask') else - call addmap(fldListFr(compocn)%flds, 'So_omask', compice, mapfcopy, 'unset', 'unset') + 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, 'So_omask', compice, mapfcopy, 'unset', 'unset') + end if end if if ( trim(coupling_mode) == 'nems_orig_data') then @@ -109,9 +108,13 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) do n = 1,size(flds) fldname = trim(flds(n)) if (phase == 'advertise') then - call addfld(fldListFr(compatm)%flds, trim(fldname)) + if (is_local%wrap%comp_present(compatm) )then + call addfld(fldListFr(compatm)%flds, trim(fldname)) + end if else - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') + if ( fldchk(is_local%wrap%FBImp(compatm,compatm), trim(fldname), rc=rc)) then + call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'one', 'unset') + end if end if end do deallocate(flds)