diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 1ab4683ca..ecde8a538 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -1985,10 +1985,14 @@ integer - 0 + -2 run_pio env_run.xml - pio rearranger communication max pending requests (comp2io) : 0 implies that CIME internally calculates the value ( = max(64, 2 * PIO_NUMTASKS) ), -1 implies no bound on max pending requests + pio rearranger communication max pending requests (io2comp) : + -2 implies that CIME internally calculates the value ( = 64), + -1 implies no bound on max pending requests + 0 implies that MPI_ALLTOALL will be used + diff --git a/mediator/esmFlds.F90 b/mediator/esmFlds.F90 index a4dfb5e3c..010aa3447 100644 --- a/mediator/esmFlds.F90 +++ b/mediator/esmFlds.F90 @@ -46,7 +46,7 @@ module esmflds ! Set coupling mode !----------------------------------------------- - character(len=10), public :: coupling_mode ! valid values are [cesm,nems_orig,nems_frac,hafs] + character(len=CS), public :: coupling_mode ! valid values are [cesm,nems_orig,nems_frac,nems_orig_data,hafs] !----------------------------------------------- ! PUblic methods diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90 index 6f6863fdc..fdd898201 100644 --- a/mediator/esmFldsExchange_nems_mod.F90 +++ b/mediator/esmFldsExchange_nems_mod.F90 @@ -31,7 +31,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) use esmflds , only : compmed, compatm, compocn, compice, comprof, ncomps use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf - use esmflds , only : coupling_mode, mapuv_with_cart3d + use esmflds , only : coupling_mode, mapuv_with_cart3d, mapnames use esmflds , only : fldListTo, fldListFr, fldListMed_aoflux, fldListMed_ocnalb use med_internalstate_mod , only : mastertask, logunit @@ -41,7 +41,8 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) integer , intent(inout) :: rc ! local variables: - integer :: i, n + integer :: i, n, maptype + character(len=CX) :: msgString character(len=CL) :: cvalue character(len=CS) :: fldname character(len=CS), allocatable :: flds(:) @@ -53,6 +54,15 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! Initialize if use 3d cartesian mapping for u,v mapuv_with_cart3d = .false. + ! Set maptype according to coupling_mode + if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then + maptype = mapnstod_consf + else + maptype = mapconsf + end if + write(msgString,'(A,i6,A)') trim(subname)//': maptype is ',maptype,', '//mapnames(maptype) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + !===================================================================== ! scalar information !===================================================================== @@ -73,26 +83,28 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) call addfld(fldListFr(compocn)%flds, 'So_omask') call addmap(fldListFr(compocn)%flds, 'So_omask', compice, mapfcopy, 'unset', 'unset') - ! atm and ocn fields required for atm/ocn flux calculation' - allocate(flds(6)) - flds = (/'Sa_u ','Sa_v ','Sa_z ','Sa_tbot','Sa_pbot','Sa_shum'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListFr(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapnstod_consf, 'none', 'unset') - end do - deallocate(flds) - - ! unused fields needed by the atm/ocn flux computation - allocate(flds(13)) - flds = (/'So_tref ', 'So_qref ','So_u10 ', 'So_ustar ','So_ssq ', & - 'So_re ', 'So_duu10n','Faox_lwup', 'Faox_sen ','Faox_lat ', & - 'Faox_evap', 'Faox_taux','Faox_tauy'/) - do n = 1,size(flds) - fldname = trim(flds(n)) - call addfld(fldListMed_aoflux%flds, trim(fldname)) - end do - deallocate(flds) + if ( trim(coupling_mode) == 'nems_orig_data') then + ! atm and ocn fields required for atm/ocn flux calculation' + allocate(flds(6)) + flds = (/'Sa_u ','Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', 'Sa_shum'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListFr(compatm)%flds, trim(fldname)) + call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'none', 'unset') + end do + deallocate(flds) + + ! unused fields needed by the atm/ocn flux computation + allocate(flds(13)) + flds = (/'So_tref ', 'So_qref ','So_u10 ', 'So_ustar ','So_ssq ', & + 'So_re ', 'So_duu10n','Faox_lwup', 'Faox_sen ','Faox_lat ', & + 'Faox_evap', 'Faox_taux','Faox_tauy'/) + do n = 1,size(flds) + fldname = trim(flds(n)) + call addfld(fldListMed_aoflux%flds, trim(fldname)) + end do + deallocate(flds) + end if ! unused fields from ice - but that are needed to be realized by the cice cap call addfld(fldListFr(compice)%flds, 'Si_avsdf') @@ -107,8 +119,8 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) !===================================================================== ! to atm: fractions (computed in med_phases_prep_atm) + call addfld(fldListFr(compice)%flds, 'Si_ifrac') call addfld(fldListTo(compatm)%flds, 'Si_ifrac') - call addfld(fldListTo(compatm)%flds, 'So_ofrac') ! to atm: unmerged from ice ! - zonal surface stress, meridional surface stress @@ -127,7 +139,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListFr(compice)%flds, trim(fldname)) call addfld(fldListTo(compatm)%flds, trim(fldname)) - call addmap(fldListFr(compice)%flds, trim(fldname), compatm, mapnstod_consf, 'ifrac', 'unset') + call addmap(fldListFr(compice)%flds, trim(fldname), compatm, maptype, 'ifrac', 'unset') call addmrg(fldListTo(compatm)%flds, trim(fldname), mrg_from1=compice, mrg_fld1=trim(fldname), mrg_type1='copy') end do deallocate(flds) @@ -135,27 +147,17 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) ! to atm: unmerged surface temperatures from ocn call addfld(fldListFr(compocn)%flds, 'So_t') call addfld(fldListTo(compatm)%flds, 'So_t') - call addmap(fldListFr(compocn)%flds, 'So_t', compatm, mapnstod_consf, 'ofrac', 'unset') + call addmap(fldListFr(compocn)%flds, 'So_t', compatm, maptype, 'ofrac', 'unset') call addmrg(fldListTo(compatm)%flds, 'So_t', mrg_from1=compocn, mrg_fld1='So_t', mrg_type1='copy') !===================================================================== ! FIELDS TO OCEAN (compocn) !===================================================================== - ! to ocn: fractional ice coverage wrt ocean from ice - call addfld(fldListFr(compice)%flds, 'Si_ifrac') - call addfld(fldListTo(compocn)%flds, 'Si_ifrac') - call addmap(fldListFr(compice)%flds, 'Si_ifrac', compocn, mapfcopy, 'unset', 'unset') - call addmrg(fldListTo(compocn)%flds, 'Si_ifrac', mrg_from1=compice, mrg_fld1='Si_ifrac', mrg_type1='copy') - ! to ocn: sea level pressure from atm call addfld(fldListTo(compocn)%flds, 'Sa_pslv') call addfld(fldListFr(compatm)%flds, 'Sa_pslv') - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, mapnstod_consf, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, mapbilnr, 'none', 'unset') - end if + call addmap(fldListFr(compatm)%flds, 'Sa_pslv', compocn, maptype, 'none', 'unset') call addmrg(fldListTo(compocn)%flds, 'Sa_pslv', mrg_from1=compatm, mrg_fld1='Sa_pslv', mrg_type1='copy') ! to ocn: from atm (custom merge in med_phases_prep_ocn) @@ -174,52 +176,32 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListTo(compocn)%flds, trim(fldname)) call addfld(fldListFr(compatm)%flds, trim(fldname)) - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapnstod_consf, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapconsf, 'none', 'unset') - end if + call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, maptype, 'none', 'unset') end do deallocate(flds) ! to ocn: merged sensible heat flux (custom merge in med_phases_prep_ocn) call addfld(fldListTo(compocn)%flds, 'Faxa_sen') call addfld(fldListFr(compatm)%flds, 'Faxa_sen') - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, mapnstod_consf, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, mapconsf, 'none', 'unset') - end if + call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, maptype, 'none', 'unset') ! to ocn: surface latent heat flux and evaporation water flux (custom merge in med_phases_prep_ocn) call addfld(fldListTo(compocn)%flds, 'Faxa_evap') call addfld(fldListFr(compatm)%flds, 'Faxa_lat') - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, mapnstod_consf, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, mapconsf, 'none', 'unset') - end if + call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, maptype, 'none', 'unset') ! to ocn: merge zonal surface stress (custom merge calculation in med_phases_prep_ocn) call addfld(fldListTo(compocn)%flds, 'Foxx_taux') call addfld(fldListFr(compice)%flds, 'Fioi_taux') call addfld(fldListFr(compatm)%flds, 'Faxa_taux') - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, 'Faxa_taux', compocn, mapnstod_consf, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, 'Faxa_taux', compocn, mapconsf, 'none', 'unset') - end if + call addmap(fldListFr(compatm)%flds, 'Faxa_taux', compocn, maptype, 'none', 'unset') call addmap(fldListFr(compice)%flds, 'Fioi_taux', compocn, mapfcopy, 'unset', 'unset') ! to ocn: meridional surface stress (custom merge calculation in med_phases_prep_ocn) call addfld(fldListTo(compocn)%flds, 'Foxx_tauy') call addfld(fldListFr(compice)%flds, 'Fioi_tauy') call addfld(fldListFr(compatm)%flds, 'Faxa_tauy') - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, 'Faxa_tauy', compocn, mapnstod_consf, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, 'Faxa_tauy', compocn, mapconsf, 'none', 'unset') - end if + call addmap(fldListFr(compatm)%flds, 'Faxa_tauy', compocn, maptype, 'none', 'unset') call addmap(fldListFr(compice)%flds, 'Fioi_tauy', compocn, mapfcopy, 'unset', 'unset') ! to ocn: net shortwave radiation from med (custom merge in med_phases_prep_ocn) @@ -271,11 +253,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListFr(compatm)%flds, trim(fldname)) call addfld(fldListTo(compice)%flds, trim(fldname)) - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mapnstod_consf, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mapconsf, 'none', 'unset') - end if + call addmap(fldListFr(compatm)%flds, trim(fldname), compice, maptype, 'none', 'unset') call addmrg(fldListTo(compice)%flds, trim(fldname), mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy') end do deallocate(flds) @@ -293,15 +271,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc) fldname = trim(flds(n)) call addfld(fldListTo(compice)%flds, trim(fldname)) call addfld(fldListFr(compatm)%flds, trim(fldname)) - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mapnstod_consf, 'none', 'unset') - else - if (trim(fldname) == 'Sa_u' .or. trim(fldname) == 'Sa_v') then - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mappatch, 'none', 'unset') - else - call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mapbilnr, 'none', 'unset') - end if - end if + call addmap(fldListFr(compatm)%flds, trim(fldname), compice, maptype, 'none', 'unset') call addmrg(fldListTo(compice)%flds, trim(fldname), mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy') end do deallocate(flds) diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index 5c9199c47..d65f7c870 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -684,7 +684,7 @@ description: sea-ice export to atm # - standard_name: Si_t - alias: sea_ice_temperature + alias: sea_ice_surface_temperature canonical_units: K description: sea-ice export # diff --git a/mediator/fd_nems.yaml b/mediator/fd_nems.yaml index f0fcad822..a74c483c9 100644 --- a/mediator/fd_nems.yaml +++ b/mediator/fd_nems.yaml @@ -43,6 +43,22 @@ # section: atmosphere export #----------------------------------- # + - standard_name: Faxa_bcph + canonical_units: kg m-2 s-1 + description: atmosphere export + # + - standard_name: Faxa_dstdry + canonical_units: kg m-2 s-1 + description: atmosphere export + # + - standard_name: Faxa_dstwet + canonical_units: kg m-2 s-1 + description: atmosphere export + # + #----------------------------------- + # section: atmosphere export + #----------------------------------- + # - standard_name: Faxa_swdn alias: mean_down_sw_flx canonical_units: W m-2 @@ -105,7 +121,11 @@ - standard_name: Sa_pslv alias: inst_pres_height_surface canonical_units: Pa - description: atmosphere export - instataneous pressure land and sea surface + description: atmosphere export - instantaneous pressure land and sea surface + # + - standard_name: Sa_ptem + canonical_units: K + description: atmosphere export - bottom layer potential temperature # - standard_name: Sa_shum alias: inst_spec_humid_height_lowest @@ -200,6 +220,18 @@ canonical_units: N m-2 description: sea-ice export - air ice meridional stress # + - standard_name: Fioi_bcphi + canonical_units: kg m-2 s-1 + description: sea-ice export to ocean - hydrophilic black carbon flux to ocean + # + - standard_name: Fioi_bcpho + canonical_units: kg m-2 s-1 + description: sea-ice export to ocean - hydrophobic black carbon flux to ocean + # + - standard_name: Fioi_flxdst + canonical_units: kg m-2 s-1 + description: sea-ice export to ocean - dust aerosol flux to ocean + # - standard_name: Fioi_melth alias: net_heat_flx_to_ocn canonical_units: W m-2 @@ -210,6 +242,11 @@ canonical_units: kg m-2 s-1 description: sea-ice export 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: sea-ice export 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 @@ -280,6 +317,10 @@ canonical_units: 1 description: sea-ice export - ice mask # + - standard_name: Si_qref + canonical_units: kg kg-1 + description: sea-ice export to atm + # - standard_name: Si_t alias: sea_ice_surface_temperature canonical_units: K @@ -299,6 +340,10 @@ description: sea-ice export volume of ice per unit area # + - standard_name: Si_snowh + canonical_units: m + description: sea-ice export - surface_snow_water_equivalent + # - standard_name: Si_vsno alias: mean_snow_volume canonical_units: m @@ -453,7 +498,6 @@ canonical_units: N m-2 description: ocean import - meridional surface stress to ocean # - # #----------------------------------- # mediator fields #----------------------------------- diff --git a/mediator/med.F90 b/mediator/med.F90 index ce870f81e..5769f84df 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -395,7 +395,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) ! local variables type(ESMF_VM) :: vm - character(len=CL) :: value + character(len=CL) :: cvalue integer :: localPet logical :: isPresent, isSet character(len=CX) :: msgString @@ -413,7 +413,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) mastertask = .false. if (localPet == 0) mastertask=.true. - ! Determine mediator logunit + ! Determine mediator logunit if (mastertask) then call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -430,14 +430,20 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) logUnit = 6 endif - call ESMF_AttributeGet(gcomp, name="Verbosity", value=value, defaultValue="max", & + ! Obtain Verbosity setting from MED_attributes + call ESMF_AttributeGet(gcomp, name="Verbosity", value=cvalue, defaultValue="max", & convention="NUOPC", purpose="Instance", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(trim(subname)//": Mediator verbosity is "//trim(value), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//": Mediator verbosity is "//trim(cvalue), ESMF_LOGMSG_INFO) - write(msgString,'(A,i6)') trim(subname)//' dbug_flag = ',dbug_flag + ! Obtain dbug_flag setting from MED_attributes if present; otherwise use default value in med_constants + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) dbug_flag + end if + write(msgString,'(A,i6)') trim(subname)//': Mediator dbug_flag is ',dbug_flag call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, acceptStringList=(/"IPDv03p"/), rc=rc) @@ -1383,7 +1389,7 @@ subroutine completeFieldInitialization(State,rc) ! Convert grid to mesh if (.not. meshcreated) then if (dbug_flag > 20) then - call med_grid_write(grid, trim(fieldName)//'_premesh.nc', rc) + call med_grid_write(grid, trim(fieldName)//'_premesh.nc', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -1520,10 +1526,8 @@ subroutine DataInitialize(gcomp, rc) character(CL) :: cvalue character(CL) :: start_type logical :: read_restart - logical :: LocalDone - logical,save :: atmDone = .false. - logical,save :: ocnDone = .false. - logical,save :: allDone = .false. + logical :: allDone = .false. + logical,save :: compDone(ncomps) logical,save :: first_call = .true. real(r8) :: real_nx, real_ny character(len=CX) :: msgString @@ -1668,7 +1672,7 @@ subroutine DataInitialize(gcomp, rc) ! Create import accumulation field bundles call FB_init(is_local%wrap%FBImpAccum(n1,n1), is_local%wrap%flds_scalar_name, & STgeom=is_local%wrap%NStateImp(n1), STflds=is_local%wrap%NStateImp(n1), & - name='FBImp'//trim(compname(n1)), rc=rc) + name='FBImpAccum'//trim(compname(n1)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call FB_reset(is_local%wrap%FBImpAccum(n1,n1), value=czero, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1814,61 +1818,47 @@ subroutine DataInitialize(gcomp, rc) call med_map_MapNorm_init(gcomp, logunit, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - first_call = .false. + !--------------------------------------- + ! Set the data initialize flag to false + !--------------------------------------- call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="false", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - return - - endif ! end first_call if-block - - !--------------------------------------- - ! Initialize mediator fields and infodata - ! This is called every loop around DataInitialize - !--------------------------------------- - - call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - do n1 = 1,ncomps - LocalDone = .true. - if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then - - call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemCount=fieldCount, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(fieldNameList(fieldCount)) - call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemNameList=fieldNameList, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------------------------------- + ! Set the first call flag to false + !--------------------------------------- - do n=1, fieldCount - call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemName=fieldNameList(n), field=field, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + first_call = .false. - atCorrectTime = NUOPC_IsAtTime(field, time, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------------------------------- + ! *** Now return **** + !--------------------------------------- - if (atCorrectTime) then - if (fieldNameList(n) == is_local%wrap%flds_scalar_name) then - call ESMF_LogWrite(trim(subname)//" MED - Initialize-Data-Dependency CSTI "//trim(compname(n1)), & - ESMF_LOGMSG_INFO, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - else - LocalDone=.false. - endif - enddo - deallocate(fieldNameList) + ! The Connectors are being "called" for the transfer of Meshes + ! (or Grids). However, being "called" can mean different + ! things! It can mean calling Initialization() phases, or Run() + ! phases. For most of the initialization hand-shake, only + ! Initialization() phases are called. This includes the entire + ! GeomTransfer protocol. However, ONLY the Run phase of a + ! Connector (full) transfers data AND timestamps! + + ! Once the first time DataInitialize() of CMEPS returns (below), + ! and NUOPC sees that its InitializeDataComplete is not yet + ! true, the NUOPC Driver will finally (for the first time!) + ! execute the Run() phase of all of the Connectors that fit the + ! *-TO-MED pattern. After that it will call CMEPS + ! DataInitialize() again. Note that the time stamps are only set + ! when the Run() phase of all the connectors are run. + + ! The Connectors Run() phase is called before the second call of + ! the CMEPS DataInitialize phase. As a result, CMEPS will see + ! the correct timestamps, which also indicates that the actual + ! data has been transferred reliably, and CMEPS can safely use it. + + RETURN - if (LocalDone) then - call ESMF_LogWrite(trim(subname)//" MED - Initialize-Data-Dependency Copy Import "//& - trim(compname(n1)), ESMF_LOGMSG_INFO, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (n1 == compocn) ocnDone = .true. - if (n1 == compatm) atmDone = .true. - endif - endif - enddo + endif ! end first_call if-block !---------------------------------------------------------- ! Create FBfrac field bundles and initialize fractions @@ -1882,70 +1872,107 @@ subroutine DataInitialize(gcomp, rc) call med_fraction_set(gcomp,rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (is_local%wrap%comp_present(compocn) .or. is_local%wrap%comp_present(compatm)) then - call med_phases_ocnalb_run(gcomp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !---------------------------------------------------------- + ! Initialize ocean albedos (this is needed for cesm and hafs) + !---------------------------------------------------------- + + if (trim(coupling_mode(1:5)) /= 'nems_') then + if (is_local%wrap%comp_present(compocn) .or. is_local%wrap%comp_present(compatm)) then + call med_phases_ocnalb_run(gcomp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if end if !--------------------------------------- - ! Carry out data dependency for atm initialization if needed + ! Loop over components and determine if they are at correct time !--------------------------------------- - if (.not. is_local%wrap%comp_present(compocn)) ocnDone = .true. - if (.not. is_local%wrap%comp_present(compatm)) atmDone = .true. - - if (.not. atmDone .and. ocnDone .and. is_local%wrap%comp_present(compatm)) then - - atmDone = .true. ! reset if an item is found that is not done - call ESMF_StateGet(is_local%wrap%NStateImp(compatm), itemCount=fieldCount, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(fieldNameList(fieldCount)) - call ESMF_StateGet(is_local%wrap%NStateImp(compatm), itemNameList=fieldNameList, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - do n=1, fieldCount - call ESMF_StateGet(is_local%wrap%NStateImp(compatm), itemName=fieldNameList(n), field=field, rc=rc) + do n1 = 1,ncomps + compDone(n1) = .true. ! even if component is not present + if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then + call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemCount=fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - atCorrectTime = NUOPC_IsAtTime(field, time, rc=rc) + allocate(fieldNameList(fieldCount)) + call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemNameList=fieldNameList, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (.not. atCorrectTime) then - ! If any atm import fields are not time stamped correctly, then dependency is not satisified - must return to atm - call ESMF_LogWrite("MED - Initialize-Data-Dependency from ATM NOT YET SATISFIED!!!", ESMF_LOGMSG_INFO, rc=rc) + do n=1, fieldCount + call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemName=fieldNameList(n), field=field, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - atmdone = .false. - exit ! break out of the loop when first not satisfied found - endif - enddo - deallocate(fieldNameList) + atCorrectTime = NUOPC_IsAtTime(field, time, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (.not. atCorrectTime) then + compDone(n1) = .false. + endif + enddo + deallocate(fieldNameList) + endif + enddo - if (.not. atmdone) then ! atmdone is not true - ! do the merge to the atmospheric component - call med_phases_prep_atm(gcomp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------------------------------- + ! Carry out data dependency for atm initialization if needed + !--------------------------------------- - ! change 'Updated' attribute to true for ALL exportState fields - call ESMF_StateGet(is_local%wrap%NStateExp(compatm), itemCount=fieldCount, rc=rc) + if (is_local%wrap%comp_present(compatm)) then + if (.not. compDone(compatm) .and. compDone(compocn)) then + compDone(compatm) = .true. ! reset if an item is found that is not done + call ESMF_StateGet(is_local%wrap%NStateImp(compatm), itemCount=fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(fieldNameList(fieldCount)) - call ESMF_StateGet(is_local%wrap%NStateExp(compatm), itemNameList=fieldNameList, rc=rc) + call ESMF_StateGet(is_local%wrap%NStateImp(compatm), itemNameList=fieldNameList, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do n=1, fieldCount - call ESMF_StateGet(is_local%wrap%NStateExp(compatm), itemName=fieldNameList(n), field=field, rc=rc) + call ESMF_StateGet(is_local%wrap%NStateImp(compatm), itemName=fieldNameList(n), field=field, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + atCorrectTime = NUOPC_IsAtTime(field, time, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end do + if (.not. atCorrectTime) then + ! If any atm import fields are not time stamped correctly, + ! then dependency is not satisified - must return to atm + call ESMF_LogWrite("MED - Initialize-Data-Dependency from ATM NOT YET SATISFIED!!!", & + ESMF_LOGMSG_INFO, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,'(A)') trim(subname)//"MED - Initialize-Data-Dependency from ATM NOT YET SATISFIED!!!" + end if + compDone(compatm) = .false. + exit ! break out of the loop when first not satisfied found + endif + enddo deallocate(fieldNameList) - ! Connectors will be automatically called between the mediator and atm until allDone is true - call ESMF_LogWrite("MED - Initialize-Data-Dependency Sending Data to ATM", ESMF_LOGMSG_INFO, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - endif + if (.not. compDone(compatm)) then ! atmdone is not true + ! do the merge to the atmospheric component + call med_phases_prep_atm(gcomp, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! change 'Updated' attribute to true for ALL exportState fields + call ESMF_StateGet(is_local%wrap%NStateExp(compatm), itemCount=fieldCount, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(fieldNameList(fieldCount)) + call ESMF_StateGet(is_local%wrap%NStateExp(compatm), itemNameList=fieldNameList, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n=1, fieldCount + call ESMF_StateGet(is_local%wrap%NStateExp(compatm), itemName=fieldNameList(n), field=field, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_SetAttribute(field, name="Updated", value="true", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end do + deallocate(fieldNameList) + + ! Connectors will be automatically called between the mediator and atm until allDone is true + call ESMF_LogWrite("MED - Initialize-Data-Dependency Sending Data to ATM", ESMF_LOGMSG_INFO, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif + end if + + !--------------------------------------- + ! Loop over components again and determine if all are at the correct time + !--------------------------------------- allDone = .true. do n1 = 1,ncomps if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then - call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemCount=fieldCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(fieldNameList(fieldCount)) @@ -1958,27 +1985,29 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (.not. atCorrectTime) then allDone=.false. + if (mastertask) then + write(logunit,'(A)') trim(subname)//" MED - Initialize-Data-Dependency check Failed for "//& + trim(compname(n1)) + end if endif enddo deallocate(fieldNameList) endif - enddo - - ! set InitializeDataComplete Component Attribute to "true", indicating - ! to the driver that this Component has fully initialized its data - if (allDone) then + ! set InitializeDataComplete Component Attribute to "true", indicating + ! to the driver that this Component has fully initialized its data call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="true", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite("MED - Initialize-Data-Dependency allDone check Passed", ESMF_LOGMSG_INFO, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - !--------------------------------------- - ! Create component dimensions in mediator internal state - !--------------------------------------- + !--------------------------------------- + ! Create component dimensions in mediator internal state + !--------------------------------------- + if (allDone) then if (mastertask) write(logunit,*) do n1 = 1,ncomps if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then @@ -2025,12 +2054,15 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif call med_phases_profile(gcomp, rc) - else + + else ! Not all done call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="false", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite("MED - Initialize-Data-Dependency allDone check Failed, another loop is required", ESMF_LOGMSG_INFO, rc=rc) + call ESMF_LogWrite("MED - Initialize-Data-Dependency allDone check Failed, another loop is required", & + ESMF_LOGMSG_INFO, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname)) diff --git a/mediator/med_fraction_mod.F90 b/mediator/med_fraction_mod.F90 index af27e3d35..f56551cd7 100644 --- a/mediator/med_fraction_mod.F90 +++ b/mediator/med_fraction_mod.F90 @@ -2,7 +2,7 @@ module med_fraction_mod !----------------------------------------------------------------------------- ! Mediator Component. - ! Sets fracations on all component grids + ! Sets fractions on all component grids ! the fractions fields are now afrac, ifrac, ofrac, lfrac, and lfrin. ! afrac = fraction of atm on a grid ! lfrac = fraction of lnd on a grid @@ -141,24 +141,7 @@ module med_fraction_mod character(len=5),parameter,dimension(2) :: fraclist_r = (/'rfrac','lfrac'/) character(len=5),parameter,dimension(1) :: fraclist_w = (/'wfrac'/) - !--- standard --- - real(R8),parameter :: eps_fracsum = 1.0e-02 ! allowed error in sum of fracs - real(R8),parameter :: eps_fracval = 1.0e-02 ! allowed error in any frac +- 0,1 - real(R8),parameter :: eps_fraclim = 1.0e-03 ! truncation limit in fractions_a(lfrac) - logical ,parameter :: atm_frac_correct = .false. ! turn on frac correction on atm grid - - !--- standard plus atm fraction consistency --- - ! real(R8),parameter :: eps_fracsum = 1.0e-12 ! allowed error in sum of fracs - ! real(R8),parameter :: eps_fracval = 1.0e-02 ! allowed error in any frac +- 0,1 - ! real(R8),parameter :: eps_fraclim = 1.0e-03 ! truncation limit in fractions_a(lfrac) - ! logical ,parameter :: atm_frac_correct = .true. ! turn on frac correction on atm grid - - !--- unconstrained and area conserving? --- - ! real(R8),parameter :: eps_fracsum = 1.0e-12 ! allowed error in sum of fracs - ! real(R8),parameter :: eps_fracval = 1.0e-02 ! allowed error in any frac +- 0,1 - ! real(R8),parameter :: eps_fraclim = 1.0e-20 ! truncation limit in fractions_a(lfrac) - ! logical ,parameter :: atm_frac_correct = .true. ! turn on frac correction on atm grid - + real(R8) , parameter :: eps_fraclim = 1.0e-03 ! truncation limit in fractions_a(lfrac) character(*), parameter :: u_FILE_u = & __FILE__ @@ -174,9 +157,10 @@ subroutine med_fraction_init(gcomp, rc) use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_GridCompGet, ESMF_StateIsCreated use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleIsCreated, ESMF_FieldBundleDestroy + use esmFlds , only : coupling_mode use esmFlds , only : compatm, compocn, compice, complnd use esmFlds , only : comprof, compglc, compwav, compname - use esmFlds , only : mapconsf, mapfcopy + use esmFlds , only : mapconsf, mapfcopy, mapnstod_consf use med_map_mod , only : med_map_Fractions_init, med_map_RH_is_created use med_internalstate_mod , only : InternalState use perf_mod , only : t_startf, t_stopf @@ -273,13 +257,13 @@ subroutine med_fraction_init(gcomp, rc) maptype = mapfcopy else maptype = mapconsf - if (.not. med_map_RH_is_created(is_local%wrap%RH(compatm,n,:),mapconsf, rc=rc)) then - call med_map_Fractions_init( gcomp, compatm, n, & - FBSrc=is_local%wrap%FBImp(compatm,compatm), & - FBDst=is_local%wrap%FBImp(compatm,n), & - RouteHandle=is_local%wrap%RH(compatm,n,mapconsf), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + end if + if (.not. med_map_RH_is_created(is_local%wrap%RH(compatm,n,:),mapconsf, rc=rc)) then + call med_map_Fractions_init( gcomp, compatm, n, & + FBSrc=is_local%wrap%FBImp(compatm,compatm), & + FBDst=is_local%wrap%FBImp(compatm,n), & + RouteHandle=is_local%wrap%RH(compatm,n,mapconsf), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if call FB_FieldRegrid(& is_local%wrap%FBfrac(compatm), 'afrac', & @@ -359,7 +343,7 @@ subroutine med_fraction_init(gcomp, rc) end if !--------------------------------------- - ! Set 'ifrac' in FBFrac(compice) and BFrac(compatm) + ! Set 'ifrac' in FBFrac(compice) and FBFrac(compatm) !--------------------------------------- if (is_local%wrap%comp_present(compice)) then @@ -425,7 +409,6 @@ subroutine med_fraction_init(gcomp, rc) end if end if - !--------------------------------------- ! Set 'lfrac' in FBFrac(compatm) and correct 'ofrac' in FBFrac(compatm) ! --------------------------------------- @@ -443,17 +426,11 @@ subroutine med_fraction_init(gcomp, rc) if (.not. is_local%wrap%comp_present(complnd)) then lfrac(:) = 0.0_R8 - if (atm_frac_correct) then - ofrac(:) = 1.0_R8 - end if else do n = 1,size(lfrac) lfrac(n) = 1.0_R8 - ofrac(n) if (abs(lfrac(n)) < eps_fraclim) then lfrac(n) = 0.0_R8 - if (atm_frac_correct) then - ofrac(n) = 1.0_R8 - end if end if end do end if @@ -469,9 +446,6 @@ subroutine med_fraction_init(gcomp, rc) ofrac(n) = 1.0_R8 - lfrac(n) if (abs(ofrac(n)) < eps_fraclim) then ofrac(n) = 0.0_R8 - if (atm_frac_correct) then - lfrac(n) = 1.0_R8 - endif end if end do @@ -627,7 +601,7 @@ subroutine med_fraction_set(gcomp, rc) use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_REGION_TOTAL, ESMF_REGION_SELECT use esmFlds , only : compatm, compocn, compice, compname - use esmFlds , only : mapconsf, mapnstod, mapfcopy + use esmFlds , only : mapconsf, mapnstod, mapfcopy, mapnstod_consf use esmFlds , only : coupling_mode use med_internalstate_mod , only : InternalState use med_map_mod , only : med_map_Fractions_init, med_map_RH_is_created @@ -641,7 +615,6 @@ subroutine med_fraction_set(gcomp, rc) type(InternalState) :: is_local real(r8), pointer :: lfrac(:) real(r8), pointer :: ifrac(:) - real(r8), pointer :: ifrac_nstod(:) real(r8), pointer :: ofrac(:) real(r8), pointer :: Si_ifrac(:) real(r8), pointer :: Si_imask(:) @@ -649,6 +622,7 @@ subroutine med_fraction_set(gcomp, rc) integer :: dbrc integer :: maptype character(len=*),parameter :: subname='(med_fraction_set)' + !--------------------------------------- call t_startf('MED:'//subname) @@ -708,7 +682,7 @@ subroutine med_fraction_set(gcomp, rc) call FB_getFldPtr(is_local%wrap%FBImp(compice,compice) , 'Si_ifrac', Si_ifrac, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_getFldPtr(is_local%wrap%FBImp(compice,compice) , 'Si_imask' , Si_imask, rc=rc) + call FB_getFldPtr(is_local%wrap%FBImp(compice,compice) , 'Si_imask', Si_imask, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ifrac', ifrac, rc=rc) @@ -719,12 +693,8 @@ subroutine med_fraction_set(gcomp, rc) ! set ifrac = Si_ifrac * Si_imask ifrac(:) = Si_ifrac(:) * Si_imask(:) - if (trim(coupling_mode) == 'nems_orig') then - ofrac(:) = 1._r8 - ifrac(:) - else - ! set ofrac = Si_imask - ifrac - ofrac(:) = Si_imask(:) - ifrac(:) - end if + ! set ofrac = Si_imask - ifrac + ofrac(:) = Si_imask(:) - ifrac(:) ! ------------------------------------------- ! Set FBfrac(compocn) @@ -753,37 +723,26 @@ subroutine med_fraction_set(gcomp, rc) ! ------------------------------------------- if (is_local%wrap%comp_present(compatm)) then - if (trim(coupling_mode) == 'nems_orig') then + if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_frac' ) then - ! Map 'ifrac' from FBfrac(compice) to FBfrac(compatm) - call FB_FieldRegrid(& - is_local%wrap%FBfrac(compice), 'ifrac', & - is_local%wrap%FBfrac(compatm), 'ifrac', & - is_local%wrap%RH(compice,compatm,:),mapnstod, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ifrac', ifrac_nstod, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Set maptype according to coupling_mode + if (trim(coupling_mode) == 'nems_orig' ) then + maptype = mapnstod_consf + else + maptype = mapconsf + end if - call FB_FieldRegrid(& - is_local%wrap%FBfrac(compice), 'ifrac', & - is_local%wrap%FBfrac(compatm), 'ifrac', & - is_local%wrap%RH(compice,compatm,:),mapconsf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_FieldRegrid(& + is_local%wrap%FBfrac(compice), 'ifrac', & + is_local%wrap%FBfrac(compatm), 'ifrac', & + is_local%wrap%RH(compice,compatm,:),maptype, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Determine ifrac on atm grid - call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ifrac', ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - where (ifrac .eq. 0.0_R8 .and. abs(ifrac_nstod) .gt. 0.0_R8) - ifrac = ifrac_nstod - endwhere - - ! Determine ofrac and lfrac on atm grid - set ofrac=1-ifrac and lfrac=0 - call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ofrac', ofrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'lfrac', lfrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ofrac(:) = 1.0_R8 - ifrac(:) - lfrac(:) = 0.0_R8 + call FB_FieldRegrid(& + is_local%wrap%FBfrac(compice), 'ofrac', & + is_local%wrap%FBfrac(compatm), 'ofrac', & + is_local%wrap%RH(compice,compatm,:),maptype, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else @@ -813,29 +772,6 @@ subroutine med_fraction_set(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! Note: 'lfrac' from FBFrac(compatm) is just going to be in the init - if ( is_local%wrap%med_coupling_active(compice,compatm) .and. & - is_local%wrap%med_coupling_active(compocn,compatm) ) then - - if (atm_frac_correct) then - call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ifrac', ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ofrac', ofrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'lfrac', lfrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - where (ifrac + ofrac > 0.0_R8) - ifrac = ifrac * ((1.0_R8 - lfrac)/(ofrac+ifrac)) - ofrac = ofrac * ((1.0_R8 - lfrac)/(ofrac+ifrac)) - elsewhere - ifrac = 0.0_R8 - ofrac = 0.0_R8 - end where - endif - endif - end if end if end if diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index bc5ce20f7..e0aafb600 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -161,7 +161,7 @@ subroutine med_map_RouteHandles_init(gcomp, llogunit, rc) srcMaskValue = ispval_mask if (n1 == compocn .or. n1 == compice) srcMaskValue = 0 if (n2 == compocn .or. n2 == compice) dstMaskValue = 0 - else if (coupling_mode(1:5) == 'nems_') then + else if (coupling_mode(1:4) == 'nems') then if (n1 == compatm .and. (n2 == compocn .or. n2 == compice)) then srcMaskValue = 1 dstMaskValue = 0 @@ -225,7 +225,7 @@ subroutine med_map_RouteHandles_init(gcomp, llogunit, rc) if (mastertask) then write(llogunit,'(3A)') subname,trim(string),' RH redist ' end if - call ESMF_LogWrite(trim(subname) // trim(string) // ' RH redist ', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname // trim(string) // ' RH redist ', ESMF_LOGMSG_INFO) call ESMF_FieldRedistStore(fldsrc, flddst, & routehandle=is_local%wrap%RH(n1,n2,mapindex), & ignoreUnmatchedIndices = .true., rc=rc) @@ -572,7 +572,7 @@ subroutine med_map_MapNorm_init(gcomp, llogunit, rc) if (dbug_flag > 1) then write(cn1,'(i1)') n1; write(cn2,'(i1)') n2; write(cm ,'(i1)') m call ESMF_LogWrite(trim(subname)//":"//'creating FBMapNormOne for '& - //compname(n1)//'->'//compname(n2)//'with mapping '//mapnames(m), & + //compname(n1)//'->'//compname(n2)//' with mapping '//mapnames(m), & ESMF_LOGMSG_INFO) endif call FB_init(FBout=is_local%wrap%FBNormOne(n1,n2,m), & diff --git a/mediator/med_merge_mod.F90 b/mediator/med_merge_mod.F90 index 3fa8daf17..c0bf98c9c 100644 --- a/mediator/med_merge_mod.F90 +++ b/mediator/med_merge_mod.F90 @@ -287,7 +287,7 @@ subroutine med_merge_auto_field(merge_type, FBout, FBoutfld, FB, FBfld, FBw, fld if (chkerr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 1) then write(msg,*)trim(subname),'input field ',trim(FBfld),' has rank ',lrank_input - call ESMF_LogWrite(msg, ESMF_LOGMSG_ERROR) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO) end if if (lrank_input == 1) then diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index 8061a1752..649f8eb3c 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -163,7 +163,7 @@ subroutine med_methods_FB_RWFields(mode,fname,FB,flag,rc) enddo call med_methods_FB_diagnose(FB, 'read '//trim(fname), rc) - if (present(flag)) flag = .true. + if (present(flag)) flag = .true. endif else diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index a2ffe9371..f4f60f09f 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -427,7 +427,6 @@ subroutine med_phases_history_write(gcomp, rc) call med_io_write(hist_file, iam, is_local%wrap%FBMed_ocnalb_o, & nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='Med_alb_ocn', rc=rc) end if - !TODO: don't write aoflux_(oa) when they're not being used if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_o,rc=rc)) then nx = is_local%wrap%nx(compocn) ny = is_local%wrap%ny(compocn) diff --git a/mediator/med_phases_prep_atm_mod.F90 b/mediator/med_phases_prep_atm_mod.F90 index c690ea02a..dc5ebf4bd 100644 --- a/mediator/med_phases_prep_atm_mod.F90 +++ b/mediator/med_phases_prep_atm_mod.F90 @@ -138,7 +138,6 @@ subroutine med_phases_prep_atm(gcomp, rc) ! Assumption here is that fluxes are computed on the ocean grid if (trim(coupling_mode) == 'cesm' .or. & - trim(coupling_mode) == 'nems_orig' .or. & trim(coupling_mode) == 'hafs') then call med_map_FB_Regrid_Norm(& fldsSrc=fldListMed_aoflux%flds, & @@ -162,13 +161,7 @@ subroutine med_phases_prep_atm(gcomp, rc) FBMed1=is_local%wrap%FBMed_ocnalb_a, & FBMed2=is_local%wrap%FBMed_aoflux_a, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - else if (trim(coupling_mode) == 'nems_orig') then - call med_merge_auto(trim(compname(compatm)), & - is_local%wrap%FBExp(compatm), is_local%wrap%FBFrac(compatm), & - is_local%wrap%FBImp(:,compatm), fldListTo(compatm), & - FBMed1=is_local%wrap%FBMed_aoflux_a, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else if (trim(coupling_mode) == 'nems_frac') then + else if (trim(coupling_mode) == 'nems_frac' .or. trim(coupling_mode) == 'nems_orig') then call med_merge_auto(trim(compname(compatm)), & is_local%wrap%FBExp(compatm), is_local%wrap%FBFrac(compatm), & is_local%wrap%FBImp(:,compatm), fldListTo(compatm), rc=rc) diff --git a/mediator/med_phases_prep_ice_mod.F90 b/mediator/med_phases_prep_ice_mod.F90 index e6a5e95f7..f4045f507 100644 --- a/mediator/med_phases_prep_ice_mod.F90 +++ b/mediator/med_phases_prep_ice_mod.F90 @@ -169,6 +169,7 @@ subroutine med_phases_prep_ice(gcomp, rc) call ESMF_StateGet(is_local%wrap%NStateImp(compatm), trim(is_local%wrap%flds_scalar_name), itemType, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (itemType /= ESMF_STATEITEM_NOTFOUND) then + if (is_local%wrap%flds_scalar_index_nextsw_cday .ne. 0) then ! send nextsw_cday to ice - first obtain it from atm import call State_GetScalar(& scalar_value=nextsw_cday, & @@ -184,6 +185,7 @@ subroutine med_phases_prep_ice(gcomp, rc) flds_scalar_name=is_local%wrap%flds_scalar_name, & flds_scalar_num=is_local%wrap%flds_scalar_num, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + end if end if !--------------------------------------- diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90 index 3076eab37..d182fe998 100644 --- a/mediator/med_phases_prep_ocn_mod.F90 +++ b/mediator/med_phases_prep_ocn_mod.F90 @@ -33,6 +33,10 @@ module med_phases_prep_ocn_mod public :: med_phases_prep_ocn_accum_fast public :: med_phases_prep_ocn_accum_avg + private :: med_phases_prep_ocn_custom_cesm + private :: med_phases_prep_ocn_custom_nems + private :: med_phases_prep_ocn_custom_nemsdata + character(*), parameter :: u_FILE_u = & __FILE__ @@ -46,10 +50,8 @@ subroutine med_phases_prep_ocn_map(gcomp, rc) ! Map all fields in from relevant source components to the ocean grid !--------------------------------------- - use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO,ESMF_SUCCESS - use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet, ESMF_ClockPrint - use ESMF , only : ESMF_FieldBundleGet + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS ! input/output variables type(ESMF_GridComp) :: gcomp @@ -58,37 +60,29 @@ subroutine med_phases_prep_ocn_map(gcomp, rc) ! local variables type(InternalState) :: is_local integer :: n1, ncnt - integer :: dbrc character(len=*), parameter :: subname='(med_phases_prep_ocn_map)' !------------------------------------------------------------------------------- + rc = ESMF_SUCCESS + call t_startf('MED:'//subname) if (dbug_flag > 20) then - call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=dbrc) + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) end if - rc = ESMF_SUCCESS call memcheck(subname, 5, mastertask) - !--------------------------------------- - ! --- Get the internal state - !--------------------------------------- - + ! Get the internal state nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! --- Count the number of fields outside of scalar data, if zero, then return - !--------------------------------------- + ! Count the number of fields outside of scalar data, if zero, then return call FB_getNumFlds(is_local%wrap%FBExp(compocn), trim(subname)//"FBexp(compocn)", ncnt, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ncnt > 0) then - !--------------------------------------- - !--- map all fields in FBImp that have active ocean coupling to the ocean grid - !--------------------------------------- - + ! map all fields in FBImp that have active ocean coupling to the ocean grid do n1 = 1,ncomps if (is_local%wrap%med_coupling_active(n1,compocn)) then call med_map_FB_Regrid_Norm( & @@ -107,17 +101,15 @@ subroutine med_phases_prep_ocn_map(gcomp, rc) call t_stopf('MED:'//subname) if (dbug_flag > 20) then - call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=dbrc) + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO) end if end subroutine med_phases_prep_ocn_map !----------------------------------------------------------------------------- - subroutine med_phases_prep_ocn_merge(gcomp, rc) - use ESMF , only : ESMF_GridComp, ESMF_FieldBundleGet - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_GridComp, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR ! input/output variables @@ -127,78 +119,34 @@ subroutine med_phases_prep_ocn_merge(gcomp, rc) ! local variables type(InternalState) :: is_local integer :: n, ncnt - real(R8) :: c1,c2,c3,c4 - real(R8), pointer :: dataptr(:) - real(R8), pointer :: dataptr_o(:) - real(R8), pointer :: ifrac(:), ofrac(:) - real(R8), pointer :: ifracr(:), ofracr(:) - real(R8), pointer :: avsdr(:), avsdf(:) - real(R8), pointer :: anidr(:), anidf(:) - real(R8), pointer :: Faxa_swvdf(:), Faxa_swndf(:) - real(R8), pointer :: Faxa_swvdr(:), Faxa_swndr(:) - real(R8), pointer :: Foxx_swnet(:) - real(R8), pointer :: Foxx_swnet_afracr(:) - real(R8), pointer :: Foxx_swnet_vdr(:), Foxx_swnet_vdf(:) - real(R8), pointer :: Foxx_swnet_idr(:), Foxx_swnet_idf(:) - real(R8), pointer :: Fioi_swpen_vdr(:), Fioi_swpen_vdf(:) - real(R8), pointer :: Fioi_swpen_idr(:), Fioi_swpen_idf(:) - real(R8), pointer :: Fioi_swpen(:) - real(R8) :: ifrac_scaled, ofrac_scaled - real(R8) :: ifracr_scaled, ofracr_scaled - real(R8) :: frac_sum - real(R8) :: albvis_dir, albvis_dif - real(R8) :: albnir_dir, albnir_dif - real(R8) :: fswabsv, fswabsi - logical :: export_swnet_by_bands - logical :: import_swpen_by_bands - logical :: export_swnet_afracr - logical :: first_precip_fact_call = .true. - real(R8) :: precip_fact - integer :: lsize - integer :: dbrc - character(CS) :: cvalue - real(R8), pointer :: ocnwgt1(:) ! NEMS_orig_data - real(R8), pointer :: icewgt1(:) ! NEMS_orig_data - real(R8), pointer :: wgtp01(:) ! NEMS_orig_data - real(R8), pointer :: wgtm01(:) ! NEMS_orig_data - real(R8), pointer :: customwgt(:) ! NEMS_orig_data - character(len=64), allocatable :: fldnames(:) - real(R8) , parameter :: const_lhvap = 2.501e6_R8 ! latent heat of evaporation ~ J/kg - real(R8) , parameter :: albdif = 0.06_r8 ! 60 deg reference albedo, diffuse character(len=*), parameter :: subname='(med_phases_prep_ocn_merge)' - logical :: compare_to_mct = .false. ! Set the following to true if want to compare directly to MCT !--------------------------------------- call t_startf('MED:'//subname) if (dbug_flag > 20) then - call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=dbrc) + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) end if rc = ESMF_SUCCESS call memcheck(subname, 5, mastertask) - !--------------------------------------- - ! --- Get the internal state - !--------------------------------------- - + ! Get the internal state nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! --- Count the number of fields outside of scalar data, if zero, then return - !--------------------------------------- - + ! Count the number of fields outside of scalar data, if zero, then return call FB_getNumFlds(is_local%wrap%FBExp(compocn), trim(subname)//"FBexp(compocn)", ncnt, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ncnt > 0) then !--------------------------------------- - !--- auto merges to ocn + ! merges to ocean !--------------------------------------- + ! auto merges to ocn if (trim(coupling_mode) == 'cesm' .or. & - trim(coupling_mode) == 'nems_orig_data' .or. & + trim(coupling_mode) == 'nems_orig_data' .or. & trim(coupling_mode) == 'hafs') then call med_merge_auto(trim(compname(compocn)), & is_local%wrap%FBExp(compocn), is_local%wrap%FBFrac(compocn), & @@ -212,415 +160,40 @@ subroutine med_phases_prep_ocn_merge(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - !--------------------------------------- - !--- custom calculations - !--------------------------------------- - + ! custom merges to ocean if (trim(coupling_mode) == 'cesm' .or. trim(coupling_mode) == 'hafs') then - - !------------- - ! Compute netsw for ocean - !------------- - - ! netsw_for_ocn = downsw_from_atm * (1-ocn_albedo) * (1-ice_fraction) + pensw_from_ice * (ice_fraction) - - ! Input from atm - call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swvdr', Faxa_swvdr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swndr', Faxa_swndr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swvdf', Faxa_swvdf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swndf', Faxa_swndf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - lsize = size(Faxa_swvdr) - - ! Input from mediator, ice-covered ocean and open ocean fractions - call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ifrac' , ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ofrac' , ofrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Input from mediator, ocean albedos - call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_avsdr' , avsdr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_anidr' , anidr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_avsdf' , avsdf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_anidf' , anidf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ifrad' , ifracr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ofrad' , ofracr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Input from ice - if (is_local%wrap%comp_present(compice)) then - call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen', Fioi_swpen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (FB_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', rc=rc)) then - import_swpen_by_bands = .true. - call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_vdr', Fioi_swpen_vdr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_vdf', Fioi_swpen_vdf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_idr', Fioi_swpen_idr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_idf', Fioi_swpen_idf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - import_swpen_by_bands = .false. - end if - end if - - ! Output to ocean swnet - if (FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet', rc=rc)) then - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet', Foxx_swnet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - lsize = size(Faxa_swvdr) - allocate(Foxx_swnet(lsize)) - end if - - ! Output to ocean swnet by radiation bands - if (FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', rc=rc)) then - export_swnet_by_bands = .true. - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', Foxx_swnet_vdr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', Foxx_swnet_vdf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', Foxx_swnet_idr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', Foxx_swnet_idf, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - export_swnet_by_bands = .false. - end if - - ! Swnet without swpen from sea-ice - if ( FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_afracr',rc=rc)) then - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_afracr', Foxx_swnet_afracr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - export_swnet_afracr = .true. - else - export_swnet_afracr = .false. - end if - - do n = 1,lsize - - ! Determine ocean albedos - albvis_dir = avsdr(n) - albvis_dif = avsdf(n) - albnir_dir = anidr(n) - albnir_dif = anidf(n) - - ! Compute total swnet to ocean independent of swpen from sea-ice - fswabsv = Faxa_swvdr(n) * (1.0_R8 - albvis_dir) + Faxa_swvdf(n) * (1.0_R8 - albvis_dif) - fswabsi = Faxa_swndr(n) * (1.0_R8 - albnir_dir) + Faxa_swndf(n) * (1.0_R8 - albnir_dif) - Foxx_swnet(n) = fswabsv + fswabsi - - ! Add swpen from sea ice if sea ice is present - if (is_local%wrap%comp_present(compice)) then - - ifrac_scaled = ifrac(n) - ofrac_scaled = ofrac(n) - frac_sum = ifrac(n) + ofrac(n) - if (frac_sum /= 0._R8) then - ifrac_scaled = ifrac(n) / (frac_sum) - ofrac_scaled = ofrac(n) / (frac_sum) - endif - - ifracr_scaled = ifracr(n) - ofracr_scaled = ofracr(n) - frac_sum = ifracr(n) + ofracr(n) - if (frac_sum /= 0._R8) then - ifracr_scaled = ifracr(n) / (frac_sum) - ofracr_scaled = ofracr(n) / (frac_sum) - endif - - Foxx_swnet(n) = ofracr_scaled*(fswabsv + fswabsi) + ifrac_scaled*Fioi_swpen(n) - - if (export_swnet_afracr) then - Foxx_swnet_afracr(n) = ofracr_scaled*(fswabsv + fswabsi) - end if - - ! To compare to mct - if (compare_to_mct) then - c1 = 0.285 - c2 = 0.285 - c3 = 0.215 - c4 = 0.215 - Foxx_swnet_vdr(n) = c1 * Foxx_swnet(n) - Foxx_swnet_vdf(n) = c2 * Foxx_swnet(n) - Foxx_swnet_idr(n) = c3 * Foxx_swnet(n) - Foxx_swnet_idf(n) = c4 * Foxx_swnet(n) - else - if (export_swnet_by_bands) then - if (import_swpen_by_bands) then - ! use each individual band for swpen coming from the sea-ice - Foxx_swnet_vdr(n) = Faxa_swvdr(n)*(1.0_R8-albvis_dir)*ofracr_scaled + Fioi_swpen_vdr(n)*ifrac_scaled - Foxx_swnet_vdf(n) = Faxa_swvdf(n)*(1.0_R8-albvis_dif)*ofracr_scaled + Fioi_swpen_vdf(n)*ifrac_scaled - Foxx_swnet_idr(n) = Faxa_swndr(n)*(1.0_R8-albnir_dir)*ofracr_scaled + Fioi_swpen_idr(n)*ifrac_scaled - Foxx_swnet_idf(n) = Faxa_swndf(n)*(1.0_R8-albnir_dif)*ofracr_scaled + Fioi_swpen_idf(n)*ifrac_scaled - else - ! scale total Foxx_swnet to get contributions from each band - c1 = 0.285 - c2 = 0.285 - c3 = 0.215 - c4 = 0.215 - Foxx_swnet_vdr(n) = c1 * Foxx_swnet(n) - Foxx_swnet_vdf(n) = c2 * Foxx_swnet(n) - Foxx_swnet_idr(n) = c3 * Foxx_swnet(n) - Foxx_swnet_idf(n) = c4 * Foxx_swnet(n) - end if - end if - end if - - end if ! if sea-ice is present - end do - - ! Deallocate Foxx_swnet if it was allocated in this subroutine - if (.not. FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet', rc=rc)) then - deallocate(Foxx_swnet) - end if - - ! Output to ocean per ice thickness fraction and sw penetrating into ocean - if ( FB_fldchk(is_local%wrap%FBExp(compocn), 'Sf_afrac', rc=rc)) then - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Sf_afrac', fldptr1=dataptr_o, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - dataptr_o(:) = ofrac(:) - end if - if ( FB_fldchk(is_local%wrap%FBExp(compocn), 'Sf_afracr', rc=rc)) then - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Sf_afracr', fldptr1=dataptr_o, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - dataptr_o(:) = ofracr(:) - end if - - !------------- - ! application of precipitation factor from ocean - !------------- - precip_fact = 1.0_R8 - if (precip_fact /= 1.0_R8) then - if (first_precip_fact_call .and. mastertask) then - write(logunit,'(a)')'(merge_to_ocn): Scaling rain, snow, liquid and ice runoff by precip_fact ' - first_precip_fact_call = .false. - end if - write(cvalue,*) precip_fact - call ESMF_LogWrite(trim(subname)//" precip_fact is "//trim(cvalue), ESMF_LOGMSG_INFO, rc=dbrc) - - allocate(fldnames(4)) - fldnames = (/'Faxa_rain','Faxa_snow', 'Foxx_rofl', 'Foxx_rofi'/) - do n = 1,size(fldnames) - if (FB_fldchk(is_local%wrap%FBExp(compocn), trim(fldnames(n)), rc=rc)) then - call FB_GetFldPtr(is_local%wrap%FBExp(compocn), trim(fldnames(n)) , dataptr, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - dataptr(:) = dataptr(:) * precip_fact - end if - end do - deallocate(fldnames) - end if - end if - - !------------- - ! Custom calculation for nems_orig or nems_frac - !------------- - - if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_frac') then - - ! get ice and open ocean fractions on the ocn mesh - call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ifrac' , ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ofrac' , ofrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - lsize = size(ofrac) - allocate(customwgt(lsize)) - - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_rain', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_rain' , wgtA=ofrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_snow', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_snow' , wgtA=ofrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_lwnet', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_lwnet', wgtA=ofrac, rc=rc) + call med_phases_prep_ocn_custom_cesm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - - customwgt(:) = -ofrac(:) / const_lhvap - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_evap', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_lat' , wgtA=customwgt, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - customwgt(:) = -ofrac(:) - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_sen', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_sen', wgtA=customwgt, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_taux', & - FBinA=is_local%wrap%FBImp(compice,compocn), fnameA='Fioi_taux' , wgtA=ifrac, & - FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_taux' , wgtB=customwgt, rc=rc) + else if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_frac') then + call med_phases_prep_ocn_custom_nems(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_tauy', & - FBinA=is_local%wrap%FBImp(compice,compocn), fnameA='Fioi_tauy' , wgtA=ifrac, & - FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_tauy' , wgtB=customwgt, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - - ! netsw_for_ocn = [downsw_from_atm*(1-ice_fraction)*(1-ocn_albedo)] + [pensw_from_ice*(ice_fraction)] - customwgt(:) = ofrac(:) * (1.0 - 0.06) - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swvdr' , wgtA=customwgt, & - FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_vdr', wgtB=ifrac, rc=rc) + else if (trim(coupling_mode) == 'nems_orig_data') then + call med_phases_prep_ocn_custom_nemsdata(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swvdf' , wgtA=customwgt, & - FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_vdf', wgtB=ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swndr' , wgtA=customwgt, & - FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_idr', wgtB=ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', & - FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swndf' , wgtA=customwgt, & - FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_idf', wgtB=ifrac, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - deallocate(customwgt) - - end if ! end of nems_orig or nems_frac - - !------------- - ! Custom calculation for nems_orig_data - !------------- - - if (trim(coupling_mode) == 'nems_orig_data') then - - ! open ocean (i.e. atm) and ice fraction - ! ocnwgt and icewgt are the "normal" fractions - ! ocnwgt1, icewgt1, and wgtp01 are the fractions that switch between atm and mediator fluxes - ! ocnwgt1+icewgt1+wgtp01 = 1.0 always - ! wgtp01 and wgtm01 are the same just one is +1 and the other is -1 to change sign depending on the ice fraction. - ! wgtp01 = 1 and wgtm01 = -1 when ice fraction = 0 - ! wgtp01 = 0 and wgtm01 = 0 when ice fraction > 0 - - allocate(ocnwgt1(lsize)) - allocate(icewgt1(lsize)) - allocate(wgtp01(lsize)) - allocate(wgtm01(lsize)) - allocate(customwgt(lsize)) - - do n = 1,lsize - if (ifrac(n) <= 0._R8) then - ! ice fraction is 0 - ocnwgt1(n) = 0.0_R8 - icewgt1(n) = 0.0_R8 - wgtp01(n) = 1.0_R8 - wgtm01(n) = -1.0_R8 - else - ! ice fraction is > 0 - ocnwgt1(n) = ofrac(n) - icewgt1(n) = ifrac(n) - wgtp01(n) = 0.0_R8 - wgtm01(n) = 0.0_R8 - end if - - ! check wgts do add to 1 as expected - if ( abs( ofrac(n) + ifrac(n) - 1.0_R8) > 1.0e-12 .or. & - abs( ocnwgt1(n) + icewgt1(n) + wgtp01(n) - 1.0_R8) > 1.0e-12 .or. & - abs( ocnwgt1(n) + icewgt1(n) - wgtm01(n) - 1.0_R8) > 1.0e-12) then - - write(6,100)trim(subname)//'ERROR: n, ofrac, ifrac, sum',& - n,ofrac(n),ifrac(n),ofrac(n)+ifrac(n) - write(6,101)trim(subname)//'ERROR: n, ocnwgt1, icewgt1, wgtp01, sum ', & - n,ocnwgt1(n),icewgt1(n),wgtp01(n),ocnwgt1(n)+icewgt1(n)+wgtp01(n) - write(6,101)trim(subname)//'ERROR: n, ocnwgt1, icewgt1, -wgtm01, sum ', & - n,ocnwgt1(n),icewgt1(n),-wgtp01(n),ocnwgt1(n)+icewgt1(n)-wgtm01(n) -100 format(a,i8,2x,3(d20.13,2x)) -101 format(a,i8,2x,4(d20.13,2x)) - - call ESMF_LogWrite(trim(subname)//": ERROR atm + ice fracs inconsistent", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__, rc=dbrc) - rc = ESMF_FAILURE - return - endif - end do - - customwgt(:) = wgtm01(:) / const_lhvap - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_evap', & - FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_evap', wgtA=ocnwgt1, & - FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_lat' , wgtB=customwgt, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_sen', & - FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_sen ', wgtA=ocnwgt1, & - FBinC=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_sen' , wgtB=wgtm01, rc=rc) - - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_taux', & - FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_taux ', wgtA=ocnwgt1, & - FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_taux' , wgtB=icewgt1, & - FBinC=is_local%wrap%FBImp(compatm,compocn), fnameC='Faxa_taux' , wgtC=wgtm01, rc=rc) - - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_tauy', & - FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_tauy ', wgtA=ocnwgt1, & - FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_tauy' , wgtB=icewgt1, & - FBinC=is_local%wrap%FBImp(compatm,compocn), fnameC='Faxa_tauy' , wgtC=wgtm01, rc=rc) - - ! If there is no ice on the ocn gridcell (ocnwgt1=0) - sum Faxa_lwdn and Faxa_lwup - ! If there is ice on the ocn gridcell - merge Faox_lwup and Faxa_lwdn and ignore Faxa_lwup - call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_lwnet', & - FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_lwup ', wgtA=ocnwgt1, & - FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_lwdn' , wgtB=ocnwgt1, & - FBinC=is_local%wrap%FBImp(compatm,compocn), fnameC='Faxa_lwnet', wgtC=wgtp01, rc=rc) - - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_rain' , & - FBInA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_rain' , wgtA=ofrac, rc=rc) - - call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_snow' , & - FBInA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_snow' , wgtA=ofrac, rc=rc) - - deallocate(ocnwgt1) - deallocate(icewgt1) - deallocate(wgtp01) - deallocate(wgtm01) - deallocate(customwgt) - end if ! end of nems_orig_data custom - !--------------------------------------- - !--- diagnose output - !--------------------------------------- - + ! diagnose output if (dbug_flag > 1) then - call FB_diagnose(is_local%wrap%FBExp(compocn), & - string=trim(subname)//' FBexp(compocn) ', rc=rc) + call FB_diagnose(is_local%wrap%FBExp(compocn), string=trim(subname)//' FBexp(compocn) ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - ! TODO (mvertens, 2018-12-16): document above custom calculation - - !--------------------------------------- - !--- clean up - !--------------------------------------- - endif if (dbug_flag > 20) then - call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO, rc=dbrc) + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if call t_stopf('MED:'//subname) end subroutine med_phases_prep_ocn_merge !----------------------------------------------------------------------------- - subroutine med_phases_prep_ocn_accum_fast(gcomp, rc) ! Carry out fast accumulation for the ocean - use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_Clock, ESMF_Time use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet, ESMF_ClockPrint - use ESMF , only : ESMF_FieldBundleGet ! input/output variables type(ESMF_GridComp) :: gcomp @@ -629,39 +202,29 @@ subroutine med_phases_prep_ocn_accum_fast(gcomp, rc) ! local variables type(ESMF_Clock) :: clock type(ESMF_Time) :: time - character(len=64) :: timestr type(InternalState) :: is_local integer :: i,j,n,ncnt - integer :: dbrc character(len=*), parameter :: subname='(med_phases_accum_fast)' !--------------------------------------- - call t_startf('MED:'//subname) - if (dbug_flag > 20) then - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO, rc=dbrc) - endif rc = ESMF_SUCCESS - !--------------------------------------- - ! --- Get the internal state - !--------------------------------------- + call t_startf('MED:'//subname) + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + endif + ! Get the internal state nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! --- Count the number of fields outside of scalar data, if zero, then return - !--------------------------------------- + ! Count the number of fields outside of scalar data, if zero, then return call FB_getNumFlds(is_local%wrap%FBExp(compocn), trim(subname)//"FBexp(compocn)", ncnt, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ncnt > 0) then - - !--------------------------------------- - !--- ocean accumulator - !--------------------------------------- - + ! ocean accumulator call FB_accum(is_local%wrap%FBExpAccum(compocn), is_local%wrap%FBExp(compocn), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -672,96 +235,70 @@ subroutine med_phases_prep_ocn_accum_fast(gcomp, rc) string=trim(subname)//' FBExpAccum accumulation ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - - !--------------------------------------- - !--- clean up - !--------------------------------------- endif if (dbug_flag > 20) then - call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO, rc=dbrc) + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if call t_stopf('MED:'//subname) end subroutine med_phases_prep_ocn_accum_fast !----------------------------------------------------------------------------- - subroutine med_phases_prep_ocn_accum_avg(gcomp, rc) ! Prepare the OCN import Fields. - use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_FieldBundleGet + use ESMF , only : ESMF_GridComp, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS ! input/output variables type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc ! local variables - type(ESMF_Clock) :: clock - type(ESMF_Time) :: time - character(len=64) :: timestr type(InternalState) :: is_local - integer :: i,j,n,ncnt - integer :: dbrc + integer :: ncnt character(len=*),parameter :: subname='(med_phases_prep_ocn_accum_avg)' !--------------------------------------- - call t_startf('MED:'//subname) - if (dbug_flag > 20) then - call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO, rc=dbrc) - endif rc = ESMF_SUCCESS - !--------------------------------------- - ! --- Get the internal state - !--------------------------------------- + call t_startf('MED:'//subname) + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + endif + ! Get the internal state nullify(is_local%wrap) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! --- Count the number of fields outside of scalar data, if zero, then return - !--------------------------------------- + ! Count the number of fields outside of scalar data, if zero, then return call FB_getNumFlds(is_local%wrap%FBExpAccum(compocn), trim(subname)//"FBExpAccum(compocn)", ncnt, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (ncnt > 0) then - !--------------------------------------- - !--- average ocn accumulator - !--------------------------------------- - + ! average ocn accumulator if (dbug_flag > 1) then call FB_diagnose(is_local%wrap%FBExpAccum(compocn), & string=trim(subname)//' FBExpAccum(compocn) before avg ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - call FB_average(is_local%wrap%FBExpAccum(compocn), & is_local%wrap%FBExpAccumCnt(compocn), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (dbug_flag > 1) then call FB_diagnose(is_local%wrap%FBExp(compocn), & string=trim(subname)//' FBExpAccum(compocn) after avg ', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - !--------------------------------------- - !--- copy to FBExp(compocn) - !--------------------------------------- - + ! copy to FBExp(compocn) call FB_copy(is_local%wrap%FBExp(compocn), is_local%wrap%FBExpAccum(compocn), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - !--- zero accumulator - !--------------------------------------- - + ! zero accumulator is_local%wrap%FBExpAccumFlag(compocn) = .true. is_local%wrap%FBExpAccumCnt(compocn) = 0 call FB_reset(is_local%wrap%FBExpAccum(compocn), value=czero, rc=rc) @@ -770,10 +307,558 @@ subroutine med_phases_prep_ocn_accum_avg(gcomp, rc) end if if (dbug_flag > 20) then - call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO, rc=dbrc) + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if call t_stopf('MED:'//subname) end subroutine med_phases_prep_ocn_accum_avg + !----------------------------------------------------------------------------- + subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) + + !--------------------------------------- + ! custom calculations for cesm + !--------------------------------------- + + use ESMF , only : ESMF_GridComp + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + real(R8), pointer :: ifrac(:), ofrac(:) + real(R8), pointer :: ifracr(:), ofracr(:) + real(R8), pointer :: avsdr(:), avsdf(:) + real(R8), pointer :: anidr(:), anidf(:) + real(R8), pointer :: Faxa_swvdf(:), Faxa_swndf(:) + real(R8), pointer :: Faxa_swvdr(:), Faxa_swndr(:) + real(R8), pointer :: Foxx_swnet(:) + real(R8), pointer :: Foxx_swnet_afracr(:) + real(R8), pointer :: Foxx_swnet_vdr(:), Foxx_swnet_vdf(:) + real(R8), pointer :: Foxx_swnet_idr(:), Foxx_swnet_idf(:) + real(R8), pointer :: Fioi_swpen_vdr(:), Fioi_swpen_vdf(:) + real(R8), pointer :: Fioi_swpen_idr(:), Fioi_swpen_idf(:) + real(R8), pointer :: Fioi_swpen(:) + real(R8), pointer :: dataptr(:) + real(R8), pointer :: dataptr_o(:) + real(R8) :: frac_sum + real(R8) :: ifrac_scaled, ofrac_scaled + real(R8) :: ifracr_scaled, ofracr_scaled + logical :: export_swnet_by_bands + logical :: import_swpen_by_bands + logical :: export_swnet_afracr + logical :: first_precip_fact_call = .true. + real(R8) :: precip_fact + character(CS) :: cvalue + real(R8) :: fswabsv, fswabsi + integer :: n + integer :: lsize + real(R8) :: c1,c2,c3,c4 + character(len=64), allocatable :: fldnames(:) + character(len=*), parameter :: subname='(med_phases_prep_ocn_custom_cesm)' + !--------------------------------------- + + rc = ESMF_SUCCESS + + call t_startf('MED:'//subname) + if (dbug_flag > 20) then + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + end if + call memcheck(subname, 5, mastertask) + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------------------------------- + ! Compute netsw for ocean + !--------------------------------------- + ! netsw_for_ocn = downsw_from_atm * (1-ocn_albedo) * (1-ice_fraction) + pensw_from_ice * (ice_fraction) + + ! Input from atm + call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swvdr', Faxa_swvdr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swndr', Faxa_swndr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swvdf', Faxa_swvdf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBImp(compatm,compocn), 'Faxa_swndf', Faxa_swndf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + lsize = size(Faxa_swvdr) + + ! Input from mediator, ocean albedos + call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_avsdr' , avsdr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_anidr' , anidr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_avsdf' , avsdf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, 'So_anidf' , anidf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Output to ocean swnet total + if (FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet', rc=rc)) then + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet', Foxx_swnet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + lsize = size(Faxa_swvdr) + allocate(Foxx_swnet(lsize)) + end if + + ! Output to ocean swnet by radiation bands + if (FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', rc=rc)) then + export_swnet_by_bands = .true. + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', Foxx_swnet_vdr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', Foxx_swnet_vdf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', Foxx_swnet_idr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', Foxx_swnet_idf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + export_swnet_by_bands = .false. + end if + + ! ----------------------- + ! If cice IS NOT PRESENT + ! ----------------------- + if (.not. is_local%wrap%comp_present(compice)) then + ! Compute total swnet to ocean independent of swpen from sea-ice + do n = 1,lsize + fswabsv = Faxa_swvdr(n) * (1.0_R8 - avsdr(n)) + Faxa_swvdf(n) * (1.0_R8 - avsdf(n)) + fswabsi = Faxa_swndr(n) * (1.0_R8 - anidr(n)) + Faxa_swndf(n) * (1.0_R8 - anidf(n)) + Foxx_swnet(n) = fswabsv + fswabsi + end do + ! Compute sw export to ocean bands if required + if (export_swnet_by_bands) then + c1 = 0.285; c2 = 0.285; c3 = 0.215; c4 = 0.215 + Foxx_swnet_vdr(:) = c1 * Foxx_swnet(:) + Foxx_swnet_vdf(:) = c2 * Foxx_swnet(:) + Foxx_swnet_idr(:) = c3 * Foxx_swnet(:) + Foxx_swnet_idf(:) = c4 * Foxx_swnet(:) + end if + end if + + ! ----------------------- + ! If cice IS PRESENT + ! ----------------------- + if (is_local%wrap%comp_present(compice)) then + + ! Input from mediator, ice-covered ocean and open ocean fractions + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ifrac' , ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ofrac' , ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ifrad' , ifracr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ofrad' , ofracr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen', Fioi_swpen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (FB_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', rc=rc)) then + import_swpen_by_bands = .true. + call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_vdr', Fioi_swpen_vdr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_vdf', Fioi_swpen_vdf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_idr', Fioi_swpen_idr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBImp(compice,compocn), 'Fioi_swpen_idf', Fioi_swpen_idf, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + import_swpen_by_bands = .false. + end if + + ! Swnet without swpen from sea-ice + if ( FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_afracr',rc=rc)) then + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Foxx_swnet_afracr', Foxx_swnet_afracr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + export_swnet_afracr = .true. + else + export_swnet_afracr = .false. + end if + + do n = 1,lsize + ! Compute total swnet to ocean independent of swpen from sea-ice + fswabsv = Faxa_swvdr(n) * (1.0_R8 - avsdr(n)) + Faxa_swvdf(n) * (1.0_R8 - avsdf(n)) + fswabsi = Faxa_swndr(n) * (1.0_R8 - anidr(n)) + Faxa_swndf(n) * (1.0_R8 - anidf(n)) + Foxx_swnet(n) = fswabsv + fswabsi + + ! Add swpen from sea ice + ifrac_scaled = ifrac(n) + ofrac_scaled = ofrac(n) + frac_sum = ifrac(n) + ofrac(n) + if (frac_sum /= 0._R8) then + ifrac_scaled = ifrac(n) / (frac_sum) + ofrac_scaled = ofrac(n) / (frac_sum) + endif + ifracr_scaled = ifracr(n) + ofracr_scaled = ofracr(n) + frac_sum = ifracr(n) + ofracr(n) + if (frac_sum /= 0._R8) then + ifracr_scaled = ifracr(n) / (frac_sum) + ofracr_scaled = ofracr(n) / (frac_sum) + endif + Foxx_swnet(n) = ofracr_scaled*(fswabsv + fswabsi) + ifrac_scaled*Fioi_swpen(n) + + if (export_swnet_afracr) then + Foxx_swnet_afracr(n) = ofracr_scaled*(fswabsv + fswabsi) + end if + + ! Compute sw export to ocean bands if required + if (export_swnet_by_bands) then + if (import_swpen_by_bands) then + ! use each individual band for swpen coming from the sea-ice + Foxx_swnet_vdr(n) = Faxa_swvdr(n)*(1.0_R8-avsdr(n))*ofracr_scaled + Fioi_swpen_vdr(n)*ifrac_scaled + Foxx_swnet_vdf(n) = Faxa_swvdf(n)*(1.0_R8-avsdf(n))*ofracr_scaled + Fioi_swpen_vdf(n)*ifrac_scaled + Foxx_swnet_idr(n) = Faxa_swndr(n)*(1.0_R8-anidr(n))*ofracr_scaled + Fioi_swpen_idr(n)*ifrac_scaled + Foxx_swnet_idf(n) = Faxa_swndf(n)*(1.0_R8-anidf(n))*ofracr_scaled + Fioi_swpen_idf(n)*ifrac_scaled + else + ! scale total Foxx_swnet to get contributions from each band + c1 = 0.285; c2 = 0.285; c3 = 0.215; c4 = 0.215 + Foxx_swnet_vdr(n) = c1 * Foxx_swnet(n) + Foxx_swnet_vdf(n) = c2 * Foxx_swnet(n) + Foxx_swnet_idr(n) = c3 * Foxx_swnet(n) + Foxx_swnet_idf(n) = c4 * Foxx_swnet(n) + end if + end if + end do + + ! Output to ocean per ice thickness fraction and sw penetrating into ocean + if ( FB_fldchk(is_local%wrap%FBExp(compocn), 'Sf_afrac', rc=rc)) then + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Sf_afrac', fldptr1=dataptr_o, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + dataptr_o(:) = ofrac(:) + end if + if ( FB_fldchk(is_local%wrap%FBExp(compocn), 'Sf_afracr', rc=rc)) then + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Sf_afracr', fldptr1=dataptr_o, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + dataptr_o(:) = ofracr(:) + end if + + end if ! if sea-ice is present + + ! Deallocate Foxx_swnet if it was allocated in this subroutine + if (.not. FB_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet', rc=rc)) then + deallocate(Foxx_swnet) + end if + + !--------------------------------------- + ! application of precipitation factor from ocean + !--------------------------------------- + precip_fact = 1.0_R8 + if (precip_fact /= 1.0_R8) then + if (first_precip_fact_call .and. mastertask) then + write(logunit,'(a)')'(merge_to_ocn): Scaling rain, snow, liquid and ice runoff by precip_fact ' + first_precip_fact_call = .false. + end if + write(cvalue,*) precip_fact + call ESMF_LogWrite(trim(subname)//" precip_fact is "//trim(cvalue), ESMF_LOGMSG_INFO) + + allocate(fldnames(4)) + fldnames = (/'Faxa_rain','Faxa_snow', 'Foxx_rofl', 'Foxx_rofi'/) + do n = 1,size(fldnames) + if (FB_fldchk(is_local%wrap%FBExp(compocn), trim(fldnames(n)), rc=rc)) then + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), trim(fldnames(n)) , dataptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + dataptr(:) = dataptr(:) * precip_fact + end if + end do + deallocate(fldnames) + end if + + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + end if + call t_stopf('MED:'//subname) + + end subroutine med_phases_prep_ocn_custom_cesm + + !----------------------------------------------------------------------------- + subroutine med_phases_prep_ocn_custom_nems(gcomp, rc) + + ! ---------------------------------------------- + ! Custom calculation for nems_orig or nems_frac + ! ---------------------------------------------- + + use ESMF , only : ESMF_GridComp + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + real(R8), pointer :: ocnwgt1(:) + real(R8), pointer :: icewgt1(:) + real(R8), pointer :: wgtp01(:) + real(R8), pointer :: wgtm01(:) + real(R8), pointer :: customwgt(:) + real(R8), pointer :: ifrac(:) + real(R8), pointer :: ofrac(:) + integer :: lsize + real(R8) , parameter :: const_lhvap = 2.501e6_R8 ! latent heat of evaporation ~ J/kg + character(len=*), parameter :: subname='(med_phases_prep_ocn_custom_nems)' + !--------------------------------------- + + rc = ESMF_SUCCESS + + call t_startf('MED:'//subname) + if (dbug_flag > 20) then + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + end if + call memcheck(subname, 5, mastertask) + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! get ice and open ocean fractions on the ocn mesh + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ifrac' , ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ofrac' , ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lsize = size(ofrac) + allocate(customwgt(lsize)) + + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_rain', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_rain' , wgtA=ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_snow', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_snow' , wgtA=ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_lwnet', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_lwnet', wgtA=ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + customwgt(:) = -ofrac(:) / const_lhvap + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_evap', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_lat' , wgtA=customwgt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + customwgt(:) = -ofrac(:) + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_sen', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_sen', wgtA=customwgt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_taux', & + FBinA=is_local%wrap%FBImp(compice,compocn), fnameA='Fioi_taux' , wgtA=ifrac, & + FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_taux' , wgtB=customwgt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_tauy', & + FBinA=is_local%wrap%FBImp(compice,compocn), fnameA='Fioi_tauy' , wgtA=ifrac, & + FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_tauy' , wgtB=customwgt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! netsw_for_ocn = [downsw_from_atm*(1-ice_fraction)*(1-ocn_albedo)] + [pensw_from_ice*(ice_fraction)] + customwgt(:) = ofrac(:) * (1.0 - 0.06) + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swvdr' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_vdr', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swvdf' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_vdf', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swndr' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_idr', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swndf' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_idf', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(customwgt) + + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + end if + call t_stopf('MED:'//subname) + + end subroutine med_phases_prep_ocn_custom_nems + + !----------------------------------------------------------------------------- + subroutine med_phases_prep_ocn_custom_nemsdata(gcomp, rc) + + ! ---------------------------------------------- + ! Custom calculation for nems_orig_data + ! ---------------------------------------------- + + use ESMF , only : ESMF_GridComp + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(InternalState) :: is_local + real(R8), pointer :: ocnwgt1(:) ! NEMS_orig_data + real(R8), pointer :: icewgt1(:) ! NEMS_orig_data + real(R8), pointer :: wgtp01(:) ! NEMS_orig_data + real(R8), pointer :: wgtm01(:) ! NEMS_orig_data + real(R8), pointer :: customwgt(:) ! NEMS_orig_data + real(R8), pointer :: ifrac(:) + real(R8), pointer :: ofrac(:) + integer :: lsize + integer :: n + real(R8) , parameter :: const_lhvap = 2.501e6_R8 ! latent heat of evaporation ~ J/kg + character(len=*), parameter :: subname='(med_phases_prep_ocn_custom_nemsdata)' + !--------------------------------------- + + rc = ESMF_SUCCESS + + call t_startf('MED:'//subname) + if (dbug_flag > 20) then + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + end if + call memcheck(subname, 5, mastertask) + + ! Get the internal state + nullify(is_local%wrap) + call ESMF_GridCompGetInternalState(gcomp, is_local, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! get ice and open ocean fractions on the ocn mesh + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ifrac' , ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call FB_GetFldPtr(is_local%wrap%FBfrac(compocn), 'ofrac' , ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lsize = size(ofrac) + allocate(customwgt(lsize)) + + ! open ocean (i.e. atm) and ice fraction + ! ocnwgt and icewgt are the "normal" fractions + ! ocnwgt1, icewgt1, and wgtp01 are the fractions that switch between atm and mediator fluxes + ! ocnwgt1+icewgt1+wgtp01 = 1.0 always + ! wgtp01 and wgtm01 are the same just one is +1 and the other is -1 to change sign depending on the ice fraction. + ! wgtp01 = 1 and wgtm01 = -1 when ice fraction = 0 + ! wgtp01 = 0 and wgtm01 = 0 when ice fraction > 0 + + allocate(ocnwgt1(lsize)) + allocate(icewgt1(lsize)) + allocate(wgtp01(lsize)) + allocate(wgtm01(lsize)) + allocate(customwgt(lsize)) + + do n = 1,lsize + if (ifrac(n) <= 0._R8) then + ! ice fraction is 0 + ocnwgt1(n) = 1.0_R8 + icewgt1(n) = 0.0_R8 + wgtp01(n) = 0.0_R8 + wgtm01(n) = 0.0_R8 + else + ! ice fraction is > 0 + ocnwgt1(n) = ofrac(n) + icewgt1(n) = ifrac(n) + wgtp01(n) = 0.0_R8 + wgtm01(n) = 0.0_R8 + end if + + ! check wgts do add to 1 as expected + ! TODO: check if this condition is still required + if(ofrac(n)+ifrac(n) /= 0._R8)then + if ( abs( ofrac(n) + ifrac(n) - 1.0_R8) > 1.0e-12 .or. & + abs( ocnwgt1(n) + icewgt1(n) + wgtp01(n) - 1.0_R8) > 1.0e-12 .or. & + abs( ocnwgt1(n) + icewgt1(n) - wgtm01(n) - 1.0_R8) > 1.0e-12) then + + write(6,100)trim(subname)//'ERROR: n, ofrac, ifrac, sum',& + n,ofrac(n),ifrac(n),ofrac(n)+ifrac(n) + write(6,101)trim(subname)//'ERROR: n, ocnwgt1, icewgt1, wgtp01, sum ', & + n,ocnwgt1(n),icewgt1(n),wgtp01(n),ocnwgt1(n)+icewgt1(n)+wgtp01(n) + write(6,101)trim(subname)//'ERROR: n, ocnwgt1, icewgt1, -wgtm01, sum ', & + n,ocnwgt1(n),icewgt1(n),-wgtp01(n),ocnwgt1(n)+icewgt1(n)-wgtm01(n) +100 format(a,i8,2x,3(d20.13,2x)) +101 format(a,i8,2x,4(d20.13,2x)) + + call ESMF_LogWrite(trim(subname)//": ERROR atm + ice fracs inconsistent", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) + rc = ESMF_FAILURE + return + endif + endif + end do + + customwgt(:) = wgtm01(:) / const_lhvap + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_evap', & + FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_evap', wgtA=ocnwgt1, & + FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_lat' , wgtB=customwgt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_sen', & + FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_sen ', wgtA=ocnwgt1, & + FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_sen' , wgtB=wgtm01, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_taux', & + FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_taux ', wgtA=ocnwgt1, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_taux' , wgtB=icewgt1, & + FBinC=is_local%wrap%FBImp(compatm,compocn), fnameC='Faxa_taux' , wgtC=wgtm01, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_tauy', & + FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_tauy ', wgtA=ocnwgt1, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_tauy' , wgtB=icewgt1, & + FBinC=is_local%wrap%FBImp(compatm,compocn), fnameC='Faxa_tauy' , wgtC=wgtm01, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! If there is no ice on the ocn gridcell (ocnwgt1=0) - sum Faxa_lwdn and Faxa_lwup + ! If there is ice on the ocn gridcell - merge Faox_lwup and Faxa_lwdn and ignore Faxa_lwup + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_lwnet', & + FBinA=is_local%wrap%FBMed_aoflux_o , fnameA='Faox_lwup ', wgtA=ocnwgt1, & + FBinB=is_local%wrap%FBImp(compatm,compocn), fnameB='Faxa_lwdn' , wgtB=ocnwgt1, & + FBinC=is_local%wrap%FBImp(compatm,compocn), fnameC='Faxa_lwnet', wgtC=wgtp01, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_rain' , & + FBInA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_rain' , wgtA=ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Faxa_snow' , & + FBInA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_snow' , wgtA=ofrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! netsw_for_ocn = [downsw_from_atm*(1-ice_fraction)*(1-ocn_albedo)] + [pensw_from_ice*(ice_fraction)] + customwgt(:) = ofrac(:) * (1.0 - 0.06) + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swvdr' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_vdr', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swvdf' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_vdf', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swndr' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_idr', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_merge_field(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', & + FBinA=is_local%wrap%FBImp(compatm,compocn), fnameA='Faxa_swndf' , wgtA=customwgt, & + FBinB=is_local%wrap%FBImp(compice,compocn), fnameB='Fioi_swpen_idf', wgtB=ifrac, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(ocnwgt1) + deallocate(icewgt1) + deallocate(wgtp01) + deallocate(wgtm01) + deallocate(customwgt) + + if (dbug_flag > 20) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + end if + call t_stopf('MED:'//subname) + + end subroutine med_phases_prep_ocn_custom_nemsdata + end module med_phases_prep_ocn_mod