From 5c50c57106d438a49430012fabcd78cfc427018a Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Mon, 25 Aug 2025 13:35:48 -0400 Subject: [PATCH 01/15] Sync ESCOMP (#148) --- .github/workflows/bumpversion.yml | 2 +- .github/workflows/extbuild.yml | 8 +- cesm/nuopc_cap_share/shr_megan_mod.F90 | 12 +- cime_config/config_archive.xml | 9 +- cime_config/config_component.xml | 26 +- cime_config/config_component_cesm.xml | 21 ++ cime_config/namelist_definition_drv.xml | 2 +- .../drv/interim_restart/shell_commands | 2 + mediator/esmFldsExchange_cesm_mod.F90 | 291 +++++++++++++++++- mediator/fd_cesm.yaml | 74 +++++ mediator/med.F90 | 1 + mediator/med_diag_mod.F90 | 43 ++- 12 files changed, 458 insertions(+), 33 deletions(-) create mode 100644 cime_config/testdefs/testmods_dirs/drv/interim_restart/shell_commands diff --git a/.github/workflows/bumpversion.yml b/.github/workflows/bumpversion.yml index b17d491f0..2289f5add 100644 --- a/.github/workflows/bumpversion.yml +++ b/.github/workflows/bumpversion.yml @@ -10,7 +10,7 @@ jobs: - uses: actions/checkout@v2 - name: Bump version and push tag id: tag_version - uses: mathieudutour/github-tag-action@v5.5 + uses: mathieudutour/github-tag-action@v6.2 with: github_token: ${{ secrets.GITHUB_TOKEN }} create_annotated_tag: true diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml index f31f46bd4..113f90885 100644 --- a/.github/workflows/extbuild.yml +++ b/.github/workflows/extbuild.yml @@ -24,7 +24,7 @@ jobs: PNETCDF_VERSION: checkpoint.1.14.0 NETCDF_FORTRAN_VERSION: v4.6.1 PIO_VERSION: pio2_6_5 - CDEPS_VERSION: cdeps1.0.72 + CDEPS_VERSION: cdeps1.0.80 steps: - uses: actions/checkout@v4 # Build the ESMF library, if the cache contains a previous build @@ -75,7 +75,7 @@ jobs: with: path: /homme/runner/work/CMEPS/CMEPS/build-cdeps key: ${{ runner.os }}-${{ env.CDEPS_VERSION }}.cdeps1 - + - name: checkout CDEPS uses: actions/checkout@v4 with: @@ -85,7 +85,7 @@ jobs: - name: get genf90 run: | cd cdeps-src - git submodule update --init + git submodule update --init - name: Build CDEPS if: steps.cache-cdeps.outputs.cache-hit != 'true' uses: ESCOMP/CDEPS/.github/actions/buildcdeps@cdeps1.0.26 @@ -95,7 +95,7 @@ jobs: src_root: ${GITHUB_WORKSPACE}/cdeps-src cmake_flags: " -Wno-dev -DDISABLE_FoX=ON -DCMAKE_BUILD_TYPE=DEBUG -DWERROR=ON -DCMAKE_Fortran_FLAGS=\"-DCPRGNU -g -Wall \ -ffree-form -ffree-line-length-none -fallow-argument-mismatch \"" - + - name: Build CMEPS run: | export PIO=$HOME/pio diff --git a/cesm/nuopc_cap_share/shr_megan_mod.F90 b/cesm/nuopc_cap_share/shr_megan_mod.F90 index 57a218dd7..d26b85814 100644 --- a/cesm/nuopc_cap_share/shr_megan_mod.F90 +++ b/cesm/nuopc_cap_share/shr_megan_mod.F90 @@ -43,13 +43,13 @@ module shr_megan_mod 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 + type(shr_megan_megcomp_t), pointer :: ptr + real(r8) :: coeff ! emissions component coeffecient endtype shr_megan_comp_ptr ! chemical compound in CAM mechanism that has MEGAN emissions @@ -227,7 +227,8 @@ subroutine shr_megan_init( specifier) if (localPet==0) write(logunit,*) ' species : ', item%name do j = 1,item%n_terms if (localPet==0) write(logunit,'(f12.4,a,a)') item%coeffs(j),' * ', item%vars(j) - shr_megan_mechcomps(i)%megan_comps(j)%ptr => add_megan_comp( item%vars(j), item%coeffs(j) ) + shr_megan_mechcomps(i)%megan_comps(j)%ptr => add_megan_comp( item%vars(j) ) + shr_megan_mechcomps(i)%megan_comps(j)%coeff = item%coeffs(j) enddo shr_megan_mechcomps_n = shr_megan_mechcomps_n+1 @@ -243,10 +244,9 @@ end subroutine shr_megan_init !------------------------------------------------------------------------- - function add_megan_comp( name, coeff ) result(megan_comp) + function add_megan_comp( name ) 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) @@ -264,7 +264,7 @@ function add_megan_comp( name, coeff ) result(megan_comp) 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) diff --git a/cime_config/config_archive.xml b/cime_config/config_archive.xml index ff8bbf533..44088fba2 100644 --- a/cime_config/config_archive.xml +++ b/cime_config/config_archive.xml @@ -1,17 +1,18 @@ r - hi?\d*.*\.nc$ + h[ix]?\d*\..*\.nc(\.gz)?$ unset - rpointer.cpl$NINST_STRING + rpointer.cpl$NINST_STRING.$DATENAME $CASE.cpl$NINST_STRING.r.$DATENAME.nc cpl_0001.log.5548574.chadmin1.180228-124723.gz casename.cpl.r.1976-01-01-00000.nc - rpointer.drv_0001 - rpointer.drv + rpointer.cpl_0001.1976-01-01-00000 + rpointer.cpl_0001.1976-01-01-43200 + rpointer.cpl.1976-01-01-00000 casenamenot.cpl.r.1976-01-01-00000.nc diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index ae6981fc4..872f45c93 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -881,6 +881,25 @@ CLM. This is currently only supported for certain machines. + + logical + TRUE,FALSE + FALSE + build_def + env_build.xml + TRUE implies linking to the FTorch library to allow calls between + fortran and a PyTorch model that has been saved to TorchScript. + + + + + char + + build_def + env_build.xml + location of libtorch and supporting libraries, may be supplied by ftorch interface if not present + + logical TRUE,FALSE @@ -1461,7 +1480,7 @@ env_run.xml wav2ocn state mapping file - + char 1.0e-02 @@ -1746,6 +1765,7 @@ env_mach_pes.xml ROOTPE (mpi task in MPI_COMM_WORLD) for each component + logical TRUE @@ -1850,7 +1870,7 @@ env_mach_pes.xml Number of GPUs per node used for simulation - + integer 0 @@ -1858,7 +1878,7 @@ env_mach_pes.xml Maximum number of GPUs allowed per node - + integer $MAX_MPITASKS_PER_NODE diff --git a/cime_config/config_component_cesm.xml b/cime_config/config_component_cesm.xml index 0502a47c5..608a5fcbd 100644 --- a/cime_config/config_component_cesm.xml +++ b/cime_config/config_component_cesm.xml @@ -270,6 +270,7 @@ 192 384 192 + 384 48 48 48 @@ -288,6 +289,22 @@ 24 48 + 48 + 48 + 48 + 96 + 192 + 360 + 720 + 1440 + 2 + 2 + 2 + 4 + 8 + 15 + 30 + 60 run_coupling env_run.xml @@ -380,6 +397,8 @@ 8 $ATM_NCPL + $ATM_NCPL + $OCN_NCPL $ATM_NCPL $ATM_NCPL $ATM_NCPL @@ -390,6 +409,7 @@ $ATM_NCPL 1 $ATM_NCPL + $ATM_NCPL run_coupling env_run.xml @@ -418,6 +438,7 @@ TRUE TRUE + TRUE TRUE TRUE FALSE diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index bf4c17ccb..318fc8235 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -1794,7 +1794,7 @@ logical aux_hist ALLCOMP_attributes - Auxiliary mediator lnd2med fields every year + Turns on history stream for annual lnd to mediator glc forcing fields .false. diff --git a/cime_config/testdefs/testmods_dirs/drv/interim_restart/shell_commands b/cime_config/testdefs/testmods_dirs/drv/interim_restart/shell_commands new file mode 100644 index 000000000..90c2d7364 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/drv/interim_restart/shell_commands @@ -0,0 +1,2 @@ +# use this with the ERR test to test the interim restart capability +./xmlchange REST_N=2 \ No newline at end of file diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index b3b305668..fb1f8d708 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -119,6 +119,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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 : map_rof2ocn_ice, map_rof2ocn_liq + use med_internalstate_mod, only : ocn_name, ice_name use esmFlds , only : addfld_ocnalb => med_fldList_addfld_ocnalb use esmFlds , only : addfld_aoflux => med_fldList_addfld_aoflux use esmFlds , only : addmap_aoflux => med_fldList_addmap_aoflux @@ -144,6 +145,8 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) character(len=CS) :: mrgfld_source logical :: wav_coupling_to_cice logical :: ocn2glc_coupling + logical :: forr_rofl_glc_merged_to_ocn + logical :: forr_rofi_glc_merged_to_ocn character(len=*) , parameter :: subname=' (esmFldsExchange_cesm) ' !-------------------------------------- @@ -1508,6 +1511,18 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(compatm, 'Si_vice', mrg_from=compice, mrg_fld='Si_vice', mrg_type='copy') end if end if + if (ice_name == 'mpassi') then + if (phase == 'advertise') then + call addfld_from(compice, 'Si_ithick') + call addfld_to(compatm, 'Si_ithick') + else + if ( fldchk(is_local%wrap%FBexp(compatm) , 'Si_ithick', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compice,compice), 'Si_ithick', rc=rc)) then + call addmap_from(compice, 'Si_ithick', compatm, mapconsf, 'ifrac', ice2atm_map) + call addmrg_to(compatm, 'Si_ithick', mrg_from=compice, mrg_fld='Si_ithick', mrg_type='copy') + end if + end if + end if if (phase == 'advertise') then call addfld_from(compice, 'Si_vsno') call addfld_to(compatm, 'Si_vsno') @@ -1783,6 +1798,22 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(compocn, 'Si_ifrac', mrg_from=compice, mrg_fld='Si_ifrac', mrg_type='copy') end if + ! --------------------------------------------------------------------- + ! to ocn: seaice basal pressure + ! --------------------------------------------------------------------- + if (ice_name == 'mpassi' .or. ocn_name == 'mpaso') then + if (phase == 'advertise') then + call addfld_from(compice, 'Si_bpress') + call addfld_to(compocn, 'Si_bpress') + else + if ( fldchk(is_local%wrap%FBImp(compice, compice), 'Si_bpress', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compocn) , 'Si_bpress', rc=rc)) then + call addmap_from(compice, 'Si_bpress', compocn, mapfcopy, 'unset', 'unset') + call addmrg_to(compocn, 'Si_bpress', mrg_from=compice, mrg_fld='Si_bpress', mrg_type='copy') + end if + end if + end if + ! --------------------------------------------------------------------- ! to ocn: downward longwave heat flux from atm ! to ocn: downward direct near-infrared incident solar radiation from atm @@ -2419,12 +2450,21 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if ! Liquid runoff from land and glc - merging + forr_rofl_glc_merged_to_ocn = .false. + if ( fldchk(is_local%wrap%FBExp(compocn), 'Forr_rofl_glc', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl_glc', rc=rc)) then + ! If the ocean is prepared to handle Forr_rofl_glc as a separate field, then keep + ! it as a separate field rather than merging it to Foxx_rofl + call addmrg_to(compocn, 'Forr_rofl_glc', mrg_from=comprof, mrg_fld='Forr_rofl_glc', mrg_type='copy') + forr_rofl_glc_merged_to_ocn = .true. + end if if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofl' , rc=rc)) then mrgfld_source = 'Forr_rofl' if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood', rc=rc)) then mrgfld_source = trim(mrgfld_source) //':Flrr_flood' end if - if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl_glc', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl_glc', rc=rc) .and. & + .not. forr_rofl_glc_merged_to_ocn) then mrgfld_source = trim(mrgfld_source) //':Forr_rofl_glc' end if call addmrg_to(compocn, 'Foxx_rofl', mrg_from=comprof, mrg_fld=trim(mrgfld_source), mrg_type='sum') @@ -2452,9 +2492,18 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if ! Frozen runoff from land and glc - merging + forr_rofi_glc_merged_to_ocn = .false. + if ( fldchk(is_local%wrap%FBExp(compocn), 'Forr_rofi_glc', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi_glc', rc=rc)) then + ! If the ocean is prepared to handle Forr_rofi_glc as a separate field, then keep + ! it as a separate field rather than merging it to Foxx_rofi + call addmrg_to(compocn, 'Forr_rofi_glc', mrg_from=comprof, mrg_fld='Forr_rofi_glc', mrg_type='copy') + forr_rofi_glc_merged_to_ocn = .true. + end if if ( fldchk(is_local%wrap%FBExp(compocn), 'Foxx_rofi' , rc=rc)) then mrgfld_source = 'Forr_rofi' - if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi_glc', rc=rc)) then + if (fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi_glc', rc=rc) .and. & + .not. forr_rofi_glc_merged_to_ocn) then mrgfld_source = trim(mrgfld_source) //':Forr_rofi_glc' end if call addmrg_to(compocn, 'Foxx_rofi', mrg_from=comprof, mrg_fld=trim(mrgfld_source), mrg_type='sum') @@ -2498,6 +2547,229 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(compocn, 'Sw_lamult', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') end if end if + if (ocn_name == 'mpaso') then + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_Hs') + call addfld_to(compocn, 'Sw_Hs') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_Hs', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_Hs', rc=rc)) then + call addmap_from(compwav, 'Sw_Hs', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_Hs', mrg_from=compwav, mrg_fld='Sw_hs', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_Fp') + call addfld_to(compocn, 'Sw_Fp') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_Fp', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_Fp', rc=rc)) then + call addmap_from(compwav, 'Sw_Fp', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_Fp', mrg_from=compwav, mrg_fld='Sw_Fp', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_ustokes_wavenumber_1') + call addfld_to(compocn, 'Sw_ustokes_wavenumber_1') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes_wavenumber_1', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes_wavenumber_1', rc=rc)) then + call addmap_from(compwav, 'Sw_ustokes_wavenumber_1', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_ustokes_wavenumber_1', mrg_from=compwav, mrg_fld='Sw_ustokes_wavenumber_1', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_vstokes_wavenumber_1') + call addfld_to(compocn, 'Sw_vstokes_wavenumber_1') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes_wavenumber_1', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes_wavenumber_1', rc=rc)) then + call addmap_from(compwav, 'Sw_vstokes_wavenumber_1', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_vstokes_wavenumber_1', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_ustokes_wavenumber_2') + call addfld_to(compocn, 'Sw_ustokes_wavenumber_2') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes_wavenumber_2', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes_wavenumber_2', rc=rc)) then + call addmap_from(compwav, 'Sw_ustokes_wavenumber_2', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_ustokes_wavenumber_2', mrg_from=compwav, mrg_fld='Sw_ustokes_wavenumber_2', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_vstokes_wavenumber_2') + call addfld_to(compocn, 'Sw_vstokes_wavenumber_2') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes_wavenumber_2', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes_wavenumber_2', rc=rc)) then + call addmap_from(compwav, 'Sw_vstokes_wavenumber_2', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_vstokes_wavenumber_2', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_ustokes_wavenumber_3') + call addfld_to(compocn, 'Sw_ustokes_wavenumber_3') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes_wavenumber_3', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes_wavenumber_3', rc=rc)) then + call addmap_from(compwav, 'Sw_ustokes_wavenumber_3', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_ustokes_wavenumber_3', mrg_from=compwav, mrg_fld='Sw_ustokes_wavenumber_3', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_vstokes_wavenumber_3') + call addfld_to(compocn, 'Sw_vstokes_wavenumber_3') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes_wavenumber_3', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes_wavenumber_3', rc=rc)) then + call addmap_from(compwav, 'Sw_vstokes_wavenumber_3', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_vstokes_wavenumber_3', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_ustokes_wavenumber_4') + call addfld_to(compocn, 'Sw_ustokes_wavenumber_4') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes_wavenumber_4', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes_wavenumber_4', rc=rc)) then + call addmap_from(compwav, 'Sw_ustokes_wavenumber_4', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_ustokes_wavenumber_4', mrg_from=compwav, mrg_fld='Sw_ustokes_wavenumber_4', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_vstokes_wavenumber_4') + call addfld_to(compocn, 'Sw_vstokes_wavenumber_4') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes_wavenumber_4', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes_wavenumber_4', rc=rc)) then + call addmap_from(compwav, 'Sw_vstokes_wavenumber_4', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_vstokes_wavenumber_4', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_ustokes_wavenumber_5') + call addfld_to(compocn, 'Sw_ustokes_wavenumber_5') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes_wavenumber_5', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes_wavenumber_5', rc=rc)) then + call addmap_from(compwav, 'Sw_ustokes_wavenumber_5', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_ustokes_wavenumber_5', mrg_from=compwav, mrg_fld='Sw_ustokes_wavenumber_5', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_vstokes_wavenumber_5') + call addfld_to(compocn, 'Sw_vstokes_wavenumber_5') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes_wavenumber_5', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes_wavenumber_5', rc=rc)) then + call addmap_from(compwav, 'Sw_vstokes_wavenumber_5', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_vstokes_wavenumber_5', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_ustokes_wavenumber_6') + call addfld_to(compocn, 'Sw_ustokes_wavenumber_6') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes_wavenumber_6', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes_wavenumber_6', rc=rc)) then + call addmap_from(compwav, 'Sw_ustokes_wavenumber_6', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_ustokes_wavenumber_6', mrg_from=compwav, mrg_fld='Sw_ustokes_wavenumber_6', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_vstokes_wavenumber_6') + call addfld_to(compocn, 'Sw_vstokes_wavenumber_6') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes_wavenumber_6', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes_wavenumber_6', rc=rc)) then + call addmap_from(compwav, 'Sw_vstokes_wavenumber_6', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_vstokes_wavenumber_6', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_ustokes_wavenumber_6') + call addfld_to(compocn, 'Sw_ustokes_wavenumber_6') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes_wavenumber_6', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes_wavenumber_6', rc=rc)) then + call addmap_from(compwav, 'Sw_ustokes_wavenumber_6', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_ustokes_wavenumber_6', mrg_from=compwav, mrg_fld='Sw_ustokes_wavenumber_6', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_vstokes_wavenumber_6') + call addfld_to(compocn, 'Sw_vstokes_wavenumber_6') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes_wavenumber_6', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes_wavenumber_6', rc=rc)) then + call addmap_from(compwav, 'Sw_vstokes_wavenumber_6', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_vstokes_wavenumber_6', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_Dp') + call addfld_to(compocn, 'Sw_Dp') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_Dp', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_Dp', rc=rc)) then + call addmap_from(compwav, 'Sw_Dp', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_Dp', mrg_from=compwav, mrg_fld='Sw_Dp', mrg_type='copy') + end if + end if + end if !----------------------------- ! to ocn: Stokes drift u component from wave !----------------------------- @@ -2986,6 +3258,21 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(compice, 'Fioo_q', mrg_from=compocn, mrg_fld='Fioo_q', mrg_type='copy') end if end if + ! --------------------------------------------------------------------- + ! to ice: frazil from ocn + ! --------------------------------------------------------------------- + if (ocn_name == 'mpaso' .or. ice_name == 'mpassi') then + if (phase == 'advertise') then + call addfld_from(compocn, 'Fioo_frazil') + call addfld_to(compice, 'Fioo_frazil') + else + if ( fldchk(is_local%wrap%FBImp(compocn, compocn), 'Fioo_frazil', rc=rc) .and. & + fldchk(is_local%wrap%FBExp(compice) , 'Fioo_frazil', rc=rc)) then + call addmap_from(compocn, 'Fioo_frazil', compice, mapfcopy, 'unset', 'unset') + call addmrg_to(compice, 'Fioo_frazil', mrg_from=compocn, mrg_fld='Fioo_frazil', mrg_type='copy') + end if + end if + end if !----------------------------- ! to ice: Ratio of ocean surface level abund. H2_16O/H2O/Rstd from ocean !----------------------------- diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index e41c61dff..d9248bf93 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -833,6 +833,10 @@ canonical_units: m description: ice import to med - surface_snow_water_equivalent # + - standard_name: Si_ithick + canonical_units: m + description: sea-ice export - ice thickness + # - standard_name: Si_vsno alias: mean_snow_volume canonical_units: m @@ -846,6 +850,11 @@ canonical_units: m description: ice import to med - ice floe diameter # + - standard_name: Si_bpress + alias: basal_pressure + canonical_units: Pa + description: sea-ice export - ice basal pressure + # #----------------------------------- # section: ocn import to med #----------------------------------- @@ -855,6 +864,11 @@ canonical_units: W m-2 description: ocn import to med # + - standard_name: Fioo_frazil + alias: frazil_mass_flux + canonical_units: kg m-2 s-1 + description: ocean export + # - standard_name: Faoo_fco2_ocn canonical_units: moles m-2 s-1 description: ocn import to med - surface flux of CO2 (downward positive) @@ -1226,6 +1240,66 @@ canonical_units: 1 description: ocean import - Langmuir multiplier # + - standard_name: Sw_Hs + canonical_units: m + description: ocean import - Significant wave height + # + - standard_name: Sw_Fp + canonical_units: 1 + description: ocean import - Peak wave frequency + # + - standard_name: Sw_Dp + canonical_units: 1 + description: ocean import - Peak wave direction + # + - standard_name: Sw_ustokes_wavenumber_1 + canonical_units: m/s + description: ocean import - partitioned Stokes drift zonal wavenumber 1 + # + - standard_name: Sw_vstokes_wavenumber_1 + canonical_units: m/s + description: ocean import - partitioned Stokes drift meridional wavenumber 1 + # + - standard_name: Sw_ustokes_wavenumber_2 + canonical_units: m/s + description: ocean import - partitioned Stokes drift zonal wavenumber 2 + # + - standard_name: Sw_vstokes_wavenumber_2 + canonical_units: m/s + description: ocean import - partitioned Stokes drift meridional wavenumber 2 + # + - standard_name: Sw_ustokes_wavenumber_3 + canonical_units: m/s + description: ocean import - partitioned Stokes drift zonal wavenumber 3 + # + - standard_name: Sw_vstokes_wavenumber_3 + canonical_units: m/s + description: ocean import - partitioned Stokes drift meridional wavenumber 3 + # + - standard_name: Sw_ustokes_wavenumber_4 + canonical_units: m/s + description: ocean import - partitioned Stokes drift zonal wavenumber 4 + # + - standard_name: Sw_vstokes_wavenumber_4 + canonical_units: m/s + description: ocean import - partitioned Stokes drift meridional wavenumber 4 + # + - standard_name: Sw_ustokes_wavenumber_5 + canonical_units: m/s + description: ocean import - partitioned Stokes drift zonal wavenumber 5 + # + - standard_name: Sw_vstokes_wavenumber_5 + canonical_units: m/s + description: ocean import - partitioned Stokes drift meridional wavenumber 5 + # + - standard_name: Sw_ustokes_wavenumber_6 + canonical_units: m/s + description: ocean import - partitioned Stokes drift zonal wavenumber 6 + # + - standard_name: Sw_vstokes_wavenumber_6 + canonical_units: m/s + description: ocean import - partitioned Stokes drift meridional wavenumber 6 + # - standard_name: Sw_ustokes canonical_units: m/s description: ocean import - Stokes drift u component diff --git a/mediator/med.F90 b/mediator/med.F90 index 067194eff..d7e0d20f5 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -53,6 +53,7 @@ module MED use med_phases_profile_mod , only : med_phases_profile_finalize use shr_log_mod , only : shr_log_error + implicit none private diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index df0d4e351..6dd8e9808 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -142,13 +142,16 @@ module med_diag_mod 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_ioff_glc = unset_index ! heat : latent, fusion, frozen runoff from glc integer :: f_heat_sen = unset_index ! heat : sensible integer :: f_heat_rain = unset_index ! heat : heat content of rain integer :: f_heat_snow = unset_index ! heat : heat content of snow integer :: f_heat_evap = unset_index ! heat : heat content of evaporation integer :: f_heat_cond = unset_index ! heat : heat content of evaporation integer :: f_heat_rofl = unset_index ! heat : heat content of liquid runoff + integer :: f_heat_rofl_glc = unset_index ! heat : heat content of liquid runoff from glc integer :: f_heat_rofi = unset_index ! heat : heat content of ice runoff + integer :: f_heat_rofi_glc = unset_index ! heat : heat content of ice runoff from glc integer :: f_watr_frz = unset_index ! water: freezing integer :: f_watr_melt = unset_index ! water: melting @@ -157,7 +160,9 @@ module med_diag_mod 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_roff_glc = unset_index ! water: runoff/flood from glc integer :: f_watr_ioff = unset_index ! water: frozen runoff + integer :: f_watr_ioff_glc = unset_index ! water: frozen runoff from glc 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 @@ -324,6 +329,7 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_heat_latvap ,'hlatvap' ) ! field heat : latent, vaporization call add_to_budget_diag(budget_diags%fields, f_heat_latf ,'hlatfus' ) ! field heat : latent, fusion, snow call add_to_budget_diag(budget_diags%fields, f_heat_ioff ,'hiroff' ) ! field heat : latent, fusion, frozen runoff + call add_to_budget_diag(budget_diags%fields, f_heat_ioff_glc ,'hiroff_glc' ) ! field heat : latent, fusion, frozen runoff from glc call add_to_budget_diag(budget_diags%fields, f_heat_sen ,'hsen' ) ! field heat : sensible if (trim(budget_table_version) == 'v0') then f_heat_beg = f_heat_frz ! field first index for heat @@ -334,9 +340,11 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_heat_evap ,'hevap' ) ! field heat : enthalpy of evaporation call add_to_budget_diag(budget_diags%fields, f_heat_cond ,'hcond' ) ! field heat : enthalpy of evaporation call add_to_budget_diag(budget_diags%fields, f_heat_rofl ,'hrofl' ) ! field heat : enthalpy of liquid runoff + call add_to_budget_diag(budget_diags%fields, f_heat_rofl_glc ,'hrofl_glc') ! field heat : enthalpy of liquid runoff from glc call add_to_budget_diag(budget_diags%fields, f_heat_rofi ,'hrofi' ) ! field heat : enthalpy of ice runoff + call add_to_budget_diag(budget_diags%fields, f_heat_rofi_glc ,'hrofi_glc') ! field heat : enthalpy of ice runoff from glc f_heat_beg = f_heat_frz ! field first index for heat - f_heat_end = f_heat_rofi ! field last index for heat + f_heat_end = f_heat_rofi_glc ! field last index for heat end if ! ----------------------------------------- @@ -355,13 +363,15 @@ subroutine med_diag_init(gcomp, rc) 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_roff_glc ,'wrunoff_glc' ) ! field water: runoff/flood from glc call add_to_budget_diag(budget_diags%fields, f_watr_ioff ,'wfrzrof' ) ! field water: frozen runoff + call add_to_budget_diag(budget_diags%fields, f_watr_ioff_glc ,'wfrzrof_glc' ) ! field water: frozen runoff from glc 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 + f_watr_end = f_watr_ioff_glc ! 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 @@ -1201,11 +1211,13 @@ subroutine med_phases_diag_rof( gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( fldbun_fldchk(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofl_glc', rc=rc)) then - call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofl_glc' , f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc) + call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofl_glc' , f_watr_roff_glc, & + ic, areas, budget_local, minus=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if ( fldbun_fldchk(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofi_glc', rc=rc)) then - call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofi_glc' , f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofi_glc' , f_watr_ioff_glc, & + ic, areas, budget_local, minus=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -1222,6 +1234,7 @@ subroutine med_phases_diag_rof( gcomp, rc) end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice + budget_local(f_heat_ioff_glc,ic,ip) = -budget_local(f_watr_ioff_glc,ic,ip)*shr_const_latice !------------------------------- ! to river from mediator @@ -1241,11 +1254,11 @@ subroutine med_phases_diag_rof( gcomp, rc) 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 if (fldbun_fldchk(is_local%wrap%FBExp(comprof), 'Fgrg_rofl', rc=rc)) then - call diag_rof(is_local%wrap%FBExp(comprof), 'Fgrg_rofl' , f_watr_roff, ic, areas, budget_local, rc=rc) + call diag_rof(is_local%wrap%FBExp(comprof), 'Fgrg_rofl' , f_watr_roff_glc, ic, areas, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if if (fldbun_fldchk(is_local%wrap%FBExp(comprof), 'Fgrg_rofi', rc=rc)) then - call diag_rof(is_local%wrap%FBExp(comprof), 'Fgrg_rofi' , f_watr_ioff, ic, areas, budget_local, rc=rc) + call diag_rof(is_local%wrap%FBExp(comprof), 'Fgrg_rofi' , f_watr_ioff_glc, ic, areas, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -1259,6 +1272,7 @@ subroutine med_phases_diag_rof( gcomp, rc) end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice + budget_local(f_heat_ioff_glc,ic,ip) = -budget_local(f_watr_ioff_glc,ic,ip)*shr_const_latice call t_stopf('MED:'//subname) end subroutine med_phases_diag_rof @@ -1367,15 +1381,15 @@ subroutine med_phases_diag_glc( gcomp, rc) 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)), 'Fgrg_rofl', f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc) + call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Fgrg_rofl', f_watr_roff_glc, 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)), 'Fgrg_rofi', f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Fgrg_rofi', f_watr_ioff_glc, 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) + call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Figg_rofi', f_watr_ioff_glc, 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 + budget_local(f_heat_ioff_glc,ic,ip) = -budget_local(f_watr_ioff_glc,ic,ip)*shr_const_latice call t_stopf('MED:'//subname) end subroutine med_phases_diag_glc @@ -1555,11 +1569,11 @@ subroutine med_phases_diag_ocn( gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Forr_rofl_glc' , rc=rc)) then - call diag_ocn(is_local%wrap%FBExp(compocn), 'Forr_rofl_glc' , f_watr_roff , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Forr_rofl_glc' , f_watr_roff_glc, 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), 'Forr_rofi_glc' , rc=rc)) then - call diag_ocn(is_local%wrap%FBExp(compocn), 'Forr_rofi_glc' , f_watr_ioff , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Forr_rofi_glc' , f_watr_ioff_glc, ic, areas, sfrac, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -1594,11 +1608,16 @@ subroutine med_phases_diag_ocn( gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_hrofl', f_heat_rofl , ic, areas, sfrac, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_hrofl_glc', f_heat_rofl_glc , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_hrofi', f_heat_rofi , ic, areas, sfrac, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_hrofi_glc', f_heat_rofi_glc , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice + budget_local(f_heat_ioff_glc,ic,ip) = -budget_local(f_watr_ioff_glc,ic,ip)*shr_const_latice deallocate(sfrac) call t_stopf('MED:'//subname) From 61b5a22ff810a647587c3e697b48a15c016f27d7 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Fri, 29 Aug 2025 13:40:28 -0600 Subject: [PATCH 02/15] FV3 -> UFSATM name change. (#145) --- mediator/esmFldsExchange_ufs_mod.F90 | 2 +- ufs/ccpp/config/ccpp_prebuild_config.py | 20 ++++++++++---------- ufs/ccpp/data/MED_typedefs.meta | 2 +- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/mediator/esmFldsExchange_ufs_mod.F90 b/mediator/esmFldsExchange_ufs_mod.F90 index dd342cf07..9b4a590c6 100644 --- a/mediator/esmFldsExchange_ufs_mod.F90 +++ b/mediator/esmFldsExchange_ufs_mod.F90 @@ -312,7 +312,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) deallocate(flds) end if - ! to atm: unmerged from mediator, merge will be done under FV3/CCPP composite step + ! to atm: unmerged from mediator, merge will be done under UFSATM/CCPP composite step ! - zonal surface stress, meridional surface stress ! - surface latent heat flux, ! - surface sensible heat flux diff --git a/ufs/ccpp/config/ccpp_prebuild_config.py b/ufs/ccpp/config/ccpp_prebuild_config.py index 8d8963bad..c9c3add7d 100755 --- a/ufs/ccpp/config/ccpp_prebuild_config.py +++ b/ufs/ccpp/config/ccpp_prebuild_config.py @@ -10,7 +10,7 @@ # Query required information/s # ############################################################################### -fv3_path = os.environ['FV3_PATH'] +ufsatm_path = os.environ['UFSATM_PATH'] ############################################################################### # Definitions # @@ -24,8 +24,8 @@ # dependencies of these files to the list. VARIABLE_DEFINITION_FILES = [ # actual variable definition files - '{}/ccpp/framework/src/ccpp_types.F90'.format(fv3_path), - '{}/ccpp/physics/physics/hooks/machine.F'.format(fv3_path), + '{}/ccpp/framework/src/ccpp_types.F90'.format(ufsatm_path), + '{}/ccpp/physics/physics/hooks/machine.F'.format(ufsatm_path), 'CMEPS/ufs/ccpp/data/MED_typedefs.F90', 'CMEPS/ufs/ccpp/data/MED_data.F90' ] @@ -58,13 +58,13 @@ # Add all physics scheme files relative to basedir SCHEME_FILES = [ - '{}/ccpp/physics/physics/SFC_Models/Ocean/UFS/sfc_ocean.F'.format(fv3_path), - '{}/ccpp/physics/physics/SFC_Layer/UFS/sfc_diff.f'.format(fv3_path), - '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.F90'.format(fv3_path), - '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.F90'.format(fv3_path), - '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90'.format(fv3_path), - '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.F90'.format(fv3_path), - '{}/ccpp/physics/physics/SFC_Layer/UFS/sfc_diag.f'.format(fv3_path) + '{}/ccpp/physics/physics/SFC_Models/Ocean/UFS/sfc_ocean.F'.format(ufsatm_path), + '{}/ccpp/physics/physics/SFC_Layer/UFS/sfc_diff.f'.format(ufsatm_path), + '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part1.F90'.format(ufsatm_path), + '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_loop_control_part2.F90'.format(ufsatm_path), + '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_pre.F90'.format(ufsatm_path), + '{}/ccpp/physics/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_surface_composites_post.F90'.format(ufsatm_path), + '{}/ccpp/physics/physics/SFC_Layer/UFS/sfc_diag.f'.format(ufsatm_path) ] # Default build dir, relative to current working directory, diff --git a/ufs/ccpp/data/MED_typedefs.meta b/ufs/ccpp/data/MED_typedefs.meta index 046e4bfa6..6f89e4842 100644 --- a/ufs/ccpp/data/MED_typedefs.meta +++ b/ufs/ccpp/data/MED_typedefs.meta @@ -1358,7 +1358,7 @@ [ccpp-table-properties] name = MED_typedefs type = module - relative_path = ../../../../../FV3/ccpp/physics/physics/hooks + relative_path = ../../../../../UFSATM/ccpp/physics/physics/hooks dependencies = machine.F,physcons.F90 [ccpp-arg-table] From 2c1f924ccc57d3c19bf788da1dbe9006d94dfc4f Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Wed, 17 Sep 2025 14:05:35 -0400 Subject: [PATCH 03/15] Replace icplocn2atm (integer) with use_oceanuv (logical) (#149) * update typedefs for icplocn2atm * update standard_name in ccpp/data --- ufs/ccpp/data/MED_typedefs.F90 | 28 ++++++++++++++-------------- ufs/ccpp/data/MED_typedefs.meta | 9 ++++----- 2 files changed, 18 insertions(+), 19 deletions(-) diff --git a/ufs/ccpp/data/MED_typedefs.F90 b/ufs/ccpp/data/MED_typedefs.F90 index 649ee9b69..a60b7cc57 100644 --- a/ufs/ccpp/data/MED_typedefs.F90 +++ b/ufs/ccpp/data/MED_typedefs.F90 @@ -5,7 +5,7 @@ module MED_typedefs !! use machine, only: kind_phys use physcons, only: con_hvap, con_cp, con_rd, con_eps, con_rocp - use physcons, only: con_epsm1, con_fvirt, con_g + use physcons, only: con_epsm1, con_fvirt, con_g use physcons, only: con_tice, karman implicit none @@ -69,7 +69,7 @@ module MED_typedefs real(kind=kind_phys), pointer :: prslki(:) => null() !< Exner function ratio bt midlayer and interface at 1st layer logical, pointer :: wet(:) => null() !< flag indicating presence of some ocean or lake surface area fraction integer, pointer :: use_lake_model(:)=>null() !< 0 for points that don't use a lake model, lkm for points that do - real (kind=kind_phys),pointer :: lake_t2m (:) => null() !< 2 meter temperature from CLM Lake model + real (kind=kind_phys),pointer :: lake_t2m (:) => null() !< 2 meter temperature from CLM Lake model real (kind=kind_phys),pointer :: lake_q2m (:) => null() !< 2 meter humidity from CLM Lake model real(kind=kind_phys), pointer :: wind(:) => null() !< wind speed at lowest model level (m/s) logical, pointer :: flag_iter(:) => null() !< flag for iteration @@ -83,7 +83,7 @@ module MED_typedefs real(kind=kind_phys), pointer :: ep1d_water(:) => null() !< surface upward potential latent heat flux over water (W/m2) real(kind=kind_phys), pointer :: tsurf_water(:) => null() !< surface skin temperature after iteration over water (K) real(kind=kind_phys), pointer :: uustar_water(:) => null() !< surface friction velocity over water (m/s) - real(kind=kind_phys), pointer :: rb_water(:) => null() !< bulk Richardson number at the surface over water + real(kind=kind_phys), pointer :: rb_water(:) => null() !< bulk Richardson number at the surface over water real(kind=kind_phys), pointer :: stress_water(:) => null() !< surface wind stress over water real(kind=kind_phys), pointer :: ffhh_water(:) => null() !< Monin-Obukhov similarity function for heat over water real(kind=kind_phys), pointer :: fh2_water(:) => null() !< Monin-Obukhov similarity parameter for heat at 2m over water @@ -96,13 +96,13 @@ module MED_typedefs real(kind=kind_phys), pointer :: sigmaf(:) => null() !< areal fractional cover of green vegetation bounded on the bottom logical, pointer :: dry(:) => null() !< flag indicating presence of some land surface area fraction real(kind=kind_phys), pointer :: tsfcl(:) => null() !< surface skin temperature over land (K) - real(kind=kind_phys), pointer :: tsurf_land(:) => null() !< surface skin temperature after iteration over land (K) + real(kind=kind_phys), pointer :: tsurf_land(:) => null() !< surface skin temperature after iteration over land (K) real(kind=kind_phys), pointer :: uustar_land(:) => null() !< surface friction velocity over land (m/s) - real(kind=kind_phys), pointer :: cd_land(:) => null() !< surface exchange coeff for momentum over land - real(kind=kind_phys), pointer :: cdq_land(:) => null() !< surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over land + real(kind=kind_phys), pointer :: cd_land(:) => null() !< surface exchange coeff for momentum over land + real(kind=kind_phys), pointer :: cdq_land(:) => null() !< surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over land real(kind=kind_phys), pointer :: rb_land(:) => null() !< bulk Richardson number at the surface over land - real(kind=kind_phys), pointer :: stress_land(:) => null() !< surface wind stress over land - real(kind=kind_phys), pointer :: ffmm_land(:) => null() !< Monin-Obukhov similarity function for momentum over land + real(kind=kind_phys), pointer :: stress_land(:) => null() !< surface wind stress over land + real(kind=kind_phys), pointer :: ffmm_land(:) => null() !< Monin-Obukhov similarity function for momentum over land real(kind=kind_phys), pointer :: ffhh_land(:) => null() !< Monin-Obukhov similarity function for heat over land real(kind=kind_phys), pointer :: fm10_land(:) => null() !< Monin-Obukhov similarity parameter for momentum at 10m over land real(kind=kind_phys), pointer :: fh2_land(:) => null() !< Monin-Obukhov similarity parameter for heat at 2m over land @@ -121,10 +121,10 @@ module MED_typedefs ! ice, not used to calculate aofluxes logical, pointer :: icy(:) => null() !< flag indicating presence of some sea ice surface area fraction real(kind=kind_phys), pointer :: tisfc(:) => null() !< surface skin temperature over ice (K) - real(kind=kind_phys), pointer :: tsurf_ice(:) => null() !< surface skin temperature after iteration over ice (K) + real(kind=kind_phys), pointer :: tsurf_ice(:) => null() !< surface skin temperature after iteration over ice (K) real(kind=kind_phys), pointer :: uustar_ice(:) => null() !< surface friction velocity over ice (m/s) - real(kind=kind_phys), pointer :: cd_ice(:) => null() !< surface exchange coeff for momentum over ice - real(kind=kind_phys), pointer :: cdq_ice(:) => null() !< surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over ice + real(kind=kind_phys), pointer :: cd_ice(:) => null() !< surface exchange coeff for momentum over ice + real(kind=kind_phys), pointer :: cdq_ice(:) => null() !< surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over ice real(kind=kind_phys), pointer :: rb_ice(:) => null() !< bulk Richardson number at the surface over ice real(kind=kind_phys), pointer :: stress_ice(:) => null() !< surface wind stress over ice real(kind=kind_phys), pointer :: ffmm_ice(:) => null() !< Monin-Obukhov similarity function for momentum over ice @@ -173,7 +173,7 @@ module MED_typedefs integer :: lsm_noahmp !< flag for NOAH MP land surface model logical :: redrag !< flag for reduced drag coeff. over sea integer :: sfc_z0_type !< surface roughness options over water - integer :: icplocn2atm !< flag controlling whether to consider ocean current in air-sea flux calculation + logical :: use_oceanuv !< flag controlling whether to consider ocean current in air-sea flux calculation logical :: thsfc_loc !< flag for reference pressure in theta calculation integer :: nstf_name(5) !< NSSTM flag: off/uncoupled/coupled=0/1/2 integer :: lkm !< 0 = no lake model, 1 = lake model, 2 = lake & nsst on lake points @@ -251,7 +251,7 @@ module MED_typedefs real(kind=kind_phys), pointer :: fice(:) => null() !< ice fraction over open water real(kind=kind_phys), pointer :: hice(:) => null() !< sea ice thickness (m) real(kind=kind_phys), pointer :: tsfco(:) => null() !< sea surface temperature - real(kind=kind_phys), pointer :: usfco(:) => null() !< sea surface ocean current (zonal) + real(kind=kind_phys), pointer :: usfco(:) => null() !< sea surface ocean current (zonal) real(kind=kind_phys), pointer :: vsfco(:) => null() !< sea surface ocean current (merdional) real(kind=kind_phys), pointer :: uustar(:) => null() !< boundary layer parameter real(kind=kind_phys), pointer :: tsfc(:) => null() !< surface skin temperature @@ -646,7 +646,7 @@ subroutine control_initialize(model) model%ivegsrc = 2 model%redrag = .false. model%sfc_z0_type = 0 - model%icplocn2atm = 0 + model%use_oceanuv = .false. model%thsfc_loc = .true. model%lsm = 1 model%lsm_noahmp = 2 diff --git a/ufs/ccpp/data/MED_typedefs.meta b/ufs/ccpp/data/MED_typedefs.meta index 6f89e4842..54c79eba1 100644 --- a/ufs/ccpp/data/MED_typedefs.meta +++ b/ufs/ccpp/data/MED_typedefs.meta @@ -911,12 +911,12 @@ units = flag dimensions = () type = logical -[icplocn2atm] - standard_name = control_for_air_sea_flux_computation_over_water +[use_oceanuv] + standard_name = do_air_sea_flux_computation_over_water long_name = air-sea flux option - units = 1 + units = flag dimensions = () - type = integer + type = logical [cpl_fire] standard_name = do_fire_coupling long_name = flag controlling fire_behavior collection (default off) @@ -1481,4 +1481,3 @@ units = none dimensions = () type = real - From 374373588e22cd86f1b8eb670d489c2967a6b40a Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Mon, 22 Sep 2025 08:21:46 -0400 Subject: [PATCH 04/15] add u,v ocn->atm for global configs (#138) * add u,v ocn->atm for global configs * update typedefs for icplocn2atm --- mediator/esmFldsExchange_ufs_mod.F90 | 30 +++++++++++++++++----------- 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/mediator/esmFldsExchange_ufs_mod.F90 b/mediator/esmFldsExchange_ufs_mod.F90 index 9b4a590c6..bc6fa86e5 100644 --- a/mediator/esmFldsExchange_ufs_mod.F90 +++ b/mediator/esmFldsExchange_ufs_mod.F90 @@ -256,19 +256,25 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) end do deallocate(flds) - ! to atm: unmerged surface temperatures from ocn - if (phase == 'advertise') then - if (is_local%wrap%comp_present(compocn) .and. is_local%wrap%comp_present(compatm)) then - call addfld_from(compocn , 'So_t') - call addfld_to(compatm , '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 - call addmap_from(compocn, 'So_t', compatm, maptype, 'ofrac', 'unset') - call addmrg_to(compatm, 'So_t', mrg_from=compocn, mrg_fld='So_t', mrg_type='copy') + ! to atm: unmerged surface temperatures and currents from ocn + allocate(flds(3)) + flds = (/'So_t', 'So_u', 'So_v'/) + 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(compatm)) then + call addfld_from(compocn , fldname) + call addfld_to(compatm , fldname) + end if + else + if ( fldchk(is_local%wrap%FBexp(compatm) , fldname, rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn), fldname, rc=rc)) then + call addmap_from(compocn, fldname, compatm, maptype, 'ofrac', 'unset') + call addmrg_to(compatm, fldname, mrg_from=compocn, mrg_fld=fldname, mrg_type='copy') + end if end if - end if + end do + deallocate(flds) ! to atm: unmerged flux components from lnd if (is_local%wrap%comp_present(complnd) .and. is_local%wrap%comp_present(compatm)) then From 607a0bddcef8b8c4f0c80886be68db88fe52429f Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 13 Nov 2025 09:27:09 -0700 Subject: [PATCH 05/15] Changes to accommodate CCPP framework upgrades (#150) * Replace horizontal_loop_extent with horizontal_dimension * One more CCPP metadata change --- ufs/ccpp/data/MED_typedefs.F90 | 1 + ufs/ccpp/data/MED_typedefs.meta | 308 ++++++++++++++++---------------- 2 files changed, 158 insertions(+), 151 deletions(-) diff --git a/ufs/ccpp/data/MED_typedefs.F90 b/ufs/ccpp/data/MED_typedefs.F90 index a60b7cc57..f51fe0a9b 100644 --- a/ufs/ccpp/data/MED_typedefs.F90 +++ b/ufs/ccpp/data/MED_typedefs.F90 @@ -22,6 +22,7 @@ module MED_typedefs !! type MED_init_type integer :: im !< horizontal loop extent + integer :: nCol !< horizontal dimension end type MED_init_type !! \section arg_table_MED_statein_type diff --git a/ufs/ccpp/data/MED_typedefs.meta b/ufs/ccpp/data/MED_typedefs.meta index 54c79eba1..a215ef28d 100644 --- a/ufs/ccpp/data/MED_typedefs.meta +++ b/ufs/ccpp/data/MED_typedefs.meta @@ -12,6 +12,12 @@ units = count dimensions = () type = integer +[nCol] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer ######################################################################## [ccpp-table-properties] @@ -26,84 +32,84 @@ standard_name = surface_air_pressure long_name = surface pressure units = Pa - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ugrs] standard_name = x_wind_at_surface_adjacent_layer long_name = zonal wind at lowest model layer units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [vgrs] standard_name = y_wind_at_surface_adjacent_layer long_name = meridional wind at lowest model layer units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tgrs] standard_name = air_temperature_at_surface_adjacent_layer long_name = mean temperature at lowest model layer units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [qgrs] standard_name = specific_humidity_at_surface_adjacent_layer long_name = water vapor specific humidity at lowest model layer units = kg kg-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [prsl] standard_name = air_pressure_at_surface_adjacent_layer long_name = mean pressure at lowest model layer units = Pa - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zlvl] standard_name = height_above_ground_at_lowest_model_layer long_name = layer 1 height above ground (not MSL) units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [prsik] standard_name = surface_dimensionless_exner_function long_name = dimensionless Exner function at lowest model interface units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [prslk] standard_name = dimensionless_exner_function_at_surface_adjacent_layer long_name = dimensionless Exner function at lowest model layer units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [u10m] standard_name = x_wind_at_10m long_name = 10 meter u wind speed units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [v10m] standard_name = y_wind_at_10m long_name = 10 meter v wind speed units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [stc] standard_name = soil_temperature long_name = soil temperature units = K - dimensions = (horizontal_loop_extent,vertical_dimension_of_soil) + dimensions = (horizontal_dimension,vertical_dimension_of_soil) type = real kind = kind_phys @@ -120,28 +126,28 @@ standard_name = x_wind_of_new_state_at_surface_adjacent_layer long_name = zonal wind at lowest model layer updated by physics units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [gv0] standard_name = y_wind_of_new_state_at_surface_adjacent_layer long_name = meridional wind at lowest model layer updated by physics units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [gt0] standard_name = air_temperature_of_new_state_at_surface_adjacent_layer long_name = temperature at lowest model layer updated by physics units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [gq0] standard_name = specific_humidity_of_new_state_at_surface_adjacent_layer long_name = water vapor specific humidity at lowest model layer updated by physics units = kg kg-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -158,55 +164,55 @@ standard_name = surface_skin_temperature_over_water long_name = surface skin temperature over water units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cd_water] standard_name = surface_drag_coefficient_for_momentum_in_air_over_water long_name = surface exchange coeff for momentum over water units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cdq_water] standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_water long_name = surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over water units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffmm_water] standard_name = Monin_Obukhov_similarity_function_for_momentum_over_water long_name = Monin-Obukhov similarity function for momentum over water units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fm10_water] standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_water long_name = Monin-Obukhov similarity parameter for momentum at 10m over water units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [prslki] standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer long_name = Exner function ratio bt midlayer and interface at 1st layer units = ratio - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [wet] standard_name = flag_nonzero_wet_surface_fraction long_name = flag indicating presence of some ocean or lake surface area fraction units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [lake_t2m] standard_name = temperature_at_2m_from_clm_lake long_name = temperature at 2m from clm lake units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys active = (control_for_lake_model_selection == 2) @@ -214,7 +220,7 @@ standard_name = specific_humidity_at_2m_from_clm_lake long_name = specific humidity at 2m from clm lake units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys active = (control_for_lake_model_selection == 2) @@ -222,557 +228,557 @@ standard_name = flag_for_using_lake_model long_name = flag indicating lake points using a lake model units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = integer [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [flag_iter] standard_name = flag_for_iteration long_name = flag for iteration units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [flag_lakefreeze] standard_name = flag_for_lake_water_freeze long_name = flag for lake water freeze units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [qss_water] standard_name = surface_specific_humidity_over_water long_name = surface air saturation specific humidity over water units = kg kg-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cmm_water] standard_name = surface_drag_wind_speed_for_momentum_in_air_over_water long_name = momentum exchange coefficient over water units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [chh_water] standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water long_name = thermal exchange coefficient over water units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [gflx_water] standard_name = upward_heat_flux_in_soil_over_water long_name = soil heat flux over water units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [evap_water] standard_name = kinematic_surface_upward_latent_heat_flux_over_water long_name = kinematic surface upward latent heat flux over water units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [evap_land] standard_name = kinematic_surface_upward_latent_heat_flux_over_land long_name = kinematic surface upward latent heat flux over land units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [evap_ice] standard_name = kinematic_surface_upward_latent_heat_flux_over_ice long_name = kinematic surface upward latent heat flux over ice units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hflx_water] standard_name = kinematic_surface_upward_sensible_heat_flux_over_water long_name = kinematic surface upward sensible heat flux over water units = K m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hflx_land] standard_name = kinematic_surface_upward_sensible_heat_flux_over_land long_name = kinematic surface upward sensible heat flux over land units = K m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hflx_ice] standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice long_name = kinematic surface upward sensible heat flux over ice units = K m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ep1d_water] standard_name = surface_upward_potential_latent_heat_flux_over_water long_name = surface upward potential latent heat flux over water units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zvfun] standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction long_name = function of surface roughness length and green vegetation fraction units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [sigmaf] standard_name = bounded_vegetation_area_fraction long_name = areal fractional cover of green vegetation bounded on the bottom units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [z01d] standard_name = perturbation_of_momentum_roughness_length long_name = perturbation of momentum roughness length units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zt1d] standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio long_name = perturbation of heat to momentum roughness length ratio units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [icy] standard_name = flag_nonzero_sea_ice_surface_fraction long_name = flag indicating presence of some sea ice surface area fraction units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [tsfcl] standard_name = surface_skin_temperature_over_land long_name = surface skin temperature over land units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tisfc] standard_name = surface_skin_temperature_over_ice long_name = surface skin temperature over ice units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tsurf_water] standard_name = surface_skin_temperature_after_iteration_over_water long_name = surface skin temperature after iteration over water units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tsurf_land] standard_name = surface_skin_temperature_after_iteration_over_land long_name = surface skin temperature after iteration over land units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tsurf_ice] standard_name = surface_skin_temperature_after_iteration_over_ice long_name = surface skin temperature after iteration over ice units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [uustar_water] standard_name = surface_friction_velocity_over_water long_name = surface friction velocity over water units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [uustar_land] standard_name = surface_friction_velocity_over_land long_name = surface friction velocity over land units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [uustar_ice] standard_name = surface_friction_velocity_over_ice long_name = surface friction velocity over ice units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cd] standard_name = surface_drag_coefficient_for_momentum_in_air long_name = surface exchange coeff for momentum units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cd_land] standard_name = surface_drag_coefficient_for_momentum_in_air_over_land long_name = surface exchange coeff for momentum over land units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cd_ice] standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice long_name = surface exchange coeff for momentum over ice units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cdq] standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air long_name = surface exchange coeff heat & moisture units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cdq_land] standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land long_name = surface exchange coeff heat & moisture over land units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cdq_ice] standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice long_name = surface exchange coeff heat & moisture over ice units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [rb_water] standard_name = bulk_richardson_number_at_lowest_model_level_over_water long_name = bulk Richardson number at the surface over water units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [rb_land] standard_name = bulk_richardson_number_at_lowest_model_level_over_land long_name = bulk Richardson number at the surface over land units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [rb_ice] standard_name = bulk_richardson_number_at_lowest_model_level_over_ice long_name = bulk Richardson number at the surface over ice units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [stress_water] standard_name = surface_wind_stress_over_water long_name = surface wind stress over water units = m2 s-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [stress_land] standard_name = surface_wind_stress_over_land long_name = surface wind stress over land units = m2 s-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [stress_ice] standard_name = surface_wind_stress_over_ice long_name = surface wind stress over ice units = m2 s-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffmm_land] standard_name = Monin_Obukhov_similarity_function_for_momentum_over_land long_name = Monin-Obukhov similarity function for momentum over land units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffmm_ice] standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice long_name = Monin-Obukhov similarity function for momentum over ice units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffhh_water] standard_name = Monin_Obukhov_similarity_function_for_heat_over_water long_name = Monin-Obukhov similarity function for heat over water units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffhh_land] standard_name = Monin_Obukhov_similarity_function_for_heat_over_land long_name = Monin-Obukhov similarity function for heat over land units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffhh_ice] standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice long_name = Monin-Obukhov similarity function for heat over ice units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fm10_land] standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land long_name = Monin-Obukhov similarity parameter for momentum at 10m over land units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fm10_ice] standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice long_name = Monin-Obukhov similarity parameter for momentum at 10m over ice units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fh2_water] standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_water long_name = Monin-Obukhov similarity parameter for heat at 2m over water units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fh2_land] standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_land long_name = Monin-Obukhov similarity parameter for heat at 2m over land units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fh2_ice] standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice long_name = Monin-Obukhov similarity parameter for heat at 2m over ice units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ztmax_water] standard_name = bounded_surface_roughness_length_for_heat_over_water long_name = bounded surface roughness length for heat over water units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ztmax_land] standard_name = bounded_surface_roughness_length_for_heat_over_land long_name = bounded surface roughness length for heat over land units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ztmax_ice] standard_name = bounded_surface_roughness_length_for_heat_over_ice long_name = bounded surface roughness length for heat over ice units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [flag_guess] standard_name = flag_for_guess_run long_name = flag for guess run units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [flag_cice] standard_name = flag_for_cice long_name = flag for cice units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [lake] standard_name = flag_nonzero_lake_surface_fraction long_name = flag indicating presence of some lake surface area fraction units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = logical [frland] standard_name = land_area_fraction_for_microphysics long_name = land area fraction used in microphysics schemes units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tprcp_water] standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water long_name = total precipitation amount in each time step over water units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tprcp_land] standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land long_name = total precipitation amount in each time step over land units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tprcp_ice] standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice long_name = total precipitation amount in each time step over ice units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [islmsk] standard_name = sea_land_ice_mask long_name = sea/land/ice mask (=0/1/2) units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = integer [islmsk_cice] standard_name = sea_land_ice_mask_cice long_name = sea/land/ice mask cice (=0/1/2) units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = integer [qss_land] standard_name = surface_specific_humidity_over_land long_name = surface air saturation specific humidity over land units = kg kg-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [qss_ice] standard_name = surface_specific_humidity_over_ice long_name = surface air saturation specific humidity over ice units = kg kg-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ep1d_ice] standard_name = surface_upward_potential_latent_heat_flux_over_ice long_name = surface upward potential latent heat flux over ice units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [gflx_ice] standard_name = upward_heat_flux_in_soil_over_ice long_name = soil heat flux over ice units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [rb] standard_name = bulk_richardson_number_at_lowest_model_level long_name = bulk Richardson number at the surface units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hflxq] standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fh2] standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m long_name = Monin-Obukhov similarity parameter for heat at 2m units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fm10] standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m long_name = Monin-Obukhov similarity parameter for momentum at 10m units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [chh_land] standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land long_name = thermal exchange coefficient over land units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [chh_ice] standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice long_name = thermal exchange coefficient over ice units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cmm_land] standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land long_name = momentum exchange coefficient over land units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cmm_ice] standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ice long_name = momentum exchange coefficient over ice units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ep1d] standard_name = surface_upward_potential_latent_heat_flux long_name = surface upward potential latent heat flux units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ep1d_land] standard_name = surface_upward_potential_latent_heat_flux_over_land long_name = surface upward potential latent heat flux over land units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hffac] standard_name = surface_upward_sensible_heat_flux_reduction_factor long_name = surface upward sensible heat flux reduction factor from canopy heat storage units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [stress] standard_name = surface_wind_stress long_name = surface wind stress units = m2 s-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [gflx] standard_name = upward_heat_flux_in_soil long_name = soil heat flux units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [gflx_land] standard_name = upward_heat_flux_in_soil_over_land long_name = soil heat flux over land units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -1014,14 +1020,14 @@ standard_name = surface_upward_sensible_heat_flux_over_ocean_from_mediator long_name = sfc sensible heat flux input over ocean for coupling units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [dqsfcin_med] standard_name = surface_upward_latent_heat_flux_over_ocean_from_mediator long_name = sfc latent heat flux input over ocean for coupling units = W m-2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -1037,21 +1043,21 @@ standard_name = cell_area long_name = area of the grid cell units = m2 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [xlat_d] standard_name = latitude_in_degree long_name = latitude in degree north units = degree_north - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [xlon_d] standard_name = longitude_in_degree long_name = longitude in degree east units = degree_east - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -1068,258 +1074,258 @@ standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = integer [shdmax] standard_name = max_vegetation_area_fraction long_name = max fractional coverage of green vegetation units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zorlw] standard_name = surface_roughness_length_over_water long_name = surface roughness length over water units = cm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zorll] standard_name = surface_roughness_length_over_land long_name = surface roughness length over land units = cm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zorli] standard_name = surface_roughness_length_over_ice long_name = surface roughness length over ice units = cm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zorlwav] standard_name = surface_roughness_length_from_wave_model long_name = surface roughness length from wave model units = cm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [slmsk] standard_name = area_type long_name = landmask: sea/land/ice=0/1/2 units = flag - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [lakefrac] standard_name = lake_area_fraction long_name = fraction of horizontal grid area occupied by lake units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [lakedepth] standard_name = lake_depth long_name = lake depth units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [landfrac] standard_name = land_area_fraction long_name = fraction of horizontal grid area occupied by land units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tprcp] standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep long_name = total precipitation amount in each time step units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [oceanfrac] standard_name = sea_area_fraction long_name = fraction of horizontal grid area occupied by ocean units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [fice] standard_name = sea_ice_area_fraction_of_sea_area_fraction long_name = ice fraction over open water units = frac - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hice] standard_name = sea_ice_thickness long_name = sea ice thickness units = m - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tsfco] standard_name = sea_surface_temperature long_name = sea surface temperature units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [usfco] standard_name = x_ocean_current long_name = zonal current at ocean surface units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [vsfco] standard_name = y_ocean_current long_name = meridional current at ocean surface units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [uustar] standard_name = surface_friction_velocity long_name = boundary layer parameter units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tsfc] standard_name = surface_skin_temperature long_name = surface skin temperature units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [snodi] standard_name = surface_snow_thickness_water_equivalent_over_ice long_name = water equivalent snow depth over ice units = mm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [snodl] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land units = mm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [qss] standard_name = surface_specific_humidity long_name = surface air saturation specific humidity units = kg kg-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [weasdi] standard_name = water_equivalent_accumulated_snow_depth_over_ice long_name = water equiv of acc snow depth over land units = mm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [weasdl] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land units = mm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [snowd] standard_name = lwe_surface_snow long_name = water equivalent snow depth units = mm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [weasd] standard_name = lwe_thickness_of_surface_snow_amount long_name = water equiv of acc snow depth over land and sea ice units = mm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffhh] standard_name = Monin_Obukhov_similarity_function_for_heat long_name = Monin-Obukhov similarity function for heat units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [ffmm] standard_name = Monin_Obukhov_similarity_function_for_momentum long_name = Monin-Obukhov similarity function for momentum units = none - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [zorl] standard_name = surface_roughness_length long_name = surface roughness length units = cm - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [evap] standard_name = surface_upward_specific_humidity_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [evap_fire] standard_name = surface_upward_specific_humidity_flux_of_fire long_name = kinematic surface upward latent heat flux of fire units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hflx] standard_name = surface_upward_temperature_flux long_name = kinematic surface upward sensible heat flux units = K m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [hflx_fire] standard_name = kinematic_surface_upward_sensible_heat_flux_of_fire long_name = kinematic surface upward sensible heat flux of fire units = K m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [tiice] standard_name = temperature_in_ice_layer long_name = sea ice internal temperature units = K - dimensions = (horizontal_loop_extent,vertical_dimension_of_sea_ice) + dimensions = (horizontal_dimension,vertical_dimension_of_sea_ice) type = real kind = kind_phys [t2m] standard_name = air_temperature_at_2m long_name = 2 meter temperature units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [q2m] standard_name = specific_humidity_at_2m long_name = 2 meter specific humidity units = kg kg-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [f10m] standard_name = ratio_of_wind_at_surface_adjacent_layer_to_wind_at_10m long_name = ratio of sigma level 1 wind and 10m wind units = ratio - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -1336,21 +1342,21 @@ standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air long_name = thermal exchange coefficient units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [cmm] standard_name = surface_drag_wind_speed_for_momentum_in_air long_name = momentum exchange coefficient units = m s-1 - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys [dpt2m] standard_name = dewpoint_temperature_at_2m long_name = 2 meter dewpoint temperature units = K - dimensions = (horizontal_loop_extent) + dimensions = (horizontal_dimension) type = real kind = kind_phys From e3837ee392cc26182a35ce9da532fa8857831385 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 17 Dec 2025 06:09:52 -0700 Subject: [PATCH 06/15] ufs/ccpp/data/MED_typedefs.meta: relative_path --> dependencies_path (#152) --- ufs/ccpp/data/MED_typedefs.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ufs/ccpp/data/MED_typedefs.meta b/ufs/ccpp/data/MED_typedefs.meta index a215ef28d..65baaa7e2 100644 --- a/ufs/ccpp/data/MED_typedefs.meta +++ b/ufs/ccpp/data/MED_typedefs.meta @@ -1364,7 +1364,7 @@ [ccpp-table-properties] name = MED_typedefs type = module - relative_path = ../../../../../UFSATM/ccpp/physics/physics/hooks + dependencies_path = ../../../../../UFSATM/ccpp/physics/physics/hooks dependencies = machine.F,physcons.F90 [ccpp-arg-table] From c71914a010e09ef5c0ced531267cd1587a4284f9 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Mon, 5 Jan 2026 12:10:29 -0500 Subject: [PATCH 07/15] Sync lastest ESCOMP (#155) --- .github/workflows/srt.yml | 25 +- CODEOWNERS | 1 + cesm/driver/esm.F90 | 5 +- cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 | 484 ++++ cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 | 714 ++++++ cesm/flux_atmocn/flux_atmocn_Large.F90 | 338 +++ cesm/flux_atmocn/flux_atmocn_UA_mod.F90 | 522 ++++ cesm/flux_atmocn/flux_atmocn_driver_mod.F90 | 141 ++ cesm/flux_atmocn/shr_flux_mod.F90 | 2321 +----------------- cime_config/buildnml | 36 +- cime_config/config_component.xml | 57 +- cime_config/config_component_cesm.xml | 92 +- cime_config/namelist_definition_drv.xml | 45 +- cime_config/testdefs/testlist_drv.xml | 6 +- doc/source/addendum/fieldnames.rst | 3 - mediator/esmFldsExchange_cesm_mod.F90 | 339 +-- mediator/fd_cesm.yaml | 140 -- mediator/med_diag_mod.F90 | 626 +---- mediator/med_internalstate_mod.F90 | 2 +- mediator/med_phases_aofluxes_mod.F90 | 89 +- mediator/med_phases_history_mod.F90 | 2 +- mediator/med_phases_post_rof_mod.F90 | 15 - 22 files changed, 2379 insertions(+), 3624 deletions(-) create mode 100644 CODEOWNERS create mode 100644 cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 create mode 100644 cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 create mode 100644 cesm/flux_atmocn/flux_atmocn_Large.F90 create mode 100644 cesm/flux_atmocn/flux_atmocn_UA_mod.F90 create mode 100644 cesm/flux_atmocn/flux_atmocn_driver_mod.F90 diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml index 31ee1d131..3afe2b7d1 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -28,7 +28,7 @@ jobs: LDFLAGS: "-L/usr/lib/x86_64-linux-gnu -lnetcdf -lnetcdff -lpnetcdf" # Versions of all dependencies can be updated here ESMF_VERSION: v8.8.0 - PARALLELIO_VERSION: pio2_6_5 + PARALLELIO_VERSION: pio2_6_6 CIME_MODEL: cesm CIME_DRIVER: nuopc GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} @@ -171,10 +171,25 @@ jobs: - name: scripts regression tests run: | pushd $GITHUB_WORKSPACE/cesm/cime/CIME/tests - ./scripts_regression_tests.py --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest + ./scripts_regression_tests.py --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest --no-teardown popd + + # How to download artifacts: + # https://docs.github.com/en/actions/managing-workflow-runs/downloading-workflow-artifacts + +# - name: Upload test logs +# if: ${{ failure() }} +# steps: +# - name: Tar test logs +# run: tar zcf scratch-${{ matrix.python-version }}.tar.gz /home/runner/cesm/scratch +# - name: save artifact +# uses: actions/upload-artifact@v4 +# with: +# name: test-logs-${{ matrix.python-version }} +# path: scratch-${{ matrix.python-version }}.tar.gz +# retention-days: 4 # 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 + - name: Setup tmate session + if: ${{ failure() }} + uses: mxschmitt/action-tmate@v3 diff --git a/CODEOWNERS b/CODEOWNERS new file mode 100644 index 000000000..0005a3b9c --- /dev/null +++ b/CODEOWNERS @@ -0,0 +1 @@ +/cesm/flux_atmocn/ @megandevlan diff --git a/cesm/driver/esm.F90 b/cesm/driver/esm.F90 index b2400a3ef..9a7bbf783 100644 --- a/cesm/driver/esm.F90 +++ b/cesm/driver/esm.F90 @@ -9,7 +9,7 @@ module ESM use shr_mem_mod , only : shr_mem_init use shr_log_mod , only : shr_log_setLogunit, shr_log_error use esm_utils_mod, only : logunit, maintask, dbug_flag, chkerr - use esmf , only : ESMF_FAILURE + use esmf , only : ESMF_FAILURE, ESMF_VMBARRIER implicit none private @@ -1557,6 +1557,9 @@ subroutine esm_finalize(driver, rc) call ESMF_VMGet(vm, mpiCommunicator=mpicomm, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMBarrier(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(driver, name="timing_dir",value=timing_dir, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return diff --git a/cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 b/cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 new file mode 100644 index 000000000..824d4097a --- /dev/null +++ b/cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 @@ -0,0 +1,484 @@ +module flux_atmocn_COARE_mod + + !------------------------------------------------------------------------------- + ! PURPOSE: + ! computes atm/ocn surface fluxes using COARE v3.0 parametrisation + ! + ! 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) + ! + ! !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 + !------------------------------------------------------------------------------- + + use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_flux_mod, only : loc_stebol, loc_latvap, loc_g, loc_cpdair + use shr_flux_mod, only : td0, maxscl, alpha, use_coldair_outbreak_mod + use shr_const_mod, only : shr_const_rgas + use shr_wv_sat_mod, only: shr_wv_sat_qsat_liquid ! use saturation calculation consistent with CAM + + implicit none + private + + public :: flux_atmOcn_COARE + public :: cor30a + + private :: psiuo + private :: psit_30 + + integer :: debug = 0 ! internal debug level + +contains + + subroutine flux_atmOcn_COARE( & + logunit, spval, nMax, zbot, ubot, vbot, thbot, & + qbot, rainc, rbot, tbot ,us ,vs, pslv, & + ts, mask, seq_flux_atmocn_minwind, & + sen, lat, lwup, evap, & + taux ,tauy, tref, qref, & + duu10n, ugust_out, u10res, & + ustar_sv, re_sv, ssq_sv) + + !--- input arguments -------------------------------- + integer , intent(in) :: logunit + real(R8) , intent(in) :: spval + 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) :: rainc(nMax) ! atm precip for convective gustiness (kg/m^3) - RBN 24Nov2008/MDF 31Jan2022 + 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) ! atm 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) + 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) :: 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) :: ugust_out(nMax) ! diag: gustiness addition to U10 (m/s) + real(R8),intent(out) :: u10res(nMax) ! diag: gustiness addition to U10 (m/s) + + 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 :: zpbl =700.0_R8 ! PBL depth [m] for gustiness parametriz. + + !--- local variables -------------------------------- + integer :: n ! vector loop index + 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) :: 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) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: zo,zot,zoq ! roughness lengths + real(R8) :: hsb,hlb ! sens & lat heat flxs at zbot + real(R8) :: tau ! stress 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) :: Tk ! dummy arg ~ temperature (K) + + !--- for cold air outbreak calc -------------------------------- + real(R8) :: tdiff(nMax) ! tbot - ts + real(R8) :: vscl + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn_COARE) ' + character(*),parameter :: F00 = "('(flux_atmOcn_COARE) ',4a)" + + if (debug > 0) write(logunit,F00) "enter" + + rh = spval + hol= spval + + !--- for cold air outbreak calc -------------------------------- + tdiff= tbot - ts + + 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 + + call shr_wv_sat_qsat_liquid(ts(n), pslv(n), qsat, ssq) + ssq = 0.98_R8 * ssq ! 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) = -loc_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/loc_latvap + + !------------------------------------------------------------ + ! 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 + + u10res(n) = sqrt(duu10n(n)) + ugust_out(n) = 0._r8 + + 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) + 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 + + u10res (n) = spval + ugust_out(n) = spval + + 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 + + end subroutine flux_atmOcn_COARE + + !================================================================= + + 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 + + ! Arguments + real(R8), intent(in) :: ubt,vbt,tbt,qbt,rbt + real(R8), intent(in) :: uss,vss,tss,qss + real(R8), intent(in) :: zbl,zbu,zbt,zrfu,zrfq,zrft + real(R8), intent(out) :: tau,hsb,hlb + real(R8), intent(out) :: zo,zot,zoq,L,usr,tsr,qsr + real(R8), intent(out) :: Cd,Ch,Ce + real(R8), intent(out) :: trf,qrf,urf,vrf + + ! Local variables + 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 :: i,nits ! iter loop counters + integer :: 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= loc_g + Rgas= shr_const_rgas + cpa = loc_cpdair + + !*** physical parameters + Le = loc_latvap -.00237e6_R8*(ts-273.16_R8) + + ! cpv = loc_cpdair*(1.0_R8 + loc_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 + !*************** end first guess ************ + + !*************** 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 + + !=============================================================================== + + real (R8) function psiuo(zet) + !====================================================================== + ! momentum stability functions adopted in COARE v3.0 parametrisation. + ! Chris Fairall's code (see cor30a) + ! + ! !REVISION HISTORY: + ! 22/11/2013: Thomas Toniazzo: comments added + !====================================================================== + + ! !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 + + real (R8) function psit_30(zet) + !=============================================================================== + ! momentum stability functions adopted in COARE v3.0 parametrisation. + ! Chris Fairall's code (see cor30a) + ! + ! !REVISION HISTORY: + ! 22/11/2013: Thomas Toniazzo: comments added + !=============================================================================== + + ! !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 flux_atmocn_COARE_mod diff --git a/cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 b/cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 new file mode 100644 index 000000000..ed0dd9a4a --- /dev/null +++ b/cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 @@ -0,0 +1,714 @@ +module flux_atmocn_diurnal_mod + + !------------------------------------------------------------------------------- + ! 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) + !------------------------------------------------------------------------------- + + use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_flux_mod, only : td0, maxscl, alpha, use_coldair_outbreak_mod + use shr_const_mod, only : shr_const_zvir, shr_const_cpdair, shr_const_karman, shr_const_g + use shr_const_mod, only : shr_const_latvap, shr_const_latice, shr_const_stebol, shr_const_tkfrz + use shr_const_mod, only : shr_const_pi, shr_const_spval, shr_const_cpvir + use shr_const_mod, only : shr_const_ocn_ref_sal, shr_const_zsrflyr, shr_const_rgas + use shr_sys_mod, only : shr_sys_abort + use flux_atmocn_COARE_mod, only : cor30a + use shr_wv_sat_mod, only : shr_wv_sat_qsat_liquid ! use saturation calculation consistent with CAM + + implicit none + private + + public :: flux_atmOcn_Diurnal + + private :: cuberoot + + integer :: flux_con_max_iter = 2 + real(r8) :: flux_con_tol = 0.0_R8 + integer :: debug = 0 + +contains + + subroutine flux_atmOcn_diurnal( & + logunit, spval, ocn_surface_flux_scheme, & + nMax, zbot, ubot, vbot, thbot, & + qbot, rbot, tbot, us, vs, & + ts, mask, seq_flux_atmocn_minwind, & + sen, lat, lwup, & + evap, taux, tauy, tref, qref, & + lwdn, swdn, swup, prec, & + swpen, ocnsal, ocn_prognostic, & + 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, cold_start) + + ! Arguments + ! + integer ,intent(in) :: logunit + real(r8) ,intent(in) :: spval + integer ,intent(in) :: ocn_surface_flux_scheme + integer ,intent(in) :: nMax ! data vector length + integer ,intent(in) :: secs ! NEW elsapsed seconds in day (GMT) + integer ,intent(in) :: dt ! NEW + logical ,intent(in) :: cold_start ! NEW cold start flag + 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) :: 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) + 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 + logical ,intent(in) :: ocn_prognostic ! NEW + real(R8) ,intent(inout) :: swpen (nMax) ! NEW + real(R8) ,intent(inout) :: ocnsal(nMax) ! NEW (kg/kg) + 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(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) :: warmMax(nMax) ! NEW + real(R8) ,intent(out) :: windMax(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 + 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) :: 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 + + !!++ 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 + + ! NOTE: this should use the shr_wv_sat_qsat_liquid if this routine is ever used in production + 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)" + + if (debug > 0) write(logunit,F00) "enter" + + 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 + u10n = 0.0_r8 + stable = 0.0_r8 + 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 + + ! This should be changed to use the subroutine below + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + ! call shr_wv_sat_qsat_liquid(tBulk(n), pslv(n), qsat, ssq) + ! ssq = 0.98_R8 * ssq ! 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 ---- + + ! This should be changed to use the subroutine below + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + ! call shr_wv_sat_qsat_liquid(tBulk(n), pslv(n), qsat, ssq) + ! ssq = 0.98_R8 * ssq ! 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 --- + + !--- 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 + + !------------------------------------------------------------ + ! 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 + + !------------------------------------------------------------ + ! 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 + 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 + salt (n) = spval + speed (n) = spval + regime (n) = spval + tBulk (n) = spval + tSkin (n) = spval + tSkin_night(n) = spval + tSkin_day (n) = spval + cSkin (n) = spval + cSkin_night(n) = spval + warmMax (n) = spval + windMax (n) = spval + qSolAvg (n) = spval + windAvg (n) = spval + warmMaxInc (n) = spval + windMaxInc (n) = spval + qSolInc (n) = spval + windInc (n) = spval + nInc (n) = 0.0_R8 + 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) + 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 + end DO ! loop over n + + end subroutine flux_atmOcn_diurnal + + ! =================================================================== + + 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 + + +end module flux_atmocn_diurnal_mod diff --git a/cesm/flux_atmocn/flux_atmocn_Large.F90 b/cesm/flux_atmocn/flux_atmocn_Large.F90 new file mode 100644 index 000000000..d58d512ba --- /dev/null +++ b/cesm/flux_atmocn/flux_atmocn_Large.F90 @@ -0,0 +1,338 @@ +module flux_atmOcn_large_mod + + !------------------------------------------------------------------------------- + ! PURPOSE: + ! computes atm/ocn surface fluxes using Large and Pond + ! + ! 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) + !------------------------------------------------------------------------------- + + use shr_kind_mod, only: R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_flux_mod, only: loc_cpdair, loc_cpvir, loc_karman, loc_g, loc_zvir + use shr_flux_mod, only: loc_latvap, loc_stebol, use_coldair_outbreak_mod + use shr_flux_mod, only: flux_con_tol, flux_con_max_iter + use shr_flux_mod, only: alpha, maxscl, td0 + use shr_sys_mod, only: shr_sys_abort + use shr_wv_sat_mod, only: shr_wv_sat_qsat_liquid ! use saturation calculation consistent with CAM + + implicit none + public + + integer, private :: debug = 0 + +contains + + subroutine flux_atmOcn_large( & + logunit, spval, nMax, & + zbot, ubot, vbot, thbot, & + qbot, rainc, rbot, & + tbot, us, vs, pslv, & + ts, mask, seq_flux_atmocn_minwind, & + sen, lat, lwup, evap, & + taux, tauy, tref, qref, & + add_gusts, duu10n, ugust_out, u10res, & + ustar_sv, re_sv, ssq_sv) + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + real(R8) ,intent(in) :: spval ! local missing value + integer ,intent(in) :: nMax ! data vector length + integer ,intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + logical ,intent(in) :: add_gusts + 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) :: rainc(nMax) ! atm precip for convective gustiness (kg/m^3) - RBN 24Nov2008/MDF 31Jan2022 + 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) ! atm 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) + 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) :: 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) :: ugust_out(nMax) ! diag: gustiness addition to U10 (m/s) + real(R8),intent(out) :: u10res(nMax) ! diag: gustiness addition to U10 (m/s) + + 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 :: 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 + + !--- local variables -------------------------------- + integer :: n ! vector loop index + integer :: 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 ! ? + 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) :: wind0 ! resolved large-scale 10m wind (no gust added) + + !--- local functions -------------------------------- + real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) + + ! (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 + + real(R8) :: ugust ! function: gustiness as a function of convective rainfall. + real(R8) :: gprec ! convective rainfall argument for ugust + ! ------------------------------------------------------------------------- + + ! Large and Yeager 2009 + cdn(Umps) = 0.0027_R8 / min(33.0000_R8,Umps) + 0.000142_R8 + & + 0.0000764_R8 * min(33.0000_R8,Umps) - 3.14807e-13_r8 * min(33.0000_R8,Umps)**6 + + ! Capped Large and Pond by wind + ! cdn(Umps) = 0.0027_R8 / min(30.0_R8,Umps) + 0.000142_R8 + 0.0000764_R8 * min(30.0_R8,Umps) + ! Capped Large and Pond by Cd + ! cdn(Umps) = min(0.0025_R8, (0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps )) + ! Large and Pond + ! 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) + + ! Convective gustiness appropriate for input precipitation. + ! Following Regelsperger et al. (2000, J. Clim) + ! Ug = log(1.0+6.69R-0.476R^2) + ! Coefficients X by 8640 for mm/s (from cam) -> cm/day (for above forumla) + ugust(gprec) = log(1._R8+57801.6_r8*gprec-3.55332096e7_r8*(gprec**2)) + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn) ' + character(*),parameter :: F00 = "('(flux_atmOcn) ',4a)" + ! -------------------------------------------------------------------------- + + if (debug > 0) write(logunit,F00) "enter" + + u10n = spval + rh = spval + psixh = spval + hol = spval + + !--- for cold air outbreak calc -------------------------------- + tdiff= tbot - ts + + al2 = log(zref/ztref) + + DO n=1,nMax + if (mask(n) /= 0) then + + !--- compute some needed quantities --- + if (add_gusts) then + vmag = max(seq_flux_atmocn_minwind, & + sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2 + (1.0_R8*ugust(min(rainc(n),6.94444e-4_r8))**2)) ) + ugust_out(n) = ugust(min(rainc(n),6.94444e-4_r8)) + else + vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + ugust_out(n) = 0.0_r8 + end if + wind0 = 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 + ! if add_gusts wind0 and vmag are different, both need this factor. + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) + vmag=vmag*vscl + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(wind0))),maxscl) + wind0=wind0*vscl + endif + endif + + call shr_wv_sat_qsat_liquid(ts(n), pslv(n), qsat, ssq) + ssq = 0.98_R8 * ssq ! 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 + + !------------------------------------------------------------ + ! 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 + u10res(n) = u10n * (wind0/vmag) ! resolved 10m wind + + !------------------------------------------------------------ + ! 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) + 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 + ugust_out(n) = spval ! gustiness addition (m/s) + u10res(n) = spval ! 10m resolved wind (no gusts) (m/s) + + 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 + + end subroutine flux_atmOcn_large + +end module flux_atmOcn_large_mod diff --git a/cesm/flux_atmocn/flux_atmocn_UA_mod.F90 b/cesm/flux_atmocn/flux_atmocn_UA_mod.F90 new file mode 100644 index 000000000..269d3ad98 --- /dev/null +++ b/cesm/flux_atmocn/flux_atmocn_UA_mod.F90 @@ -0,0 +1,522 @@ +module flux_atmocn_UA_mod + + !=============================================================================== + ! !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. + !=============================================================================== + + use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_flux_mod, only : td0, maxscl, alpha + use shr_flux_mod, only : loc_zvir, loc_tkfrz, loc_cpdair, loc_cpvir, loc_g + use shr_flux_mod, only : use_coldair_outbreak_mod, loc_karman, loc_stebol + + implicit none + private + + public :: flux_atmOcn_UA + + ! private member functions: + private :: psi_ua + private :: qsat_ua + private :: rough_ua + + integer, private :: debug = 0 + +contains + + subroutine flux_atmOcn_UA( & + logunit, spval, nMax, & + zbot, ubot, vbot, thbot, & + qbot, rbot, tbot, us, vs, pslv, & + ts, mask, sen, lat, lwup, evap, & + taux, tauy, tref, qref, & + duu10n, ustar_sv, re_sv, ssq_sv) + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + real(R8) ,intent(in) :: spval + 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) :: 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) :: 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 :: 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 :: n ! vector loop index + integer :: 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) :: 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" + + ! 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 + + !------------------------------------------------------------ + ! 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) + 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 + + + !=============================================================================== + + real(R8) function psi_ua(k,zeta) + + ! Stability function for rb < 0 + + !-----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 + + !=============================================================================== + + real(R8) function qsat_ua(t,p,loc_epsilon) + + ! Uses Tetens' formula for saturation vapor pressure from + ! Buck(1981) JAM 20, 1527-1532 + + !-----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 + + !=============================================================================== + + subroutine rough_ua(zo,zot,zoq,ustar,visa) + + ! Calculate roughness lengths: zo, zot, zoq. + + !-----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 + +end module flux_atmocn_UA_mod diff --git a/cesm/flux_atmocn/flux_atmocn_driver_mod.F90 b/cesm/flux_atmocn/flux_atmocn_driver_mod.F90 new file mode 100644 index 000000000..82a2b97d8 --- /dev/null +++ b/cesm/flux_atmocn/flux_atmocn_driver_mod.F90 @@ -0,0 +1,141 @@ +module flux_atmocn_driver_mod + + use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_const_mod, only : shr_const_spval + use shr_sys_mod, only : shr_sys_abort + use shr_strconvert_mod, only : toString + use flux_atmocn_Large_mod, only : flux_atmocn_Large + use flux_atmocn_COARE_mod, only : flux_atmocn_COARE + use flux_atmocn_UA_mod, only : flux_atmocn_UA + + implicit none + public + + integer, private, parameter :: ocn_flux_scheme_large_and_pond = 0 + integer, private, parameter :: ocn_flux_scheme_coare = 1 + integer, private, parameter :: ocn_flux_scheme_ua = 2 + +contains + + subroutine flux_atmOcn_driver(logunit, nMax, & + zbot, ubot, vbot, thbot, & + qbot, rainc, rbot, & + tbot, us, vs, pslv, & + ts, mask, seq_flux_atmocn_minwind, & + sen, lat, lwup, evap, & + taux, tauy, tref, qref, & + ocn_surface_flux_scheme, & + add_gusts, duu10n, ugust_out, u10res, & + ustar_sv, re_sv, ssq_sv, missval) + + !--- 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 + logical , intent(in) :: add_gusts + 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) :: rainc(nMax) ! atm precip for convective gustiness (kg/m^3) - RBN 24Nov2008/MDF 31Jan2022 + 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) ! atm 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) + real(R8) , intent(in) :: seq_flux_atmocn_minwind ! minimum wind speed for atmocn (m/s) + integer , intent(in) :: ocn_surface_flux_scheme + + !--- 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) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, meridional (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) :: ugust_out(nMax) ! diag: gustiness addition to U10 (m/s) + real(R8),intent(out) :: u10res(nMax) ! diag: gustiness addition to U10 (m/s) + + 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 variables -------------------------------- + integer :: n + real(R8) :: spval ! local missing value + !-------------------------------------------------------------------------------- + + if (present(missval)) then + spval = missval + else + spval = shr_const_spval + endif + + !!................................................................. + !! ocn_surface_flux_scheme = 0 : Large and Pond + !! = 1 : COARE algorithm + !! = 2 : UA algorithm + !!................................................................. + + ! Default flux scheme. + if (ocn_surface_flux_scheme == ocn_flux_scheme_large_and_pond) then + + call flux_atmOcn_Large( & + logunit, spval, nMax, & + zbot, ubot, vbot, thbot, & + qbot, rainc, rbot, & + tbot, us, vs, pslv, & + ts, mask, seq_flux_atmocn_minwind, & + sen, lat, lwup, evap, & + taux, tauy, tref, qref, & + add_gusts, duu10n, ugust_out, u10res, & + ustar_sv=ustar_sv, re_sv=re_sv, ssq_sv=ssq_sv) + + else if (ocn_surface_flux_scheme == ocn_flux_scheme_coare) then + + call flux_atmOcn_COARE( & + logunit, spval, nMax, & + zbot, ubot, vbot, thbot, & + qbot, rainc, rbot, & + tbot, us, vs, pslv, & + ts, mask, seq_flux_atmocn_minwind, & + sen, lat, lwup, evap, & + taux, tauy, tref, qref, & + duu10n, ugust_out, u10res, & + ustar_sv=ustar_sv, re_sv=re_sv, ssq_sv=ssq_sv) + + else if (ocn_surface_flux_scheme == ocn_flux_scheme_ua) then + + call flux_atmOcn_UA( & + logunit, spval, nMax, & + zbot, ubot, vbot, thbot, & + qbot, rbot, tbot, us, vs, pslv, & + ts, mask, sen, lat, lwup, evap, & + taux, tauy, tref, qref, & + duu10n, ustar_sv=ustar_sv, re_sv=re_sv, ssq_sv=ssq_sv) + + do n = 1,nMax + if (mask(n) /= 0) then + u10res(n) = sqrt(duu10n(n)) + ugust_out(n) = 0._r8 + else + u10res (n) = spval + ugust_out(n) = spval + end if + end do + + else + + call shr_sys_abort("ocn_srfuace_flux_scheme = "// toString(ocn_surface_flux_scheme)//" is not supported") + + end if + + end subroutine flux_atmOcn_driver + +end module flux_atmocn_driver_mod diff --git a/cesm/flux_atmocn/shr_flux_mod.F90 b/cesm/flux_atmocn/shr_flux_mod.F90 index c40c4d732..27e905e9e 100644 --- a/cesm/flux_atmocn/shr_flux_mod.F90 +++ b/cesm/flux_atmocn/shr_flux_mod.F90 @@ -1,55 +1,26 @@ module shr_flux_mod - ! atm/ocn/flux calculations + ! constants for atm/ocn/flux calculations - ! !USES: - - use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds use shr_const_mod, only : shr_const_zvir, shr_const_cpdair, shr_const_cpvir, shr_const_karman, shr_const_g ! shared constants - use shr_const_mod, only : shr_const_latvap, shr_const_latice, shr_const_stebol, shr_const_tkfrz, shr_const_pi, shr_const_spval + use shr_const_mod, only : shr_const_latvap, shr_const_latice, shr_const_stebol, shr_const_tkfrz use shr_const_mod, only : shr_const_ocn_ref_sal, shr_const_zsrflyr, shr_const_rgas - use shr_sys_mod, only : shr_sys_abort ! shared system routines - implicit none - - private ! default private + use shr_sys_mod, only : shr_sys_abort ! shared system routines - ! !PUBLIC TYPES: - - ! none - - ! !PUBLIC MEMBER FUNCTIONS: + implicit none + public - 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 + 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 @@ -63,16 +34,14 @@ module shr_flux_mod ! 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 + integer :: 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__ + real(R8),parameter :: td0 = -10._R8 ! start t-ts for scaling !=============================================================================== contains @@ -80,23 +49,24 @@ module shr_flux_mod subroutine shr_flux_adjust_constants( & zvir, cpair, cpvir, karman, gravit, & - latvap, latice, stebol, flux_convergence_tolerance, & + 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 + 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 @@ -113,2247 +83,4 @@ subroutine shr_flux_adjust_constants( & 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, rainc ,s16O ,sHDO ,s18O ,rbot, & - & tbot ,us ,vs, pslv, & - & 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, & - & add_gusts, & - & duu10n, & - & ugust_out, & - & u10res, & - & 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 - logical ,intent(in) :: add_gusts - 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) :: rainc(nMax) ! atm precip for convective gustiness (kg/m^3) - RBN 24Nov2008/MDF 31Jan2022 - 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) ! atm 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) - 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) :: ugust_out(nMax) ! diag: gustiness addition to U10 (m/s) - real(R8),intent(out) :: u10res(nMax) ! diag: gustiness addition to U10 (m/s) - - 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 - real(R8) :: wind0 ! resolved large-scale 10m wind (no gust added) - !!++ 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 - - real(R8) :: ugust ! function: gustiness as a function of convective rainfall. - real(R8) :: gprec ! convective rainfall argument for ugust - - qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) - - ! Large and Yeager 2009 - cdn(Umps) = 0.0027_R8 / min(33.0000_R8,Umps) + 0.000142_R8 + & - 0.0000764_R8 * min(33.0000_R8,Umps) - 3.14807e-13_r8 * min(33.0000_R8,Umps)**6 - ! Capped Large and Pond by wind - ! cdn(Umps) = 0.0027_R8 / min(30.0_R8,Umps) + 0.000142_R8 + 0.0000764_R8 * min(30.0_R8,Umps) - ! Capped Large and Pond by Cd - ! cdn(Umps) = min(0.0025_R8, (0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps )) - ! Large and Pond - ! 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) - - ! Convective gustiness appropriate for input precipitation. - ! Following Regelsperger et al. (2000, J. Clim) - ! Ug = log(1.0+6.69R-0.476R^2) - ! Coefficients X by 8640 for mm/s (from cam) -> cm/day (for above forumla) - ugust(gprec) = log(1._R8+57801.6_r8*gprec-3.55332096e7_r8*(gprec**2)) - - - !--- 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 --- - if (add_gusts) then - vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2 + (1.0_R8*ugust(min(rainc(n),6.94444e-4_r8))**2)) ) - ugust_out(n) = ugust(min(rainc(n),6.94444e-4_r8)) - else - vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) - ugust_out(n) = 0.0_r8 - end if - wind0 = 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 - ! if add_gusts wind0 and vmag are different, both need this factor. - vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) - vmag=vmag*vscl - vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(wind0))),maxscl) - wind0=wind0*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 - u10res(n) = u10n * (wind0/vmag) ! resolved 10m wind - - !------------------------------------------------------------ - ! 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 - ugust_out(n) = spval ! gustiness addition (m/s) - u10res(n) = spval ! 10m resolved wind (no gusts) (m/s) - - 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 if (ocn_surface_flux_scheme .eq. 2) then - - call 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) - - else - - call shr_sys_abort(subName//" subroutine flux_atmOcn requires ocn_surface_flux_scheme = 0, 1 or 2") - - 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 - u10n = 0.0_r8 - stable = 0.0_r8 - 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/cime_config/buildnml b/cime_config/buildnml index 7ffc28f82..d92cc2731 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -7,7 +7,7 @@ _CIMEROOT = os.environ.get("CIMEROOT") if _CIMEROOT is None: raise SystemExit("ERROR: must set CIMEROOT environment variable") -sys.path.append(os.path.join(_CIMEROOT, "scripts", "Tools")) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) import shutil, glob, itertools from standard_script_setup import * @@ -37,8 +37,6 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): config["CPL_I2O_PER_CAT"] = case.get_value("CPL_I2O_PER_CAT") config["DRV_THREADING"] = case.get_value("DRV_THREADING") config["CPL_ALBAV"] = case.get_value("CPL_ALBAV") - config["CPL_EPBAL"] = case.get_value("CPL_EPBAL") - config["FLDS_WISO"] = case.get_value("FLDS_WISO") config["BUDGETS"] = case.get_value("BUDGETS") config["MACH"] = case.get_value("MACH") config["MPILIB"] = case.get_value("MPILIB") @@ -51,7 +49,6 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): ) config["timer_level"] = "pos" if case.get_value("TIMER_LEVEL") >= 1 else "neg" 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") for val in ("HIST", "REST", "STOP"): config[val.lower()+"_option"] = case.get_value(val+"_OPTION") @@ -137,7 +134,8 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): elif case.get_value("RUN_TYPE") == "branch": config["run_type"] = "branch" - config['wav_ice_coupling'] = 'ww3' in config['COMP_WAV'] and config['COMP_ICE'] == 'cice' + if config['COMP_WAV'] == 'ww3' and config['COMP_ICE'] == 'cice': + config["wav_ice_coupling"] = "on" if config["COMP_OCN"] == "blom": if "ecosys" in case.get_value("BLOM_TRACER_MODULES"): @@ -628,6 +626,26 @@ def compare_drv_flds_in(first, second, infile1, infile2): % (infile1, infile2), ) +def cmeps_lib_list(case): + # provide a list of support libs that must be built for this case + # should be ordered with dependent libraries listed after those depended on + # the library names should match the keys in variable BUILD_LIB_FILE from config_files.xml + ufs_driver = os.environ.get("UFS_DRIVER") + if ufs_driver: + logger.info("UFS_DRIVER is set to {}".format(ufs_driver)) + + libs = case.get_values("CASE_SUPPORT_LIBRARIES") + + mpilib = case.get_value("MPILIB") + if mpilib == "mpi-serial" and "mpi-serial" not in libs: + libs.insert(0, mpilib) + + ocn_model = case.get_value("COMP_OCN") + # These will be handled by MOM and CAM, included here for backward compatibility. + atm_dycore = case.get_value("CAM_DYCORE") + if (ocn_model == "mom" or (atm_dycore and atm_dycore == "fv3")) and "FMS" not in libs: + libs.append("FMS") + return libs ############################################################################### def buildnml(case, caseroot, component): @@ -635,6 +653,10 @@ def buildnml(case, caseroot, component): if component != "drv": raise AttributeError + libs = cmeps_lib_list(case) + with Case(case.get_value("CASEROOT"), read_only=False) as case_tmp: + case_tmp.set_value("CASE_SUPPORT_LIBRARIES", ",".join(libs)) + esmfmkfile = os.getenv("ESMFMKFILE") expect( esmfmkfile and os.path.isfile(esmfmkfile), @@ -648,7 +670,7 @@ def buildnml(case, caseroot, component): major = line[-2] if "MAJOR" in line else major minor = line[-2] if "MINOR" in line else minor logger.debug("ESMF version major {} minor {}".format(major, minor)) - expect(int(major) >= 8 and int(minor) >=4, "ESMF version should be 8.4.1 or newer") + expect(int(major) >= 9 or (int(major) >= 8 and int(minor) >=4), "ESMF version should be 8.4.1 or newer") confdir = os.path.join(case.get_value("CASEBUILD"), "cplconf") if not os.path.isdir(confdir): @@ -725,7 +747,7 @@ def buildnml(case, caseroot, component): def _main_func(): caseroot = parse_input(sys.argv) - with Case(caseroot) as case: + with Case(caseroot, read_only=False) as case: buildnml(case, caseroot, "drv") diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 872f45c93..626110251 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -489,17 +489,6 @@ - - logical - TRUE,FALSE - FALSE - run_begin_stop_restart - env_run.xml - - A setting of TRUE implies a continuation run for mediator only - - - integer 0 @@ -817,6 +806,8 @@ char none,a100 + none,a10,a2 + none,v100,a100,h100,mi300a none build_def env_build.xml @@ -915,21 +906,6 @@ 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 @@ -2331,16 +2307,7 @@ FALSE run_coupling env_run.xml - determine if per ice thickness category fields are passed from ice to ocean - DO NOT EDIT (set by POP build-namelist) - - - - integer - 0,1,2,3,4,5,6,7,8,9 - 1 - run_flags - env_run.xml - level of debug output, 0=minimum, 1=normal, 2=more, 3=too much + determine if per ice thickness category fields are passed from ice to ocean - DO NOT EDIT (set by MOM6) @@ -2520,9 +2487,21 @@ Remote git repository used for this case - - - + + char + + + gptl,pio,csm_share,FTorch,CDEPS + + build_def + env_build.xml + Support libraries required + + + + + + logical diff --git a/cime_config/config_component_cesm.xml b/cime_config/config_component_cesm.xml index 608a5fcbd..b5bc98695 100644 --- a/cime_config/config_component_cesm.xml +++ b/cime_config/config_component_cesm.xml @@ -107,7 +107,6 @@ CO2A none - CO2A CO2A CO2A CO2A @@ -220,6 +219,7 @@ integer 48 + 2 144 288 288 @@ -231,8 +231,6 @@ 48 24 24 - - 72 @@ -248,8 +246,6 @@ - 24 - 48 48 48 @@ -279,16 +275,6 @@ 72 144 288 - - - - - 1 - - - - 24 - 48 48 48 48 @@ -297,6 +283,7 @@ 360 720 1440 + 2 2 2 @@ -305,6 +292,16 @@ 15 30 60 + + + + + 1 + + + + 24 + 48 run_coupling env_run.xml @@ -403,7 +400,6 @@ $ATM_NCPL $ATM_NCPL 1 - 8 8 8 $ATM_NCPL @@ -429,56 +425,23 @@ - logical TRUE,FALSE FALSE - TRUE - TRUE - TRUE - TRUE - TRUE - FALSE + TRUE + TRUE run_component_cpl env_run.xml - Only used for compsets with DATM and [POP or MOM] (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 + 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 + dependence. + 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 + does not have a zenith-angle dependence. @@ -546,12 +509,10 @@ TRUE,FALSE FALSE - TRUE TRUE TRUE TRUE TRUE - TRUE TRUE run_budgets @@ -571,24 +532,11 @@ 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. + CLM if CLM_CO2_TYPE is constant or + MOM6 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 diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index 318fc8235..eb7b66902 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -879,15 +879,27 @@ - + integer expdef MED_attributes - Level of debug output, 0=minimum, 1=normal, 2=more, 3=too much (default: 1) + Level of debug output; higher values give progressively more output + + Some example values (other values are also accepted) + - 0: no extra debug output + - 1: a bit of debug output + - 2: a bit more debug output + - 6: a moderate amount of debug output + - 11: a lot of debug output + - 21: a huge amount of debug output + + Note that setting this to moderate - high values can lead to overwhelming amounts of output. + + (Default: 0) - $INFO_DBUG + 0 @@ -931,24 +943,13 @@ 0 - - real - control - MED_attributes - - wind gustiness factor - - - 0.0D0 - - - logical control MED_attributes - add a wind gustiness factor + Add a wind gustiness factor. This should be false for + ocn_surface_flux_scheme settings of 1 or 2. .true. @@ -1787,6 +1788,7 @@ + @@ -2318,7 +2320,7 @@ $WAV2OCN_SMAPNAME - + @@ -2505,7 +2507,6 @@ - logical flds @@ -2514,7 +2515,7 @@ Pass water isotopes between components - $FLDS_WISO + .false. @@ -2872,6 +2873,7 @@ .false. .false. .false. + .false. @@ -3726,7 +3728,7 @@ components that need to look at the same data. - Buildconf/camconf/drv_flds_in,Buildconf/clmconf/drv_flds_in,Buildconf/datmconf/drv_flds_in + Buildconf/camconf/drv_flds_in,Buildconf/clmconf/drv_flds_in,Buildconf/datmconf/drv_flds_in,Buildconf/dlndconf/drv_flds_in @@ -3835,8 +3837,7 @@ .false. - - + .true. diff --git a/cime_config/testdefs/testlist_drv.xml b/cime_config/testdefs/testlist_drv.xml index fd1ad7ac6..b57b7ba12 100644 --- a/cime_config/testdefs/testlist_drv.xml +++ b/cime_config/testdefs/testlist_drv.xml @@ -46,7 +46,7 @@ - + @@ -55,7 +55,7 @@ - + @@ -292,7 +292,7 @@ - + diff --git a/doc/source/addendum/fieldnames.rst b/doc/source/addendum/fieldnames.rst index 471d52e7a..58b2713e0 100644 --- a/doc/source/addendum/fieldnames.rst +++ b/doc/source/addendum/fieldnames.rst @@ -34,7 +34,6 @@ The following state names are currently supported. Note that each application mi "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" @@ -56,10 +55,8 @@ The following state names are currently supported. Note that each application mi "Sl_lfrac", "" "Sl_lfrin", "" "Sl_qref", "" - "Sl_qref_wiso", "" "Sl_ram1", "" "Sl_snowh", "" - "Sl_snowh_wiso", "" "Sl_t", "" "Sl_topo_elev", "" "Sl_topo", "" diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index fb1f8d708..5872b5b19 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -75,10 +75,10 @@ module esmFldsExchange_cesm_mod character(len=CX) :: rof2lnd_map = 'unset' character(len=CX) :: lnd2rof_map = 'unset' - ! optional mapping files + ! optional mapping files character(len=CX) :: wav2ocn_map ='unset' character(len=CX) :: ocn2wav_map = 'unset' - + ! no mapping files (value is 'idmap' or 'unset') character(len=CX) :: atm2ice_map = 'unset' character(len=CX) :: atm2ocn_map = 'unset' @@ -95,7 +95,6 @@ module esmFldsExchange_cesm_mod 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 logical :: add_gusts ! Whether to include fields related to the gustiness parameterization @@ -237,11 +236,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) flds_i2o_per_cat - ! 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 - 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 @@ -262,7 +256,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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)//' add_gusts = ', add_gusts @@ -315,9 +308,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld_from(compatm, 'Sa_ptem') call addfld_from(compatm, 'Sa_dens') call addfld_from(compatm, 'Faxa_rainc') - if (flds_wiso) then - call addfld_from(compatm, 'Sa_shum_wiso') - end if else if (is_local%wrap%aoflux_grid == 'ogrid') then if (mapuv_with_cart3d) then @@ -335,9 +325,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmap_from(compatm, 'Sa_ptem', compocn, mapbilnr, 'one', atm2ocn_map) call addmap_from(compatm, 'Sa_dens', compocn, mapbilnr, 'one', atm2ocn_map) call addmap_from(compatm, 'Sa_pslv', compocn, mapbilnr, 'one', atm2ocn_map) - if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_shum_wiso', rc=rc)) then - call addmap_from(compatm, 'Sa_shum_wiso', compocn, mapbilnr, 'one', atm2ocn_map) - end if end if end if @@ -490,18 +477,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(complnd, '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_from(compatm, 'Sa_shum_wiso') - call addfld_to(complnd, 'Sa_shum_wiso') - else - 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_from(compatm, 'Sa_shum_wiso', complnd, mapbilnr, 'one', atm2lnd_map) - call addmrg_to(complnd, 'Sa_shum_wiso', mrg_from=compatm, mrg_fld='Sa_shum_wiso', mrg_type='copy') - end if - end if - end if ! --------------------------------------------------------------------- ! to lnd: prognostic CO2 at the lowest atm model level ! --------------------------------------------------------------------- @@ -759,42 +734,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_from(comprof, 'Flrr_volr_wiso') - call addfld_to(complnd, '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_from(comprof, 'Flrr_volr_wiso', complnd, mapconsf, 'one', rof2lnd_map) - call addmrg_to(complnd, 'Flrr_volr_wiso', & - mrg_from=comprof, mrg_fld='Flrr_volr_wiso', mrg_type='copy') - end if - end if - if (phase == 'advertise') then - call addfld_from(comprof, 'Flrr_volrmch_wiso') - call addfld_to(complnd, '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_from(comprof, 'Flrr_volrmch_wiso', complnd, mapconsf, 'one', rof2lnd_map) - call addmrg_to(complnd, 'Flrr_volrmch_wiso', & - mrg_from=comprof, mrg_fld='Flrr_volrmch_wiso', mrg_type='copy') - end if - end if - if (phase == 'advertise') then - call addfld_from(comprof, 'Flrr_flood_wiso') - call addfld_to(complnd, 'Flrr_flood_wiso') - else - 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_from(comprof, 'Flrr_flood_wiso', complnd, mapconsf, 'one', rof2lnd_map) - call addmrg_to(complnd, 'Flrr_flood_wiso', & - mrg_from=comprof, mrg_fld='Flrr_flood_wiso', mrg_type='copy') - end if - end if - end if - ! --------------------------------------------------------------------- ! to lnd: ice sheet grid coverage on global grid from glc ! to lnd: ice sheet mask where we are potentially sending non-zero fluxes from glc @@ -1055,35 +994,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_from(complnd , 'Sl_qref_wiso') - call addfld_from(compice , 'Si_qref_wiso') - call addfld_aoflux('So_qref_wiso') - call addfld_to(compatm , '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_from(complnd , 'Sl_qref_wiso', compatm, mapconsf, map_fracname_lnd2atm, lnd2atm_map) - call addmrg_to(compatm , 'Sx_qref_wiso', & - mrg_from=complnd, mrg_fld='Sl_qref_wiso', mrg_type='merge', mrg_fracname=mrg_fracname_lnd2atm_state) - end if - if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_qref_wiso', rc=rc)) then - call addmap_from(compice , 'Si_qref_wiso', compatm, mapconsf, 'ifrac', ice2atm_map) - call addmrg_to(compatm , '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_aoflux( 'So_qref_wiso', compatm, mapconsf, 'ofrac', ocn2atm_map) ! map ocn->atm - end if - call addmrg_to(compatm , '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 @@ -1171,34 +1081,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_from(complnd , 'Sl_qref_wiso') - call addfld_from(compice , 'Si_qref_wiso') - call addfld_aoflux('So_qref_wiso') - call addfld_to(compatm , '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_from(complnd , 'Sl_qref_wiso', compatm, mapconsf, map_fracname_lnd2atm, lnd2atm_map) - call addmrg_to(compatm , 'Sx_qref_wiso', & - mrg_from=complnd, mrg_fld='Sl_qref_wiso', mrg_type='merge', mrg_fracname=mrg_fracname_lnd2atm_state) - end if - if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_qref_wiso', rc=rc)) then - call addmap_from(compice , 'Si_qref_wiso', compatm, mapconsf, 'ifrac', ice2atm_map) - call addmrg_to(compatm , '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_aoflux('So_qref_wiso', compatm, mapconsf, 'ofrac', ocn2atm_map) - end if - call addmrg_to(compatm , '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 @@ -1206,7 +1088,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) ! to atm: merged surface sensible heat flux ! to atm: merged surface upward longwave heat flux ! to atm: evaporation water flux from water - ! to atm: evaporation water flux from water isotopes ! --------------------------------------------------------------------- if (phase == 'advertise') then call addfld_to(compatm, 'Faxx_taux') @@ -1370,35 +1251,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_to(compatm, 'Faxx_evap_wiso') - call addfld_from(complnd, 'Fall_evap_wiso') - call addfld_from(compice, 'Faii_evap_wiso') - call addfld_aoflux( 'Faox_evap_wiso') - else - 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_from(complnd , 'Fall_evap_wiso', compatm, mapconsf, map_fracname_lnd2atm, lnd2atm_map) - call addmrg_to(compatm , 'Faxx_evap_wiso', & - mrg_from=complnd, mrg_fld='Fall_evap_wiso', mrg_type='merge', mrg_fracname=mrg_fracname_lnd2atm_flux) - end if - if (fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_evap_wiso', rc=rc)) then - call addmap_from(compice , 'Faii_evap_wiso', compatm, mapconsf, 'ifrac', ice2atm_map) - call addmrg_to(compatm , '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_evap_wiso', rc=rc)) then - if (trim(is_local%wrap%aoflux_grid) == 'ogrid') then - call addmap_aoflux('Faox_evap_wiso', compatm, mapconsf, 'ofrac', ocn2atm_map) - end if - call addmrg_to(compatm , 'Faxx_evap_wiso', & - mrg_from=compmed, mrg_fld='Faox_evap_wiso', mrg_type='merge', mrg_fracname='ofrac') - end if - end if - end if - end if - ! --------------------------------------------------------------------- ! to atm: merged surface temperature and unmerged temperatures from ice and ocn ! --------------------------------------------------------------------- @@ -1705,8 +1557,8 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld_from(complnd, 'Fall_fco2_lnd') call addfld_to(compatm, 'Fall_fco2_lnd') else - if ( fldchk(is_local%wrap%FBImp(compocn,compocn), 'Faoo_co2_lnd', rc=rc) .and. & - fldchk(is_local%wrap%FBexp(compatm) , 'Faoo_co2_lnd', rc=rc)) then + if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_fco2_lnd', rc=rc) .and. & + fldchk(is_local%wrap%FBexp(compatm) , 'Fall_fco2_lnd', rc=rc)) then call addmap_from(complnd, 'Fall_fco2_lnd', compatm, mapconsf, 'one', lnd2atm_map) call addmrg_to(compatm, 'Fall_fco2_lnd', & mrg_from=complnd, mrg_fld='Fall_fco2_lnd', mrg_type='copy_with_weights', mrg_fracname=mrg_fracname_lnd2atm_flux) @@ -2045,38 +1897,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_from(compatm, 'Faxa_rainc_wiso') - call addfld_from(compatm, 'Faxa_rainl_wiso') - call addfld_to(compocn, 'Faxa_rain_wiso' ) - call addfld_from(compatm, 'Faxa_snowc_wiso') - call addfld_from(compatm, 'Faxa_snowl_wiso') - call addfld_from(compatm, '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_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_from(compatm, 'Faxa_rainl_wiso', compocn, mapconsf, 'one', atm2ocn_map) - call addmap_from(compatm, 'Faxa_rainc_wiso', compocn, mapconsf, 'one', atm2ocn_map) - call addmrg_to(compocn, 'Faxa_rain_wiso' , & - mrg_from=compatm, mrg_fld=trim('Faxa_rainc_wiso')//':'//trim('Faxa_rainl_wiso'), & - mrg_type='sum_with_weights', mrg_fracname='ofrac') - end if - 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_from(compatm, 'Faxa_snowl_wiso', compocn, mapconsf, 'one', atm2ocn_map) - call addmap_from(compatm, 'Faxa_snowc_wiso', compocn, mapconsf, 'one', atm2ocn_map) - call addmrg_to(compocn, 'Faxa_snow_wiso', & - mrg_from=compatm, mrg_fld=trim('Faxa_snowc_wiso')//':'//trim('Faxa_snowl_wiso'), & - mrg_type='sum_with_weights', mrg_fracname='ofrac') - end if - end if - end if - ! --------------------------------------------------------------------- ! to ocn: merged sensible heat flux ! --------------------------------------------------------------------- @@ -2113,18 +1933,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_aoflux( 'Faox_lat_wiso' ) - call addfld_to(compocn, 'Foxx_lat_wiso' ) - else - if ( fldchk(is_local%wrap%FBexp(compocn), 'Foxx_lat_wiso', rc=rc)) then - call addmrg_to(compocn, '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 ! --------------------------------------------------------------------- @@ -2317,19 +2125,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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_from(compice , 'Fioi_meltw_wiso') - call addfld_to(compocn , 'Fioi_meltw_wiso') - else - 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_from(compice, 'Fioi_meltw_wiso', compocn, mapfcopy, 'unset', 'unset') - call addmrg_to(compocn, 'Fioi_meltw_wiso', & - mrg_from=compice, mrg_fld='Fioi_meltw_wiso', mrg_type='copy_with_weights', mrg_fracname='ifrac') - end if - end if - end if ! --------------------------------------------------------------------- ! to ocn: heat flux from melting ice from ice ! --------------------------------------------------------------------- @@ -2549,7 +2344,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if if (ocn_name == 'mpaso') then !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_Hs') @@ -2562,7 +2357,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_Fp') @@ -2575,7 +2370,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_1') @@ -2588,7 +2383,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_vstokes_wavenumber_1') @@ -2601,7 +2396,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_2') @@ -2614,7 +2409,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_vstokes_wavenumber_2') @@ -2627,7 +2422,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_3') @@ -2640,7 +2435,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_vstokes_wavenumber_3') @@ -2653,7 +2448,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_4') @@ -2666,7 +2461,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_vstokes_wavenumber_4') @@ -2679,7 +2474,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_5') @@ -2692,7 +2487,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_vstokes_wavenumber_5') @@ -2705,7 +2500,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_6') @@ -2718,7 +2513,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_vstokes_wavenumber_6') @@ -2731,7 +2526,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_6') @@ -2744,7 +2539,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if !----------------------------- - ! to ocn: + ! to ocn: !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_vstokes_wavenumber_6') @@ -3004,49 +2799,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_from(compatm, 'Faxa_rainc_wiso') - call addfld_from(compatm, 'Faxa_rainl_wiso') - call addfld_from(compatm, 'Faxa_rain_wiso' ) - call addfld_to(compice, '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_from(compatm, 'Faxa_rainc_wiso', compice, mapconsf, 'one', atm2ice_map) - call addmap_from(compatm, 'Faxa_rainl_wiso', compice, mapconsf, 'one', atm2ice_map) - call addmrg_to(compice, '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_from(compatm, 'Faxa_rain_wiso', compice, mapconsf, 'one', atm2ice_map) - call addmrg_to(compice, 'Faxa_rain_wiso', & - mrg_from=compatm, mrg_fld='Faxa_rain_wiso', mrg_type='copy') - end if - end if - - if (phase == 'advertise') then - call addfld_from(compatm, 'Faxa_snowc_wiso') - call addfld_from(compatm, 'Faxa_snowl_wiso') - call addfld_from(compatm, 'Faxa_snow_wiso' ) - call addfld_to(compice, '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_from(compatm, 'Faxa_snowc_wiso', compice, mapconsf, 'one', atm2ice_map) - call addmap_from(compatm, 'Faxa_snowl_wiso', compice, mapconsf, 'one', atm2ice_map) - call addmrg_to(compice, '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_from(compatm, 'Faxa_snow_wiso', compice, mapconsf, 'one', atm2ice_map) - call addmrg_to(compice, '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 ! --------------------------------------------------------------------- @@ -3146,7 +2898,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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 ! --------------------------------------------------------------------- if (phase == 'advertise') then call addfld_from(compatm, 'Sa_shum') @@ -3158,19 +2909,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(compice, '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_from(compatm, 'Sa_shum_wiso') - call addfld_to(compice, 'Sa_shum_wiso') - else - 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_from(compatm, 'Sa_shum_wiso', compice, mapbilnr, 'one', atm2ice_map) - call addmrg_to(compice, 'Sa_shum_wiso', mrg_from=compatm, mrg_fld='Sa_shum_wiso', mrg_type='copy') - end if - end if - end if - ! --------------------------------------------------------------------- ! to ice: sea surface temperature from ocn ! --------------------------------------------------------------------- @@ -3273,22 +3011,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end if end if - !----------------------------- - ! to ice: Ratio of ocean surface level abund. H2_16O/H2O/Rstd from ocean - !----------------------------- - if (flds_wiso) then - if (phase == 'advertise') then - call addfld_from(compocn, 'So_roce_wiso') - call addfld_to(compice, '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_from(compocn, 'So_roce_wiso', compice, mapfcopy, 'unset', 'unset') - call addmrg_to(compice, 'So_roce_wiso', mrg_from=compocn, mrg_fld='So_roce_wiso', mrg_type='copy') - end if - end if - end if - ! --------------------------------------------------------------------- ! to ice: wave elevation spectrum (field with ungridded dimensions) ! --------------------------------------------------------------------- @@ -3494,27 +3216,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) end if end do - ! --------------------------------------------------------------------- - ! to rof: liquid and ice from glc water isoptopes - ! --------------------------------------------------------------------- - do ns = 1, is_local%wrap%num_icesheets - if (phase == 'advertise') then - call addfld_from(compglc(ns), 'Fgrg_rofl_wiso') - call addfld_from(compglc(ns), 'Fgrg_rofi_wiso') - call addfld_to(comprof, 'Fgrg_rofl_wiso') - call addfld_to(comprof, 'Fgrg_rofi_wiso') - else - if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fgrg_rofl_wiso' , rc=rc)) then - call addmap_from(compglc(ns), 'Fgrg_rofl_wiso', comprof, mapconsd, 'one' , 'unset') - ! TODO: implement custom merge - end if - if (fldchk(is_local%wrap%FBImp(compglc(ns), compglc(ns)), 'Fgrg_rofi_wiso' , rc=rc)) then - call addmap_from(compglc(ns), 'Fgrg_rofi_wiso', comprof, mapconsd, 'one', 'unset') - ! TODO: implement custom merge - end if - end if - end do - ! --------------------------------------------------------------------- ! to rof: water flux from land (liquid surface) ! --------------------------------------------------------------------- diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index d9248bf93..96489eca2 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -43,10 +43,6 @@ canonical_units: kg m-2 s-1 description: med export - atm/ocn evaporation water flux computed in medidator # - - standard_name: Faox_evap_wiso - canonical_units: kg m-2 s-1 - description: med export - atm/ocn evaporation water flux 16O, 18O, HDO computed in medidator - # - standard_name: Faox_lat alias: mean_laten_heat_flx_atm_into_ocn canonical_units: W m-2 @@ -90,10 +86,6 @@ canonical_units: kg m-2 s-1 description: lnd import to med # - - standard_name: Fall_evap_wiso - canonical_units: kg m-2 s-1 - description: lnd import to med - # - standard_name: Fall_fco2_lnd canonical_units: moles m-2 s-1 description: lnd import to med @@ -174,10 +166,6 @@ canonical_units: kg kg-1 description: lnd import to med # - - standard_name: Sl_qref_wiso - canonical_units: kg kg-1 - description: lnd import to med - # - standard_name: Sl_ram1 canonical_units: s/m description: lnd import to med @@ -186,10 +174,6 @@ canonical_units: m description: lnd import to med # - - standard_name: Sl_snowh_wiso - canonical_units: m - description: lnd import to med - # - standard_name: Sl_soilw canonical_units: m3/m3 description: lnd import to med @@ -302,61 +286,32 @@ canonical_units: kg(N)/m2/sec description: atm import to med - currently nhx and noy # - - standard_name: Faxa_prec_wiso - canonical_units: kg m-2 s-1 - description: atm import to med - # - standard_name: Faxa_rain alias: mean_prec_rate canonical_units: kg m-2 s-1 description: atm import to med # - - standard_name: Faxa_rain_wiso - alias: mean_prec_rate_wiso - canonical_units: kg m-2 s-1 - description: atm import to med - # - standard_name: Faxa_rainc canonical_units: kg m-2 s-1 description: atm import to med # - - standard_name: Faxa_rainc_wiso - canonical_units: kg m-2 s-1 - description: atm import to med - # - standard_name: Faxa_rainl canonical_units: kg m-2 s-1 description: atm import to med # - - standard_name: Faxa_rainl_wiso - canonical_units: kg m-2 s-1 - description: atm import to med - # - standard_name: Faxa_snow alias: mean_fprec_rate canonical_units: kg m-2 s-1 description: atm import to med # - - standard_name: Faxa_snow_wiso - canonical_units: kg m-2 s-1 - description: atm import to med - # - standard_name: Faxa_snowc canonical_units: kg m-2 s-1 description: atm import to med # - - standard_name: Faxa_snowc_wiso - canonical_units: kg m-2 s-1 - description: atm import to med - # - standard_name: Faxa_snowl canonical_units: kg m-2 s-1 description: atm import to med # - - standard_name: Faxa_snowl_wiso - canonical_units: kg m-2 s-1 - description: atm import to med - # - standard_name: Faxa_swnet canonical_units: W m-2 description: atm import to med @@ -430,11 +385,6 @@ canonical_units: kg kg-1 description: atm import to med - bottom layer specific humidiaty # - - standard_name: Sa_shum_wiso - alias: inst_spec_humid_height_lowest_wiso - canonical_units: kg kg-1 - description: atm import to med - bottom layer specific humidity 16O, 18O, HDO - # - standard_name: Sa_tbot alias: inst_temp_height_lowest canonical_units: K @@ -501,10 +451,6 @@ canonical_units: kg m-2 s-1 description: atm export from meditor - merged water evaporation flux # - - standard_name: Faxx_evap_wiso - canonical_units: kg m-2 s-1 - description: atm export from med - merged water evaporation flux for 16O, 18O and HDO - # - standard_name: Faxx_lat alias: mean_laten_heat_flx canonical_units: W m-2 @@ -549,10 +495,6 @@ canonical_units: kg kg-1 description: atm export from med # - - standard_name: Sx_qref_wiso - canonical_units: kg kg-1 - description: atm export from med - # - standard_name: Sx_t alias: surface_temperature canonical_units: K @@ -589,26 +531,14 @@ canonical_units: kg m-2 s-1 description: glc import tomed - glacier frozen_runoff_flux_to_ocean # - - standard_name: Fgrg_rofi_wiso - canonical_units: kg m-2 s-1 - description: glc import to med - glacier_frozen_runoff_flux_to_ocean for 16O, 18O, HDO - # - standard_name: Fgrg_rofl canonical_units: kg m-2 s-1 description: glc import to med - glacier liquid runoff flux to ocean # - - standard_name: Fgrg_rofl_wiso - canonical_units: kg m-2 s-1 - description: glc import to med - glacier_frozen_runoff_flux_to_ocean for 16O, 18O, HDO - # - standard_name: Figg_rofi canonical_units: kg m-2 s-1 description: glc import to med - glc frozen runoff_iceberg flux to ice # - - standard_name: Figg_rofi_wiso - canonical_units: kg m-2 s-1 - description: glc import to med - glc frozen runoff_iceberg flux to ice for 16O, 18O, HDO - # - standard_name: Flgg_hflx canonical_units: W m-2 description: glc import to med to med (no elevation classes) @@ -660,10 +590,6 @@ canonical_units: kg m-2 s-1 description: ice import to med # - - standard_name: Faii_evap_wiso - canonical_units: kg m-2 s-1 - description: ice import to med for 16O, 18O, HDO - # - standard_name: Faii_lat alias: mean_laten_heat_flx_atm_into_ice canonical_units: W m-2 @@ -710,24 +636,11 @@ canonical_units: W m-2 description: ice import to med to ocean - net heat flux to ocean # - - standard_name: Fioi_melth_wiso - canonical_units: kg m-2 s-1 - description: ice import to med to ocean - isotope head flux to ocean for 16O, 18O, HDO - # - - standard_name: Fioi_melth_HDO - canonical_units: kg m-2 s-1 - description: ice import to med to ocean - isotope head flux to ocean - # - standard_name: Fioi_meltw alias: mean_fresh_water_to_ocean_rate canonical_units: kg m-2 s-1 description: ice import to med to ocean - fresh water to ocean (h2o flux from melting) # - - standard_name: Fioi_meltw_wiso - alias: mean_fresh_water_to_ocean_rate_wiso - canonical_units: kg m-2 s-1 - description: ice import to med to ocean - fresh water to ocean (h2o flux from melting) for 16O, 18O, HDO - # - standard_name: Fioi_salt alias: mean_salt_rate canonical_units: kg m-2 s-1 @@ -807,10 +720,6 @@ canonical_units: kg kg-1 description: ice import to med # - - standard_name: Si_qref_wiso - canonical_units: kg kg-1 - description: ice import to med - # - standard_name: Si_t alias: sea_ice_surface_temperature canonical_units: K @@ -941,22 +850,10 @@ canonical_units: kg kg-1 description: ocn import to med # - - standard_name: So_qref_wiso - canonical_units: kg kg-1 - description: ocn import to med - # - standard_name: So_re canonical_units: 1 description: ocn import to med # - - standard_name: So_qref_wiso - canonical_units: kg kg-1 - description: ocn import to med - # - - standard_name: So_roce_wiso - canonical_units: unitless - description: ocn import to med - # - standard_name: So_s alias: s_surf canonical_units: g kg-1 @@ -1052,19 +949,10 @@ canonical_units: kg m-2 s-1 description: med export to ocn - specific humidity flux # - - standard_name: Foxx_evap_wiso - alias: mean_evap_rate_wiso - canonical_units: kg m-2 s-1 - description: med export to ocn - specific humidity flux 16O, 18O, HDO - # - standard_name: Foxx_lat canonical_units: W m-2 description: med export to ocn - latent heat flux into ocean # - - standard_name: Foxx_lat_wiso - canonical_units: W m-2 - description: med export to ocn - latent heat flux into ocean for 16O, 18O, HDO - # - standard_name: Foxx_lat canonical_units: W m-2 description: med export to ocn - latent heat flux into ocean for HDO @@ -1103,19 +991,11 @@ canonical_units: kg m-2 s-1 description: med export to ocn - water flux due to runoff (frozen) # - - standard_name: Foxx_rofi_wiso - canonical_units: kg m-2 s-1 - description: med export to ocn - water flux due to runoff (frozen) for 16O, 18O, HDO - # - standard_name: Foxx_rofl alias: mean_runoff_rate canonical_units: kg m-2 s-1 description: med export to ocn - water flux due to runoff (liquid) # - - standard_name: Foxx_rofl_wiso - canonical_units: kg m-2 s-1 - description: med export to ocn - water flux due to runoff (liquid) for 16O, 18O, HDO - # - standard_name: Foxx_swnet alias: mean_net_sw_flx canonical_units: W m-2 @@ -1176,26 +1056,14 @@ canonical_units: kg m-2 s-1 description: river import to med - water flux due to flooding # - - standard_name: Flrr_flood_wiso - canonical_units: kg m-2 s-1 - description: river import to med - water flux due to flooding for 16O, 18O, HDO - # - standard_name: Flrr_volr canonical_units: m description: river import to med - river channel total water volume # - - standard_name: Flrr_volr_wiso - canonical_units: m - description: river import to med - river channel total water volume from 16O, 18O, HDO - # - standard_name: Flrr_volrmch canonical_units: m description: river import to med - river channel main channel water volume # - - standard_name: Flrr_volrmch_wiso - canonical_units: m - description: river import to med - river channel main channel water volume from 16O, 18O, HDO - # - standard_name: Sr_tdepth canonical_units: m description: river import to med - tributary channel water depth @@ -1212,10 +1080,6 @@ canonical_units: kg m-2 s-1 description: river export to ocean - water flux due to runoff originating from glc (frozen) # - - standard_name: Forr_rofi_wiso - canonical_units: kg m-2 s-1 - description: river import to med - water flux due to runoff (frozen) for 16O, 18O, HDO - # - standard_name: Forr_rofl canonical_units: kg m-2 s-1 description: river import to med - water flux due to runoff (liquid) @@ -1224,10 +1088,6 @@ canonical_units: kg m-2 s-1 description: river import to med - water flux due to runoff originating from glc (liquid) # - - standard_name: Forr_rofl_wiso - canonical_units: kg m-2 s-1 - description: river import to med - water flux due to runoff (frozen) for 16O, 18O, HDO - # #----------------------------------- # section: wav import to med #----------------------------------- diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index 6dd8e9808..787202db6 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -33,7 +33,7 @@ module med_diag_mod use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf use shr_log_mod , only : shr_log_error - + implicit none private @@ -163,27 +163,6 @@ module med_diag_mod integer :: f_watr_roff_glc = unset_index ! water: runoff/flood from glc integer :: f_watr_ioff = unset_index ! water: frozen runoff integer :: f_watr_ioff_glc = unset_index ! water: frozen runoff from glc - 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 @@ -192,25 +171,6 @@ module med_diag_mod 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 - ! --------------------------------- - - logical :: flds_wiso = .false.! If water isotope fields are active - - ! TODO: for now set to .false. - but this needs to be set in an initialization phase - - integer, parameter :: nisotopes = 3 - integer :: iso0(nisotopes) - integer :: isof(nisotopes) - character(len=5) :: isoname(nisotopes) - ! --------------------------------- ! P for period ! --------------------------------- @@ -373,43 +333,6 @@ subroutine med_diag_init(gcomp, rc) end if f_watr_end = f_watr_ioff_glc ! 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 - ! ----------------------------------------- ! Salt fluxes budget terms (for v1 only) ! ----------------------------------------- @@ -729,15 +652,6 @@ 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 - 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 budget_local(f_heat_latf,c_lnd_arecv,ip) = -budget_local(f_watr_snow,c_lnd_arecv,ip)*shr_const_latice @@ -775,14 +689,6 @@ 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 - ! water isotopes - 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) end subroutine med_phases_diag_atm @@ -857,118 +763,6 @@ subroutine diag_atm_send(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifra end if end subroutine diag_atm_send - subroutine diag_atm_wiso_recv(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, & - afrac, lfrac, ofrac, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: afrac(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(in) :: ofrac(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - ! local variables - integer :: n, ip - real(r8), pointer :: data(:,:) - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1,size(data, dim=2) - budget(nf_16O,c_atm_recv,ip) = budget(nf_16O,c_atm_recv,ip) - areas(n)*afrac(n)*data(1,n) - budget(nf_16O,c_lnd_arecv,ip) = budget(nf_16O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(1,n) - budget(nf_16O,c_ocn_arecv,ip) = budget(nf_16O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(1,n) - if (lats(n) > 0.0_r8) then - budget(nf_16O,c_inh_arecv,ip) = budget(nf_16O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(1,n) - else - budget(nf_16O,c_ish_arecv,ip) = budget(nf_16O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(1,n) - end if - - budget(nf_18O,c_atm_recv,ip) = budget(nf_18O,c_atm_recv,ip) - areas(n)*afrac(n)*data(2,n) - budget(nf_18O,c_lnd_arecv,ip) = budget(nf_18O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(2,n) - budget(nf_18O,c_ocn_arecv,ip) = budget(nf_18O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(2,n) - if (lats(n) > 0.0_r8) then - budget(nf_18O,c_inh_arecv,ip) = budget(nf_18O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(2,n) - else - budget(nf_18O,c_ish_arecv,ip) = budget(nf_18O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(2,n) - end if - - budget(nf_HDO,c_atm_recv,ip) = budget(nf_HDO,c_atm_recv,ip) - areas(n)*afrac(n)*data(3,n) - budget(nf_HDO,c_lnd_arecv,ip) = budget(nf_HDO,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(3,n) - budget(nf_HDO,c_ocn_arecv,ip) = budget(nf_HDO,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(3,n) - if (lats(n) > 0.0_r8) then - budget(nf_HDO,c_inh_arecv,ip) = budget(nf_HDO,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(3,n) - else - budget(nf_HDO,c_ish_arecv,ip) = budget(nf_HDO,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_atm_wiso_recv - - subroutine diag_atm_wiso_send(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, & - afrac, lfrac, ofrac, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: afrac(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(in) :: ofrac(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - ! local variables - integer :: n, ip - real(r8), pointer :: data(:,:) - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1,size(data, dim=2) - budget(nf_16O,c_atm_send,ip) = budget(nf_16O,c_atm_send,ip) - areas(n)*afrac(n)*data(1,n) - budget(nf_16O,c_lnd_asend,ip) = budget(nf_16O,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(1,n) - budget(nf_16O,c_ocn_asend,ip) = budget(nf_16O,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(1,n) - if (lats(n) > 0.0_r8) then - budget(nf_16O,c_inh_asend,ip) = budget(nf_16O,c_inh_asend,ip) + areas(n)*ifrac(n)*data(1,n) - else - budget(nf_16O,c_ish_asend,ip) = budget(nf_16O,c_ish_asend,ip) + areas(n)*ifrac(n)*data(1,n) - end if - - budget(nf_18O,c_atm_send,ip) = budget(nf_18O,c_atm_send,ip) - areas(n)*afrac(n)*data(2,n) - budget(nf_18O,c_lnd_asend,ip) = budget(nf_18O,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(2,n) - budget(nf_18O,c_ocn_asend,ip) = budget(nf_18O,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(2,n) - if (lats(n) > 0.0_r8) then - budget(nf_18O,c_inh_asend,ip) = budget(nf_18O,c_inh_asend,ip) + areas(n)*ifrac(n)*data(2,n) - else - budget(nf_18O,c_ish_asend,ip) = budget(nf_18O,c_ish_asend,ip) + areas(n)*ifrac(n)*data(2,n) - end if - - budget(nf_HDO,c_atm_send,ip) = budget(nf_HDO,c_atm_send,ip) - areas(n)*afrac(n)*data(3,n) - budget(nf_HDO,c_lnd_asend,ip) = budget(nf_HDO,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(3,n) - budget(nf_HDO,c_ocn_asend,ip) = budget(nf_HDO,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(3,n) - if (lats(n) > 0.0_r8) then - budget(nf_HDO,c_inh_asend,ip) = budget(nf_HDO,c_inh_asend,ip) + areas(n)*ifrac(n)*data(3,n) - else - budget(nf_HDO,c_ish_asend,ip) = budget(nf_HDO,c_ish_asend,ip) + areas(n)*ifrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_atm_wiso_send - !=============================================================================== subroutine med_phases_diag_lnd( gcomp, rc) @@ -1040,18 +834,6 @@ subroutine med_phases_diag_lnd( gcomp, rc) areas, lfrac, budget_local, minus=.true., rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - 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 !------------------------------- @@ -1077,23 +859,6 @@ subroutine med_phases_diag_lnd( gcomp, rc) 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 - 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 call t_stopf('MED:'//subname) @@ -1130,43 +895,6 @@ subroutine diag_lnd(FB, fldname, nf, ic, areas, lfrac, budget, minus, rc) end if end subroutine diag_lnd - subroutine diag_lnd_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, lfrac, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - ! local variables - integer :: n, ip - real(r8), pointer :: data(:,:) - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (present(minus)) then - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*lfrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*lfrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*lfrac(n)*data(3,n) - else - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*lfrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*lfrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*lfrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_lnd_wiso - !=============================================================================== subroutine med_phases_diag_rof( gcomp, rc) @@ -1221,18 +949,6 @@ subroutine med_phases_diag_rof( gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - 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 budget_local(f_heat_ioff_glc,ic,ip) = -budget_local(f_watr_ioff_glc,ic,ip)*shr_const_latice @@ -1262,15 +978,6 @@ subroutine med_phases_diag_rof( gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - 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 budget_local(f_heat_ioff_glc,ic,ip) = -budget_local(f_watr_ioff_glc,ic,ip)*shr_const_latice @@ -1308,43 +1015,6 @@ subroutine diag_rof(FB, fldname, nf, ic, areas, budget, minus, rc) end if end subroutine diag_rof - subroutine diag_rof_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - - ! local variables - integer :: n, ip - real(r8), pointer :: data(:,:) - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (present(minus)) then - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*data(3,n) - else - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*data(3,n) - end if - end do - end if - end subroutine diag_rof_wiso - !=============================================================================== subroutine med_phases_diag_glc( gcomp, rc) @@ -1577,27 +1247,6 @@ subroutine med_phases_diag_ocn( gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - 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 - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_hrain', f_heat_rain , ic, areas, sfrac, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_hsnow', f_heat_snow , ic, areas, sfrac, budget_local, rc=rc) @@ -1655,36 +1304,6 @@ subroutine diag_ocn(FB, fldname, nf, ic, areas, frac, budget, scale, rc) end if end subroutine diag_ocn - subroutine diag_ocn_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, frac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: frac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - - ! local variables - integer :: n, ip - real(r8), pointer :: data(:,:) - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*frac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*frac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*frac(n)*data(3,n) - end do - end if - end subroutine diag_ocn_wiso - !=============================================================================== subroutine med_phases_diag_ice_ice2med( gcomp, rc) @@ -1782,15 +1401,6 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) areas, lats, ifrac, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - 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 @@ -1838,47 +1448,6 @@ subroutine diag_ice_recv(FB, fldname, nf, areas, lats, ifrac, budget, minus, sca end if end subroutine diag_ice_recv - subroutine diag_ice_recv_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - ! local variables - integer :: n, ic, ip - real(r8), pointer :: data(:,:) - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (lats(n) > 0.0_r8) then - ic = c_inh_recv - else - ic = c_ish_recv - endif - if (present(minus)) then - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*ifrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*ifrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*ifrac(n)*data(3,n) - else - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_ice_recv_wiso !=============================================================================== subroutine med_phases_diag_ice_med2ice( gcomp, rc) @@ -1965,15 +1534,6 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) budget_local(f_watr_frz ,ic,ip) = budget_local(f_heat_frz ,ic,ip)*HFLXtoWFLX end if - 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 @@ -2007,41 +1567,6 @@ subroutine diag_ice_send(FB, fldname, nf, areas, lats, ifrac, budget, rc) end if end subroutine diag_ice_send - subroutine diag_ice_send_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - - ! local variables - integer :: n, ic, ip - real(r8), pointer :: data(:,:) - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (lats(n) > 0.0_r8) then - ic = c_inh_send - else - ic = c_ish_send - endif - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n) - end do - end if - end subroutine diag_ice_send_wiso - !=============================================================================== subroutine med_phases_diag_print(gcomp, rc) @@ -2159,9 +1684,6 @@ subroutine med_phases_diag_print(gcomp, rc) ! budget normalizations (global area and 1e6 for water) datagpr = datagpr/(4.0_r8*shr_const_pi) datagpr(f_watr_beg:f_watr_end,:,:) = datagpr(f_watr_beg:f_watr_end,:,:) * 1.0e6_r8 - if ( flds_wiso ) then - datagpr(iso0(1):isof(nisotopes),:,:) = datagpr(iso0(1):isof(nisotopes),:,:) * 1.0e6_r8 - end if datagpr(:,:,:) = datagpr(:,:,:)/budget_counter(:,:,:) ! Write diagnostic tables to logunit (maintask only) @@ -2207,7 +1729,7 @@ subroutine med_diag_print_atm(data, ip, date, tod) integer , intent(in) :: tod ! local variables - integer :: ic,nf,is ! data array indicies + integer :: ic,nf ! data array indicies integer :: ica,icl integer :: icn,ics,ico character(len=40) :: str ! string @@ -2311,38 +1833,6 @@ subroutine med_diag_print_atm(data, ip, date, tod) sum(data(f_watr_beg:f_watr_end,icn,ip)) + sum(data(f_watr_beg:f_watr_end,ics,ip)) + & sum(data(f_watr_beg:f_watr_end,ico,ip)) - if ( flds_wiso ) then - do is = 1, nisotopes - write(diagunit,*) ' ' - write(diagunit,FAH) subname,trim(str)//' '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', & - trim(budget_diags%periods(ip)%name),': date = ',date,tod - write(diagunit,FA0) & - budget_diags%comps(ica)%name,& - budget_diags%comps(icl)%name,& - budget_diags%comps(icn)%name,& - budget_diags%comps(ics)%name,& - budget_diags%comps(ico)%name,' *SUM* ' - do nf = iso0(is), isof(is) - write(diagunit,FA1) budget_diags%fields(nf)%name,& - data(nf,ica,ip), & - data(nf,icl,ip), & - data(nf,icn,ip), & - data(nf,ics,ip), & - data(nf,ico,ip), & - data(nf,ica,ip) + data(nf,icl,ip) + data(nf,icn,ip) + data(nf,ics,ip) + data(nf,ico,ip) - enddo - write(diagunit,FA1) ' *SUM*', & - sum(data(iso0(is):isof(is),ica,ip)), & - sum(data(iso0(is):isof(is),icl,ip)), & - sum(data(iso0(is):isof(is),icn,ip)), & - sum(data(iso0(is):isof(is),ics,ip)), & - sum(data(iso0(is):isof(is),ico,ip)), & - sum(data(iso0(is):isof(is),ica,ip)) + sum(data(iso0(is):isof(is),icl,ip)) + & - sum(data(iso0(is):isof(is),icn,ip)) + sum(data(iso0(is):isof(is),ics,ip)) + & - sum(data(iso0(is):isof(is),ico,ip)) - end do - end if - enddo end subroutine med_diag_print_atm @@ -2361,7 +1851,7 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, date, tod) integer , intent(in) :: tod ! local variables - integer :: ic,nf,is ! data array indicies + integer :: ic,nf ! data array indicies integer :: icar,icas integer :: icxs,icxr character(len=40) :: str ! string @@ -2450,65 +1940,6 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, date, tod) -sum(data(f_watr_beg:f_watr_end,icas,ip)), & -sum(data(f_watr_beg:f_watr_end,icar,ip)) + sum(data(f_watr_beg:f_watr_end,icxs,ip)) + & sum(data(f_watr_beg:f_watr_end,icxr,ip)) - sum(data(f_watr_beg:f_watr_end,icas,ip)) - - if ( flds_wiso ) then - do is = 1, nisotopes - - ! heat budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh for water isotopes - - write(diagunit,*) ' ' - write(diagunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',& - trim(budget_diags%periods(ip)%name), & - ': date = ',date,tod - write(diagunit,FA0) & - budget_diags%comps(icar)%name,& - budget_diags%comps(icxs)%name,& - budget_diags%comps(icxr)%name,& - budget_diags%comps(icas)%name,' *SUM* ' - do nf = iso0(is), isof(is) - write(diagunit,FA1) budget_diags%fields(nf)%name,& - -data(nf,icar,ip), & - data(nf,icxs,ip), & - data(nf,icxr,ip), & - -data(nf,icas,ip), & - -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip) - enddo - write(diagunit,FA1) ' *SUM*',& - -sum(data(iso0(is):isof(is),icar,ip)),& - sum(data(iso0(is):isof(is),icxs,ip)), & - sum(data(iso0(is):isof(is),icxr,ip)), & - -sum(data(iso0(is):isof(is),icas,ip)), & - -sum(data(iso0(is):isof(is),icar,ip)) + sum(data(iso0(is):isof(is),icxs,ip)) + & - sum(data(iso0(is):isof(is),icxr,ip)) - sum(data(iso0(is):isof(is),icas,ip)) - - ! water budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh for water isotopes - - write(diagunit,*) ' ' - write(diagunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',& - trim(budget_diags%periods(ip)%name),& - ': date = ',date,tod - write(diagunit,FA0) & - budget_diags%comps(icar)%name,& - budget_diags%comps(icxs)%name,& - budget_diags%comps(icxr)%name,& - budget_diags%comps(icas)%name,' *SUM* ' - do nf = iso0(is), isof(is) - write(diagunit,FA1) budget_diags%fields(nf)%name,& - -data(nf,icar,ip), & - data(nf,icxs,ip), & - data(nf,icxr,ip), & - -data(nf,icas,ip), & - -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip) - enddo - write(diagunit,FA1) ' *SUM*', & - -sum(data(iso0(is):isof(is), icar, ip)), & - sum(data(iso0(is):isof(is), icxs, ip)), & - sum(data(iso0(is):isof(is), icxr, ip)), & - -sum(data(iso0(is):isof(is), icas, ip)), & - -sum(data(iso0(is):isof(is), icar, ip)) + sum(data(iso0(is):isof(is), icxs, ip)) + & - sum(data(iso0(is):isof(is), icxr, ip)) - sum(data(iso0(is):isof(is), icas, ip)) - end do - end if enddo end subroutine med_diag_print_lnd_ice_ocn @@ -2527,7 +1958,7 @@ subroutine med_diag_print_summary(data, ip, date, tod) integer , intent(in) :: tod ! local variables - integer :: nf,is ! data array indicies + integer :: nf ! data array indicies real(r8) :: atm_area, lnd_area, ocn_area real(r8) :: ice_area_nh, ice_area_sh real(r8) :: sum_area @@ -2666,55 +2097,6 @@ subroutine med_diag_print_summary(data, ip, date, tod) sum_net_water_atm, sum_net_water_lnd, sum_net_water_rof, sum_net_water_ocn, & sum_net_water_ice_nh, sum_net_water_ice_sh, sum_net_water_glc, sum_net_water_tot - ! write out net water water-isoptope budgets - - if ( flds_wiso ) then - - do is = 1, nisotopes - write(diagunit,*) ' ' - write(diagunit,FAH) subname,'NET '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): 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 = iso0(is), isof(is) - net_water_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip) - net_water_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip) - net_water_rof = data(nf, c_rof_recv, ip) + data(nf, c_rof_send, ip) - net_water_ocn = data(nf, c_ocn_recv, ip) + data(nf, c_ocn_send, ip) - net_water_ice_nh = data(nf, c_inh_recv, ip) + data(nf, c_inh_send, ip) - net_water_ice_sh = data(nf, c_ish_recv, ip) + data(nf, c_ish_send, ip) - net_water_glc = data(nf, c_glc_recv, ip) + data(nf, c_glc_send, ip) - net_water_tot = net_water_atm + net_water_lnd + net_water_rof + net_water_ocn + & - net_water_ice_nh + net_water_ice_sh + net_water_glc - - write(diagunit,FA1r) budget_diags%fields(nf)%name,& - net_water_atm, net_water_lnd, net_water_rof, net_water_ocn, & - net_water_ice_nh, net_water_ice_sh, net_water_glc, net_water_tot - enddo - - sum_net_water_atm = sum(data(iso0(is):isof(is), c_atm_recv, ip)) + & - sum(data(iso0(is):isof(is), c_atm_send, ip)) - sum_net_water_lnd = sum(data(iso0(is):isof(is), c_lnd_recv, ip)) + & - sum(data(iso0(is):isof(is), c_lnd_send, ip)) - sum_net_water_rof = sum(data(iso0(is):isof(is), c_rof_recv, ip)) + & - sum(data(iso0(is):isof(is), c_rof_send, ip)) - sum_net_water_ocn = sum(data(iso0(is):isof(is), c_ocn_recv, ip)) + & - sum(data(iso0(is):isof(is), c_ocn_send, ip)) - sum_net_water_ice_nh = sum(data(iso0(is):isof(is), c_inh_recv, ip)) + & - sum(data(iso0(is):isof(is), c_inh_send, ip)) - sum_net_water_ice_sh = sum(data(iso0(is):isof(is), c_ish_recv, ip)) + & - sum(data(iso0(is):isof(is), c_ish_send, ip)) - sum_net_water_glc = sum(data(iso0(is):isof(is), c_glc_recv, ip)) + & - sum(data(iso0(is):isof(is), c_glc_send, ip)) - sum_net_water_tot = sum_net_water_atm + sum_net_water_lnd + sum_net_water_rof + & - sum_net_water_ocn + sum_net_water_ice_nh + sum_net_water_ice_sh + & - sum_net_water_glc - - write(diagunit,FA1r)' *SUM*',& - sum_net_water_atm, sum_net_water_lnd, sum_net_water_rof, sum_net_water_ocn, & - sum_net_water_ice_nh, sum_net_water_ice_sh, sum_net_water_glc, sum_net_water_tot - end do - end if - ! ----------------------------- ! write out net salt budgets ! ----------------------------- diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index b0caebd9a..70c95ac37 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -279,7 +279,7 @@ subroutine med_internalstate_init(gcomp, rc) end if if (maintask) then - write(logunit,'(a,l)') trim(subname)//' atm and lnd is on same grid = ', samegrid_atmlnd + write(logunit,'(a,l2)') trim(subname)//' atm and lnd is on same grid = ', samegrid_atmlnd end if ! See med_fraction_mod for the following definitions diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index b3618c1ba..9417e2528 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -74,7 +74,6 @@ module med_phases_aofluxes_mod ! Private data !-------------------------------------------------------------------------- - logical :: flds_wiso ! use case logical :: compute_atm_dens logical :: compute_atm_thbot integer :: ocn_surface_flux_scheme ! use case @@ -107,9 +106,7 @@ module med_phases_aofluxes_mod 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 @@ -122,9 +119,6 @@ module med_phases_aofluxes_mod real(R8) , pointer :: psfc (:) => null() ! atm surface pressure real(R8) , pointer :: dens (:) => null() ! atm bottom density real(R8) , pointer :: tbot (:) => null() ! atm bottom surface T - 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 :: lwdn (:) => null() ! atm downward longwave heat flux real(R8) , pointer :: rainc (:) => null() ! convective rain flux ! local size and computational mask and area: on aoflux grid @@ -139,9 +133,6 @@ module med_phases_aofluxes_mod real(R8) , pointer :: lat (:) => null() ! heat flux: latent real(R8) , pointer :: lwup (:) => null() ! lwup over ocean real(R8) , pointer :: evap (:) => null() ! water flux: evaporation - real(R8) , pointer :: evap_16O (:) => null() ! H2O flux: evaporation - real(R8) , pointer :: evap_HDO (:) => null() ! HDO flux: evaporation - real(R8) , pointer :: evap_18O (:) => null() ! H218O flux: evaporation real(R8) , pointer :: taux (:) => null() ! wind stress, zonal real(R8) , pointer :: tauy (:) => null() ! wind stress, meridional real(R8) , pointer :: tref (:) => null() ! diagnostic: 2m ref T @@ -386,13 +377,6 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) ! Initialize module variables !---------------------------------- - call NUOPC_CompAttributeGet(gcomp, name='flds_wiso', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) flds_wiso - 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 @@ -637,13 +621,8 @@ subroutine med_aofluxes_init_agrid(gcomp, aoflux_in, aoflux_out, rc) ! input fields from atm and ocn on atm grid ! ------------------------ - if (flds_wiso) then - allocate(fldnames_ocn_in(5)) - fldnames_ocn_in = (/'So_omask ','So_t ','So_u ','So_v ','So_roce_wiso' /) - else - allocate(fldnames_ocn_in(4)) - fldnames_ocn_in = (/'So_omask','So_t ','So_u ','So_v '/) - end if + allocate(fldnames_ocn_in(4)) + fldnames_ocn_in = (/'So_omask','So_t ','So_u ','So_v '/) 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 @@ -972,7 +951,7 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) use med_methods_mod, only : FB_fldchk => med_methods_FB_fldchk use med_methods_mod, only : FB_diagnose => med_methods_FB_diagnose #ifdef CESMCOUPLED - use shr_flux_mod , only : flux_atmocn + use flux_atmocn_driver_mod, only : flux_atmocn_driver #else use flux_atmocn_mod, only : flux_atmocn #endif @@ -1068,24 +1047,17 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) !---------------------------------- #ifdef CESMCOUPLED - call flux_atmocn (logunit=logunit, & + call flux_atmocn_driver (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, & - rainc=aoflux_in%rainc, & - 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, pslv=aoflux_in%psfc, 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, & + zbot=aoflux_in%zbot, ubot=aoflux_in%ubot, vbot=aoflux_in%vbot, thbot=aoflux_in%thbot, & + qbot=aoflux_in%shum, rainc=aoflux_in%rainc, rbot=aoflux_in%dens, & + tbot=aoflux_in%tbot, us=aoflux_in%uocn, vs=aoflux_in%vocn, pslv=aoflux_in%psfc, & + 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, evap=aoflux_out%evap, & taux=aoflux_out%taux, tauy=aoflux_out%tauy, tref=aoflux_out%tref, qref=aoflux_out%qref, & ocn_surface_flux_scheme=ocn_surface_flux_scheme, & - add_gusts=add_gusts, & - duu10n=aoflux_out%duu10n, & - ugust_out = aoflux_out%ugust_out, & - u10res = aoflux_out%u10res, & - ustar_sv=aoflux_out%ustar, re_sv=aoflux_out%re, ssq_sv=aoflux_out%ssq, & - missval=0.0_r8) + add_gusts=add_gusts, duu10n=aoflux_out%duu10n, ugust_out = aoflux_out%ugust_out, u10res = aoflux_out%u10res, & + ustar_sv=aoflux_out%ustar, re_sv=aoflux_out%re, ssq_sv=aoflux_out%ssq, missval=0.0_r8) #else #ifdef UFS_AOFLUX @@ -1658,19 +1630,6 @@ subroutine set_aoflux_in_pointers(fldbun_a, fldbun_o, aoflux_in, lsize, xgrid, r 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 ! ------------------------ @@ -1684,18 +1643,6 @@ subroutine set_aoflux_in_pointers(fldbun_a, fldbun_o, aoflux_in, lsize, xgrid, r 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 @@ -1741,18 +1688,6 @@ subroutine set_aoflux_out_pointers(fldbun, lsize, aoflux_out, xgrid, rc) 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 if (add_gusts) then call fldbun_getfldptr(fldbun, 'So_ugustOut', aoflux_out%ugust_out, xgrid=xgrid, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 5f3bba1e7..fd533d70c 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -1769,7 +1769,7 @@ subroutine med_phases_history_set_timeinfo(gcomp, hclock, alarmname, & 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) + call ESMF_TimeIntervalGet(timediff(1), startTimeIn=starttime, 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 diff --git a/mediator/med_phases_post_rof_mod.F90 b/mediator/med_phases_post_rof_mod.F90 index f21bf2271..472502f21 100644 --- a/mediator/med_phases_post_rof_mod.F90 +++ b/mediator/med_phases_post_rof_mod.F90 @@ -64,7 +64,6 @@ subroutine med_phases_post_rof_init(gcomp, rc) ! local variables character(CL) :: cvalue logical :: isPresent, isSet - logical :: flds_wiso character(len=*), parameter :: subname='(med_phases_post_rof_init)' !--------------------------------------- @@ -95,20 +94,6 @@ subroutine med_phases_post_rof_init(gcomp, rc) remove_negative_runoff_glc = .false. end if - ! remove_negative_runoff isn't yet set up to handle isotope fields, so ensure that - ! this isn't set along with flds_wiso - call NUOPC_CompAttributeGet(gcomp, name='flds_wiso', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) flds_wiso - else - flds_wiso = .false. - end if - if ((remove_negative_runoff_lnd .or. remove_negative_runoff_glc) .and. flds_wiso) then - call shr_log_error('remove_negative_runoff_lnd and remove_negative_runoff_glc must be set to false when flds_wiso is true', rc=rc) - return - end if - if (maintask) then write(logunit,'(a,l7)') trim(subname)//' remove_negative_runoff_lnd = ', remove_negative_runoff_lnd write(logunit,'(a,l7)') trim(subname)//' remove_negative_runoff_glc = ', remove_negative_runoff_glc From 8f85ca3dc60348098624d59d9e43eb672280f821 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 15 Jan 2026 10:40:06 -0500 Subject: [PATCH 08/15] update Sa_pslv to be bilinear (#156) * update Sa_pslv to be bilinear * change coupling mode for bulk aoflux scheme consistent w/ mapping * minor tweaks to aoflux module for clarity --- mediator/esmFldsExchange_ufs_mod.F90 | 2 +- mediator/med_phases_aofluxes_mod.F90 | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/mediator/esmFldsExchange_ufs_mod.F90 b/mediator/esmFldsExchange_ufs_mod.F90 index bc6fa86e5..f0f907c9d 100644 --- a/mediator/esmFldsExchange_ufs_mod.F90 +++ b/mediator/esmFldsExchange_ufs_mod.F90 @@ -370,7 +370,7 @@ subroutine esmFldsExchange_ufs(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_from(compatm, 'Sa_pslv', compocn, maptype, 'one', 'unset') + call addmap_from(compatm, 'Sa_pslv', compocn, mapbilnr, 'one', 'unset') call addmrg_to(compocn, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') end if end if diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index 9417e2528..626f4b129 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -1558,8 +1558,8 @@ subroutine set_aoflux_in_pointers(fldbun_a, fldbun_o, aoflux_in, lsize, xgrid, r lsize = size(aoflux_in%zbot) aoflux_in%lsize = lsize - ! bulk formula quantities for ufs non-frac with med-aoflux - if (trim(coupling_mode) == 'ufs.nfrac.aoflux' .and. ocn_surface_flux_scheme == -1) then + ! note the ocn_surface_flux_scheme -1 will be deprecated in the future + if (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) @@ -1587,8 +1587,8 @@ subroutine set_aoflux_in_pointers(fldbun_a, fldbun_o, aoflux_in, lsize, xgrid, r end if end if - ! extra fields for ufs.frac.aoflux - if (trim(coupling_mode) == 'ufs.frac.aoflux') then + ! extra fields for CCPP aoflux + if (trim(aoflux_code) == 'ccpp') then call fldbun_getfldptr(fldbun_a, 'Sa_u10m', aoflux_in%usfc, xgrid=xgrid, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call fldbun_getfldptr(fldbun_a, 'Sa_v10m', aoflux_in%vsfc, xgrid=xgrid, rc=rc) From 4bb06b3f4834142b8ae4e9a6ab8a6aa7b1e098a7 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 16 Jan 2026 11:10:39 -0500 Subject: [PATCH 09/15] add CDEPS inline data for GFS_surface_composites_pre/post (#159) --- ufs/ccpp/data/MED_typedefs.F90 | 24 ++++++++++++++++- ufs/ccpp/data/MED_typedefs.meta | 46 +++++++++++++++++++++++++++++++++ ufs/flux_atmocn_ccpp_mod.F90 | 2 +- 3 files changed, 70 insertions(+), 2 deletions(-) diff --git a/ufs/ccpp/data/MED_typedefs.F90 b/ufs/ccpp/data/MED_typedefs.F90 index f51fe0a9b..8e98bda9b 100644 --- a/ufs/ccpp/data/MED_typedefs.F90 +++ b/ufs/ccpp/data/MED_typedefs.F90 @@ -169,6 +169,7 @@ module MED_typedefs type MED_control_type logical :: lseaspray !< flag for sea spray parameterization logical :: use_med_flux !< flag for using atmosphere-ocean fluxes form mediator + logical :: use_cdeps_inline !< default no data from cdeps inline integer :: ivegsrc !< land use dataset choice 0 => USGS, 1 => IGBP, 2 => UMD integer :: lsm !< flag for land surface model integer :: lsm_noahmp !< flag for NOAH MP land surface model @@ -215,6 +216,12 @@ module MED_typedefs type MED_coupling_type real(kind=kind_phys), pointer :: dtsfcin_med(:) => null() !< sfc latent heat flux over ocean real(kind=kind_phys), pointer :: dqsfcin_med(:) => null() !< sfc sensible heat flux over ocean + !-- lake surface temperature from cdeps inline + real(kind=kind_phys), pointer :: mask_dat (:) => null() !< land-sea mask from cdeps inline + real(kind=kind_phys), pointer :: tsfco_dat (:) => null() !< sfc temperature from cdeps inline + real(kind=kind_phys), pointer :: tice_dat (:) => null() !< sfc temperature over ice from cdeps inline + real(kind=kind_phys), pointer :: hice_dat (:) => null() !< sfc ice thickness from cdeps inline + real(kind=kind_phys), pointer :: fice_dat (:) => null() !< sfc ice fraction from cdeps inline contains procedure :: create => coupling_create !< allocate array data end type MED_coupling_type @@ -644,6 +651,7 @@ subroutine control_initialize(model) model%lseaspray = .false. model%use_med_flux = .false. + model%use_cdeps_inline = .false. model%ivegsrc = 2 model%redrag = .false. model%sfc_z0_type = 0 @@ -680,15 +688,29 @@ subroutine control_initialize(model) end subroutine control_initialize - subroutine coupling_create(coupling, im) + subroutine coupling_create(coupling, im, model) implicit none class(MED_coupling_type) :: coupling integer, intent(in) :: im + type(MED_control_type), intent(in) :: model allocate(coupling%dtsfcin_med(im)) coupling%dtsfcin_med = clear_val allocate(coupling%dqsfcin_med(im)) coupling%dqsfcin_med = clear_val + + if (model%use_cdeps_inline) then + allocate (coupling%tsfco_dat(im)) + coupling%tsfco_dat = clear_val + allocate (coupling%mask_dat(im)) + coupling%mask_dat = clear_val + allocate (coupling%tice_dat(im)) + coupling%tice_dat = clear_val + allocate (coupling%hice_dat(im)) + coupling%hice_dat = clear_val + allocate (coupling%fice_dat(im)) + coupling%fice_dat = clear_val + endif end subroutine coupling_create diff --git a/ufs/ccpp/data/MED_typedefs.meta b/ufs/ccpp/data/MED_typedefs.meta index 65baaa7e2..9d838d52a 100644 --- a/ufs/ccpp/data/MED_typedefs.meta +++ b/ufs/ccpp/data/MED_typedefs.meta @@ -803,6 +803,12 @@ units = flag dimensions = () type = logical +[use_cdeps_inline] + standard_name = do_cdeps_inline + long_name = flag for using data provided by CDEPS inline (default false) + units = flag + dimensions = () + type = logical [ivegsrc] standard_name = control_for_vegetation_dataset long_name = land use dataset choice @@ -1030,6 +1036,46 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[tsfco_dat] + standard_name = sea_surface_temperature_from_data + long_name = sfc temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (do_cdeps_inline) +[mask_dat] + standard_name = land_sea_mask_from_data + long_name = landmask + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (do_cdeps_inline) +[tice_dat] + standard_name = surface_skin_temperature_over_ice_from_data + long_name = surface skin temperature over ice + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (do_cdeps_inline) +[hice_dat] + standard_name = sea_ice_thickness_from_data + long_name = sea-ice thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (do_cdeps_inline) +[fice_dat] + standard_name = sea_ice_area_fraction_of_sea_area_fraction_from_data + long_name = sea-ice concentration [0,1] + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + active = (do_cdeps_inline) ######################################################################## [ccpp-table-properties] diff --git a/ufs/flux_atmocn_ccpp_mod.F90 b/ufs/flux_atmocn_ccpp_mod.F90 index 84f1652bf..bfebc2976 100644 --- a/ufs/flux_atmocn_ccpp_mod.F90 +++ b/ufs/flux_atmocn_ccpp_mod.F90 @@ -137,7 +137,7 @@ subroutine flux_atmOcn_ccpp(gcomp, maintask, logunit, nMax, mask, psfc, pbot, & call physics%statein%create(nMax,physics%model) call physics%stateout%create(nMax) call physics%interstitial%create(nMax) - call physics%coupling%create(nMax) + call physics%coupling%create(nMax,physics%model) call physics%grid%create(nMax) call physics%sfcprop%create(nMax,physics%model) call physics%diag%create(nMax) From 5ec03ea1c3c38d7f2b2cd0048bd1caddd1069988 Mon Sep 17 00:00:00 2001 From: Dusan Jovic <48258889+DusanJovic-NOAA@users.noreply.github.com> Date: Tue, 20 Jan 2026 11:34:51 -0500 Subject: [PATCH 10/15] Add tracing instrumentation to nuopc driver (#151) --- mediator/CMakeLists.txt | 3 ++- mediator/med.F90 | 29 ++++++++++++++++++++- mediator/med_phases_history_mod.F90 | 10 ++++++++ mediator/med_phases_ocnalb_mod.F90 | 4 +++ mediator/med_phases_post_atm_mod.F90 | 5 +++- mediator/med_phases_post_ice_mod.F90 | 5 +++- mediator/med_phases_post_ocn_mod.F90 | 5 +++- mediator/med_phases_post_wav_mod.F90 | 5 +++- mediator/med_phases_prep_atm_mod.F90 | 3 +++ mediator/med_phases_prep_ice_mod.F90 | 3 +++ mediator/med_phases_prep_ocn_mod.F90 | 5 ++++ mediator/med_phases_prep_wav_mod.F90 | 5 ++++ mediator/med_phases_restart_mod.F90 | 5 ++++ mediator/med_ufs_trace_wrapper.F90 | 38 ++++++++++++++++++++++++++++ 14 files changed, 119 insertions(+), 6 deletions(-) create mode 100644 mediator/med_ufs_trace_wrapper.F90 diff --git a/mediator/CMakeLists.txt b/mediator/CMakeLists.txt index 80be3d2e8..36d5db290 100644 --- a/mediator/CMakeLists.txt +++ b/mediator/CMakeLists.txt @@ -16,7 +16,8 @@ set(SRCFILES esmFldsExchange_cesm_mod.F90 med_fraction_mod.F90 med_phases_post_ocn_mod.F90 med_phases_ocnalb_mod.F90 med_phases_post_atm_mod.F90 med_phases_post_ice_mod.F90 med_phases_post_lnd_mod.F90 med_phases_post_glc_mod.F90 - med_phases_post_rof_mod.F90 med_phases_post_wav_mod.F90) + med_phases_post_rof_mod.F90 med_phases_post_wav_mod.F90 + med_ufs_trace_wrapper.F90) foreach(FILE ${SRCFILES}) if(EXISTS "${CASEROOT}/SourceMods/src.cmeps/${FILE}") diff --git a/mediator/med.F90 b/mediator/med.F90 index d7e0d20f5..2e59cf8a9 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -52,7 +52,7 @@ module MED use esmFldsExchange_hafs_mod , only : esmFldsExchange_hafs use med_phases_profile_mod , only : med_phases_profile_finalize use shr_log_mod , only : shr_log_error - + use med_ufs_trace_wrapper_mod, only : ufs_trace_init_wrapper, ufs_trace_wrapper, ufs_trace_finalize_wrapper implicit none private @@ -87,6 +87,7 @@ subroutine SetServices(gcomp, rc) use ESMF , only: ESMF_SUCCESS, ESMF_GridCompSetEntryPoint use ESMF , only: ESMF_METHOD_INITIALIZE, ESMF_METHOD_RUN use ESMF , only: ESMF_GridComp, ESMF_MethodRemove + use ESMF , only: ESMF_VM, ESMF_VMGet, ESMF_GridCompGet use NUOPC , only: NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize, NUOPC_NoOP use NUOPC_Mediator , only: mediator_routine_SS => SetServices use NUOPC_Mediator , only: mediator_routine_Run => routine_Run @@ -133,6 +134,8 @@ subroutine SetServices(gcomp, rc) type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc + type(ESMF_VM) :: vm + integer :: localPet ! local variables character(len=*), parameter :: subname = '('//__FILE__//':SetServices)' !----------------------------------------------------------- @@ -140,6 +143,15 @@ subroutine SetServices(gcomp, rc) rc = ESMF_SUCCESS if (profile_memory) call ESMF_VMLogMemInfo("Entering "//trim(subname)) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + maintask = .false. + if (localPet == 0) maintask=.true. + if (maintask) call ufs_trace_init_wrapper() + if (maintask) call ufs_trace_wrapper("cmeps", "SetServices", "B") + !------------------ ! the NUOPC model component mediator_routine_SS will register the generic methods !------------------ @@ -555,6 +567,7 @@ subroutine SetServices(gcomp, rc) if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) + if (maintask) call ufs_trace_wrapper("cmeps", "SetServices", "E") end subroutine SetServices !----------------------------------------------------------------------------- @@ -592,6 +605,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) if (profile_memory) call ESMF_VMLogMemInfo("Entering "//trim(subname)) + if (maintask) call ufs_trace_wrapper("cmeps", "InitializeP0", "B") call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_VMGet(vm, localPet=localPet, rc=rc) @@ -662,6 +676,8 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + if (maintask) call ufs_trace_wrapper("cmeps", "InitializeP0", "E") + end subroutine InitializeP0 !----------------------------------------------------------------------- @@ -701,6 +717,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) character(len=*), parameter :: subname = '('//__FILE__//':AdvertiseFields)' !----------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "AdvertiseFields", "B") call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) rc = ESMF_SUCCESS if (profile_memory) call ESMF_VMLogMemInfo("Entering "//trim(subname)) @@ -980,6 +997,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + if (maintask) call ufs_trace_wrapper("cmeps", "AdvertiseFields", "E") end subroutine AdvertiseFields !----------------------------------------------------------------------------- @@ -1006,6 +1024,7 @@ subroutine RealizeFieldsWithTransferProvided(gcomp, importState, exportState, cl integer :: n character(len=*), parameter :: subname = '('//__FILE__//':RealizeFieldsWithTransferProvided)' !----------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "RealizeFieldsWithTransferProvided", "B") call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) rc = ESMF_SUCCESS @@ -1043,6 +1062,7 @@ subroutine RealizeFieldsWithTransferProvided(gcomp, importState, exportState, cl if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + if (maintask) call ufs_trace_wrapper("cmeps", "RealizeFieldsWithTransferProvided", "E") end subroutine RealizeFieldsWithTransferProvided @@ -1067,6 +1087,7 @@ subroutine ModifyDecompofMesh(gcomp, importState, exportState, clock, rc) integer :: n1 character(len=*), parameter :: subname = '('//__FILE__//':ModifyDecompofMesh)' !----------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "ModifyDecompofMesh", "B") call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) rc = ESMF_SUCCESS @@ -1095,6 +1116,7 @@ subroutine ModifyDecompofMesh(gcomp, importState, exportState, clock, rc) enddo if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + if (maintask) call ufs_trace_wrapper("cmeps", "ModifyDecompofMesh", "E") contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1392,6 +1414,7 @@ subroutine RealizeFieldsWithTransferAccept(gcomp, importState, exportState, cloc integer :: n1 character(len=*), parameter :: subname = '('//__FILE__//':RealizeFieldsWithTransferAccept)' !----------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "RealizeFieldsWithTransferAccept", "B") call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -1431,6 +1454,7 @@ subroutine RealizeFieldsWithTransferAccept(gcomp, importState, exportState, cloc if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + if (maintask) call ufs_trace_wrapper("cmeps", "RealizeFieldsWithTransferAccept", "E") contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1655,6 +1679,7 @@ subroutine DataInitialize(gcomp, rc) character(len=CX) :: msgString character(len=*), parameter :: subname = '('//__FILE__//':DataInitialize)' !----------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "DataInitialize", "B") call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) rc = ESMF_SUCCESS @@ -1963,6 +1988,7 @@ subroutine DataInitialize(gcomp, rc) ! the correct timestamps, which also indicates that the actual ! data has been transferred reliably, and CMEPS can safely use it. + if (maintask) call ufs_trace_wrapper("cmeps", "DataInitialize", "E") RETURN endif ! end first_call if-block @@ -2254,6 +2280,7 @@ subroutine DataInitialize(gcomp, rc) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) endif + if (maintask) call ufs_trace_wrapper("cmeps", "DataInitialize", "E") end subroutine DataInitialize !----------------------------------------------------------------------------- diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index fd533d70c..2cb31f907 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -24,6 +24,8 @@ module med_phases_history_mod use perf_mod , only : t_startf, t_stopf use pio , only : file_desc_t use shr_log_mod , only : shr_log_error + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper + implicit none private @@ -188,6 +190,7 @@ subroutine med_phases_history_write(gcomp, rc) !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write", "B") call t_startf('MED:'//subname) ! Get the internal state @@ -383,6 +386,7 @@ subroutine med_phases_history_write(gcomp, rc) call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write", "E") end subroutine med_phases_history_write !=============================================================================== @@ -420,6 +424,7 @@ subroutine med_phases_history_write_med(gcomp, rc) character(len=*), parameter :: subname='(med_phases_history_write_med)' !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write_med", "B") ! Get the internal state nullify(is_local%wrap) @@ -526,6 +531,7 @@ subroutine med_phases_history_write_med(gcomp, rc) end if ! end of if-write_now block end if ! end of if-active block + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write_med", "E") end subroutine med_phases_history_write_med !=============================================================================== @@ -567,6 +573,7 @@ subroutine med_phases_history_write_lnd2glc(gcomp, fldbun_lnd, rc, fldbun_glc) !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write_lnd2glc", "B") ! Get the internal state nullify(is_local%wrap) @@ -655,6 +662,7 @@ subroutine med_phases_history_write_lnd2glc(gcomp, fldbun_lnd, rc, fldbun_glc) call med_io_close(io_file, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write_lnd2glc", "E") end subroutine med_phases_history_write_lnd2glc !=============================================================================== @@ -668,6 +676,7 @@ subroutine med_phases_history_write_comp(gcomp, compid, rc) integer , intent(out) :: rc !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write_comp", "B") call med_phases_history_write_comp_inst(gcomp, compid, instfiles(compid), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -676,6 +685,7 @@ subroutine med_phases_history_write_comp(gcomp, compid, rc) call med_phases_history_write_comp_aux(gcomp, compid, auxcomp(compid), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_history_write_comp", "E") end subroutine med_phases_history_write_comp !=============================================================================== diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90 index b7c95389a..5f247192d 100644 --- a/mediator/med_phases_ocnalb_mod.F90 +++ b/mediator/med_phases_ocnalb_mod.F90 @@ -11,6 +11,8 @@ module med_phases_ocnalb_mod use shr_orb_mod , only : shr_orb_cosz, shr_orb_decl use shr_orb_mod , only : shr_orb_params, SHR_ORB_UNDEF_INT, SHR_ORB_UNDEF_REAL use shr_log_mod , only : shr_log_unit, shr_log_error + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper + implicit none private @@ -314,6 +316,7 @@ subroutine med_phases_ocnalb_run(gcomp, rc) !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_ocnalb_run", "B") ! Determine main task call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) @@ -507,6 +510,7 @@ subroutine med_phases_ocnalb_run(gcomp, rc) end if call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_ocnalb_run", "E") end subroutine med_phases_ocnalb_run !=============================================================================== diff --git a/mediator/med_phases_post_atm_mod.F90 b/mediator/med_phases_post_atm_mod.F90 index 333497a69..52651951a 100644 --- a/mediator/med_phases_post_atm_mod.F90 +++ b/mediator/med_phases_post_atm_mod.F90 @@ -28,13 +28,14 @@ subroutine med_phases_post_atm(gcomp, rc) 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 + use med_internalstate_mod , only : InternalState, maintask 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 use med_internalstate_mod , only : compocn, compatm, compice, complnd, compwav use perf_mod , only : t_startf, t_stopf + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper ! input/output variables type(ESMF_GridComp) :: gcomp @@ -47,6 +48,7 @@ subroutine med_phases_post_atm(gcomp, rc) !------------------------------------------------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_atm", "B") call t_startf('MED:'//subname) if (dbug_flag > 20) then @@ -126,6 +128,7 @@ subroutine med_phases_post_atm(gcomp, rc) end if call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_atm", "E") end subroutine med_phases_post_atm end module med_phases_post_atm_mod diff --git a/mediator/med_phases_post_ice_mod.F90 b/mediator/med_phases_post_ice_mod.F90 index 739369525..ff2ca2dca 100644 --- a/mediator/med_phases_post_ice_mod.F90 +++ b/mediator/med_phases_post_ice_mod.F90 @@ -28,10 +28,11 @@ subroutine med_phases_post_ice(gcomp, rc) 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 + use med_internalstate_mod , only : InternalState, maintask use med_phases_history_mod, only : med_phases_history_write_comp use med_internalstate_mod , only : compice, compocn, compwav use perf_mod , only : t_startf, t_stopf + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper ! input/output variables type(ESMF_GridComp) :: gcomp @@ -43,6 +44,7 @@ subroutine med_phases_post_ice(gcomp, rc) character(len=*),parameter :: subname='(med_phases_post_ice)' !------------------------------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_ice", "B") call t_startf('MED:'//subname) rc = ESMF_SUCCESS @@ -99,6 +101,7 @@ subroutine med_phases_post_ice(gcomp, rc) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end if + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_ice", "E") end subroutine med_phases_post_ice end module med_phases_post_ice_mod diff --git a/mediator/med_phases_post_ocn_mod.F90 b/mediator/med_phases_post_ocn_mod.F90 index b253de664..cba5ce7b2 100644 --- a/mediator/med_phases_post_ocn_mod.F90 +++ b/mediator/med_phases_post_ocn_mod.F90 @@ -26,11 +26,12 @@ subroutine med_phases_post_ocn(gcomp, rc) 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 + use med_internalstate_mod , only : InternalState, maintask 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 + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper ! input/output variables type(ESMF_GridComp) :: gcomp @@ -43,6 +44,7 @@ subroutine med_phases_post_ocn(gcomp, rc) !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_ocn", "B") call t_startf('MED:'//subname) if (dbug_flag > 20) then @@ -101,6 +103,7 @@ subroutine med_phases_post_ocn(gcomp, rc) end if call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_ocn", "E") end subroutine med_phases_post_ocn end module med_phases_post_ocn_mod diff --git a/mediator/med_phases_post_wav_mod.F90 b/mediator/med_phases_post_wav_mod.F90 index 50592012c..34b0d1677 100644 --- a/mediator/med_phases_post_wav_mod.F90 +++ b/mediator/med_phases_post_wav_mod.F90 @@ -23,10 +23,11 @@ subroutine med_phases_post_wav(gcomp, rc) 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 + use med_internalstate_mod , only : InternalState, maintask use med_internalstate_mod , only : compwav, compatm, compocn, compice use med_phases_history_mod, only : med_phases_history_write_comp use perf_mod , only : t_startf, t_stopf + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper ! input/output variables type(ESMF_GridComp) :: gcomp @@ -38,6 +39,7 @@ subroutine med_phases_post_wav(gcomp, rc) character(len=*),parameter :: subname='(med_phases_post_wav)' !------------------------------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_wav", "B") call t_startf('MED:'//subname) rc = ESMF_SUCCESS @@ -97,6 +99,7 @@ subroutine med_phases_post_wav(gcomp, rc) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end if + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_post_wav", "E") end subroutine med_phases_post_wav end module med_phases_post_wav_mod diff --git a/mediator/med_phases_prep_atm_mod.F90 b/mediator/med_phases_prep_atm_mod.F90 index bcdf2ea42..6fe283928 100644 --- a/mediator/med_phases_prep_atm_mod.F90 +++ b/mediator/med_phases_prep_atm_mod.F90 @@ -23,6 +23,7 @@ module med_phases_prep_atm_mod 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 + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper implicit none private @@ -60,6 +61,7 @@ subroutine med_phases_prep_atm(gcomp, rc) character(len=*),parameter :: subname='(med_phases_prep_atm)' !------------------------------------------------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_atm", "B") call t_startf('MED:'//subname) rc = ESMF_SUCCESS @@ -248,6 +250,7 @@ subroutine med_phases_prep_atm(gcomp, rc) end if call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_atm", "E") end subroutine med_phases_prep_atm !----------------------------------------------------------------------------- diff --git a/mediator/med_phases_prep_ice_mod.F90 b/mediator/med_phases_prep_ice_mod.F90 index 4aaa8c264..baaed9ff1 100644 --- a/mediator/med_phases_prep_ice_mod.F90 +++ b/mediator/med_phases_prep_ice_mod.F90 @@ -41,6 +41,7 @@ subroutine med_phases_prep_ice(gcomp, rc) use med_internalstate_mod , only : coupling_mode use esmFlds , only : med_fldList_GetFldListTo use perf_mod , only : t_startf, t_stopf + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper ! input/output variables type(ESMF_GridComp) :: gcomp @@ -59,6 +60,7 @@ subroutine med_phases_prep_ice(gcomp, rc) character(len=*),parameter :: subname='(med_phases_prep_ice)' !--------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_ice", "B") call t_startf('MED:'//subname) if (dbug_flag > 5) then @@ -158,6 +160,7 @@ subroutine med_phases_prep_ice(gcomp, rc) endif call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_ice", "E") end subroutine med_phases_prep_ice end module med_phases_prep_ice_mod diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90 index e30c4ada5..ebb6e99a9 100644 --- a/mediator/med_phases_prep_ocn_mod.F90 +++ b/mediator/med_phases_prep_ocn_mod.F90 @@ -23,6 +23,7 @@ module med_phases_prep_ocn_mod use esmFlds , only : med_fldList_GetfldListTo, med_fldlist_type use med_internalstate_mod , only : compocn, compatm, compice, coupling_mode use perf_mod , only : t_startf, t_stopf + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper implicit none private @@ -104,6 +105,7 @@ subroutine med_phases_prep_ocn_accum(gcomp, rc) character(len=*), parameter :: subname='(med_phases_prep_ocn_accum)' !--------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_ocn_accum", "B") call t_startf('MED:'//subname) if (dbug_flag > 20) then call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) @@ -266,6 +268,7 @@ subroutine med_phases_prep_ocn_accum(gcomp, rc) end if call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_ocn_accum", "E") end subroutine med_phases_prep_ocn_accum !----------------------------------------------------------------------------- @@ -288,6 +291,7 @@ subroutine med_phases_prep_ocn_avg(gcomp, rc) !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_ocn_avg", "B") call t_startf('MED:'//subname) if (dbug_flag > 20) then @@ -341,6 +345,7 @@ subroutine med_phases_prep_ocn_avg(gcomp, rc) call t_stopf('MED:'//subname) first_call = .false. + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_ocn_avg", "E") end subroutine med_phases_prep_ocn_avg !----------------------------------------------------------------------------- diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 1cfd158be..4f36c8df1 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -21,6 +21,7 @@ module med_phases_prep_wav_mod use esmFlds , only : med_fldList_GetfldListTo use med_internalstate_mod , only : compatm, compwav use perf_mod , only : t_startf, t_stopf + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper implicit none private @@ -84,6 +85,7 @@ subroutine med_phases_prep_wav_accum(gcomp, rc) character(len=*), parameter :: subname='(med_phases_prep_wav_accum)' !--------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_wav_accum", "B") call t_startf('MED:'//subname) if (dbug_flag > 20) then call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) @@ -147,6 +149,7 @@ subroutine med_phases_prep_wav_accum(gcomp, rc) end if call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_wav_accum", "E") end subroutine med_phases_prep_wav_accum !----------------------------------------------------------------------------- @@ -168,6 +171,7 @@ subroutine med_phases_prep_wav_avg(gcomp, rc) !--------------------------------------- rc = ESMF_SUCCESS + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_wav_avg", "B") call t_startf('MED:'//subname) if (dbug_flag > 20) then @@ -219,5 +223,6 @@ subroutine med_phases_prep_wav_avg(gcomp, rc) end if call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_prep_wav_avg", "E") 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 705bf7ac5..350fbe8ce 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -19,6 +19,7 @@ module med_phases_restart_mod use shr_is_restart_fh_mod , only : log_restart_fh #endif use shr_log_mod , only : shr_log_error + use med_ufs_trace_wrapper_mod, only : ufs_trace_wrapper implicit none private @@ -198,6 +199,7 @@ subroutine med_phases_restart_write(gcomp, rc) character(len=*), parameter :: subname='(med_phases_restart_write)' !--------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_restart_write", "B") call t_startf('MED:'//subname) if (dbug_flag > 5) then call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) @@ -508,6 +510,7 @@ subroutine med_phases_restart_write(gcomp, rc) endif call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_restart_write", "E") end subroutine med_phases_restart_write !=============================================================================== @@ -543,6 +546,7 @@ subroutine med_phases_restart_read(gcomp, rc) character(ESMF_MAXSTR) :: restart_pfile ! Local path to restart pointer filename character(len=*), parameter :: subname='(med_phases_restart_read)' !--------------------------------------- + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_restart_read", "B") call t_startf('MED:'//subname) call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) rc = ESMF_SUCCESS @@ -661,6 +665,7 @@ subroutine med_phases_restart_read(gcomp, rc) call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) call t_stopf('MED:'//subname) + if (maintask) call ufs_trace_wrapper("cmeps", "med_phases_restart_read", "E") end subroutine med_phases_restart_read !=============================================================================== diff --git a/mediator/med_ufs_trace_wrapper.F90 b/mediator/med_ufs_trace_wrapper.F90 new file mode 100644 index 000000000..8a0415a95 --- /dev/null +++ b/mediator/med_ufs_trace_wrapper.F90 @@ -0,0 +1,38 @@ +module med_ufs_trace_wrapper_mod + +#ifdef UFS_TRACING + use ufs_trace_mod, only: ufs_trace_init, ufs_trace, ufs_trace_finalize +#endif + + implicit none + + private + + public ufs_trace_init_wrapper + public ufs_trace_wrapper + public ufs_trace_finalize_wrapper + +contains + + subroutine ufs_trace_init_wrapper() +#ifdef UFS_TRACING + call ufs_trace_init +#endif + return + end subroutine ufs_trace_init_wrapper + + subroutine ufs_trace_wrapper(component, routine, ph) + character(len=*), intent(in) :: component, routine, ph +#ifdef UFS_TRACING + call ufs_trace(component, routine, ph) +#endif + return + end subroutine ufs_trace_wrapper + + subroutine ufs_trace_finalize_wrapper() +#ifdef UFS_TRACING + call ufs_trace_finalize +#endif + end subroutine ufs_trace_finalize_wrapper + +end module med_ufs_trace_wrapper_mod From 27e3961d9bb323fc5ff16a532947caddb515eb95 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Wed, 21 Jan 2026 16:54:26 -0500 Subject: [PATCH 11/15] add optional mapfiles when available (#158) --- mediator/esmFldsExchange_ufs_mod.F90 | 95 +++++++++++++++++++++------- 1 file changed, 72 insertions(+), 23 deletions(-) diff --git a/mediator/esmFldsExchange_ufs_mod.F90 b/mediator/esmFldsExchange_ufs_mod.F90 index f0f907c9d..919ec34ff 100644 --- a/mediator/esmFldsExchange_ufs_mod.F90 +++ b/mediator/esmFldsExchange_ufs_mod.F90 @@ -6,6 +6,11 @@ module esmFldsExchange_ufs_mod ! mapping and merging !--------------------------------------------------------------------- + use ESMF + use NUOPC + use med_utils_mod , only : chkerr => med_utils_chkerr + use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 + implicit none public @@ -14,6 +19,14 @@ module esmFldsExchange_ufs_mod integer :: atm2lnd_maptype integer :: lnd2atm_maptype + ! optional mapping files + character(len=CL) :: a2oi_bilnr + character(len=CL) :: a2oi_patch + character(len=CL) :: a2oi_consf + character(len=CL) :: a2w_bilnr + character(len=CL) :: w2oi_bilnr_nstod + character(len=CL) :: oi2w_bilnr_nstod + character(*), parameter :: u_FILE_u = & __FILE__ @@ -23,10 +36,6 @@ module esmFldsExchange_ufs_mod subroutine esmFldsExchange_ufs(gcomp, phase, rc) - use ESMF - use NUOPC - use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 - use med_utils_mod , only : chkerr => med_utils_chkerr use med_methods_mod , only : fldchk => med_methods_FB_FldChk use med_internalstate_mod , only : InternalState use med_internalstate_mod , only : compmed, compatm, compocn, compice, complnd, compwav, ncomps @@ -76,7 +85,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Set maptype according to coupling_mode - if (trim(coupling_mode) == 'ufs.nfrac' .or. trim(coupling_mode) == 'ufs.nfrac.aoflux') then + if (trim(coupling_mode) == 'ufs.nfrac') then maptype = mapnstod_consf else maptype = mapconsf @@ -101,6 +110,22 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) end if end if + ! to ocn/ice + a2oi_bilnr = get_mapfile(gcomp, 'map_a2oi_bilnr', rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + a2oi_patch = get_mapfile(gcomp, 'map_a2oi_patch', rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + a2oi_consf = get_mapfile(gcomp, 'map_a2oi_consf', rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + w2oi_bilnr_nstod = get_mapfile(gcomp, 'map_w2oi_bilnr_nstod', rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! to wav + a2w_bilnr = get_mapfile(gcomp, 'map_a2w_bilnr', rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + oi2w_bilnr_nstod = get_mapfile(gcomp, 'map_oi2w_bilnr_nstod', rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (trim(coupling_mode) == 'ufs.nfrac.aoflux' .or. trim(coupling_mode) == 'ufs.frac.aoflux') then med_aoflux_to_ocn = .true. else @@ -159,7 +184,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) call addfld_from(compatm , fldname) else if ( fldchk(is_local%wrap%FBImp(compatm,compatm), fldname, rc=rc)) then - call addmap_from(compatm, fldname, compocn, mapbilnr, 'one', 'unset') + call addmap_from(compatm, fldname, compocn, mapbilnr, 'one', a2oi_bilnr) end if end if end do @@ -370,7 +395,7 @@ subroutine esmFldsExchange_ufs(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_from(compatm, 'Sa_pslv', compocn, mapbilnr, 'one', 'unset') + call addmap_from(compatm, 'Sa_pslv', compocn, mapbilnr, 'one', a2oi_bilnr) call addmrg_to(compocn, 'Sa_pslv', mrg_from=compatm, mrg_fld='Sa_pslv', mrg_type='copy') end if end if @@ -405,7 +430,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) 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 - call addmap_from(compatm, trim(aflds(n)), compocn, maptype, 'one', 'unset') + call addmap_from(compatm, trim(aflds(n)), compocn, maptype, 'one', a2oi_consf) end if end if end do @@ -440,7 +465,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), fldname, rc=rc)) then - call addmap_from(compatm, fldname, compocn, maptype, 'one', 'unset') + call addmap_from(compatm, fldname, compocn, maptype, 'one', a2oi_consf) call addmrg_to(compocn, fldname, & mrg_from=compatm, mrg_fld=fldname, mrg_type='copy_with_weights', mrg_fracname='ofrac') end if @@ -475,9 +500,9 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_'//fldname, rc=rc)) then call addmap_from(compice, 'Fioi_'//fldname, compocn, mapfcopy, 'unset', 'unset') if (mapuv_with_cart3d) then - call addmap_from(compatm, 'Faxa_'//fldname, compocn, mapconsf_uv3d, 'aofrac', 'unset') + call addmap_from(compatm, 'Faxa_'//fldname, compocn, mapconsf_uv3d, 'aofrac', a2oi_consf) else - call addmap_from(compatm, 'Faxa_'//fldname, compocn, mapconsf_aofrac, 'aofrac', 'unset') + call addmap_from(compatm, 'Faxa_'//fldname, compocn, mapconsf_aofrac, 'aofrac', a2oi_consf) end if call addmrg_to(compocn, 'Foxx_'//fldname, & mrg_from=compice, mrg_fld='Fioi_'//fldname, mrg_type='merge', mrg_fracname='ifrac') @@ -511,7 +536,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_lwnet', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwnet', rc=rc)) then - call addmap_from(compatm, 'Faxa_lwnet', compocn, mapconsf_aofrac, 'aofrac', 'unset') + call addmap_from(compatm, 'Faxa_lwnet', compocn, mapconsf_aofrac, 'aofrac', a2oi_consf) call addmrg_to(compocn, 'Foxx_lwnet', & mrg_from=compatm, mrg_fld='Faxa_lwnet', mrg_type='copy_with_weights', mrg_fracname='ofrac') end if @@ -535,7 +560,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_sen', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_sen', rc=rc)) then - call addmap_from(compatm, 'Faxa_sen', compocn, mapconsf_aofrac, 'aofrac', 'unset') + call addmap_from(compatm, 'Faxa_sen', compocn, mapconsf_aofrac, 'aofrac', a2oi_consf) call addmrg_to(compocn, 'Foxx_sen', & mrg_from=compatm, mrg_fld='Faxa_sen', mrg_type='copy_with_weights', mrg_fracname='ofrac') end if @@ -559,7 +584,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , 'Foxx_evap', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_evap' , rc=rc)) then - call addmap_from(compatm, 'Faxa_evap', compocn, mapconsf_aofrac, 'aofrac', 'unset') + call addmap_from(compatm, 'Faxa_evap', compocn, mapconsf_aofrac, 'aofrac', a2oi_consf) call addmrg_to(compocn, 'Foxx_evap', & mrg_from=compatm, mrg_fld='Faxa_evap', mrg_type='copy_with_weights', mrg_fracname='ofrac') end if @@ -603,7 +628,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compocn) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav,compwav), fldname, rc=rc)) then - call addmap_from(compwav, fldname, compocn, mapbilnr_nstod, 'one', 'unset') + call addmap_from(compwav, fldname, compocn, mapbilnr_nstod, 'one', w2oi_bilnr_nstod) call addmrg_to(compocn, fldname, mrg_from=compwav, mrg_fld=fldname, mrg_type='copy') end if end if @@ -636,7 +661,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compice) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), fldname, rc=rc)) then - call addmap_from(compatm, fldname, compice, maptype, 'one', 'unset') + call addmap_from(compatm, fldname, compice, maptype, 'one', a2oi_consf) call addmrg_to(compice, fldname, mrg_from=compatm, mrg_fld=fldname, mrg_type='copy') end if end if @@ -662,7 +687,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compice) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), fldname, rc=rc)) then - call addmap_from(compatm, fldname, compice, mapbilnr, 'one', 'unset') + call addmap_from(compatm, fldname, compice, mapbilnr, 'one', a2oi_bilnr) call addmrg_to(compice, fldname, mrg_from=compatm, mrg_fld=fldname, mrg_type='copy') end if end if @@ -682,9 +707,9 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) if ( fldchk(is_local%wrap%FBexp(compice) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), fldname, rc=rc)) then if (mapuv_with_cart3d) then - call addmap_from(compatm, fldname, compice, mappatch_uv3d, 'one', 'unset') + call addmap_from(compatm, fldname, compice, mappatch_uv3d, 'one', a2oi_patch) else - call addmap_from(compatm, fldname, compice, mappatch, 'one', 'unset') + call addmap_from(compatm, fldname, compice, mappatch, 'one', a2oi_patch) end if call addmrg_to(compice, fldname, mrg_from=compatm, mrg_fld=fldname, mrg_type='copy') end if @@ -728,7 +753,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compice) , 'Sw_elevation_spectrum', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav,compwav), 'Sw_elevation_spectrum', rc=rc)) then - call addmap_from(compwav, 'Sw_elevation_spectrum', compice, mapbilnr_nstod, 'one', 'unset') + call addmap_from(compwav, 'Sw_elevation_spectrum', compice, mapbilnr_nstod, 'one', w2oi_bilnr_nstod) call addmrg_to(compice, 'Sw_elevation_spectrum', mrg_from=compwav, & mrg_fld='Sw_elevation_spectrum', mrg_type='copy') end if @@ -753,7 +778,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compwav) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compatm,compatm), fldname, rc=rc)) then - call addmap_from(compatm, fldname, compwav, mapbilnr, 'one', 'unset') + call addmap_from(compatm, fldname, compwav, mapbilnr, 'one', a2w_bilnr) call addmrg_to(compwav, fldname, mrg_from=compatm, mrg_fld=fldname, mrg_type='copy') end if end if @@ -776,7 +801,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compwav) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compice,compice), fldname, rc=rc)) then - call addmap_from(compice, fldname, compwav, mapbilnr_nstod , 'one', 'unset') + call addmap_from(compice, fldname, compwav, mapbilnr_nstod , 'one', oi2w_bilnr_nstod) call addmrg_to(compwav, fldname, mrg_from=compice, mrg_fld=fldname, mrg_type='copy') end if end if @@ -799,7 +824,7 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBexp(compwav) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compocn,compocn), fldname, rc=rc)) then - call addmap_from(compocn, fldname, compwav, mapbilnr_nstod , 'one', 'unset') + call addmap_from(compocn, fldname, compwav, mapbilnr_nstod , 'one', oi2w_bilnr_nstod) call addmrg_to(compwav, fldname, mrg_from=compocn, mrg_fld=fldname, mrg_type='copy') end if end if @@ -866,4 +891,28 @@ subroutine esmFldsExchange_ufs(gcomp, phase, rc) end subroutine esmFldsExchange_ufs + function get_mapfile(gcomp, attribute_name, rc) result(mapfile) + + type(ESMF_GridComp), intent(in) :: gcomp + character(len=*) , intent(in) :: attribute_name + integer , intent(inout) :: rc + character(len=CL) :: mapfile + + logical :: isPresent, isSet + character(len=CL) :: cvalue + !-------------------------------------- + + rc = ESMF_SUCCESS + + mapfile = 'unset' + call NUOPC_CompAttributeGet(gcomp, name=attribute_name, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name=attribute_name, value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + mapfile = trim(cvalue) + end if + + end function get_mapfile + end module esmFldsExchange_ufs_mod From ecf85a803363f11e84684b344dc8aad11913de32 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Wed, 4 Mar 2026 12:20:37 -0500 Subject: [PATCH 12/15] Sync with escomp (#163) --- .github/workflows/srt.yml | 2 +- cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 | 18 +- cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 | 14 +- cesm/flux_atmocn/flux_atmocn_Large.F90 | 19 +- cesm/flux_atmocn/flux_atmocn_driver_mod.F90 | 8 +- .../shr_lnd2rof_tracers_mod.F90 | 94 ++++++ cesm/share_wrappers/wtracers_mod.F90 | 18 ++ cime_config/buildexe | 1 + cime_config/namelist_definition_drv.xml | 38 ++- mediator/CMakeLists.txt | 1 + mediator/esmFldsExchange_cesm_mod.F90 | 128 +++----- mediator/fd_cesm.yaml | 12 + mediator/med.F90 | 23 +- mediator/med_field_info_mod.F90 | 293 ++++++++++++++++++ mediator/med_fraction_mod.F90 | 26 +- mediator/med_methods_mod.F90 | 166 ++-------- mediator/med_phases_aofluxes_mod.F90 | 54 +++- mediator/med_phases_cdeps_mod.F90 | 1 - mediator/med_phases_history_mod.F90 | 24 +- mediator/med_phases_prep_glc_mod.F90 | 10 +- mediator/med_phases_prep_ocn_mod.F90 | 9 +- mediator/med_phases_prep_rof_mod.F90 | 157 +++++----- mediator/med_phases_prep_wav_mod.F90 | 9 +- ufs/CMakeLists.txt | 2 +- ufs/wtracers_mod.F90 | 34 ++ 25 files changed, 806 insertions(+), 355 deletions(-) create mode 100644 cesm/nuopc_cap_share/shr_lnd2rof_tracers_mod.F90 create mode 100644 cesm/share_wrappers/wtracers_mod.F90 create mode 100644 mediator/med_field_info_mod.F90 create mode 100644 ufs/wtracers_mod.F90 diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml index 3afe2b7d1..361c561fd 100644 --- a/.github/workflows/srt.yml +++ b/.github/workflows/srt.yml @@ -19,7 +19,7 @@ jobs: strategy: fail-fast: false matrix: - python-version: [ 3.8, 3.11, 3.x ] + python-version: [ "3.10", 3.12, 3.x ] env: CC: mpicc FC: mpifort diff --git a/cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 b/cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 index 824d4097a..15e38d02a 100644 --- a/cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 +++ b/cesm/flux_atmocn/flux_atmocn_COARE_mod.F90 @@ -45,6 +45,7 @@ subroutine flux_atmOcn_COARE( & ts, mask, seq_flux_atmocn_minwind, & sen, lat, lwup, evap, & taux ,tauy, tref, qref, & + aofluxes_use_shr_wv_sat, & duu10n, ugust_out, u10res, & ustar_sv, re_sv, ssq_sv) @@ -53,6 +54,7 @@ subroutine flux_atmOcn_COARE( & real(R8) , intent(in) :: spval integer , intent(in) :: nMax ! data vector length integer , intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + logical , intent(in) :: aofluxes_use_shr_wv_sat ! use shr_wv_sat_mod to calculate qsat for atm-ocn flux calculations 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) @@ -107,6 +109,8 @@ subroutine flux_atmOcn_COARE( & real(R8) :: hsb,hlb ! sens & lat heat flxs at zbot real(R8) :: tau ! stress at zbot real(R8) :: trf,qrf,urf,vrf ! reference-height quantities + real(r8) :: esat_val ! value of esat (saturation vapor pressure) at this point + real(r8) :: qsat_val ! value of qsat (saturation specific humidity) at this point !--- local functions -------------------------------- real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) @@ -116,6 +120,9 @@ subroutine flux_atmOcn_COARE( & real(R8) :: tdiff(nMax) ! tbot - ts real(R8) :: vscl + !--- functions --- + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + !--- formats ---------------------------------------- character(*),parameter :: subName = '(flux_atmOcn_COARE) ' character(*),parameter :: F00 = "('(flux_atmOcn_COARE) ',4a)" @@ -145,8 +152,15 @@ subroutine flux_atmOcn_COARE( & endif endif - call shr_wv_sat_qsat_liquid(ts(n), pslv(n), qsat, ssq) - ssq = 0.98_R8 * ssq ! sea surf hum (kg/kg) + if (aofluxes_use_shr_wv_sat) then + ! This version uses a qsat calculation method consistent with what's used in CAM + call shr_wv_sat_qsat_liquid(ts(n), pslv(n), esat_val, qsat_val) + ssq = 0.98_R8 * qsat_val ! sea surf hum (kg/kg) + else + ! This version uses the qsat calculation method that was used for many years, + ! prior to Aug 2025, and which is still being used by default in NorESM + ssq = 0.98_R8 * qsat(ts(n)) / rbot(n) ! sea surf hum (kg/kg) + end if 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 diff --git a/cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 b/cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 index ed0dd9a4a..8e4106409 100644 --- a/cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 +++ b/cesm/flux_atmocn/flux_atmocn_Diurnal_mod.F90 @@ -26,7 +26,6 @@ module flux_atmocn_diurnal_mod use shr_const_mod, only : shr_const_ocn_ref_sal, shr_const_zsrflyr, shr_const_rgas use shr_sys_mod, only : shr_sys_abort use flux_atmocn_COARE_mod, only : cor30a - use shr_wv_sat_mod, only : shr_wv_sat_qsat_liquid ! use saturation calculation consistent with CAM implicit none private @@ -236,7 +235,8 @@ subroutine flux_atmOcn_diurnal( & real(R8) :: tdiff(nMax) ! tbot - ts real(R8) :: vscl - ! NOTE: this should use the shr_wv_sat_qsat_liquid if this routine is ever used in production + ! NOTE: this should use the shr_wv_sat_qsat_liquid if this routine is ever used in + ! production (see https://github.com/ESCOMP/CMEPS/issues/624) 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 @@ -354,10 +354,9 @@ subroutine flux_atmOcn_diurnal( & speed(n) = 0.0_R8 endif - ! This should be changed to use the subroutine below + ! This should be changed to use shr_wv_sat_qsat_liquid (see + ! https://github.com/ESCOMP/CMEPS/issues/624) ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) - ! call shr_wv_sat_qsat_liquid(tBulk(n), pslv(n), qsat, ssq) - ! ssq = 0.98_R8 * ssq ! sea surf hum (kg/kg) delt = thbot(n) - tBulk(n) ! pot temp diff (K) delq = qbot(n) - ssq ! spec hum dif (kg/kg) @@ -503,10 +502,9 @@ subroutine flux_atmOcn_diurnal( & !--need to update ssq,delt,delq as function of tBulk ---- - ! This should be changed to use the subroutine below + ! This should be changed to use shr_wv_sat_qsat_liquid (see + ! https://github.com/ESCOMP/CMEPS/issues/624) ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) - ! call shr_wv_sat_qsat_liquid(tBulk(n), pslv(n), qsat, ssq) - ! ssq = 0.98_R8 * ssq ! sea surf hum (kg/kg) delt = thbot(n) - tBulk(n) ! pot temp diff (K) delq = qbot(n) - ssq ! spec hum dif (kg/kg) diff --git a/cesm/flux_atmocn/flux_atmocn_Large.F90 b/cesm/flux_atmocn/flux_atmocn_Large.F90 index d58d512ba..b0df413db 100644 --- a/cesm/flux_atmocn/flux_atmocn_Large.F90 +++ b/cesm/flux_atmocn/flux_atmocn_Large.F90 @@ -42,7 +42,8 @@ subroutine flux_atmOcn_large( & ts, mask, seq_flux_atmocn_minwind, & sen, lat, lwup, evap, & taux, tauy, tref, qref, & - add_gusts, duu10n, ugust_out, u10res, & + add_gusts, aofluxes_use_shr_wv_sat, & + duu10n, ugust_out, u10res, & ustar_sv, re_sv, ssq_sv) !--- input arguments -------------------------------- @@ -51,6 +52,7 @@ subroutine flux_atmOcn_large( & integer ,intent(in) :: nMax ! data vector length integer ,intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain logical ,intent(in) :: add_gusts + logical ,intent(in) :: aofluxes_use_shr_wv_sat ! use shr_wv_sat_mod to calculate qsat for atm-ocn flux calculations 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) @@ -121,6 +123,8 @@ subroutine flux_atmOcn_large( & real(R8) :: cp ! specific heat of moist air real(R8) :: fac ! vertical interpolation factor real(R8) :: wind0 ! resolved large-scale 10m wind (no gust added) + real(r8) :: esat_val ! value of esat (saturation vapor pressure) at this point + real(r8) :: qsat_val ! value of qsat (saturation specific humidity) at this point !--- local functions -------------------------------- real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) @@ -143,6 +147,8 @@ subroutine flux_atmOcn_large( & real(R8) :: gprec ! convective rainfall argument for ugust ! ------------------------------------------------------------------------- + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + ! Large and Yeager 2009 cdn(Umps) = 0.0027_R8 / min(33.0000_R8,Umps) + 0.000142_R8 + & 0.0000764_R8 * min(33.0000_R8,Umps) - 3.14807e-13_r8 * min(33.0000_R8,Umps)**6 @@ -208,8 +214,15 @@ subroutine flux_atmOcn_large( & endif endif - call shr_wv_sat_qsat_liquid(ts(n), pslv(n), qsat, ssq) - ssq = 0.98_R8 * ssq ! sea surf hum (kg/kg) + if (aofluxes_use_shr_wv_sat) then + ! This version uses a qsat calculation method consistent with what's used in CAM + call shr_wv_sat_qsat_liquid(ts(n), pslv(n), esat_val, qsat_val) + ssq = 0.98_R8 * qsat_val ! sea surf hum (kg/kg) + else + ! This version uses the qsat calculation method that was used for many years, + ! prior to Aug 2025, and which is still being used by default in NorESM + ssq = 0.98_R8 * qsat(ts(n)) / rbot(n) ! sea surf hum (kg/kg) + end if delt = thbot(n) - ts(n) ! pot temp diff (K) delq = qbot(n) - ssq ! spec hum dif (kg/kg) alz = log(zbot(n)/zref) diff --git a/cesm/flux_atmocn/flux_atmocn_driver_mod.F90 b/cesm/flux_atmocn/flux_atmocn_driver_mod.F90 index 82a2b97d8..6bca47e05 100644 --- a/cesm/flux_atmocn/flux_atmocn_driver_mod.F90 +++ b/cesm/flux_atmocn/flux_atmocn_driver_mod.F90 @@ -25,7 +25,8 @@ subroutine flux_atmOcn_driver(logunit, nMax, & sen, lat, lwup, evap, & taux, tauy, tref, qref, & ocn_surface_flux_scheme, & - add_gusts, duu10n, ugust_out, u10res, & + add_gusts, aofluxes_use_shr_wv_sat, & + duu10n, ugust_out, u10res, & ustar_sv, re_sv, ssq_sv, missval) !--- input arguments -------------------------------- @@ -33,6 +34,7 @@ subroutine flux_atmOcn_driver(logunit, nMax, & integer , intent(in) :: nMax ! data vector length integer , intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain logical , intent(in) :: add_gusts + logical , intent(in) :: aofluxes_use_shr_wv_sat ! use shr_wv_sat_mod to calculate qsat for atm-ocn flux calculations 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) @@ -94,7 +96,8 @@ subroutine flux_atmOcn_driver(logunit, nMax, & ts, mask, seq_flux_atmocn_minwind, & sen, lat, lwup, evap, & taux, tauy, tref, qref, & - add_gusts, duu10n, ugust_out, u10res, & + add_gusts, aofluxes_use_shr_wv_sat, & + duu10n, ugust_out, u10res, & ustar_sv=ustar_sv, re_sv=re_sv, ssq_sv=ssq_sv) else if (ocn_surface_flux_scheme == ocn_flux_scheme_coare) then @@ -107,6 +110,7 @@ subroutine flux_atmOcn_driver(logunit, nMax, & ts, mask, seq_flux_atmocn_minwind, & sen, lat, lwup, evap, & taux, tauy, tref, qref, & + aofluxes_use_shr_wv_sat, & duu10n, ugust_out, u10res, & ustar_sv=ustar_sv, re_sv=re_sv, ssq_sv=ssq_sv) diff --git a/cesm/nuopc_cap_share/shr_lnd2rof_tracers_mod.F90 b/cesm/nuopc_cap_share/shr_lnd2rof_tracers_mod.F90 new file mode 100644 index 000000000..e673983b7 --- /dev/null +++ b/cesm/nuopc_cap_share/shr_lnd2rof_tracers_mod.F90 @@ -0,0 +1,94 @@ +module shr_lnd2rof_tracers_mod + + !======================================================================== + ! read lnd2rof_tracers_inparm namelist and sets up driver list of fields for + ! lnd -> river communications + !======================================================================== + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet, ESMF_VMBroadcast + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : shr_log_getLogUnit + use shr_kind_mod , only : r8 => shr_kind_r8, cs => shr_kind_cs + use shr_nl_mod , only : shr_nl_find_group_name + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS + public :: shr_lnd2rof_tracers_readnl ! Read namelist + + character(len=*), parameter :: & + u_FILE_u=__FILE__ + +!==================================================================================== +CONTAINS +!==================================================================================== + + subroutine shr_lnd2rof_tracers_readnl(NLFilename, lnd2rof_tracer_list) + + ! input/output variables + character(len=*), intent(in) :: NLFilename ! Namelist filename + character(len=*), intent(out) :: lnd2rof_tracer_list ! Colon delimited string of liquid lnd2rof tracers + + !----- local ----- + 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 + integer :: logunit + character(len=CS) :: lnd2rof_tracers + character(*),parameter :: subName = '(shr_lnd2rof_tracers_readnl) ' + ! ------------------------------------------------------------------ + + namelist /lnd2rof_tracers_inparm/ lnd2rof_tracers + + !----------------------------------------------------------------------------- + ! Read namelist and figure out the lnd2rof_tracers field list to pass + ! First check if file exists and if not, n_lnd2rof_tracers 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 shr_log_getLogUnit(logunit) + + lnd2rof_tracers = ' ' + lnd2rof_tracer_list = ' ' + + 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' ) + call shr_nl_find_group_name(unitn, 'lnd2rof_tracers_inparm', ierr) + if (ierr == 0) then + ! Note that if ierr /= 0, no namelist is present. + read(unitn, lnd2rof_tracers_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort(trim(subName) //'problem of read of lnd2rof_tracers_inparm ') + endif + endif + close( unitn ) + end if + end if + call ESMF_VMBroadcast(vm, lnd2rof_tracers, CS, 0, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (lnd2rof_tracers /= ' ') then + lnd2rof_tracer_list = trim(lnd2rof_tracers) + end if + + end subroutine shr_lnd2rof_tracers_readnl + +end module shr_lnd2rof_tracers_mod diff --git a/cesm/share_wrappers/wtracers_mod.F90 b/cesm/share_wrappers/wtracers_mod.F90 new file mode 100644 index 000000000..860640720 --- /dev/null +++ b/cesm/share_wrappers/wtracers_mod.F90 @@ -0,0 +1,18 @@ +module wtracers_mod + + !----------------------------------------------------------------------------- + ! This module wraps shr_wtracers_mod from the CESM_share repository to avoid direct + ! dependencies on this share code from CMEPS. + ! + ! See also the version of wtracers_mod in the ufs directory for when we do not have + ! access to the CESM_share library. + !----------------------------------------------------------------------------- + + use shr_wtracers_mod, only : wtracers_is_wtracer_field => shr_wtracers_is_wtracer_field + + implicit none + private + + public :: wtracers_is_wtracer_field ! return true if the given field name is a water tracer field + +end module wtracers_mod diff --git a/cime_config/buildexe b/cime_config/buildexe index 4923f016d..c8664d705 100755 --- a/cime_config/buildexe +++ b/cime_config/buildexe @@ -94,6 +94,7 @@ def _main_func(): if not skip_mediator: out.write(os.path.join(cmeps_dir, "mediator") + "\n") out.write(os.path.join(cmeps_dir, "cesm", "flux_atmocn") + "\n") + out.write(os.path.join(cmeps_dir, "cesm", "share_wrappers") + "\n") out.write(os.path.join(cmeps_dir, "cesm", "driver") + "\n") # build model executable diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index eb7b66902..429d42c08 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -938,11 +938,33 @@ MED_attributes atm/ocn flux calculation scheme + + 0: Large and Pond + 1: COARE algorithm + 2: UA algorithm 0 + + logical + control + MED_attributes + + If true, use shr_wv_sat_mod to calculate qsat for atm-ocn flux calculations. + + If false, use the older inline calculation of qsat, which uses a different + formulation. + + (Currently only relevant for ocn_surface_flux_scheme = 0 or 1.) + + + + .true. + + logical control @@ -1456,7 +1478,7 @@ Auxiliary mediator a2x dynamic, radiation, and precipitation fields 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 + 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_co2prog @@ -1521,7 +1543,7 @@ MED_attributes Auxiliary mediator a2x aerosol and ghg history output daily or endofrun - Faxa_bcph:Faxa_ocph:Faxa_dstwet:Faxa_dstdry:Sa_co2prog:Sa_co2diag + Faxa_bcph:Faxa_ocph:Faxa_dstwet:Faxa_dstdry:Faxa_ndep:Sa_co2diag @@ -1530,7 +1552,7 @@ MED_attributes history option type - nhours + ndays @@ -1539,7 +1561,7 @@ MED_attributes history option span - 3 + 1 @@ -1557,7 +1579,7 @@ MED_attributes Number of time samples per file. - 2 + 1 @@ -1796,7 +1818,7 @@ logical aux_hist ALLCOMP_attributes - Turns on history stream for annual lnd to mediator glc forcing fields + Auxiliary mediator lnd2med fields every year .false. @@ -2095,6 +2117,7 @@ ALLCOMP_attributes .false. + .true. Auxiliary mediator wav2med average history output every day. Note that ww3dev will use this configuration variable and send @@ -2106,6 +2129,7 @@ MED_attributes Sw_hs_avg:Sw_Tm1_avg:Sw_thm_avg:Sw_u_avg:Sw_v_avg:Sw_ustokes_avg:Sw_vstokes_avg:Sw_tusx_avg:Sw_tusy_avg:Sw_thp0_avg:Sw_fp0_avg:Sw_phs0_avg:Sw_phs1_avg:Sw_pdir0_avg:Sw_pdir1_avg:Sw_pTm10_avg:Sw_pTm11_avg + Sw_Hs:Sw_t01:Sw_t0m1:Sw_thm:Sw_lamult:Sw_ustokes:Sw_vstokes Auxiliary mediator wav2med file1 colon delimited output fields. NOTE: these are assumed to be time averaged over a day in @@ -2137,6 +2161,7 @@ MED_attributes .false. + .true. Auxiliary mediator wav2med file1 time averaged flag for file output. If this flag is set to .false. only instantaneous output will be created in the auxiliary file. @@ -2147,6 +2172,7 @@ MED_attributes wav.24h.avg + ww3 diff --git a/mediator/CMakeLists.txt b/mediator/CMakeLists.txt index 36d5db290..4b35db94b 100644 --- a/mediator/CMakeLists.txt +++ b/mediator/CMakeLists.txt @@ -1,6 +1,7 @@ project(cmeps Fortran) set(SRCFILES esmFldsExchange_cesm_mod.F90 med_fraction_mod.F90 + med_field_info_mod.F90 med_methods_mod.F90 med_phases_prep_ice_mod.F90 med_phases_restart_mod.F90 esmFldsExchange_hafs_mod.F90 med_internalstate_mod.F90 med_phases_aofluxes_mod.F90 diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index 5872b5b19..0a7132b4b 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -994,93 +994,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) 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_from(complnd , 'Sl_tref') - call addfld_from(compice , 'Si_tref') - call addfld_aoflux('So_tref') - call addfld_to(compatm , '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_from(complnd , 'Sl_tref', compatm, mapconsf, map_fracname_lnd2atm, lnd2atm_map) - call addmrg_to(compatm , 'Sx_tref', & - mrg_from=complnd, mrg_fld='Sl_tref', mrg_type='merge', mrg_fracname=mrg_fracname_lnd2atm_state) - end if - if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_tref', rc=rc)) then - call addmap_from(compice , 'Si_tref', compatm, mapconsf, 'ifrac', ice2atm_map) - call addmrg_to(compatm , '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_aoflux('So_tref', compatm, mapconsf, 'ofrac', ocn2atm_map) - end if - call addmrg_to(compatm , '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_from(complnd , 'Sl_u10') - call addfld_from(compice , 'Si_u10') - call addfld_aoflux('So_u10') - call addfld_to(compatm , '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_from(complnd , 'Sl_u10', compatm, mapconsf, map_fracname_lnd2atm, lnd2atm_map) - call addmrg_to(compatm , 'Sx_u10', & - mrg_from=complnd, mrg_fld='Sl_u10', mrg_type='merge', mrg_fracname=mrg_fracname_lnd2atm_state) - end if - if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_u10', rc=rc)) then - call addmap_from(compice , 'Si_u10', compatm, mapconsf, 'ifrac', ice2atm_map) - call addmrg_to(compatm , '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_aoflux('So_u10', compatm, mapconsf, 'ofrac', ocn2atm_map) - end if - call addmrg_to(compatm , '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_from(complnd , 'Sl_qref') - call addfld_from(compice , 'Si_qref') - call addfld_aoflux('So_qref') - call addfld_to(compatm , '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_from(complnd , 'Sl_qref', compatm, mapconsf, map_fracname_lnd2atm, lnd2atm_map) - call addmrg_to(compatm , 'Sx_qref', & - mrg_from=complnd, mrg_fld='Sl_qref', mrg_type='merge', mrg_fracname=mrg_fracname_lnd2atm_state) - end if - if (fldchk(is_local%wrap%FBImp(compice,compice ), 'Si_qref', rc=rc)) then - call addmap_from(compice , 'Si_qref', compatm, mapconsf, 'ifrac', ice2atm_map) - call addmrg_to(compatm , '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_aoflux('So_qref', compatm, mapconsf, 'ofrac', ocn2atm_map) - end if - call addmrg_to(compatm , 'Sx_qref', & - mrg_from=compmed, mrg_fld='So_qref', mrg_type='merge', mrg_fracname='ofrac') - end if - end if - end if - ! --------------------------------------------------------------------- ! to atm: merged zonal surface stress ! to atm: merged meridional surface stress @@ -2342,7 +2255,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(compocn, 'Sw_lamult', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') end if end if - if (ocn_name == 'mpaso') then + if (ocn_name == 'mpaso' .or. ocn_name == 'mom') then !----------------------------- ! to ocn: !----------------------------- @@ -2372,6 +2285,45 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) !----------------------------- ! to ocn: !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_t0m1') + call addfld_to(compocn, 'Sw_t0m1') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_t0m1', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_t0m1', rc=rc)) then + call addmap_from(compwav, 'Sw_t0m1', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_t0m1', mrg_from=compwav, mrg_fld='Sw_t0m1', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_t01') + call addfld_to(compocn, 'Sw_t01') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_t01', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_t01', rc=rc)) then + call addmap_from(compwav, 'Sw_t01', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_t01', mrg_from=compwav, mrg_fld='Sw_t01', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_thm') + call addfld_to(compocn, 'Sw_thm') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_thm', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_thm', rc=rc)) then + call addmap_from(compwav, 'Sw_thm', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_thm', mrg_from=compwav, mrg_fld='Sw_thm', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_1') call addfld_to(compocn, 'Sw_ustokes_wavenumber_1') diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index 96489eca2..7d1c46a15 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -1104,6 +1104,18 @@ canonical_units: m description: ocean import - Significant wave height # + - standard_name: Sw_t0m1 + canonical_units: s + description: Wind sea mean wave period (Tm0,-1) + # + - standard_name: Sw_t01 + canonical_units: s + description: Wind sea mean wave period (Tm0,1) + # + - standard_name: Sw_thm + canonical_units: radians + description: Mean wave direction + # - standard_name: Sw_Fp canonical_units: 1 description: ocean import - Peak wave frequency diff --git a/mediator/med.F90 b/mediator/med.F90 index 2e59cf8a9..9c45172b4 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -37,6 +37,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_field_info_mod , only : med_field_info_type + use med_field_info_mod , only : med_field_info_array_from_names_wtracers, med_field_info_array_from_state use med_utils_mod , only : memcheck => med_memcheck use med_internalstate_mod , only : InternalState, med_internalstate_init, med_internalstate_coupling use med_internalstate_mod , only : med_internalstate_defaultmasks, logunit, maintask @@ -54,6 +56,7 @@ module MED use shr_log_mod , only : shr_log_error use med_ufs_trace_wrapper_mod, only : ufs_trace_init_wrapper, ufs_trace_wrapper, ufs_trace_finalize_wrapper + implicit none private @@ -1660,6 +1663,7 @@ subroutine DataInitialize(gcomp, rc) ! local variables type(InternalState) :: is_local + type(med_field_info_type), allocatable :: field_info_array(:) type(ESMF_Clock) :: clock type(ESMF_State) :: importState, exportState type(ESMF_Time) :: time @@ -1774,19 +1778,25 @@ subroutine DataInitialize(gcomp, rc) trim(compname(n1))//'_'//trim(compname(n2)) end if + call med_field_info_array_from_state( & + state = is_local%wrap%NStateImp(n1), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Check import FB, if there is no field in it then use export FB ! 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 call FB_init(is_local%wrap%FBImp(n1,n2), is_local%wrap%flds_scalar_name, & + field_info_array=field_info_array, & STgeom=is_local%wrap%NStateExp(n2), & - STflds=is_local%wrap%NStateImp(n1), & name='FBImp'//trim(compname(n1))//'_'//trim(compname(n2)), rc=rc) else call FB_init(is_local%wrap%FBImp(n1,n2), is_local%wrap%flds_scalar_name, & + field_info_array=field_info_array, & STgeom=is_local%wrap%NStateImp(n2), & - STflds=is_local%wrap%NStateImp(n1), & name='FBImp'//trim(compname(n1))//'_'//trim(compname(n2)), rc=rc) end if if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1814,14 +1824,19 @@ subroutine DataInitialize(gcomp, rc) allocate(fldnames(fieldCount)) call med_fldList_getfldnames(fldListMed_ocnalb%fields, fldnames, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_field_info_array_from_names_wtracers( & + field_names = fldnames, & + field_info_array = field_info_array, & + 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) + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(compatm), name='FBMed_ocnalb_a', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (maintask) 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) + field_info_array = field_info_array, STgeom=is_local%wrap%NStateImp(compocn), name='FBMed_ocnalb_o', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (maintask) then write(logunit,'(a)') trim(subname)//' initializing FB FBMed_ocnalb_o' diff --git a/mediator/med_field_info_mod.F90 b/mediator/med_field_info_mod.F90 new file mode 100644 index 000000000..9f04ccb0f --- /dev/null +++ b/mediator/med_field_info_mod.F90 @@ -0,0 +1,293 @@ +module med_field_info_mod + + !----------------------------------------------------------------------------- + ! Defines a type and related operations for storing metadata about fields that can be + ! used to create an ESMF FieldBundle. + !----------------------------------------------------------------------------- + + use ESMF , only : ESMF_MAXSTR, ESMF_SUCCESS, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_Field, ESMF_State, ESMF_StateGet + use ESMF , only : ESMF_Mesh, ESMF_MeshLoc + use ESMF , only : ESMF_FieldCreate, ESMF_FieldGet + use med_utils_mod , only : ChkErr => med_utils_ChkErr + use shr_log_mod , only : shr_log_error + use wtracers_mod , only : wtracers_is_wtracer_field + + implicit none + private + + !----------------------------------------------- + ! Public methods + !----------------------------------------------- + + ! Create a single field_info object from direct specification of values + public :: med_field_info_create_directly + + ! Create a single field_info object from information in an ESMF_Field + public :: med_field_info_create_from_field + + ! Create an array of field_info objects based on an array of names, where water tracers + ! are treated specially (being given an ungridded dimension) + public :: med_field_info_array_from_names_wtracers + + ! Create an array of field_info objects based on the fields in an ESMF State + public :: med_field_info_array_from_state + + ! Create an ESMF Field (using ESMF_FieldCreate) based on a field_info object + public :: med_field_info_esmf_fieldcreate + + !----------------------------------------------- + ! Types + !----------------------------------------------- + + type, public :: med_field_info_type + character(ESMF_MAXSTR) :: name + integer :: n_ungridded ! number of ungridded dimensions + + ! These arrays will be allocated to be of size ungridded_count + integer, allocatable :: ungridded_lbound(:) + integer, allocatable :: ungridded_ubound(:) + end type med_field_info_type + + character(len=*),parameter :: u_FILE_u = & + __FILE__ + +!================================================================================ +contains +!================================================================================ + + function med_field_info_create_directly(name, ungridded_lbound, ungridded_ubound, rc) result(field_info) + ! Create a single field_info object from direct specification of values + + ! input/output variables + character(len=*), intent(in) :: name + + ! ungridded_lbound and ungridded_ubound must either both be present or both be absent; + ! if present, they must be the same size + integer, intent(in), optional :: ungridded_lbound(:) + integer, intent(in), optional :: ungridded_ubound(:) + + integer, intent(out) :: rc + type(med_field_info_type) :: field_info ! function result + + ! local variables + integer :: n_ungridded + character(len=*), parameter :: subname = '(med_field_info_create_directly)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + if (present(ungridded_lbound) .neqv. present(ungridded_ubound)) then + call shr_log_error( & + subname//": ERROR: ungridded_lbound and ungridded_ubound must both be present or both absent.", & + line=__LINE__, file=u_FILE_u, rc=rc) + return + end if + + field_info%name = name + + if (present(ungridded_lbound)) then + n_ungridded = size(ungridded_lbound) + if (size(ungridded_ubound) /= n_ungridded) then + call shr_log_error( & + subname//": ERROR: ungridded_lbound and ungridded_ubound must have the same size.", & + line=__LINE__, file=u_FILE_u, rc=rc) + return + end if + field_info%n_ungridded = n_ungridded + allocate(field_info%ungridded_lbound(n_ungridded)) + allocate(field_info%ungridded_ubound(n_ungridded)) + field_info%ungridded_lbound = ungridded_lbound + field_info%ungridded_ubound = ungridded_ubound + else + field_info%n_ungridded = 0 + end if + + end function med_field_info_create_directly + + !----------------------------------------------------------------------------- + + function med_field_info_create_from_field(field, name, rc) result(field_info) + ! Create a single field_info object from information in an ESMF_Field + + ! input/output variables + ! We get information other than the name from this ESMF_Field object + type(ESMF_Field), intent(in) :: field + + ! We should be able to get the name from the field, but in all current uses of this + ! function, we already have the name available, so it's easy enough to just pass it in + ! rather than making this function query it again. If future users did not already + ! have the name readily available, we could either change this to optional or remove + ! it entirely and just always get the name from querying the field. + character(len=*), intent(in) :: name + + integer, intent(out) :: rc + type(med_field_info_type) :: field_info ! function result + + ! local variables + integer :: n_ungridded + integer, allocatable :: ungridded_lbound(:) + integer, allocatable :: ungridded_ubound(:) + + character(len=*), parameter :: subname = '(med_field_info_create_from_field)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_FieldGet(field, ungriddedDimCount=n_ungridded, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (n_ungridded == 0) then + field_info = med_field_info_create_directly( & + name=name, & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + allocate(ungridded_lbound(n_ungridded)) + allocate(ungridded_ubound(n_ungridded)) + call ESMF_FieldGet(field, & + ungriddedLBound=ungridded_lbound, ungriddedUBound=ungridded_ubound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + field_info = med_field_info_create_directly( & + name=name, & + ungridded_lbound=ungridded_lbound, & + ungridded_ubound=ungridded_ubound, & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + deallocate(ungridded_lbound) + deallocate(ungridded_ubound) + end if + end function med_field_info_create_from_field + + !----------------------------------------------------------------------------- + + subroutine med_field_info_array_from_names_wtracers(field_names, field_info_array, rc) + ! Create an array of field_info objects based on an array of names, where water + ! tracers are treated specially (being given an ungridded dimension). + ! + ! It is assumed that fields generally have no ungridded dimensions. However, for + ! fields ending with the water tracer suffix, it is instead assumed that they have a + ! single ungridded dimension of size given by shr_wtracers_get_num_tracers. + ! + ! field_info_array is allocated here (and, since it has intent(out), it is + ! automatically deallocated if it is already allocated on entry to this subroutine) + + ! input/output variables + character(len=*), intent(in) :: field_names(:) + type(med_field_info_type), allocatable, intent(out) :: field_info_array(:) + integer, intent(out) :: rc + + ! local variables + integer :: i, n_fields + logical :: is_tracer + integer :: n_tracers + character(len=*), parameter :: subname = '(med_field_info_array_from_names_wtracers)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + n_fields = size(field_names) + allocate(field_info_array(n_fields)) + ! For now, hard-code n_tracers, since we haven't set up the tracer information; we'll + ! fix this in an upcoming set of changes + n_tracers = 0 + + do i = 1, n_fields + is_tracer = wtracers_is_wtracer_field(field_names(i)) + if (is_tracer) then + ! Field is a water tracer; assume a single ungridded dimension + field_info_array(i) = med_field_info_create_directly( & + name=field_names(i), & + ungridded_lbound=[1], & + ungridded_ubound=[n_tracers], & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + ! Not a water tracer; assume no ungridded dimensions + field_info_array(i) = med_field_info_create_directly( & + name=field_names(i), & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + end do + + end subroutine med_field_info_array_from_names_wtracers + + !----------------------------------------------------------------------------- + + subroutine med_field_info_array_from_state(state, field_info_array, rc) + ! Create an array of field_info objects based on the Fields in an ESMF State + ! + ! field_info_array is allocated here (and, since it has intent(out), it is + ! automatically deallocated if it is already allocated on entry to this subroutine) + + ! input/output variables + type(ESMF_State), intent(in) :: state + type(med_field_info_type), allocatable, intent(out) :: field_info_array(:) + integer, intent(out) :: rc + + ! local variables + integer :: i, n_fields + character(ESMF_MAXSTR), allocatable :: field_names(:) + type(ESMF_Field) :: field + character(len=*), parameter :: subname = '(med_field_info_array_from_state)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(state, itemCount=n_fields, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(field_names(n_fields)) + allocate(field_info_array(n_fields)) + call ESMF_StateGet(state, itemNameList=field_names, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do i = 1, n_fields + call ESMF_StateGet(state, itemName=trim(field_names(i)), field=field, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + field_info_array(i) = med_field_info_create_from_field( & + field=field, & + name=field_names(i), & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + + end subroutine med_field_info_array_from_state + + !----------------------------------------------------------------------------- + + subroutine med_field_info_esmf_fieldcreate(field_info, mesh, meshloc, field, rc) + ! Create an ESMF Field (using ESMF_FieldCreate) based on a field_info object + + ! input/output variables + type(med_field_info_type), intent(in) :: field_info + type(ESMF_Mesh), intent(in) :: mesh + type(ESMF_MeshLoc), intent(in) :: meshloc + type(ESMF_Field), intent(out) :: field + integer, intent(out) :: rc + + ! local variables + character(len=*), parameter :: subname = '(med_field_info_esmf_fieldcreate)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + if (field_info%n_ungridded > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, meshloc=meshloc, & + name=field_info%name, & + ungriddedLbound=field_info%ungridded_lbound, & + ungriddedUbound=field_info%ungridded_ubound, & + gridToFieldMap=[field_info%n_ungridded+1], & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, meshloc=meshloc, & + name=field_info%name, & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + end subroutine med_field_info_esmf_fieldcreate + +end module med_field_info_mod diff --git a/mediator/med_fraction_mod.F90 b/mediator/med_fraction_mod.F90 index 7f9cfb8ba..9d58a43d1 100644 --- a/mediator/med_fraction_mod.F90 +++ b/mediator/med_fraction_mod.F90 @@ -135,6 +135,8 @@ module med_fraction_mod 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, samegrid_atmlnd + use med_field_info_mod , only : med_field_info_type + use med_field_info_mod , only : med_field_info_array_from_names_wtracers, med_field_info_array_from_state implicit none private @@ -189,6 +191,7 @@ subroutine med_fraction_init(gcomp, rc) type(InternalState) :: is_local type(ESMF_Field) :: field_src type(ESMF_Field) :: field_dst + type(med_field_info_type), allocatable :: field_info_array(:) real(R8), pointer :: frac(:) real(R8), pointer :: ofrac(:) real(R8), pointer :: aofrac(:) @@ -255,13 +258,18 @@ subroutine med_fraction_init(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! create FBFrac + call med_field_info_array_from_names_wtracers( & + field_names = fraclist(:,n1), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (fieldCount == 0) then call fldbun_init(is_local%wrap%FBfrac(n1), is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateExp(n1), fieldNameList=fraclist(:,n1), & + field_info_array=field_info_array, STgeom=is_local%wrap%NStateExp(n1), & name='FBfrac'//trim(compname(n1)), rc=rc) else call fldbun_init(is_local%wrap%FBfrac(n1), is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateImp(n1), fieldNameList=fraclist(:,n1), & + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(n1), & name='FBfrac'//trim(compname(n1)), rc=rc) end if if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -673,9 +681,14 @@ subroutine med_fraction_init(gcomp, rc) if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compocn)) then if (.not. med_map_RH_is_created(is_local%wrap%RH(compice,compocn,:),mapfcopy, rc=rc)) then if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compice,compocn))) then + call med_field_info_array_from_state( & + state = is_local%wrap%NStateImp(compice), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call fldbun_init(is_local%wrap%FBImp(compice,compocn), is_local%wrap%flds_scalar_name, & + field_info_array=field_info_array, & STgeom=is_local%wrap%NStateImp(compocn), & - STflds=is_local%wrap%NStateImp(compice), & name='FBImp'//trim(compname(compice))//'_'//trim(compname(compocn)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -687,9 +700,14 @@ subroutine med_fraction_init(gcomp, rc) end if if (.not. med_map_RH_is_created(is_local%wrap%RH(compocn,compice,:),mapfcopy, rc=rc)) then if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compocn,compice))) then + call med_field_info_array_from_state( & + state = is_local%wrap%NStateImp(compocn), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call fldbun_init(is_local%wrap%FBImp(compocn,compice), is_local%wrap%flds_scalar_name, & + field_info_array = field_info_array, & STgeom=is_local%wrap%NStateImp(compice), & - STflds=is_local%wrap%NStateImp(compocn), & name='FBImp'//trim(compname(compocn))//'_'//trim(compname(compice)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index ac059bc7c..b577b9578 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -15,6 +15,7 @@ module med_methods_mod use med_constants_mod , only : czero => med_constants_czero use med_constants_mod , only : spval_init => med_constants_spval_init use med_utils_mod , only : ChkErr => med_utils_ChkErr + use med_field_info_mod , only : med_field_info_type, med_field_info_esmf_fieldcreate use shr_log_mod , only : shr_log_error implicit none private @@ -223,42 +224,37 @@ end subroutine med_methods_FB_init_pointer !----------------------------------------------------------------------------- - subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, STgeom, FBflds, STflds, name, rc) + subroutine med_methods_FB_init(FBout, flds_scalar_name, field_info_array, FBgeom, STgeom, name, rc) ! ---------------------------------------------- - ! Create FBout from fieldNameList, FBflds, STflds, FBgeom or STgeom in that order or priority - ! Pass in FBgeom OR STgeom, get mesh from that object + ! Create FBout from field_info_array (see med_field_info_mod for some convenience + ! functions for creating a field_info array from field names or an ESMF State) + ! + ! Mesh is retrieved from either FBgeom or STgeom (one of those must be present, but + ! not both) ! ---------------------------------------------- use ESMF , only : ESMF_Field, ESMF_FieldBundle, ESMF_FieldBundleCreate, ESMF_FieldBundleGet use ESMF , only : ESMF_State, ESMF_Mesh, ESMF_StaggerLoc, ESMF_MeshLoc use ESMF , only : ESMF_StateGet, ESMF_FieldGet, ESMF_FieldBundleAdd, ESMF_FieldCreate - use ESMF , only : ESMF_TYPEKIND_R8, ESMF_FIELDSTATUS_EMPTY, ESMF_AttributeGet + use ESMF , only : ESMF_FIELDSTATUS_EMPTY, ESMF_AttributeGet ! input/output variables type(ESMF_FieldBundle), intent(inout) :: FBout ! output field bundle character(len=*) , intent(in) :: flds_scalar_name ! name of scalar fields - character(len=*) , intent(in), optional :: fieldNameList(:) ! names of fields to use in output field bundle + type(med_field_info_type), intent(in) :: field_info_array(:) ! info on the fields to put in the output FieldBundle type(ESMF_FieldBundle), intent(in), optional :: FBgeom ! input field bundle geometry to use type(ESMF_State) , intent(in), optional :: STgeom ! input state geometry to use - type(ESMF_FieldBundle), intent(in), optional :: FBflds ! input field bundle fields - type(ESMF_State) , intent(in), optional :: STflds ! input state fields character(len=*) , intent(in), optional :: name ! name to use for output field bundle integer , intent(out) :: rc ! local variables - integer :: n,n1 + integer :: n integer :: fieldCount,fieldCountgeom character(ESMF_MAXSTR) :: lname type(ESMF_Field) :: field,lfield type(ESMF_Mesh) :: lmesh type(ESMF_MeshLoc) :: meshloc - integer :: ungriddedCount - integer :: ungriddedCount_in - integer, allocatable :: ungriddedLBound(:) - integer, allocatable :: ungriddedUBound(:) - logical :: isPresent - character(ESMF_MAXSTR), allocatable :: lfieldNameList(:) character(len=*), parameter :: subname='(med_methods_FB_init)' ! ---------------------------------------------- @@ -278,11 +274,6 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S ! verify that geom argument has a field !--------------------------------- - if (present(fieldNameList) .and. present(FBflds) .and. present(STflds)) then - call shr_log_error(trim(subname)//": ERROR only fieldNameList, FBflds, or STflds can be an argument", rc=rc) - return - endif - if (present(FBgeom) .and. present(STgeom)) then call shr_log_error(trim(subname)//": ERROR FBgeom and STgeom cannot both be arguments", rc=rc) return @@ -305,70 +296,12 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S endif !--------------------------------- - ! determine the names of fields that will be in FBout - !--------------------------------- - - if (present(fieldNameList)) then - fieldcount = size(fieldNameList) - allocate(lfieldNameList(fieldcount)) - lfieldNameList = fieldNameList - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" fieldNameList from argument", ESMF_LOGMSG_INFO) - end if - elseif (present(FBflds)) then - call ESMF_FieldBundleGet(FBflds, fieldCount=fieldCount, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(lfieldNameList(fieldCount)) - call ESMF_FieldBundleGet(FBflds, fieldNameList=lfieldNameList, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" fieldNameList from FBflds", ESMF_LOGMSG_INFO) - end if - elseif (present(STflds)) then - call ESMF_StateGet(STflds, itemCount=fieldCount, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(lfieldNameList(fieldCount)) - call ESMF_StateGet(STflds, itemNameList=lfieldNameList, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" fieldNameList from STflds", ESMF_LOGMSG_INFO) - end if - elseif (present(FBgeom)) then - call ESMF_FieldBundleGet(FBgeom, fieldCount=fieldCount, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(lfieldNameList(fieldCount)) - call ESMF_FieldBundleGet(FBgeom, fieldNameList=lfieldNameList, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" fieldNameList from FBgeom", ESMF_LOGMSG_INFO) - end if - elseif (present(STgeom)) then - call ESMF_StateGet(STgeom, itemCount=fieldCount, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - allocate(lfieldNameList(fieldCount)) - call ESMF_StateGet(STgeom, itemNameList=lfieldNameList, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 5) then - call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" fieldNameList from STgeom", ESMF_LOGMSG_INFO) - end if - else - call shr_log_error(trim(subname)//": ERROR fieldNameList, FBflds, STflds, FBgeom, or STgeom must be passed", rc=rc) - return - endif - - !--------------------------------- - ! remove scalar field and blank fields from field bundle + ! Determine number of fields + ! + ! Note that scalars and blank fields will be removed later !--------------------------------- - do n = 1, fieldCount - if (trim(lfieldnamelist(n)) == trim(flds_scalar_name) .or. & - trim(lfieldnamelist(n)) == '') then - do n1 = n, fieldCount-1 - lfieldnamelist(n1) = lfieldnamelist(n1+1) - enddo - fieldCount = fieldCount - 1 - endif - enddo ! n + fieldCount = size(field_info_array) !--------------------------------- ! create the mesh(lmesh) that will be used for FBout fields @@ -426,61 +359,19 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S ! Now loop over all the fields in the field name list do n = 1, fieldCount - ! Note that input fields come from ONE of FBFlds, STflds, or fieldNamelist input argument - if (present(FBFlds) .or. present(STflds)) then - - ! ungridded dimensions might be present in the input states or field bundles - if (present(FBflds)) then - call ESMF_FieldBundleGet(FBflds, fieldName=lfieldnamelist(n), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - elseif (present(STflds)) then - call ESMF_StateGet(STflds, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end if - - ! Determine ungridded lower and upper bounds for lfield - call ESMF_AttributeGet(lfield, name="UngriddedUBound", convention="NUOPC", & - purpose="Instance", itemCount=ungriddedCount_in, isPresent=isPresent, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent) then - ungriddedCount = ungriddedCount_in - else - ungriddedCount=0 ! initialize in case it was not set - end if - - ! Create the field on a lmesh - if (ungriddedCount > 0) then - ! ungridded dimensions in field - 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 - - field = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, meshloc=meshloc, name=lfieldNameList(n), & - ungriddedLbound=ungriddedLbound, ungriddedUbound=ungriddedUbound, gridToFieldMap=(/2/)) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - deallocate( ungriddedLbound, ungriddedUbound) - else - ! No ungridded dimensions in field - field = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, meshloc=meshloc, name=lfieldNameList(n), rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end if - - else if (present(fieldNameList)) then - - ! Assume no ungridded dimensions if just the field name list is give - field = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, meshloc=meshloc, name=lfieldNameList(n), rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - + ! Don't add scalar field or blank fields to field bundle + if (field_info_array(n)%name == flds_scalar_name .or. & + len_trim(field_info_array(n)%name) == 0) then + cycle end if - ! Add the created field bundle FBout + ! Create the field + call med_field_info_esmf_fieldcreate(field_info_array(n), lmesh, meshloc, field, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Add the created field to field bundle FBout if (dbug_flag > 1) then - call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" adding field "//trim(lfieldNameList(n)), & + call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" adding field "//trim(field_info_array(n)%name), & ESMF_LOGMSG_INFO) end if call ESMF_FieldBundleAdd(FBout, (/field/), rc=rc) @@ -489,8 +380,6 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S enddo ! fieldCount endif ! fieldcountgeom - deallocate(lfieldNameList) - call med_methods_FB_reset(FBout, value=spval_init, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -819,7 +708,8 @@ end subroutine med_methods_State_reset subroutine med_methods_FB_average(FB, count, rc) ! ---------------------------------------------- - ! Set all fields to zero in FB + ! Divide all fields in FB by count + ! If count is 0, nothing is done ! ---------------------------------------------- use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field @@ -1339,7 +1229,9 @@ subroutine med_methods_FB_accum(FBout, FBin, copy, rc) ! ---------------------------------------------- ! Accumulate common field names from FBin to FBout - ! If copy is passed in and true, the this is a copy + ! + ! If copy is passed in and true, then data is copied from FBin to FBout, overwriting + ! values in FBout, rather than accumulating ! ---------------------------------------------- use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index 626f4b129..00a590c8a 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -31,6 +31,8 @@ module med_phases_aofluxes_mod 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_field_info_mod , only : med_field_info_type + use med_field_info_mod , only : med_field_info_array_from_names_wtracers, med_field_info_array_from_state use perf_mod , only : t_startf, t_stopf #ifndef CESMCOUPLED use ufs_const_mod , only : rearth => SHR_CONST_REARTH @@ -78,6 +80,7 @@ module med_phases_aofluxes_mod logical :: compute_atm_thbot integer :: ocn_surface_flux_scheme ! use case logical :: add_gusts + logical :: aofluxes_use_shr_wv_sat ! use shr_wv_sat_mod to calculate qsat for atm-ocn flux calculations character(len=CS), pointer :: fldnames_ocn_in(:) character(len=CS), pointer :: fldnames_atm_in(:) @@ -173,6 +176,7 @@ subroutine med_phases_aofluxes_init_fldbuns(gcomp, rc) integer :: fieldcount type(med_fldList_type), pointer :: fldListMed_aoflux type(InternalState) :: is_local + type(med_field_info_type), allocatable :: field_info_array(:) character(len=*),parameter :: subname=' (med_phases_aofluxes_init_fldbuns) ' !--------------------------------------- @@ -190,9 +194,16 @@ subroutine med_phases_aofluxes_init_fldbuns(gcomp, rc) call med_fldList_getfldnames(fldListMed_aoflux%fields, fldnames_aof_out, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Create field_info_array for FBMed_aoflux_a and FBMed_aoflux_o + call med_field_info_array_from_names_wtracers( & + field_names = fldnames_aof_out, & + field_info_array = field_info_array, & + 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) + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(compatm), name='FBMed_aoflux_a', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (maintask) then write(logunit,*) @@ -201,7 +212,7 @@ subroutine med_phases_aofluxes_init_fldbuns(gcomp, rc) ! 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) + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(compocn), name='FBMed_aoflux_o', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (maintask) then write(logunit,'(a)') trim(subname)//' initialized FB FBMed_aoflux_o' @@ -219,8 +230,13 @@ subroutine med_phases_aofluxes_init_fldbuns(gcomp, rc) if (maintask) then write(logunit,'(a)') trim(subname)//' creating field bundle FBImp(compatm,compocn)' end if + call med_field_info_array_from_state( & + state = is_local%wrap%NStateImp(compatm), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return 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), & + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(compocn), & name='FBImp'//trim(compname(compatm))//'_'//trim(compname(compocn)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -234,8 +250,13 @@ subroutine med_phases_aofluxes_init_fldbuns(gcomp, rc) if (maintask) then write(logunit,'(a)') trim(subname)//' creating field bundle FBImp(compocn,compatm)' end if + call med_field_info_array_from_state( & + state = is_local%wrap%NStateImp(compocn), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return 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), & + field_info_array = field_info_array, STgeom=is_local%wrap%NStateImp(compatm), & name='FBImp'//trim(compname(compocn))//'_'//trim(compname(compatm)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -399,6 +420,20 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) add_gusts = .false. end if + call NUOPC_CompAttributeGet(gcomp, name='aofluxes_use_shr_wv_sat', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) aofluxes_use_shr_wv_sat + else + aofluxes_use_shr_wv_sat = .false. + end if +#ifdef CESMCOUPLED + if (maintask) then + write(logunit,*) + write(logunit,'(a,l7)') trim(subname)//' aofluxes_use_shr_wv_sat = ', aofluxes_use_shr_wv_sat + end if +#endif + ! 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 @@ -606,6 +641,7 @@ subroutine med_aofluxes_init_agrid(gcomp, aoflux_in, aoflux_out, rc) integer :: maptype type(ESMF_Field) :: lfield type(ESMF_Mesh) :: lmesh + type(med_field_info_type), allocatable :: field_info_array(:) real(R8), pointer :: garea(:) => null() type(ESMF_CoordSys_Flag) :: coordSys character(len=*),parameter :: subname=' (med_aofluxes_init_atmgrid) ' @@ -623,8 +659,13 @@ subroutine med_aofluxes_init_agrid(gcomp, aoflux_in, aoflux_out, rc) allocate(fldnames_ocn_in(4)) fldnames_ocn_in = (/'So_omask','So_t ','So_u ','So_v '/) + call med_field_info_array_from_names_wtracers( & + field_names = fldnames_ocn_in, & + field_info_array = field_info_array, & + rc = rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return 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) + field_info_array=field_info_array, FBgeom=is_local%wrap%FBImp(compatm,compatm), name='FBocn_a', rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call set_aoflux_in_pointers(is_local%wrap%FBImp(compatm,compatm), FBocn_a, aoflux_in, lsize, rc=rc) @@ -1056,7 +1097,8 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) 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, & ocn_surface_flux_scheme=ocn_surface_flux_scheme, & - add_gusts=add_gusts, duu10n=aoflux_out%duu10n, ugust_out = aoflux_out%ugust_out, u10res = aoflux_out%u10res, & + add_gusts=add_gusts, aofluxes_use_shr_wv_sat=aofluxes_use_shr_wv_sat, & + duu10n=aoflux_out%duu10n, ugust_out = aoflux_out%ugust_out, u10res = aoflux_out%u10res, & ustar_sv=aoflux_out%ustar, re_sv=aoflux_out%re, ssq_sv=aoflux_out%ssq, missval=0.0_r8) #else diff --git a/mediator/med_phases_cdeps_mod.F90 b/mediator/med_phases_cdeps_mod.F90 index 4f37b6f79..9fe869bb2 100644 --- a/mediator/med_phases_cdeps_mod.F90 +++ b/mediator/med_phases_cdeps_mod.F90 @@ -20,7 +20,6 @@ module med_phases_cdeps_mod use med_methods_mod , only: FB_FldChk => med_methods_FB_FldChk use med_methods_mod , only: FB_getFieldN => med_methods_FB_getFieldN use med_methods_mod , only: FB_getNumflds => med_methods_FB_getNumflds - use med_methods_mod , only: FB_init => med_methods_FB_Init use med_methods_mod , only: FB_diagnose => med_methods_FB_diagnose use med_methods_mod , only: FB_write => med_methods_FB_write use med_methods_mod , only: FB_GetFldPtr => med_methods_FB_GetFldPtr diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 2cb31f907..67883d9c1 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -21,6 +21,7 @@ module med_phases_history_mod use med_internalstate_mod , only : ncomps, compname use med_internalstate_mod , only : InternalState, maintask, logunit use med_io_mod , only : med_io_write, med_io_wopen, med_io_enddef, med_io_close + use med_field_info_mod , only : med_field_info_type, med_field_info_array_from_state use perf_mod , only : t_startf, t_stopf use pio , only : file_desc_t use shr_log_mod , only : shr_log_error @@ -853,6 +854,7 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) ! local variables type(InternalState) :: is_local + type(med_field_info_type), allocatable :: field_info_array(:) 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 @@ -917,8 +919,13 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) 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_field_info_array_from_state( & + state = is_local%wrap%NStateImp(compid), & + field_info_array = field_info_array, & + rc = rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call med_methods_FB_init(avgfile%FBaccum_import, scalar_name, & - STgeom=is_local%wrap%NStateImp(compid), STflds=is_local%wrap%NStateImp(compid), rc=rc) + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(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 @@ -926,8 +933,13 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) end if if ( ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid)) .and. .not. & ESMF_FieldBundleIsCreated(avgfile%FBaccum_export)) then + call med_field_info_array_from_state( & + state = is_local%wrap%NStateExp(compid), & + field_info_array = field_info_array, & + rc = rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call med_methods_FB_init(avgfile%FBaccum_export, scalar_name, & - STgeom=is_local%wrap%NStateExp(compid), STflds=is_local%wrap%NStateExp(compid), rc=rc) + field_info_array=field_info_array, STgeom=is_local%wrap%NStateExp(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 @@ -1060,6 +1072,7 @@ subroutine med_phases_history_write_comp_aux(gcomp, compid, auxcomp, rc) ! local variables type(InternalState) :: is_local + type(med_field_info_type), allocatable :: field_info_array(:) type(ESMF_VM) :: vm type(ESMF_Calendar) :: calendar ! calendar type logical :: isPresent ! is attribute present @@ -1189,8 +1202,13 @@ subroutine med_phases_history_write_comp_aux(gcomp, compid, auxcomp, rc) 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_field_info_array_from_state( & + state = is_local%wrap%NStateImp(compid), & + field_info_array = field_info_array, & + rc = rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call med_methods_FB_init(auxcomp%files(nfcnt)%FBaccum, is_local%wrap%flds_scalar_name, & - STgeom=is_local%wrap%NStateImp(compid), STflds=is_local%wrap%NStateImp(compid), & + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(compid), & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call med_methods_FB_reset(auxcomp%files(nfcnt)%FBaccum, czero, rc=rc) diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index e0e29089a..e218db9d9 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -38,6 +38,7 @@ module med_phases_prep_glc_mod use med_methods_mod , only : field_getdata2d => med_methods_Field_getdata2d use med_methods_mod , only : field_getdata1d => med_methods_Field_getdata1d use med_methods_mod , only : fldchk => med_methods_FB_FldChk + use med_field_info_mod , only : med_field_info_type, med_field_info_array_from_state use med_utils_mod , only : chkerr => med_utils_ChkErr use nuopc_shr_methods , only : alarmInit use glc_elevclass_mod , only : glc_get_num_elevation_classes @@ -131,6 +132,7 @@ subroutine med_phases_prep_glc_init(gcomp, rc) ! local variables type(InternalState) :: is_local + type(med_field_info_type), allocatable :: field_info_array(:) integer :: n,ns,nf type(ESMF_Mesh) :: mesh_l type(ESMF_Mesh) :: mesh_o @@ -286,9 +288,13 @@ 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 med_field_info_array_from_state( & + state = is_local%wrap%NStateImp(compglc(ns)), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return 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)), & + field_info_array=field_info_array, STgeom=is_local%wrap%NStateImp(complnd), & name='FBImp'//trim(compname(compglc(ns)))//'_'//trim(compname(complnd)), rc=rc) end if call med_map_routehandles_init( compglc(ns), complnd, & diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90 index ebb6e99a9..b3dce6b9b 100644 --- a/mediator/med_phases_prep_ocn_mod.F90 +++ b/mediator/med_phases_prep_ocn_mod.F90 @@ -20,6 +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 med_methods_mod , only : FB_check_for_nans => med_methods_FB_check_for_nans + use med_field_info_mod , only : med_field_info_type, med_field_info_array_from_state use esmFlds , only : med_fldList_GetfldListTo, med_fldlist_type use med_internalstate_mod , only : compocn, compatm, compice, coupling_mode use perf_mod , only : t_startf, t_stopf @@ -52,6 +53,7 @@ subroutine med_phases_prep_ocn_init(gcomp, rc) ! local variables type(InternalState) :: is_local + type(med_field_info_type), allocatable :: field_info_array(:) character(len=*),parameter :: subname=' (med_phases_prep_ocn_init) ' !--------------------------------------- @@ -65,8 +67,13 @@ subroutine med_phases_prep_ocn_init(gcomp, rc) if (maintask) then write(logunit,'(a)') trim(subname)//' initializing ocean export accumulation FB for ' end if + call med_field_info_array_from_state( & + state = is_local%wrap%NStateExp(compocn), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return 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), & + field_info_array=field_info_array, STgeom=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) diff --git a/mediator/med_phases_prep_rof_mod.F90 b/mediator/med_phases_prep_rof_mod.F90 index 1f6eeb0ba..e39fcb2aa 100644 --- a/mediator/med_phases_prep_rof_mod.F90 +++ b/mediator/med_phases_prep_rof_mod.F90 @@ -21,10 +21,13 @@ module med_phases_prep_rof_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_accum => med_methods_FB_accum use med_methods_mod , only : fldbun_average => med_methods_FB_average use med_methods_mod , only : field_getdata1d => med_methods_Field_getdata1d - use med_methods_mod , only : fldbun_fldchk => med_methods_FB_fldchk use med_methods_mod , only : FB_check_for_nans => med_methods_FB_check_for_nans + use med_field_info_mod , only : med_field_info_type + use med_field_info_mod , only : med_field_info_create_directly, med_field_info_create_from_field + use med_field_info_mod , only : med_field_info_esmf_fieldcreate use perf_mod , only : t_startf, t_stopf use shr_log_mod , only : shr_log_error @@ -63,8 +66,6 @@ module med_phases_prep_rof_mod type(ESMF_FieldBundle), public :: FBlndAccum2rof_l type(ESMF_FieldBundle), public :: FBlndAccum2rof_r - character(len=9) :: fldnames_fr_glc(2) = (/'Fgrg_rofl', 'Fgrg_rofi'/) - character(*) , parameter :: u_FILE_u = & __FILE__ @@ -80,7 +81,7 @@ subroutine med_phases_prep_rof_init(gcomp, rc) !--------------------------------------- use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate + use ESMF , only : ESMF_Field, ESMF_FieldGet 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 @@ -96,9 +97,12 @@ subroutine med_phases_prep_rof_init(gcomp, rc) ! local variables type(InternalState) :: is_local integer :: n, nflds + logical :: is_present type(ESMF_Mesh) :: mesh_l type(ESMF_Mesh) :: mesh_r + type(ESMF_Field) :: lfield_template type(ESMF_Field) :: lfield + type(med_field_info_type) :: field_info type(med_fldList_type), pointer :: fldList type(med_fldList_entry_type), pointer :: fldptr character(len=CS) :: fldname @@ -145,13 +149,47 @@ subroutine med_phases_prep_rof_init(gcomp, 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) + ! Determine information about this Field - particularly the sizes of any ungridded + ! dimensions - so that we can create a correctly-sized Field in the accumulation + ! FieldBundles. + call ESMF_FieldBundleGet(is_local%wrap%FBExp(comprof), & + fieldName=lnd2rof_flds(n), & + isPresent=is_present, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (is_present) then + call ESMF_FieldBundleGet(is_local%wrap%FBExp(comprof), & + fieldName=lnd2rof_flds(n), & + field=lfield_template, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + field_info = med_field_info_create_from_field( & + field=lfield_template, & + name=lnd2rof_flds(n), & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + ! If this Field isn't in FBExp(comprof), then it could probably be left out of + ! the Accumulator FieldBundles. But we're leaving it in there to maintain + ! earlier behavior of the code and avoid the need to determine if it's safe to + ! leave it out. However, in this case, we don't bother determining the sizes of + ! any ungridded dimensions (because it shouldn't matter and we don't have an + ! obvious place to get this information from). + field_info = med_field_info_create_directly( & + name=lnd2rof_flds(n), & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + call med_field_info_esmf_fieldcreate(field_info=field_info, & + mesh=mesh_l, meshloc=ESMF_MESHLOC_ELEMENT, & + field=lfield, 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) + call med_field_info_esmf_fieldcreate(field_info=field_info, & + mesh=mesh_r, meshloc=ESMF_MESHLOC_ELEMENT, & + field=lfield, 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 @@ -190,11 +228,8 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) ! Mapping from the land to the rof grid is then done with the time averaged fields !------------------------------------ - use NUOPC , only : NUOPC_IsConnected use ESMF , only : ESMF_GridComp, ESMF_GridCompGet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_FieldBundleGet, ESMF_StateIsCreated, ESMF_StateGet - use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_Field, ESMF_FieldGet ! input/output variables type(ESMF_GridComp) :: gcomp @@ -202,12 +237,6 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: n - logical :: exists - real(r8), pointer :: dataptr1d(:) - real(r8), pointer :: dataptr1d_accum(:) - type(ESMF_Field) :: lfield - type(ESMF_Field) :: lfield_accum character(len=*), parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof_accum)' !--------------------------------------- @@ -224,24 +253,8 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Accumulate lnd input on lnd grid for fields that will be sent to rof - 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(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 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 - end do + call fldbun_accum(FBout=FBlndAccum2rof_l, FBin=is_local%wrap%FBImp(complnd,complnd), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! Accumulate counter lndAccum2rof_cnt = lndAccum2rof_cnt + 1 @@ -267,7 +280,6 @@ subroutine med_phases_prep_rof(gcomp, rc) use NUOPC , only : NUOPC_IsConnected use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldGet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use esmFlds , only : med_fldList_GetfldListTo, med_fldList_type use med_map_mod , only : med_map_field_packed @@ -280,12 +292,9 @@ subroutine med_phases_prep_rof(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: n,ns,nf + integer :: ns integer :: count - logical :: exists - real(r8), pointer :: dataptr_in(:) real(r8), pointer :: dataptr_out(:) - type(ESMF_Field) :: lfield type(med_fldList_type), pointer :: fldList character(len=*),parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof)' !--------------------------------------- @@ -315,23 +324,12 @@ subroutine med_phases_prep_rof(gcomp, rc) write(logunit,'(a)')trim(subname)//'accumulation count for land input averging to river is 0 '// & ' accumulation field is set to zero' end if - end if - - do n = 1,size(lnd2rof_flds) - call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), isPresent=exists, rc=rc) + call fldbun_reset(FB=FBlndAccum2rof_l, 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, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata1d(lfield, dataptr_out, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (count == 0) then - dataptr_out(:) = czero - else - dataptr_out(:) = dataptr_out(:) / real(count, r8) - end if - end if - end do + else + call fldbun_average(FB=FBlndAccum2rof_l, count=count, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if if (dbug_flag > 1) then call fldbun_diagnose(FBlndAccum2rof_l, string=trim(subname)//' FBlndAccum2rof_l after avg ', rc=rc) @@ -385,25 +383,24 @@ subroutine med_phases_prep_rof(gcomp, rc) ! custom merge for glc->rof ! glc->rof is mapped in med_phases_post_glc do ns = 1,is_local%wrap%num_icesheets - if (is_local%wrap%med_coupling_active(compglc(ns),comprof)) then - do nf = 1,size(fldnames_fr_glc) - if ( fldbun_fldchk(is_local%wrap%FBImp(compglc(ns),comprof), fldnames_fr_glc(nf), rc=rc) .and. & - fldbun_fldchk(is_local%wrap%FBExp(comprof), fldnames_fr_glc(nf), rc=rc) ) then - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),comprof), & - trim(fldnames_fr_glc(nf)), dataptr_in, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call fldbun_getdata1d(is_local%wrap%FBExp(comprof), & - trim(fldnames_fr_glc(nf)), dataptr_out , rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Determine export data - if (ns == 1) then - dataptr_out(:) = dataptr_in(:) - else - dataptr_out(:) = dataptr_out(:) + dataptr_in(:) - end if - end if - end do - end if + if (is_local%wrap%med_coupling_active(compglc(ns),comprof)) then + ! This fldbun_accum call is used to sum the inputs from each ice sheet - so it + ! is an accumulation in space (as opposed to the accumulation in time done in + ! med_phases_prep_rof_accum). This accumulation acts over all of the fields that + ! are common to FBExp(comprof) and FBImp(compglc(ns),comprof), which is the set + ! of fields sent from glc to rof. Note that the 'copy' argument is set to true + ! for the first loop iteration and false for subsequent loop iterations; this + ! serves to initialize the export field bundle in the first loop iteration + ! (simply copying the import fields to the export) and then iteratively + ! accumulating the imports from the other ice sheets in subsequent loop + ! iterations. + call fldbun_accum( & + FBout=is_local%wrap%FBExp(comprof), & + FBin=is_local%wrap%FBImp(compglc(ns),comprof), & + copy=(ns==1), & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if end do ! Check for nans in fields export to rof @@ -424,18 +421,8 @@ subroutine med_phases_prep_rof(gcomp, rc) lndAccum2rof_cnt = 0 ! 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(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata1d(lfield, dataptr_out, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr_out(:) = czero - end if - end do + call fldbun_reset(FBlndAccum2rof_l, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 20) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90 index 4f36c8df1..c289ba709 100644 --- a/mediator/med_phases_prep_wav_mod.F90 +++ b/mediator/med_phases_prep_wav_mod.F90 @@ -18,6 +18,7 @@ module med_phases_prep_wav_mod use med_methods_mod , only : FB_copy => med_methods_FB_copy use med_methods_mod , only : FB_reset => med_methods_FB_reset use med_methods_mod , only : FB_check_for_nans => med_methods_FB_check_for_nans + use med_field_info_mod , only : med_field_info_type, med_field_info_array_from_state use esmFlds , only : med_fldList_GetfldListTo use med_internalstate_mod , only : compatm, compwav use perf_mod , only : t_startf, t_stopf @@ -48,6 +49,7 @@ subroutine med_phases_prep_wav_init(gcomp, rc) ! local variables type(InternalState) :: is_local + type(med_field_info_type), allocatable :: field_info_array(:) character(len=*),parameter :: subname=' (med_phases_prep_wav_init) ' !--------------------------------------- @@ -61,8 +63,13 @@ subroutine med_phases_prep_wav_init(gcomp, rc) if (maintask) then write(logunit,'(a)') trim(subname)//' initializing wave export accumulation FB for ' end if + call med_field_info_array_from_state( & + state = is_local%wrap%NStateExp(compwav), & + field_info_array = field_info_array, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return 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), & + field_info_array = field_info_array, STgeom=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) diff --git a/ufs/CMakeLists.txt b/ufs/CMakeLists.txt index bb047dabb..19b34b5ae 100644 --- a/ufs/CMakeLists.txt +++ b/ufs/CMakeLists.txt @@ -1,6 +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) +add_library(cmeps_share flux_atmocn_mod.F90 glc_elevclass_mod.F90 perf_mod.F90 ufs_const_mod.F90 ufs_kind_mod.F90 wtracers_mod.F90) target_include_directories (cmeps_share PUBLIC ${CMAKE_CURRENT_SOURCE_DIR} ${ESMF_F90COMPILEPATHS} ${PIO_Fortran_INCLUDE_DIRS}) diff --git a/ufs/wtracers_mod.F90 b/ufs/wtracers_mod.F90 new file mode 100644 index 000000000..17d2f3014 --- /dev/null +++ b/ufs/wtracers_mod.F90 @@ -0,0 +1,34 @@ +module wtracers_mod + + !----------------------------------------------------------------------------- + ! This module provides stub implementations for the shr_wtracers_mod code for when we + ! do not have access to the CESM_share library. + ! + ! See also the version of wtracers_mod in the cesm directory for when we have access to + ! the CESM_share library. + !----------------------------------------------------------------------------- + + implicit none + private + + public :: wtracers_is_wtracer_field ! return true if the given field name is a water tracer field + +contains + + !----------------------------------------------------------------------- + function wtracers_is_wtracer_field(fieldname) + ! + ! !DESCRIPTION: + ! Return true if the given field name is a water tracer field + ! + ! In this stub implementation, we always return false, since water tracers are not + ! implemented here. + ! + ! !ARGUMENTS + character(len=*), intent(in) :: fieldname + logical :: wtracers_is_wtracer_field + !----------------------------------------------------------------------- + wtracers_is_wtracer_field = .false. + end function wtracers_is_wtracer_field + +end module wtracers_mod From 33d42f9b1b2eb50900faa58a18677079aeff8a73 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Tue, 24 Mar 2026 10:33:45 -0400 Subject: [PATCH 13/15] remove ocn scheme -1 (bulk) (#167) --- mediator/med_phases_aofluxes_mod.F90 | 38 ++++++++++------------------ ufs/flux_atmocn_mod.F90 | 14 +++------- 2 files changed, 16 insertions(+), 36 deletions(-) diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index 00a590c8a..103d37ba4 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -1600,33 +1600,21 @@ subroutine set_aoflux_in_pointers(fldbun_a, fldbun_o, aoflux_in, lsize, xgrid, r lsize = size(aoflux_in%zbot) aoflux_in%lsize = lsize - ! note the ocn_surface_flux_scheme -1 will be deprecated in the future - if (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) + 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 + if (add_gusts) then + call fldbun_getfldptr(fldbun_a, 'Faxa_rainc', aoflux_in%rainc, 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 - if (add_gusts) then - call fldbun_getfldptr(fldbun_a, 'Faxa_rainc', aoflux_in%rainc, xgrid=xgrid, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - else - ! rainc is not used without add_gusts but some compilers complain about the unallocated pointer - ! in the subroutine interface - allocate(aoflux_in%rainc(1)) - end if + ! rainc is not used without add_gusts but some compilers complain about the unallocated pointer + ! in the subroutine interface + allocate(aoflux_in%rainc(1)) end if ! extra fields for CCPP aoflux diff --git a/ufs/flux_atmocn_mod.F90 b/ufs/flux_atmocn_mod.F90 index 3e5b58602..36dc6ceec 100644 --- a/ufs/flux_atmocn_mod.F90 +++ b/ufs/flux_atmocn_mod.F90 @@ -63,7 +63,7 @@ subroutine flux_adjust_constants( flux_convergence_tolerance, & end subroutine flux_adjust_constants !=============================================================================== - subroutine flux_atmOcn(logunit, nMax,zbot ,ubot ,vbot ,thbot , & + subroutine flux_atmOcn(logunit, nMax,zbot ,ubot ,vbot ,thbot , & & qbot , rbot ,tbot ,us ,vs , & & ts , mask ,sen ,lat ,lwup , & & evap , taux ,tauy ,tref ,qref , & @@ -255,11 +255,7 @@ subroutine flux_atmOcn(logunit, nMax,zbot ,ubot ,vbot ,thbot , & !--- shift wind speed using old coefficient --- rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) - if (ocn_surface_flux_scheme == -1)then - u10n = vmag - else - u10n = vmag * rd / rdn - end if + u10n = vmag * rd / rdn !--- update transfer coeffs at 10m and neutral stability --- rdn = sqrt(cdn(u10n)) @@ -268,11 +264,7 @@ subroutine flux_atmOcn(logunit, nMax,zbot ,ubot ,vbot ,thbot , & !(1.0_R8-stable) * chxcdu + stable * chxcds !--- shift all coeffs to measurement height and stability --- - if (ocn_surface_flux_scheme == -1)then - rd = rdn - else - rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) - end if + 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)) From c14c1ef3f4d06506bdc48fbe8200b56b6b8b30ff Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 2 Apr 2026 10:51:13 -0400 Subject: [PATCH 14/15] Purge hycom related code (#164) * purge hafs only related code, swap remaining mode name to hafs, not hafs.mom6 --- mediator/esmFldsExchange_hafs_mod.F90 | 483 ++++++++++---------------- mediator/med.F90 | 4 +- mediator/med_internalstate_mod.F90 | 5 +- mediator/med_map_mod.F90 | 4 +- 4 files changed, 192 insertions(+), 304 deletions(-) diff --git a/mediator/esmFldsExchange_hafs_mod.F90 b/mediator/esmFldsExchange_hafs_mod.F90 index 0515c8707..7d997699f 100644 --- a/mediator/esmFldsExchange_hafs_mod.F90 +++ b/mediator/esmFldsExchange_hafs_mod.F90 @@ -30,24 +30,24 @@ module esmFldsExchange_hafs_mod __FILE__ type gcomp_attr - character(len=CX) :: atm2ocn_fmap = 'unset' - character(len=CX) :: atm2ocn_smap = 'unset' - character(len=CX) :: atm2ocn_vmap = 'unset' - character(len=CX) :: atm2wav_smap = 'unset' - character(len=CX) :: ocn2atm_fmap = 'unset' - character(len=CX) :: ocn2atm_smap = 'unset' - character(len=CX) :: ocn2wav_smap = 'unset' - character(len=CX) :: wav2ocn_smap = 'unset' - character(len=CX) :: wav2atm_smap = 'unset' - character(len=CS) :: mapnorm = 'one' - logical :: atm_present = .false. - logical :: ocn_present = .false. - logical :: wav_present = .false. - end type - -!=============================================================================== + character(len=CX) :: atm2ocn_fmap = 'unset' + character(len=CX) :: atm2ocn_smap = 'unset' + character(len=CX) :: atm2ocn_vmap = 'unset' + character(len=CX) :: atm2wav_smap = 'unset' + character(len=CX) :: ocn2atm_fmap = 'unset' + character(len=CX) :: ocn2atm_smap = 'unset' + character(len=CX) :: ocn2wav_smap = 'unset' + character(len=CX) :: wav2ocn_smap = 'unset' + character(len=CX) :: wav2atm_smap = 'unset' + character(len=CS) :: mapnorm = 'one' + logical :: atm_present = .false. + logical :: ocn_present = .false. + logical :: wav_present = .false. + end type gcomp_attr + + !=============================================================================== contains -!=============================================================================== + !=============================================================================== subroutine esmFldsExchange_hafs(gcomp, phase, rc) @@ -64,19 +64,19 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc) rc = ESMF_SUCCESS if (phase == 'advertise') then - call esmFldsExchange_hafs_advt(gcomp, phase, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + call esmFldsExchange_hafs_advt(gcomp, phase, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return elseif (phase == 'fieldcheck') then - call esmFldsExchange_hafs_fchk(gcomp, phase, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + call esmFldsExchange_hafs_fchk(gcomp, phase, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return elseif (phase == 'initialize') then - call esmFldsExchange_hafs_init(gcomp, phase, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + call esmFldsExchange_hafs_init(gcomp, phase, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return else - call ESMF_LogSetError(ESMF_FAILURE, & - msg=trim(subname)//": Phase is set to "//trim(phase), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return ! bail out + call ESMF_LogSetError(ESMF_FAILURE, & + msg=trim(subname)//": Phase is set to "//trim(phase), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return ! bail out endif call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) @@ -115,11 +115,11 @@ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) !===================================================================== call NUOPC_CompAttributeGet(gcomp, name='ScalarFieldName', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", & - value=cvalue, rc=rc) + value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1,ncomps call addfld_from(n, trim(cvalue)) @@ -150,13 +150,12 @@ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) !---------------------------------------------------------- ! from med: ocean albedos (not sent to the ATM in UFS). !---------------------------------------------------------- - if (trim(coupling_mode) == 'hafs.mom6') then - if (phase == 'advertise') then - call addfld_ocnalb('So_avsdr') - call addfld_ocnalb('So_avsdf') - call addfld_ocnalb('So_anidr') - call addfld_ocnalb('So_anidf') - end if + + if (phase == 'advertise') then + call addfld_ocnalb('So_avsdr') + call addfld_ocnalb('So_avsdf') + call addfld_ocnalb('So_anidr') + call addfld_ocnalb('So_anidf') end if !===================================================================== @@ -167,27 +166,16 @@ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) ! to atm: surface temperatures from ocn ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%ocn_present) then - if (trim(coupling_mode) == 'hafs') then - allocate(S_flds(1)) - S_flds = (/'So_t'/) ! sea_surface_temperature - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compocn, trim(fldname)) - call addfld_to(compatm, trim(fldname)) - end do - deallocate(S_flds) - else - allocate(S_flds(3)) - S_flds = (/'So_t', & ! sea_surface_temperature - 'So_u', & ! surface zonal current - 'So_v'/) ! surface meridional current - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compocn, trim(fldname)) - call addfld_to(compatm, trim(fldname)) - end do - deallocate(S_flds) - end if + allocate(S_flds(3)) + S_flds = (/'So_t', & ! sea_surface_temperature + 'So_u', & ! surface zonal current + 'So_v'/) ! surface meridional current + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compocn, trim(fldname)) + call addfld_to(compatm, trim(fldname)) + end do + deallocate(S_flds) end if ! --------------------------------------------------------------------- @@ -212,84 +200,50 @@ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc) ! to ocn: state fields ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%ocn_present) then - if (trim(coupling_mode) == 'hafs') then - allocate(S_flds(6)) - S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m - 'Sa_v10m', & ! inst_merid_wind_height10m - 'Sa_t2m ', & ! inst_temp_height2m - 'Sa_q2m ', & ! inst_spec_humid_height2m - 'Sa_pslv', & ! inst_pres_height_surface - 'Sa_tskn' /) ! inst_temp_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compatm, trim(fldname)) - call addfld_to(compocn, trim(fldname)) - end do - deallocate(S_flds) - else - allocate(S_flds(1)) - S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compatm, trim(fldname)) - call addfld_to(compocn, trim(fldname)) - end do - deallocate(S_flds) - end if + allocate(S_flds(1)) + S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compatm, trim(fldname)) + call addfld_to(compocn, trim(fldname)) + end do + deallocate(S_flds) end if ! --------------------------------------------------------------------- ! to ocn: flux fields ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%ocn_present) then - if (trim(coupling_mode) == 'hafs') then - allocate(F_flds(7,2)) - F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx - F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx - F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx - F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - call addfld_from(compatm, trim(fldname1)) - call addfld_to(compocn, trim(fldname2)) - end do - deallocate(F_flds) - else - allocate(F_flds(10,2)) - F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx - F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx - F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate - F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx - F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx - F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx - F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - call addfld_from(compatm, trim(fldname1)) - call addfld_to(compocn, trim(fldname2)) - end do - deallocate(F_flds) - end if + allocate(F_flds(10,2)) + F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx + F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx + F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate + F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx + F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx + F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx + F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + call addfld_from(compatm, trim(fldname1)) + call addfld_to(compocn, trim(fldname2)) + end do + deallocate(F_flds) end if ! to ocn: partitioned stokes drift from wav if (hafs_attr%wav_present .and. hafs_attr%ocn_present) then - allocate(S_flds(2)) - S_flds = (/'Sw_pstokes_x', 'Sw_pstokes_y'/) - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - call addfld_from(compwav , fldname) - call addfld_to(compocn , fldname) - end do - deallocate(S_flds) + allocate(S_flds(2)) + S_flds = (/'Sw_pstokes_x', 'Sw_pstokes_y'/) + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + call addfld_from(compwav , fldname) + call addfld_to(compocn , fldname) + end do + deallocate(S_flds) end if !===================================================================== @@ -359,11 +313,11 @@ subroutine esmFldsExchange_hafs_fchk(gcomp, phase, rc) if (fldchk(is_local%wrap%FBImp(compocn,compocn),'So_omask',rc=rc)) then call ESMF_LogWrite(trim(subname)//": Field connected "//"So_omask", & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_INFO) else call ESMF_LogSetError(ESMF_FAILURE, & - msg=trim(subname)//": Field is not connected "//"So_omask", & - line=__LINE__, file=__FILE__, rcToReturn=rc) + msg=trim(subname)//": Field is not connected "//"So_omask", & + line=__LINE__, file=__FILE__, rcToReturn=rc) return ! bail out endif @@ -442,39 +396,22 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) ! to atm: sea surface temperature ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%ocn_present) then - if (trim(coupling_mode) == 'hafs') then - allocate(S_flds(1)) - S_flds = (/'So_t'/) ! sea_surface_temperature - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & - ) then - call addmap_from(compocn, trim(fldname), compatm, & - mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%ocn2atm_smap) - call addmrg_to(compatm, trim(fldname), & - mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) - else - allocate(S_flds(3)) - S_flds = (/'So_t', & ! sea_surface_temperature - 'So_u', & ! surface zonal current - 'So_v'/) ! surface meridional current - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & - ) then - call addmap_from(compocn, trim(fldname), compatm, & - mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%ocn2atm_smap) - call addmrg_to(compatm, trim(fldname), & - mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) - end if + allocate(S_flds(3)) + S_flds = (/'So_t', & ! sea_surface_temperature + 'So_u', & ! surface zonal current + 'So_v'/) ! surface meridional current + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) & + ) then + call addmap_from(compocn, trim(fldname), compatm, & + mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%ocn2atm_smap) + call addmrg_to(compatm, trim(fldname), & + mrg_from=compocn, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) end if ! --------------------------------------------------------------------- @@ -486,8 +423,8 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) do n = 1,size(S_flds) fldname = trim(S_flds(n)) if (fldchk(is_local%wrap%FBExp(compatm),trim(fldname),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compwav,compwav),trim(fldname),rc=rc) & - ) then + fldchk(is_local%wrap%FBImp(compwav,compwav),trim(fldname),rc=rc) & + ) then call addmap_from(compwav, trim(fldname), compatm, & mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%wav2atm_smap) call addmrg_to(compatm, trim(fldname), & @@ -505,96 +442,50 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) ! to ocn: state fields ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%ocn_present) then - if (trim(coupling_mode) == 'hafs') then - allocate(S_flds(6)) - S_flds = (/'Sa_u10m', & ! inst_zonal_wind_height10m - 'Sa_v10m', & ! inst_merid_wind_height10m - 'Sa_t2m ', & ! inst_temp_height2m - 'Sa_q2m ', & ! inst_spec_humid_height2m - 'Sa_pslv', & ! inst_pres_height_surface - 'Sa_tskn' /) ! inst_temp_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - 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_from(compatm, trim(fldname), compocn, & - mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) - else - allocate(S_flds(1)) - S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - 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_from(compatm, trim(fldname), compocn, & - mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) - end if + allocate(S_flds(1)) + S_flds = (/'Sa_pslv'/) ! inst_pres_height_surface + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + 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_from(compatm, trim(fldname), compocn, & + mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2ocn_smap) + call addmrg_to(compocn, trim(fldname), & + mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) end if ! --------------------------------------------------------------------- ! to ocn: flux fields ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%ocn_present) then - if (trim(coupling_mode) == 'hafs') then - allocate(F_flds(7,2)) - F_flds(1,:) = (/'Faxa_taux ','Faxa_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2,:) = (/'Faxa_tauy ','Faxa_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4,:) = (/'Faxa_swnet','Faxa_swnet'/) ! inst_net_sw_flx - F_flds(5,:) = (/'Faxa_lwnet','Faxa_lwnet'/) ! inst_net_lw_flx - F_flds(6,:) = (/'Faxa_sen ','Faxa_sen '/) ! inst_sensi_heat_flx - F_flds(7,:) = (/'Faxa_lat ','Faxa_lat '/) ! inst_laten_heat_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & - ) then - call addmap_from(compatm, trim(fldname1), compocn, & - mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname2), & - mrg_from=compatm, mrg_fld=trim(fldname1), mrg_type='copy') - end if - end do - deallocate(F_flds) - else - allocate(F_flds(10,2)) - F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm - F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm - F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate - F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx - F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx - F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate - F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx - F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx - F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx - F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx - do n = 1,size(F_flds,1) - fldname1 = trim(F_flds(n,1)) - fldname2 = trim(F_flds(n,2)) - if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & - fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & + allocate(F_flds(10,2)) + F_flds(1 ,:) = (/'Faxa_taux ','Foxx_taux '/) ! inst_zonal_moment_flx_atm + F_flds(2 ,:) = (/'Faxa_tauy ','Foxx_tauy '/) ! inst_merid_moment_flx_atm + F_flds(3 ,:) = (/'Faxa_rain ','Faxa_rain '/) ! inst_prec_rate + F_flds(4 ,:) = (/'Faxa_lwnet ','Foxx_lwnet '/) ! inst_net_lw_flx + F_flds(5 ,:) = (/'Faxa_sen ','Foxx_sen '/) ! inst_sensi_heat_flx + F_flds(6 ,:) = (/'Faxa_evap ','Foxx_evap '/) ! inst_evap_rate + F_flds(7 ,:) = (/'Faxa_swndr ','Foxx_swnet_idr'/) ! inst_down_sw_ir_dir_flx + F_flds(8 ,:) = (/'Faxa_swndf ','Foxx_swnet_idf'/) ! inst_down_sw_ir_dif_flx + F_flds(9 ,:) = (/'Faxa_swvdr ','Foxx_swnet_vdr'/) ! inst_down_sw_vis_dir_flx + F_flds(10,:) = (/'Faxa_swvdf ','Foxx_swnet_vdf'/) ! inst_down_sw_vis_dif_flx + do n = 1,size(F_flds,1) + fldname1 = trim(F_flds(n,1)) + fldname2 = trim(F_flds(n,2)) + if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname2),rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname1),rc=rc) & ) then - call addmap_from(compatm, trim(fldname1), compocn, & - mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2ocn_smap) - call addmrg_to(compocn, trim(fldname2), & - mrg_from=compatm, mrg_fld=trim(fldname1), mrg_type='copy') - end if - end do - deallocate(F_flds) - end if + call addmap_from(compatm, trim(fldname1), compocn, & + mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2ocn_smap) + call addmrg_to(compocn, trim(fldname2), & + mrg_from=compatm, mrg_fld=trim(fldname1), mrg_type='copy') + end if + end do + deallocate(F_flds) end if ! --------------------------------------------------------------------- @@ -606,9 +497,9 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) fldname = trim(S_flds(n)) if ( fldchk(is_local%wrap%FBexp(compocn) , fldname, rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav,compwav), fldname, rc=rc)) then - call addmap_from(compwav, fldname, compocn, mapfillv_bilnr, & - hafs_attr%mapnorm, 'unset') - call addmrg_to(compocn, fldname, mrg_from=compwav, mrg_fld=fldname, mrg_type='copy') + call addmap_from(compwav, fldname, compocn, mapfillv_bilnr, & + hafs_attr%mapnorm, 'unset') + call addmrg_to(compocn, fldname, mrg_from=compwav, mrg_fld=fldname, mrg_type='copy') end if end do deallocate(S_flds) @@ -621,20 +512,20 @@ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc) ! to wav: 10-m wind components ! --------------------------------------------------------------------- if (hafs_attr%atm_present .and. hafs_attr%wav_present) then - allocate(S_flds(2)) - S_flds = (/'Sa_u10m', 'Sa_v10m'/) - do n = 1,size(S_flds) - fldname = trim(S_flds(n)) - 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_from(compatm, trim(fldname), compwav, & - mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2wav_smap) - call addmrg_to(compwav, trim(fldname), & - mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') - end if - end do - deallocate(S_flds) + allocate(S_flds(2)) + S_flds = (/'Sa_u10m', 'Sa_v10m'/) + do n = 1,size(S_flds) + fldname = trim(S_flds(n)) + 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_from(compatm, trim(fldname), compwav, & + mapfillv_bilnr, hafs_attr%mapnorm, hafs_attr%atm2wav_smap) + call addmrg_to(compwav, trim(fldname), & + mrg_from=compatm, mrg_fld=trim(fldname), mrg_type='copy') + end if + end do + deallocate(S_flds) end if ! --------------------------------------------------------------------- @@ -681,7 +572,7 @@ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc) ! Query component for name, verbosity, and diagnostic values call NUOPC_CompGet(gcomp, name=cname, verbosity=verbosity, & - diagnostic=diagnostic, rc=rc) + diagnostic=diagnostic, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return !---------------------------------------------------------- @@ -689,21 +580,21 @@ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc) !---------------------------------------------------------- call NUOPC_CompAttributeGet(gcomp, name='ATM_model', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + 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') hafs_attr%atm_present = .true. end if call NUOPC_CompAttributeGet(gcomp, name='OCN_model', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + 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') hafs_attr%ocn_present = .true. end if call NUOPC_CompAttributeGet(gcomp, name='WAV_model', & - value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + 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') hafs_attr%wav_present = .true. @@ -714,11 +605,11 @@ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc) !---------------------------------------------------------- call NUOPC_CompAttributeGet(gcomp, name='normalization', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='normalization', & - value=hafs_attr%mapnorm, rc=rc) + value=hafs_attr%mapnorm, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if @@ -728,81 +619,81 @@ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc) ! to atm call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', & - value=hafs_attr%ocn2atm_smap, rc=rc) + value=hafs_attr%ocn2atm_smap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', & - value=hafs_attr%ocn2atm_fmap, rc=rc) + value=hafs_attr%ocn2atm_fmap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if ! to ocn call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', & - value=hafs_attr%atm2ocn_fmap, rc=rc) + value=hafs_attr%atm2ocn_fmap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then - call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', & - value=hafs_attr%atm2ocn_smap, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', & + value=hafs_attr%atm2ocn_smap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', & - value=hafs_attr%atm2ocn_vmap, rc=rc) + value=hafs_attr%atm2ocn_vmap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if ! to wav call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', & - value=hafs_attr%atm2wav_smap, rc=rc) + value=hafs_attr%atm2wav_smap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if call NUOPC_CompAttributeGet(gcomp, name='ocn2wav_smapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='ocn2wav_smapname', & - value=hafs_attr%ocn2wav_smap, rc=rc) + value=hafs_attr%ocn2wav_smap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if ! from wav call NUOPC_CompAttributeGet(gcomp, name='wav2atm_smapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='wav2atm_smapname', & - value=hafs_attr%wav2atm_smap, rc=rc) + value=hafs_attr%wav2atm_smap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if call NUOPC_CompAttributeGet(gcomp, name='wav2ocn_smapname', & - isPresent=isPresent, rc=rc) + isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (isPresent) then call NUOPC_CompAttributeGet(gcomp, name='wav2ocn_smapname', & - value=hafs_attr%wav2ocn_smap, rc=rc) + value=hafs_attr%wav2ocn_smap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if @@ -810,22 +701,22 @@ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc) if (btest(verbosity,16)) then write(cvalue,"(I0)") verbosity call ESMF_LogWrite(trim(subname)//': Verbosity = '// & - trim(cvalue), ESMF_LOGMSG_INFO) + trim(cvalue), ESMF_LOGMSG_INFO) write(cvalue,"(I0)") diagnostic call ESMF_LogWrite(trim(subname)//': Diagnostic = '// & - trim(cvalue), ESMF_LOGMSG_INFO) + trim(cvalue), ESMF_LOGMSG_INFO) call ESMF_LogWrite(trim(subname)//': normalization = '// & - trim(hafs_attr%mapnorm), ESMF_LOGMSG_INFO) + trim(hafs_attr%mapnorm), ESMF_LOGMSG_INFO) call ESMF_LogWrite(trim(subname)//': ocn2atm_smapname = '// & - trim(hafs_attr%ocn2atm_smap), ESMF_LOGMSG_INFO) + trim(hafs_attr%ocn2atm_smap), ESMF_LOGMSG_INFO) call ESMF_LogWrite(trim(subname)//': ocn2atm_fmapname = '// & - trim(hafs_attr%ocn2atm_fmap), ESMF_LOGMSG_INFO) + trim(hafs_attr%ocn2atm_fmap), ESMF_LOGMSG_INFO) call ESMF_LogWrite(trim(subname)//': atm2ocn_fmapname = '// & - trim(hafs_attr%atm2ocn_fmap), ESMF_LOGMSG_INFO) + trim(hafs_attr%atm2ocn_fmap), ESMF_LOGMSG_INFO) call ESMF_LogWrite(trim(subname)//': atm2ocn_smapname = '// & - trim(hafs_attr%atm2ocn_smap), ESMF_LOGMSG_INFO) + trim(hafs_attr%atm2ocn_smap), ESMF_LOGMSG_INFO) call ESMF_LogWrite(trim(subname)//': atm2ocn_vmapname = '// & - trim(hafs_attr%atm2ocn_vmap), ESMF_LOGMSG_INFO) + trim(hafs_attr%atm2ocn_vmap), ESMF_LOGMSG_INFO) endif call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) diff --git a/mediator/med.F90 b/mediator/med.F90 index 9c45172b4..6ca303b21 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -857,7 +857,7 @@ subroutine AdvertiseFields(gcomp, importState, exportState, clock, rc) else if (coupling_mode(1:3) == 'ufs') then call esmFldsExchange_ufs(gcomp, phase='advertise', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - else if (coupling_mode(1:4) == 'hafs') then + else if (trim(coupling_mode) == 'hafs') then call esmFldsExchange_hafs(gcomp, phase='advertise', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return else @@ -1882,7 +1882,7 @@ subroutine DataInitialize(gcomp, rc) else if (coupling_mode(1:3) == 'ufs') then call esmFldsExchange_ufs(gcomp, phase='initialize', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - else if (coupling_mode(1:4) == 'hafs') then + else if (trim(coupling_mode) == 'hafs') then call esmFldsExchange_hafs(gcomp, phase='initialize', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index 70c95ac37..f8412e6f1 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -47,7 +47,7 @@ module med_internalstate_mod character(len=CS), public :: glc_name = '' ! Coupling mode - character(len=CS), public :: coupling_mode ! valid values are [cesm,ufs.nfrac,ufs.frac,ufs.nfrac.aoflux,ufs.frac.aoflux,hafs,hafs.mom6] + character(len=CS), public :: coupling_mode ! valid values are [cesm,ufs.nfrac,ufs.frac,ufs.nfrac.aoflux,ufs.frac.aoflux,hafs] ! Atmosphere-ocean flux algorithm character(len=CS), public :: aoflux_code ! valid values are [cesm,ccpp] @@ -692,9 +692,6 @@ subroutine med_internalstate_defaultmasks(gcomp, rc) if ( coupling_mode(1:3) == 'ufs') then if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,2) = 1 endif - if ( trim(coupling_mode) == 'hafs') then ! not hafs.mom6 - if (is_local%wrap%comp_present(compatm)) defaultMasks(compatm,1) = 1 - endif if ( coupling_mode /= 'cesm') then if (is_local%wrap%comp_present(compatm) .and. atm_name(1:4) == 'datm') then defaultMasks(compatm,1) = 0 diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index a3d50c5e4..7a44f673a 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -431,7 +431,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, dstMaskValue = ispval_mask end if end if - if (coupling_mode(1:4) == 'hafs') then + if (trim(coupling_mode) == 'hafs') then if (n1 == compatm .and. n2 == compwav) then srcMaskValue = ispval_mask end if @@ -446,7 +446,7 @@ 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 end if - if (trim(coupling_mode) == 'hafs.mom6') then + if (trim(coupling_mode) == 'hafs') then polemethod = ESMF_POLEMETHOD_NONE endif From fc8b9140e08465dcb5eab48056d4d5636c0e1716 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 6 Apr 2026 10:45:53 -0400 Subject: [PATCH 15/15] change incoming and outgoing surface-adjacent state variable standard names to match feature/tendency_cleanup branch (#161) --- ufs/ccpp/data/MED_typedefs.meta | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/ufs/ccpp/data/MED_typedefs.meta b/ufs/ccpp/data/MED_typedefs.meta index 9d838d52a..3731b84b2 100644 --- a/ufs/ccpp/data/MED_typedefs.meta +++ b/ufs/ccpp/data/MED_typedefs.meta @@ -36,28 +36,28 @@ type = real kind = kind_phys [ugrs] - standard_name = x_wind_at_surface_adjacent_layer + standard_name = physics_timestep_initial_x_wind_at_surface_adjacent_layer long_name = zonal wind at lowest model layer units = m s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys [vgrs] - standard_name = y_wind_at_surface_adjacent_layer + standard_name = physics_timestep_initial_y_wind_at_surface_adjacent_layer long_name = meridional wind at lowest model layer units = m s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys [tgrs] - standard_name = air_temperature_at_surface_adjacent_layer + standard_name = physics_timestep_initial_air_temperature_at_surface_adjacent_layer long_name = mean temperature at lowest model layer units = K dimensions = (horizontal_dimension) type = real kind = kind_phys [qgrs] - standard_name = specific_humidity_at_surface_adjacent_layer + standard_name = physics_timestep_initial_specific_humidity_at_surface_adjacent_layer long_name = water vapor specific humidity at lowest model layer units = kg kg-1 dimensions = (horizontal_dimension) @@ -123,28 +123,28 @@ name = MED_stateout_type type = ddt [gu0] - standard_name = x_wind_of_new_state_at_surface_adjacent_layer + standard_name = x_wind_at_surface_adjacent_layer long_name = zonal wind at lowest model layer updated by physics units = m s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys [gv0] - standard_name = y_wind_of_new_state_at_surface_adjacent_layer + standard_name = y_wind_at_surface_adjacent_layer long_name = meridional wind at lowest model layer updated by physics units = m s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys [gt0] - standard_name = air_temperature_of_new_state_at_surface_adjacent_layer + standard_name = air_temperature_at_surface_adjacent_layer long_name = temperature at lowest model layer updated by physics units = K dimensions = (horizontal_dimension) type = real kind = kind_phys [gq0] - standard_name = specific_humidity_of_new_state_at_surface_adjacent_layer + standard_name = specific_humidity_at_surface_adjacent_layer long_name = water vapor specific humidity at lowest model layer updated by physics units = kg kg-1 dimensions = (horizontal_dimension)