diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md index 5f1fbbdd9..36cc6403f 100644 --- a/.github/pull_request_template.md +++ b/.github/pull_request_template.md @@ -9,7 +9,7 @@ CMEPS Issues Fixed (include github issue #): Are changes expected to change answers? - [ ] bit for bit - [ ] different at roundoff level - - [ ] more substantial + - [ ] more substantial Any User Interface Changes (namelist or namelist defaults changes)? - [ ] Yes @@ -42,7 +42,7 @@ Testing performed if application target is UFS-HAFS: Hashes used for testing: - [ ] CESM: - repository to check out: https://github.com/ESCOMP/CESM.git - - branch: nuopc_dev + - branch: - hash: - [ ] UFS-coupled, then umbrella repostiory to check out and associated hash: - repository to check out: diff --git a/.github/workflows/bumpversion.yml b/.github/workflows/bumpversion.yml index c682973c4..7364cb8d8 100644 --- a/.github/workflows/bumpversion.yml +++ b/.github/workflows/bumpversion.yml @@ -8,13 +8,12 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v2 - with: - fetch-depth: '0' - name: Bump version and push tag - uses: anothrNick/github-tag-action@1.26.0 - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - WITH_V: true - DEFAULT_BUMP: minor - RELEASE_BRANCHES: master - DRY_RUN: False + id: tag_version + uses: mathieudutour/github-tag-action@v5.5 + with: + github_token: ${{ secrets.GITHUB_TOKEN }} + create_annotated_tag: true + default_bump: patch + dry_run: false + tag_prefix: cmeps diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml index f3563cbad..69ad954a3 100644 --- a/.github/workflows/extbuild.yml +++ b/.github/workflows/extbuild.yml @@ -35,7 +35,9 @@ jobs: path: ~/ESMF key: ${{ runner.os }}-${{ env.ESMF_VERSION }}-ESMF - id: load-env - run: sudo apt-get install gfortran wget openmpi-bin netcdf-bin libopenmpi-dev libnetcdf-dev + run: | + sudo apt-get update + sudo apt-get install gfortran wget openmpi-bin netcdf-bin libopenmpi-dev libnetcdf-dev - id: build-ESMF if: steps.cache-esmf.outputs.cache-hit != 'true' run: | diff --git a/cime_config/buildexe b/cime_config/buildexe index ed5b04459..476bee765 100755 --- a/cime_config/buildexe +++ b/cime_config/buildexe @@ -39,6 +39,7 @@ def _main_func(): ocn_model = case.get_value("COMP_OCN") atm_model = case.get_value("COMP_ATM") gmake_args = get_standard_makefile_args(case) + esmf_aware_threading = case.get_value("ESMF_AWARE_THREADING") # Determine valid components valid_comps = [] @@ -73,6 +74,8 @@ def _main_func(): gmake_args += " {}_PRESENT=FALSE".format(comp) if skip_mediator: gmake_args += " MED_PRESENT=FALSE" + if esmf_aware_threading: + gmake_args += " USER_CPPDEFS=-DESMF_AWARE_THREADING" gmake_args += " IAC_PRESENT=FALSE" expect((num_esp is None) or (int(num_esp) == 1), "ESP component restricted to one instance") @@ -93,6 +96,11 @@ def _main_func(): makefile = os.path.join(casetools, "Makefile") exename = os.path.join(exeroot, cime_model + ".exe") + # always rebuild file esm.F90 this is because cpp macros in that file may have changed + esm = os.path.join(bld_root,"esm.o") + if os.path.isfile(esm): + os.remove(esm) + # always relink if os.path.isfile(exename): os.remove(exename) diff --git a/cime_config/buildnml b/cime_config/buildnml index af6ba9011..00b3dad35 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -516,6 +516,24 @@ def buildnml(case, caseroot, component): if component != "drv": raise AttributeError +# Do a check here of ESMF VERSION, requires 8.1.0 or newer (8.2.0 or newer for esmf_aware_threading) + esmf_aware_threading = case.get_value("ESMF_AWARE_THREADING") + esmfmkfile = os.getenv("ESMFMKFILE") + expect(esmfmkfile and os.path.isfile(esmfmkfile),"ESMFMKFILE not found {}".format(esmfmkfile)) + with open(esmfmkfile, 'r') as f: + major = None + minor = None + for line in f.readlines(): + if 'ESMF_VERSION' in line: + major = line[-2] if 'MAJOR' in line else major + minor = line[-2] if 'MINOR' in line else minor + logger.debug("ESMF version major {} minor {}".format(major,minor)) + expect(int(major) >=8,"ESMF version should be 8.1 or newer") + if esmf_aware_threading: + expect(int(minor) >= 2, "ESMF version should be 8.2.0 or newer when using ESMF_AWARE_THREADING") + else: + expect(int(minor) >= 1, "ESMF version should be 8.1.0 or newer") + confdir = os.path.join(case.get_value("CASEBUILD"), "cplconf") if not os.path.isdir(confdir): os.makedirs(confdir) diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 4c1686b7b..8f6030c52 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -186,6 +186,13 @@ username of user who created case + + char + case_desc + env_case.xml + Unique identifier for case + + @@ -798,6 +805,15 @@ TRUE implies that at least one of the components is built threaded (DO NOT EDIT) + + logical + TRUE,FALSE + FALSE + mach_pes + env_mach_pes.xml + TRUE indicates that the ESMF Aware threading method is used + + logical TRUE,FALSE @@ -1183,6 +1199,9 @@ glacier (glc) grid - DO NOT EDIT (for experts only) + integer 0 @@ -1190,7 +1209,6 @@ env_build.xml number of glc cells in i direction - DO NOT EDIT (for experts only) - integer 0 @@ -1199,7 +1217,6 @@ number of glc cells in j direction - DO NOT EDIT (for experts only) - char UNSET @@ -1423,22 +1440,6 @@ lnd2atm state mapping file - - char - idmap - run_domain - env_run.xml - lnd2glc flux mapping file - - - - char - idmap - run_domain - env_run.xml - lnd2glc state mapping file - - char idmap @@ -1479,22 +1480,6 @@ rof2ocn runoff mapping file - - char - idmap - run_domain - env_run.xml - glc2lnd flux mapping file - - - - char - idmap - run_domain - env_run.xml - glc2lnd state mapping file - - char idmap diff --git a/cime_config/config_component_cesm.xml b/cime_config/config_component_cesm.xml index bf75e52ba..49ed73ed7 100644 --- a/cime_config/config_component_cesm.xml +++ b/cime_config/config_component_cesm.xml @@ -35,16 +35,6 @@ run DOI - - logical - TRUE,FALSE - FALSE - run_flags - env_run.xml - Turns on component varying thread control in the driver. - Used to set the driver namelist variable "drv_threading". - - logical TRUE,FALSE @@ -499,7 +489,8 @@ 284.7 367.0 - 284.7 + 284.317 + 284.7 run_co2 env_run.xml @@ -540,7 +531,7 @@ TRUE + feedbacks for a TG compset, this will give us additional diagnostics --> TRUE run_glc diff --git a/cime_config/config_component_ufs.xml b/cime_config/config_component_ufs.xml index b4901ea3b..1516f97b0 100644 --- a/cime_config/config_component_ufs.xml +++ b/cime_config/config_component_ufs.xml @@ -35,16 +35,6 @@ run DOI - - logical - TRUE,FALSE - FALSE - run_flags - env_run.xml - Turns on component varying thread control in the driver. - Used to set the driver namelist variable "drv_threading". - - logical TRUE,FALSE diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index 249683e8e..71eca18ec 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -178,31 +178,6 @@ - - - - - - - - - - - - - - logical - performance - DRIVER_attributes - - turn on run time control of threading per pe per component by the driver - default: false - - - $DRV_THREADING - - - logical performance @@ -596,7 +571,7 @@ - + logical expdef DRIVER_attributes @@ -732,7 +707,7 @@ single_column ALLCOMP_attributes - DOMAIN file needed for single column model IF and only if + DOMAIN file needed for single column model IF and only if a nearest neighbor search is done to match the PTS_LAT and PTS_LON to the closest point in the domain file. This file is ONLY used in single column mode. @@ -894,28 +869,6 @@ $ICE_NY - - integer - control - MED_attributes - - number of glc cells in i direction - - - $GLC_NX - - - - integer - control - MED_attributes - - number of glc cells in j direction - - - $GLC_NY - - integer control @@ -1072,7 +1025,7 @@ $MASK_MESH - null + null @@ -1085,7 +1038,7 @@ $ATM_DOMAIN_MESH - null + null @@ -1098,7 +1051,7 @@ $LND_DOMAIN_MESH - null + null @@ -1111,7 +1064,7 @@ $OCN_DOMAIN_MESH - null + null @@ -1124,7 +1077,7 @@ $ICE_DOMAIN_MESH - null + null @@ -1137,7 +1090,7 @@ $ROF_DOMAIN_MESH - null + null @@ -1150,7 +1103,7 @@ $GLC_DOMAIN_MESH - null + null @@ -1163,7 +1116,7 @@ $WAV_DOMAIN_MESH - null + null @@ -1643,7 +1596,7 @@ - + @@ -1666,7 +1619,7 @@ total number of scalars in the scalar coupling field - 5 + 4 @@ -1714,8 +1667,20 @@ index of scalar containing epbal precipitation factor from ocn (only for POP) - 0 - 5 + 4 + 0 + + + + + integer + expdef + ALLCOMP_attributes + + number of glc ice sheets + + + 1 @@ -2040,58 +2005,6 @@ - - char - mapping - abs - MED_attributes - - land to glc mapping file for fluxes - - - $LND2GLC_FMAPNAME - - - - - char - mapping - abs - MED_attributes - - land to glc mapping file for states - - - $LND2GLC_SMAPNAME - - - - - char - mapping - abs - MED_attributes - - glc to land mapping file for fluxes - - - $GLC2LND_FMAPNAME - - - - - char - mapping - abs - MED_attributes - - glc to land mapping file for states - - - $GLC2LND_SMAPNAME - - - char mapping diff --git a/cime_config/namelist_definition_modelio.xml b/cime_config/namelist_definition_modelio.xml index ea5d47f0a..35af19567 100644 --- a/cime_config/namelist_definition_modelio.xml +++ b/cime_config/namelist_definition_modelio.xml @@ -166,6 +166,7 @@ $ROF_PIO_NETCDF_FORMAT $GLC_PIO_NETCDF_FORMAT $WAV_PIO_NETCDF_FORMAT + $ESP_PIO_NETCDF_FORMAT diff --git a/cime_config/runseq/runseq_general.py b/cime_config/runseq/runseq_general.py index 3bc307488..db323b3c2 100644 --- a/cime_config/runseq/runseq_general.py +++ b/cime_config/runseq/runseq_general.py @@ -100,7 +100,6 @@ def gen_runseq(case, coupling_times): runseq.add_action("MED med_phases_prep_ice" , med_to_ice) runseq.add_action("MED -> ICE :remapMethod=redist" , med_to_ice) - runseq.add_action("MED med_phases_diag_ice_med2ice" , run_ice and diag_mode) runseq.add_action("MED med_phases_prep_wav" , med_to_wav) runseq.add_action("MED -> WAV :remapMethod=redist" , med_to_wav) @@ -132,9 +131,12 @@ def gen_runseq(case, coupling_times): runseq.add_action("LND -> MED :remapMethod=redist" , run_lnd) runseq.add_action("MED med_phases_post_lnd" , run_lnd) + runseq.add_action("MED med_phases_diag_lnd" , run_lnd and diag_mode) + runseq.add_action("MED med_phases_diag_rof" , run_rof and diag_mode) + runseq.add_action("MED med_phases_diag_ice_ice2med" , run_ice and diag_mode) + runseq.add_action("MED med_phases_diag_glc" , run_glc and diag_mode) runseq.add_action("ICE -> MED :remapMethod=redist" , run_ice) - runseq.add_action("MED med_phases_diag_ice_ice2med" , run_ice and diag_mode) runseq.add_action("MED med_phases_post_ice" , run_ice) runseq.add_action("MED med_phases_prep_atm" , med_to_atm) @@ -142,6 +144,8 @@ def gen_runseq(case, coupling_times): runseq.add_action("ATM" , run_atm) runseq.add_action("ATM -> MED :remapMethod=redist" , run_atm) runseq.add_action("MED med_phases_post_atm" , run_atm) + runseq.add_action("MED med_phases_diag_atm" , run_atm and diag_mode) + runseq.add_action("MED med_phases_diag_ice_med2ice" , run_ice and diag_mode) runseq.add_action("WAV -> MED :remapMethod=redist", run_wav) runseq.add_action("MED med_phases_post_wav" , run_wav) @@ -149,10 +153,6 @@ def gen_runseq(case, coupling_times): runseq.add_action("ROF -> MED :remapMethod=redist", run_rof and not rof_outer_loop) runseq.add_action("MED med_phases_post_rof" , run_rof and not rof_outer_loop) - runseq.add_action("MED med_phases_diag_atm" , run_atm and diag_mode) - runseq.add_action("MED med_phases_diag_lnd" , run_lnd and diag_mode) - runseq.add_action("MED med_phases_diag_rof" , run_rof and diag_mode) - runseq.add_action("MED med_phases_diag_glc" , run_glc and diag_mode) runseq.add_action("MED med_phases_diag_accum" , diag_mode) runseq.add_action("MED med_phases_diag_print" , diag_mode) diff --git a/cime_config/testdefs/testlist_drv.xml b/cime_config/testdefs/testlist_drv.xml index 80b28a301..d255baa18 100644 --- a/cime_config/testdefs/testlist_drv.xml +++ b/cime_config/testdefs/testlist_drv.xml @@ -166,6 +166,17 @@ + + + + + + + + + + + @@ -376,7 +387,7 @@ - + @@ -386,12 +397,21 @@ + + + + + + + + + - + @@ -400,7 +420,7 @@ - + diff --git a/drivers/cime/esm.F90 b/drivers/cime/esm.F90 index 44dc74a51..e1a18f135 100644 --- a/drivers/cime/esm.F90 +++ b/drivers/cime/esm.F90 @@ -613,7 +613,7 @@ end subroutine CheckAttributes !=============================================================================== - subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, rc) + subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, nthrds, rc) ! Add specific set of attributes to components from driver attributes @@ -628,6 +628,7 @@ subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, r integer , intent(in) :: compid character(len=*) , intent(in) :: compname character(len=*) , intent(in) :: inst_suffix + integer , intent(in) :: nthrds integer , intent(inout) :: rc ! local variables @@ -712,6 +713,12 @@ subroutine AddAttributes(gcomp, driver, config, compid, compname, inst_suffix, r call NUOPC_CompAttributeSet(gcomp, name='inst_suffix', value=inst_suffix, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if + ! Add the nthreads attribute + call NUOPC_CompAttributeAdd(gcomp, attrList=(/'nthreads'/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(cvalue, *) nthrds + call NUOPC_CompAttributeSet(gcomp, name='nthreads', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return !------ ! Add single column and single point attributes @@ -802,40 +809,69 @@ subroutine esm_init_pelayout(driver, maxthreads, rc) use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_VM, ESMF_VMGet use ESMF , only : ESMF_LogWrite, ESMF_SUCCESS, ESMF_LOGMSG_INFO, ESMF_Config use ESMF , only : ESMF_ConfigGetLen, ESMF_LogFoundAllocError, ESMF_ConfigGetAttribute - use ESMF , only : ESMF_RC_NOT_VALID, ESMF_LogSetError + use ESMF , only : ESMF_RC_NOT_VALID, ESMF_LogSetError, ESMF_Info, ESMF_InfoSet use ESMF , only : ESMF_GridCompIsPetLocal, ESMF_MethodAdd, ESMF_UtilStringLowerCase + use ESMF , only : ESMF_InfoCreate, ESMF_InfoDestroy use NUOPC , only : NUOPC_CompAttributeGet use NUOPC_Driver , only : NUOPC_DriverAddComp - use mpi , only : MPI_COMM_NULL +#ifndef NO_MPI2 + use mpi , only : MPI_COMM_NULL, mpi_comm_size +#endif use mct_mod , only : mct_world_init use shr_pio_mod , only : shr_pio_init2 #ifdef MED_PRESENT use med_internalstate_mod , only : med_id use med , only : MedSetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use med , only : MEDSetVM => SetVM +#endif #endif #ifdef ATM_PRESENT use atm_comp_nuopc , only : ATMSetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use atm_comp_nuopc , only : ATMSetVM => SetVM +#endif #endif #ifdef ICE_PRESENT use ice_comp_nuopc , only : ICESetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use ice_comp_nuopc , only : ICESetVM => SetVM +#endif #endif #ifdef LND_PRESENT use lnd_comp_nuopc , only : LNDSetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use lnd_comp_nuopc , only : LNDSetVM => SetVM +#endif #endif #ifdef OCN_PRESENT use ocn_comp_nuopc , only : OCNSetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use ocn_comp_nuopc , only : OCNSetVM => SetVM +#endif #endif #ifdef WAV_PRESENT use wav_comp_nuopc , only : WAVSetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use wav_comp_nuopc , only : WAVSetVM => SetVM +#endif #endif #ifdef ROF_PRESENT use rof_comp_nuopc , only : ROFSetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use rof_comp_nuopc , only : ROFSetVM => SetVM +#endif #endif #ifdef GLC_PRESENT use glc_comp_nuopc , only : GLCSetServices => SetServices +#ifdef ESMF_AWARE_THREADING + use glc_comp_nuopc , only : GLCSetVM => SetVM +#endif +#endif +#ifdef NO_MPI2 + include 'mpif.h' #endif - ! input/output variables type(ESMF_GridComp) :: driver integer, intent(out) :: maxthreads ! maximum number of threads any component @@ -845,6 +881,7 @@ subroutine esm_init_pelayout(driver, maxthreads, rc) type(ESMF_GridComp) :: child type(ESMF_VM) :: vm type(ESMF_Config) :: config + type(ESMF_Info) :: info integer :: componentcount integer :: PetCount integer :: LocalPet @@ -864,13 +901,13 @@ subroutine esm_init_pelayout(driver, maxthreads, rc) character(len=5) :: inst_suffix character(CL) :: cvalue logical :: found_comp + integer :: rank, nprocs, ierr character(len=*), parameter :: subname = "(esm_pelayout.F90:esm_init_pelayout)" !--------------------------------------- rc = ESMF_SUCCESS call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) - maxthreads = 1 call ESMF_GridCompGet(driver, vm=vm, config=config, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -907,9 +944,21 @@ subroutine esm_init_pelayout(driver, maxthreads, rc) allocate(comms(componentCount+1), comps(componentCount+1)) comps(1) = 1 + comms = MPI_COMM_NULL comms(1) = Global_Comm + + maxthreads = 1 do i=1,componentCount + namestr = ESMF_UtilStringLowerCase(compLabels(i)) + if (namestr == 'med') namestr = 'cpl' + call NUOPC_CompAttributeGet(driver, name=trim(namestr)//'_nthreads', value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) nthrds + if(nthrds > maxthreads) maxthreads = nthrds + enddo + + do i=1,componentCount namestr = ESMF_UtilStringLowerCase(compLabels(i)) if (namestr == 'med') namestr = 'cpl' call NUOPC_CompAttributeGet(driver, name=trim(namestr)//'_ntasks', value=cvalue, rc=rc) @@ -926,7 +975,11 @@ subroutine esm_init_pelayout(driver, maxthreads, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) nthrds - if(nthrds > maxthreads) maxthreads = nthrds + info = ESMF_InfoCreate(rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_InfoSet(info, key="/NUOPC/Hint/PePerPet/MaxCount", value=nthrds, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(driver, name=trim(namestr)//'_rootpe', value=cvalue, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -945,84 +998,145 @@ subroutine esm_init_pelayout(driver, maxthreads, rc) call NUOPC_CompAttributeGet(driver, name=trim(namestr)//'_pestride', value=cvalue, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return read(cvalue,*) stride - if (stride < 1 .or. rootpe+ntasks*stride > PetCount) then + if (stride < 1 .or. rootpe+(ntasks-1)*stride > PetCount) then write (msgstr, *) "Invalid pestride value specified for component: ",namestr,& - ' rootpe: ',rootpe, ' pestride: ', stride + ' rootpe: ',rootpe, ' pestride: ', stride, ' ntasks: ',ntasks, ' PetCount: ', PetCount call ESMF_LogSetError(ESMF_RC_NOT_VALID, msg=msgstr, line=__LINE__, file=__FILE__, rcToReturn=rc) return endif if (allocated(petlist)) then +#ifdef ESMF_AWARE_THREADING + if(size(petlist) .ne. ntasks*nthrds) then +#else if(size(petlist) .ne. ntasks) then +#endif deallocate(petlist) endif endif if(.not. allocated(petlist)) then +#ifdef ESMF_AWARE_THREADING + allocate(petlist(ntasks*nthrds)) +#else allocate(petlist(ntasks)) +#endif endif +#ifdef ESMF_AWARE_THREADING cnt = 1 - do ntask = rootpe, (rootpe+ntasks*stride)-1, stride + do ntask = rootpe, rootpe+nthrds*ntasks*stride-1, stride petlist(cnt) = ntask cnt = cnt + 1 enddo +#else + do ntask = 1, size(petlist) + petlist(ntask) = rootpe + (ntask-1)*stride + enddo +#endif comps(i+1) = i+1 - found_comp = .false. #ifdef MED_PRESENT if (trim(compLabels(i)) == 'MED') then med_id = i + 1 - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), MEDSetServices, petList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), MEDSetServices, MEDSetVM, & + petList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), MEDSetServices, & + petList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if #endif #ifdef ATM_PRESENT if (trim(compLabels(i)) .eq. 'ATM') then - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ATMSetServices, petList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ATMSetServices, ATMSetVM, & + petList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ATMSetServices, & + petList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if #endif #ifdef LND_PRESENT if (trim(compLabels(i)) .eq. 'LND') then - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), LNDSetServices, PetList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), LNDSetServices, LNDSetVM, & + PetList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), LNDSetServices, & + PetList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if #endif #ifdef OCN_PRESENT if (trim(compLabels(i)) .eq. 'OCN') then - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), OCNSetServices, PetList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), OCNSetServices, OCNSetVM, & + PetList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), OCNSetServices, & + PetList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if #endif #ifdef ICE_PRESENT if (trim(compLabels(i)) .eq. 'ICE') then - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ICESetServices, PetList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ICESetServices, ICESetVM, & + PetList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ICESetServices, & + PetList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if #endif #ifdef GLC_PRESENT if (trim(compLabels(i)) .eq. 'GLC') then - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), GLCSetServices, PetList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), GLCSetServices, GLCSetVM, & + PetList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), GLCSetServices, & + PetList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if #endif #ifdef ROF_PRESENT if (trim(compLabels(i)) .eq. 'ROF') then - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ROFSetServices, PetList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ROFSetServices, ROFSetVM, & + PetList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), ROFSetServices, & + PetList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if #endif #ifdef WAV_PRESENT if (trim(compLabels(i)) .eq. 'WAV') then - call NUOPC_DriverAddComp(driver, trim(compLabels(i)), WAVSetServices, PetList=petlist, comp=child, rc=rc) +#ifdef ESMF_AWARE_THREADING + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), WAVSetServices, WAVSetVM, & + PetList=petlist, comp=child, info=info, rc=rc) +#else + call NUOPC_DriverAddComp(driver, trim(compLabels(i)), WAVSetServices, & + PetList=petlist, comp=child, rc=rc) +#endif if (chkerr(rc,__LINE__,u_FILE_u)) return found_comp = .true. end if @@ -1039,27 +1153,37 @@ subroutine esm_init_pelayout(driver, maxthreads, rc) call ESMF_LogSetError(ESMF_RC_NOT_VALID, msg=msgstr, line=__LINE__, file=__FILE__, rcToReturn=rc) return endif + comp_iamin(i) = .false. + + call AddAttributes(child, driver, config, i+1, trim(compLabels(i)), inst_suffix, nthrds, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return if (ESMF_GridCompIsPetLocal(child, rc=rc)) then + call ESMF_GridCompGet(child, vm=vm, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, mpiCommunicator=comms(i+1), localPet=comp_comm_iam(i), rc=rc) + call ESMF_VMGet(vm, mpiCommunicator=comms(i+1), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call AddAttributes(child, driver, config, i+1, trim(compLabels(i)), inst_suffix, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + if (comms(i+1) .ne. MPI_COMM_NULL) then + call ESMF_VMGet(vm, localPet=comp_comm_iam(i), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + comp_iamin(i) = .true. + call MPI_Comm_size(comms(i+1), nprocs, ierr) + call MPI_Comm_rank(comms(i+1), rank, ierr) + if(nprocs /= ntasks) then + write(msgstr,*) 'Component ',trim(compLabels(i)),' has mpi task mismatch, do threads align with nodes?' + call ESMF_LogSetError(ESMF_RC_NOT_VALID, msg=msgstr, line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + endif + endif - ! This code is not supported, we need an optional arg to NUOPC_DriverAddComp to include the - ! per component thread count. #3614572 in esmf_support - ! call ESMF_GridCompSetVMMaxPEs(child, maxPeCountPerPet=nthrds, rc=rc) - ! if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_InfoDestroy(info, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - comp_iamin(i) = .true. - else - comms(i+1) = MPI_COMM_NULL - comp_iamin(i) = .false. - endif enddo ! Initialize MCT (this is needed for data models and cice prescribed capability) @@ -1134,6 +1258,8 @@ subroutine esm_set_single_column_attributes(compname, gcomp, rc) read(cvalue,*) scol_lat call NUOPC_CompAttributeGet(gcomp, name='single_column_lnd_domainfile', value=single_column_lnd_domainfile, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeAdd(gcomp, attrList=(/'scol_spval'/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return if ( (scol_lon < scol_spval .and. scol_lat > scol_spval) .or. & (scol_lon > scol_spval .and. scol_lat < scol_spval)) then @@ -1175,8 +1301,7 @@ subroutine esm_set_single_column_attributes(compname, gcomp, rc) 'scol_lndmask', & 'scol_lndfrac', & 'scol_ocnmask', & - 'scol_ocnfrac', & - 'scol_spval '/), rc=rc) + 'scol_ocnfrac'/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (trim(single_column_lnd_domainfile) /= 'UNSET') then @@ -1390,7 +1515,6 @@ subroutine esm_finalize(driver, rc) call t_prf(trim(timing_dir)//'/model_timing'//trim(inst_suffix), mpicom=mpicomm) call t_finalizef() - end subroutine esm_finalize diff --git a/drivers/cime/esmApp.F90 b/drivers/cime/esmApp.F90 index 186e0b699..1516ffa10 100644 --- a/drivers/cime/esmApp.F90 +++ b/drivers/cime/esmApp.F90 @@ -10,15 +10,13 @@ program esmApp use ESMF, only : ESMF_GridCompDestroy, ESMF_LOGMSG_INFO, ESMF_GridComp, ESMF_GridCompRun use ESMF, only : ESMF_GridCompFinalize, ESMF_GridCompCreate, ESMF_GridCompInitialize use ESMF, only : ESMF_LOGKIND_MULTI_ON_ERROR, ESMF_LogKind_Flag -#ifdef USE_MPI2 - use mpi, only : MPI_COMM_WORLD, MPI_COMM_NULL, MPI_Init, MPI_FINALIZE, MPI_BCAST, MPI_COMM_RANK -#else + use ESMF, only : ESMF_VMGet, ESMF_VM, ESMF_InitializePreMPI + use mpi -#endif use NUOPC, only : NUOPC_FieldDictionarySetup use ensemble_driver, only : SetServices use shr_pio_mod, only : shr_pio_init1 - use shr_sys_mod, only : shr_sys_abort + use shr_sys_mod, only : shr_sys_abort implicit none @@ -30,14 +28,20 @@ program esmApp logical :: create_esmf_pet_files = .false. integer :: iam, ier integer :: fileunit + integer :: provided + type(ESMF_VM) :: vm - namelist /debug_inparm / create_esmf_pet_files + namelist /debug_inparm / create_esmf_pet_files !----------------------------------------------------------------------------- ! Initiallize MPI !----------------------------------------------------------------------------- - +#ifndef NO_MPI2 + call ESMF_InitializePreMPI() + call MPI_init_thread(MPI_THREAD_SERIALIZED, provided, rc) +#else call MPI_init(rc) +#endif COMP_COMM = MPI_COMM_WORLD !----------------------------------------------------------------------------- @@ -57,7 +61,6 @@ program esmApp ! by default, ESMF_LOGKIND_MULTI_ON_ERROR does not create files PET[N*].ESMF_LogFile unless there is an error ! if want those files, comment out the following line and uncomment the line logkindflag = ESMF_LOGKIND_MULTI - call mpi_comm_rank(COMP_COMM, iam, ier) if (iam==0) then open(newunit=fileunit, status="old", file="drv_in") @@ -74,9 +77,15 @@ program esmApp else logkindflag = ESMF_LOGKIND_MULTI_ON_ERROR end if - call ESMF_Initialize(mpiCommunicator=COMP_COMM, logkindflag=logkindflag, logappendflag=.false., & - defaultCalkind=ESMF_CALKIND_GREGORIAN, ioUnitLBound=5001, ioUnitUBound=5101, rc=rc) + defaultCalkind=ESMF_CALKIND_GREGORIAN, ioUnitLBound=5001, ioUnitUBound=5101, vm=vm, rc=rc) + + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + call ESMF_Finalize(endflag=ESMF_END_ABORT) + + call ESMF_VMGet(vm, mpiCommunicator=COMP_COMM, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & line=__LINE__, & file=__FILE__)) & @@ -185,7 +194,6 @@ program esmApp line=__LINE__, & file=__FILE__)) & call ESMF_Finalize(endflag=ESMF_END_ABORT) - call ESMF_Finalize() end program diff --git a/drivers/cime/esm_time_mod.F90 b/drivers/cime/esm_time_mod.F90 index 55b269cde..49c0226bb 100644 --- a/drivers/cime/esm_time_mod.F90 +++ b/drivers/cime/esm_time_mod.F90 @@ -9,7 +9,7 @@ module esm_time_mod use ESMF , only : ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet, ESMF_TimeIntervalGet - use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE, ESMF_LOGMSG_ERROR use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_VMBroadcast use ESMF , only : ESMF_LOGMSG_INFO, ESMF_FAILURE use ESMF , only : operator(<), operator(/=), operator(+) @@ -150,7 +150,7 @@ subroutine esm_time_clockInit(ensemble_driver, instance_driver, logunit, mastert if (ierr < 0) then rc = ESMF_FAILURE call ESMF_LogWrite(trim(subname)//' ERROR rpointer file open returns error', & - ESMF_LOGMSG_INFO, line=__LINE__, file=__FILE__) + ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) return end if read(unitn,'(a)', iostat=ierr) restart_file @@ -162,7 +162,7 @@ subroutine esm_time_clockInit(ensemble_driver, instance_driver, logunit, mastert end if close(unitn) call ESMF_LogWrite(trim(subname)//" read driver restart from file = "//trim(restart_file), & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_ERROR) call esm_time_read_restart(restart_file, start_ymd, start_tod, curr_ymd, curr_tod, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -419,17 +419,18 @@ subroutine esm_time_alarmInit( clock, alarm, option, & endif ! Get calendar from clock - call ESMF_ClockGet(clock, calendar=cal) + call ESMF_ClockGet(clock, calendar=cal, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return ! Error checks if (trim(option) == optdate) then if (.not. present(opt_ymd)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if if (lymd < 0 .or. ltod < 0) then - call ESMF_LogWrite(subname//trim(option)//'opt_ymd, opt_tod invalid', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//trim(option)//'opt_ymd, opt_tod invalid', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if @@ -441,12 +442,12 @@ subroutine esm_time_alarmInit( clock, alarm, option, & trim(option) == optNMonths .or. & trim(option) == optNYears) then if (.not.present(opt_n)) then - call ESMF_LogWrite(subname//trim(option)//' requires opt_n', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//trim(option)//' requires opt_n', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if if (opt_n <= 0) then - call ESMF_LogWrite(subname//trim(option)//' invalid opt_n', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//trim(option)//' invalid opt_n', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if @@ -462,6 +463,15 @@ subroutine esm_time_alarmInit( clock, alarm, option, & if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. + case (optDate) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call esm_time_date2ymd(opt_ymd, cyy, cmm, cdd) + + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=cdd, s=ltod, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + case (optNever) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -525,7 +535,7 @@ subroutine esm_time_alarmInit( clock, alarm, option, & update_nextalarm = .true. case default - call ESMF_LogWrite(subname//'unknown option '//trim(option), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//'unknown option '//trim(option), ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return @@ -585,7 +595,7 @@ subroutine esm_time_timeInit( Time, ymd, cal, tod, desc, logunit ) write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & 'time-of-day out of bounds', ymd, ltod end if - call ESMF_LogWrite( subname//'ERROR: Bad input' , ESMF_LOGMSG_INFO) + call ESMF_LogWrite( subname//'ERROR: Bad input' , ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if @@ -646,66 +656,66 @@ subroutine esm_time_read_restart(restart_file, start_ymd, start_tod, curr_ymd, c rc = ESMF_SUCCESS status = nf90_open(restart_file, NF90_NOWRITE, ncid) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_open: '//trim(restart_file), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_open: '//trim(restart_file), ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return endif status = nf90_inq_varid(ncid, 'start_ymd', varid) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid start_ymd', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid start_ymd', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_get_var(ncid, varid, start_ymd) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var start_ymd', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var start_ymd', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_inq_varid(ncid, 'start_tod', varid) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid start_tod', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid start_tod', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_get_var(ncid, varid, start_tod) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var start_tod', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var start_tod', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_inq_varid(ncid, 'curr_ymd', varid) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid curr_ymd', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid curr_ymd', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_get_var(ncid, varid, curr_ymd) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var curr_ymd', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var curr_ymd', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_inq_varid(ncid, 'curr_tod', varid) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid curr_tod', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_inq_varid curr_tod', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_get_var(ncid, varid, curr_tod) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var curr_tod', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_get_var curr_tod', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if status = nf90_close(ncid) if (status /= nf90_NoErr) then - call ESMF_LogWrite(trim(subname)//' ERROR: nf90_close', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//' ERROR: nf90_close', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if diff --git a/drivers/cime/esm_utils_mod.F90 b/drivers/cime/esm_utils_mod.F90 index dec3c593a..f6a4aeb40 100644 --- a/drivers/cime/esm_utils_mod.F90 +++ b/drivers/cime/esm_utils_mod.F90 @@ -15,7 +15,7 @@ module esm_utils_mod !=============================================================================== logical function ChkErr(rc, line, file, mpierr) -#ifdef USE_MPI2 +#ifndef NO_MPI2 use mpi, only : MPI_ERROR_STRING, MPI_MAX_ERROR_STRING, MPI_SUCCESS #else use mpi, only : MPI_SUCCESS @@ -28,7 +28,7 @@ logical function ChkErr(rc, line, file, mpierr) character(len=*), intent(in) :: file logical, optional, intent(in) :: mpierr -#ifndef USE_MPI2 +#ifdef NO_MPI2 integer, parameter :: MPI_MAX_ERROR_STRING=80 #endif character(MPI_MAX_ERROR_STRING) :: lstring diff --git a/mediator/esmFlds.F90 b/mediator/esmFlds.F90 index 0a7dfbd9a..70057f340 100644 --- a/mediator/esmFlds.F90 +++ b/mediator/esmFlds.F90 @@ -17,7 +17,8 @@ module esmflds integer, public, parameter :: comprof = 6 integer, public, parameter :: compwav = 7 integer, public, parameter :: compglc1 = 8 - integer, public, parameter :: ncomps = 8 + integer, public, parameter :: compglc2 = 9 + integer, public, parameter :: ncomps = 9 character(len=*), public, parameter :: compname(ncomps) = & (/'med ',& @@ -27,11 +28,12 @@ module esmflds 'ice ',& 'rof ',& 'wav ',& - 'glc '/) + 'glc1',& + 'glc2'/) - integer, public, parameter :: max_icesheets = 1 - integer, public :: compglc(max_icesheets) = (/compglc1/) - integer, public :: num_icesheets = 1 + integer, public, parameter :: max_icesheets = 2 + integer, public :: compglc(max_icesheets) = (/compglc1,compglc2/) + integer, public :: num_icesheets ! obtained from attribute logical, public :: ocn2glc_coupling ! obtained from attribute logical, public :: dststatus_print = .false. @@ -363,12 +365,8 @@ subroutine med_fldList_Realize(state, fldList, flds_scalar_name, flds_scalar_num use ESMF , only : ESMF_StateGet, ESMF_LogFoundError use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_LOGERR_PASSTHRU use ESMF , only : ESMF_LOGMSG_INFO, ESMF_StateRemove, ESMF_SUCCESS -#if ESMF_VERSION_MAJOR >= 8 -#if ESMF_VERSION_MINOR > 0 use ESMF , only : ESMF_STATEINTENT_IMPORT, ESMF_STATEINTENT_EXPORT, ESMF_StateIntent_Flag use ESMF , only : ESMF_RC_ARG_BAD, ESMF_LogSetError, operator(==) -#endif -#endif ! input/output variables type(ESMF_State) , intent(inout) :: state type(med_fldlist_type), intent(in) :: fldList @@ -386,11 +384,7 @@ subroutine med_fldList_Realize(state, fldList, flds_scalar_name, flds_scalar_num character(CS) :: shortname character(CS) :: stdname character(ESMF_MAXSTR) :: transferActionAttr -#if ESMF_VERSION_MAJOR >= 8 -#if ESMF_VERSION_MINOR > 0 type(ESMF_StateIntent_Flag) :: stateIntent -#endif -#endif character(ESMF_MAXSTR) :: transferAction character(ESMF_MAXSTR), pointer :: StandardNameList(:) => null() character(ESMF_MAXSTR), pointer :: ConnectedList(:) => null() @@ -454,9 +448,6 @@ subroutine med_fldList_Realize(state, fldList, flds_scalar_name, flds_scalar_num #endif nflds = size(fldList%flds) - transferActionAttr="TransferActionGeomObject" -#if ESMF_VERSION_MAJOR >= 8 -#if ESMF_VERSION_MINOR > 0 call ESMF_StateGet(state, stateIntent=stateIntent, rc=rc) if (stateIntent==ESMF_STATEINTENT_EXPORT) then transferActionAttr="ProducerTransferAction" @@ -470,8 +461,6 @@ subroutine med_fldList_Realize(state, fldList, flds_scalar_name, flds_scalar_num rcToReturn=rc) return ! bail out endif -#endif -#endif do n = 1, nflds shortname = fldList%flds(n)%shortname diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index 8253fe951..3b84c7223 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -30,14 +30,12 @@ module esmFldsExchange_cesm_mod character(len=CX) :: atm2ice_fmap='unset', atm2ice_smap='unset', atm2ice_vmap='unset' character(len=CX) :: atm2ocn_fmap='unset', atm2ocn_smap='unset', atm2ocn_vmap='unset' character(len=CX) :: atm2lnd_fmap='unset', atm2lnd_smap='unset' - character(len=CX) :: glc2lnd_smap='unset', glc2lnd_fmap='unset' character(len=CX) :: glc2ice_rmap='unset' character(len=CX) :: glc2ocn_liq_rmap='unset' character(len=CX) :: glc2ocn_ice_rmap='unset' character(len=CX) :: ice2atm_fmap='unset', ice2atm_smap='unset' character(len=CX) :: ocn2atm_fmap='unset', ocn2atm_smap='unset' character(len=CX) :: lnd2atm_fmap='unset', lnd2atm_smap='unset' - character(len=CX) :: lnd2glc_fmap='unset', lnd2glc_smap='unset' character(len=CX) :: lnd2rof_fmap='unset' character(len=CX) :: rof2lnd_fmap='unset' character(len=CX) :: rof2ocn_fmap='unset', rof2ocn_ice_rmap='unset', rof2ocn_liq_rmap='unset' @@ -140,12 +138,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call NUOPC_CompAttributeGet(gcomp, name='rof2lnd_fmapname', value=rof2lnd_fmap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (mastertask) write(logunit, '(a)') trim(subname)//'rof2lnd_fmapname = '// trim(rof2lnd_fmap) - call NUOPC_CompAttributeGet(gcomp, name='glc2lnd_fmapname', value=glc2lnd_fmap, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit, '(a)') trim(subname)//'glc2lnd_smapname = '// trim(glc2lnd_fmap) - call NUOPC_CompAttributeGet(gcomp, name='glc2lnd_smapname', value=glc2lnd_smap, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit, '(a)') trim(subname)//'glc2lnd_smapname = '// trim(glc2lnd_smap) ! mapping to ice call NUOPC_CompAttributeGet(gcomp, name='atm2ice_fmapname', value=atm2ice_fmap, rc=rc) @@ -206,14 +198,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2rof_fmapname = '// trim(lnd2rof_fmap) - ! mapping to glc - call NUOPC_CompAttributeGet(gcomp, name='lnd2glc_fmapname', value=lnd2glc_fmap, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2glc_fmapname = '// trim(lnd2glc_fmap) - call NUOPC_CompAttributeGet(gcomp, name='lnd2glc_smapname', value=lnd2glc_smap, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2glc_smapname = '// trim(lnd2glc_smap) - ! mapping to wav call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', value=atm2wav_smap, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -1979,7 +1963,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addfld(fldListFr(compocn)%flds, 'Faoo_fco2_ocn') call addfld(fldListTo(compatm)%flds, 'Faoo_fco2_ocn') else - call addmap(fldListFr(compocn)%flds, 'Faoo_fco2_ocn', compatm, mapconsf, 'one', ocn2atm_fmap) + call addmap(fldListFr(compocn)%flds, 'Faoo_fco2_ocn', compatm, mapconsd, 'one', ocn2atm_fmap) ! custom merge in med_phases_prep_atm end if endif diff --git a/mediator/esmFldsExchange_hafs_mod.F90 b/mediator/esmFldsExchange_hafs_mod.F90 index 1786f3684..22ef604af 100644 --- a/mediator/esmFldsExchange_hafs_mod.F90 +++ b/mediator/esmFldsExchange_hafs_mod.F90 @@ -930,28 +930,9 @@ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc) rc = ESMF_SUCCESS ! Query component for name, verbosity, and diagnostic values -#if ESMF_VERSION_MAJOR >= 8 call NUOPC_CompGet(gcomp, name=cname, verbosity=verbosity, & diagnostic=diagnostic, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return -#else - call ESMF_GridCompGet(gcomp, name=cname, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_AttributeGet(gcomp, name="Verbosity", value=cvalue, & - defaultValue="0", convention="NUOPC", purpose="Instance", rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - verbosity = ESMF_UtilString2Int(cvalue, & - specialStringList=(/"off ","low ","high","max "/), & - specialValueList=(/0,9985,32513,131071/), rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_AttributeGet(gcomp, name="Diagnostic", value=cvalue, & - defaultValue="0", convention="NUOPC", purpose="Instance", rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - diagnostic = ESMF_UtilString2Int(cvalue, & - specialStringList=(/"off ","max "/), & - specialValueList=(/0,131071/), rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return -#endif !---------------------------------------------------------- ! Initialize system type diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index ab4c5cd9a..1a4889bc0 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -43,6 +43,10 @@ canonical_units: N m-2 description: mediator export # + - standard_name: area + canonical_units: radians**2 + description: mediator area for component + # #----------------------------------- # section: land export #----------------------------------- diff --git a/mediator/med.F90 b/mediator/med.F90 index 467c85163..53c8698eb 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -3,8 +3,8 @@ module MED !----------------------------------------------------------------------------- ! Mediator Component. !----------------------------------------------------------------------------- - use ESMF , only : ESMF_VMLogMemInfo + use NUOPC_Model , only : SetVM use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_constants_mod , only : spval_init => med_constants_spval_init @@ -48,7 +48,7 @@ module MED private public SetServices - + public SetVM private InitializeP0 private InitializeIPDv03p1 ! advertise fields private InitializeIPDv03p3 ! realize connected Fields with transfer action "provide" @@ -279,7 +279,7 @@ subroutine SetServices(gcomp, rc) call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_TimestampExport, & specPhaselabel="med_phases_post_ocn", specRoutine=NUOPC_NoOp, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - + !------------------ ! prep and post routines for ice !------------------ @@ -556,9 +556,9 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) use ESMF , only : ESMF_GridCompGet, ESMF_VMGet, ESMF_AttributeGet, ESMF_AttributeSet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_METHOD_INITIALIZE use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet - use med_internalstate_mod, only : mastertask, logunit + use med_internalstate_mod, only : mastertask, logunit, diagunit use esmFlds, only : dststatus_print - + type(ESMF_GridComp) :: gcomp type(ESMF_State) :: importState, exportState type(ESMF_Clock) :: clock @@ -568,10 +568,13 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) type(ESMF_VM) :: vm character(len=CL) :: cvalue integer :: localPet + integer :: i logical :: isPresent, isSet character(len=CX) :: msgString character(len=CX) :: diro character(len=CX) :: logfile + character(len=CX) :: diagfile + character(len=CX) :: do_budgets character(len=*),parameter :: subname=' (module_MED:InitializeP0) ' !----------------------------------------------------------- @@ -597,6 +600,16 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) logfile = 'mediator.log' end if open(newunit=logunit, file=trim(diro)//"/"//trim(logfile)) + + call NUOPC_CompAttributeGet(gcomp, name="do_budgets", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(cvalue) .eq. '.true.') then + i = index(logfile, '.log') + diagfile = "diags"//logfile(i:) + open(newunit=diagunit, file=trim(diro)//"/"//trim(diagfile)) + endif + end if else logUnit = 6 endif @@ -651,6 +664,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) ! TransferOfferGeomObject Attribute. use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Clock, ESMF_SUCCESS, ESMF_LogFoundAllocError + use ESMF , only : ESMF_StateIsCreated use ESMF , only : ESMF_LogMsg_Info, ESMF_LogWrite use ESMF , only : ESMF_END_ABORT, ESMF_Finalize use NUOPC , only : NUOPC_AddNamespace, NUOPC_Advertise, NUOPC_AddNestedState @@ -731,6 +745,14 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) nestedState=is_local%wrap%NStateExp(compwav), rc=rc) ! Only create nested states for active ice sheets + call NUOPC_CompAttributeGet(gcomp, name='num_icesheets', value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) num_icesheets + else + num_icesheets = 0 + end if do ns = 1,num_icesheets write(cnum,'(i0)') ns call NUOPC_AddNestedState(importState, CplSet="GLC"//trim(cnum), & @@ -905,7 +927,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) if (isPresent .and. isSet) then read(cvalue,*) is_local%wrap%flds_scalar_index_precip_factor else - is_local%wrap%flds_scalar_index_precip_factor = spval + is_local%wrap%flds_scalar_index_precip_factor = 0 end if !------------------ @@ -915,39 +937,42 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) do ncomp = 1,ncomps if (ncomp /= compmed) then if (mastertask) write(logunit,*) - nflds = med_fldList_GetNumFlds(fldListFr(ncomp)) - do n = 1,nflds - call med_fldList_GetFldInfo(fldListFr(ncomp), n, stdname, shortname) - if (mastertask) then - write(logunit,'(a)') trim(subname)//':Fr_'//trim(compname(ncomp))//': '//trim(shortname) - end if - if (trim(shortname) == is_local%wrap%flds_scalar_name) then - transferOffer = 'will provide' - else - transferOffer = 'cannot provide' - end if - call NUOPC_Advertise(is_local%wrap%NStateImp(ncomp), standardName=stdname, shortname=shortname, name=shortname, & - TransferOfferGeomObject=transferOffer, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(subname//':Fr_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) - end do - - nflds = med_fldList_GetNumFlds(fldListTo(ncomp)) - do n = 1,nflds - call med_fldList_GetFldInfo(fldListTo(ncomp), n, stdname, shortname) - if (mastertask) then - write(logunit,'(a)') trim(subname)//':To_'//trim(compname(ncomp))//': '//trim(shortname) - end if - if (trim(shortname) == is_local%wrap%flds_scalar_name) then - transferOffer = 'will provide' - else - transferOffer = 'cannot provide' - end if - call NUOPC_Advertise(is_local%wrap%NStateExp(ncomp), standardName=stdname, shortname=shortname, name=shortname, & - TransferOfferGeomObject=transferOffer, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(subname//':To_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) - end do + if (ESMF_StateIsCreated(is_local%wrap%NStateImp(ncomp))) then + nflds = med_fldList_GetNumFlds(fldListFr(ncomp)) + do n = 1,nflds + call med_fldList_GetFldInfo(fldListFr(ncomp), n, stdname, shortname) + if (mastertask) then + write(logunit,'(a)') trim(subname)//':Fr_'//trim(compname(ncomp))//': '//trim(shortname) + end if + if (trim(shortname) == is_local%wrap%flds_scalar_name) then + transferOffer = 'will provide' + else + transferOffer = 'cannot provide' + end if + call NUOPC_Advertise(is_local%wrap%NStateImp(ncomp), standardName=stdname, shortname=shortname, name=shortname, & + TransferOfferGeomObject=transferOffer, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//':Fr_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) + end do + end if + if (ESMF_StateIsCreated(is_local%wrap%NStateExp(ncomp))) then + nflds = med_fldList_GetNumFlds(fldListTo(ncomp)) + do n = 1,nflds + call med_fldList_GetFldInfo(fldListTo(ncomp), n, stdname, shortname) + if (mastertask) then + write(logunit,'(a)') trim(subname)//':To_'//trim(compname(ncomp))//': '//trim(shortname) + end if + if (trim(shortname) == is_local%wrap%flds_scalar_name) then + transferOffer = 'will provide' + else + transferOffer = 'cannot provide' + end if + call NUOPC_Advertise(is_local%wrap%NStateExp(ncomp), standardName=stdname, shortname=shortname, name=shortname, & + TransferOfferGeomObject=transferOffer, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//':To_'//trim(compname(ncomp))//': '//trim(shortname), ESMF_LOGMSG_INFO) + end do + end if end if end do ! end of ncomps loop @@ -965,12 +990,9 @@ subroutine InitializeIPDv03p3(gcomp, importState, exportState, clock, rc) use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Clock, ESMF_VM, ESMF_SUCCESS use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_TimeInterval use ESMF , only : ESMF_VMGet, ESMF_StateIsCreated, ESMF_GridCompGet -#if ESMF_VERSION_MAJOR >= 8 -#if ESMF_VERSION_MINOR > 0 use ESMF , only : ESMF_StateSet, ESMF_StateIntent_Import, ESMF_StateIntent_Export use ESMF , only : ESMF_StateIntent_Flag -#endif -#endif + ! Input/output variables type(ESMF_GridComp) :: gcomp type(ESMF_State) :: importState, exportState @@ -1001,24 +1023,16 @@ subroutine InitializeIPDv03p3(gcomp, importState, exportState, clock, rc) ! Realize States do n = 1,ncomps if (ESMF_StateIsCreated(is_local%wrap%NStateImp(n), rc=rc)) then -#if ESMF_VERSION_MAJOR >= 8 -#if ESMF_VERSION_MINOR > 0 call ESMF_StateSet(is_local%wrap%NStateImp(n), stateIntent=ESMF_StateIntent_Import, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return -#endif -#endif call med_fldList_Realize(is_local%wrap%NStateImp(n), fldListFr(n), & is_local%wrap%flds_scalar_name, is_local%wrap%flds_scalar_num, & tag=subname//':Fr_'//trim(compname(n)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif if (ESMF_StateIsCreated(is_local%wrap%NStateExp(n), rc=rc)) then -#if ESMF_VERSION_MAJOR >= 8 -#if ESMF_VERSION_MINOR > 0 call ESMF_StateSet(is_local%wrap%NStateExp(n), stateIntent=ESMF_StateIntent_Export, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return -#endif -#endif call med_fldList_Realize(is_local%wrap%NStateExp(n), fldListTo(n), & is_local%wrap%flds_scalar_name, is_local%wrap%flds_scalar_num, & tag=subname//':To_'//trim(compname(n)), rc=rc) @@ -1995,7 +2009,7 @@ subroutine DataInitialize(gcomp, rc) ! Create mesh info data call med_meshinfo_create(is_local%wrap%FBImp(n1,n1), & - is_local%wrap%mesh_info(n1), rc=rc) + is_local%wrap%mesh_info(n1), is_local%wrap%FBArea(n1), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -2408,7 +2422,8 @@ subroutine DataInitialize(gcomp, rc) !--------------------------------------- call med_diag_init(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_diag_zero(gcomp, mode='all', rc=rc) + call med_diag_zero(mode='all', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------------------------------- @@ -2465,7 +2480,7 @@ subroutine DataInitialize(gcomp, rc) end if call med_phases_profile(gcomp, rc) - + if (ChkErr(rc,__LINE__,u_FILE_u)) return else ! Not all done call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="false", rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2553,17 +2568,19 @@ end subroutine SetRunClock !----------------------------------------------------------------------------- - subroutine med_meshinfo_create(FB, mesh_info, rc) + subroutine med_meshinfo_create(FB, mesh_info, FBArea, rc) use ESMF , only : ESMF_Array, ESMF_ArrayCreate, ESMF_ArrayDestroy, ESMF_Field, ESMF_FieldGet use ESMF , only : ESMF_DistGrid, ESMF_FieldBundle, ESMF_FieldRegridGetArea, ESMF_FieldBundleGet use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8 use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_LogWrite, ESMF_LOGMSG_INFO + use ESMF , only : ESMF_FieldCreate, ESMF_FieldBundleCreate, ESMF_FieldBundleAdd use med_internalstate_mod , only : mesh_info_type ! input/output variables type(ESMF_FieldBundle) , intent(in) :: FB type(mesh_info_type) , intent(inout) :: mesh_info + type(ESMF_FieldBundle) , intent(inout) :: FBArea integer , intent(out) :: rc ! local variables @@ -2614,6 +2631,17 @@ subroutine med_meshinfo_create(FB, mesh_info, rc) end do deallocate(ownedElemCoords) + ! Create field bundle with areas so that this can be output to mediator history file + lfield = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_r8, name='area', meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + FBArea = ESMF_FieldBundleCreate(rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleAdd(FBArea, (/lfield/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + dataptr(:) = mesh_info%areas(:) + end subroutine med_meshinfo_create !----------------------------------------------------------------------------- diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index 72295a5ac..c996f4354 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -21,13 +21,13 @@ module med_diag_mod use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time use ESMF , only : ESMF_VM, ESMF_VMReduce, ESMF_REDUCE_SUM - use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet + use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet, ESMF_ClockGetNextTime use ESMF , only : ESMF_Alarm, ESMF_ClockGetAlarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff use ESMF , only : ESMF_FieldBundle, ESMF_Field, ESMF_FieldGet use shr_const_mod , only : shr_const_rearth, shr_const_pi, shr_const_latice use shr_const_mod , only : shr_const_ice_ref_sal, shr_const_ocn_ref_sal, shr_const_isspval use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 - use med_internalstate_mod , only : InternalState, logunit, mastertask + use med_internalstate_mod , only : InternalState, logunit, mastertask, diagunit use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_fldChk => med_methods_FB_FldChk @@ -66,6 +66,11 @@ module med_diag_mod end type budget_diag_indices type(budget_diag_indices) :: budget_diags + interface med_diag_zero + module procedure med_diag_zero_mode + module procedure med_diag_zero_select + end interface + ! --------------------------------- ! print options (obtained from mediator config input) ! --------------------------------- @@ -195,11 +200,11 @@ module med_diag_mod ! P for period ! --------------------------------- - integer :: period_inst - integer :: period_day - integer :: period_mon - integer :: period_ann - integer :: period_inf + integer :: period_inst=0 + integer :: period_day=0 + integer :: period_mon=0 + integer :: period_ann=0 + integer :: period_inf=0 ! --------------------------------- ! local constants @@ -281,6 +286,8 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%comps, c_ocn_arecv, 'a2c_ocn' ) ! comp index: ocn, on atm grid call add_to_budget_diag(budget_diags%fields, f_area ,'area' ) ! field area (wrt to unit sphere) + + ! Note that this order is important here to determine f_heat_beg and f_heat_end call add_to_budget_diag(budget_diags%fields, f_heat_frz ,'hfreeze' ) ! field heat : latent, freezing call add_to_budget_diag(budget_diags%fields, f_heat_melt ,'hmelt' ) ! field heat : latent, melting call add_to_budget_diag(budget_diags%fields, f_heat_swnet ,'hnetsw' ) ! field heat : short wave, net @@ -290,6 +297,8 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_heat_latf ,'hlatfus' ) ! field heat : latent, fusion, snow call add_to_budget_diag(budget_diags%fields, f_heat_ioff ,'hiroff' ) ! field heat : latent, fusion, frozen runoff call add_to_budget_diag(budget_diags%fields, f_heat_sen ,'hsen' ) ! field heat : sensible + + ! Note that this order is important here to determine f_watr_beg and f_watr_end call add_to_budget_diag(budget_diags%fields, f_watr_frz ,'wfreeze' ) ! field water: freezing call add_to_budget_diag(budget_diags%fields, f_watr_melt ,'wmelt' ) ! field water: melting call add_to_budget_diag(budget_diags%fields, f_watr_rain ,'wrain' ) ! field water: precip, liquid @@ -298,6 +307,7 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_watr_salt ,'weqsaltf' ) ! field water: water equivalent of salt flux call add_to_budget_diag(budget_diags%fields, f_watr_roff ,'wrunoff' ) ! field water: runoff/flood call add_to_budget_diag(budget_diags%fields, f_watr_ioff ,'wfrzrof' ) ! field water: frozen runoff + call add_to_budget_diag(budget_diags%fields, f_watr_frz_16O ,'wfreeze_16O' ) ! field water isotope: freezing call add_to_budget_diag(budget_diags%fields, f_watr_melt_16O ,'wmelt_16O' ) ! field water isotope: melting call add_to_budget_diag(budget_diags%fields, f_watr_rain_16O ,'wrain_16O' ) ! field water isotope: precip, liquid @@ -337,22 +347,6 @@ subroutine med_diag_init(gcomp, rc) isof(:) = (/ f_16O_end, f_18O_end, f_hdO_end /) isoname(:) = (/ 'H216O', 'H218O', ' HDO' /) - ! period types - call add_to_budget_diag(budget_diags%periods, period_inst,' inst') - call add_to_budget_diag(budget_diags%periods, period_day ,' daily') - call add_to_budget_diag(budget_diags%periods, period_mon ,' monthly') - call add_to_budget_diag(budget_diags%periods, period_ann ,' annual') - call add_to_budget_diag(budget_diags%periods, period_inf ,'all_time') - - ! allocate module budget arrays - c_size = size(budget_diags%comps) - f_size = size(budget_diags%fields) - p_size = size(budget_diags%periods) - - allocate(budget_local (f_size , c_size , p_size)) ! local sum, valid on all pes - allocate(budget_global (f_size , c_size , p_size)) ! global sum, valid only on root pe - allocate(budget_counter (f_size , c_size , p_size)) ! counter, valid only on root pe - allocate(budget_global_1d(f_size * c_size * p_size)) ! needed for ESMF_VMReduce call !------------------------------------------------------------------------------- ! Get config variables !------------------------------------------------------------------------------- @@ -369,6 +363,24 @@ subroutine med_diag_init(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return budget_print_ltend = get_diag_attribute(gcomp, 'budget_ltend', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! period types + call add_to_budget_diag(budget_diags%periods, period_inst,' inst') + if(budget_print_daily > 0) call add_to_budget_diag(budget_diags%periods, period_day ,' daily') + if(budget_print_month > 0) call add_to_budget_diag(budget_diags%periods, period_mon ,' monthly') + if(budget_print_ann > 0) call add_to_budget_diag(budget_diags%periods, period_ann ,' annual') + call add_to_budget_diag(budget_diags%periods, period_inf ,'all_time') + + ! allocate module budget arrays + c_size = size(budget_diags%comps) + f_size = size(budget_diags%fields) + p_size = size(budget_diags%periods) + + allocate(budget_local (f_size , c_size , p_size)) ! local sum, valid on all pes + allocate(budget_global (f_size , c_size , p_size)) ! global sum, valid only on root pe + allocate(budget_counter (f_size , c_size , p_size)) ! counter, valid only on root pe + allocate(budget_global_1d(f_size * c_size * p_size)) ! needed for ESMF_VMReduce call + if (budget_print_inst + budget_print_daily + budget_print_month + budget_print_ann + budget_print_ltann + budget_print_ltend > 0) then ! Set stop alarm (needed for budgets) call NUOPC_CompAttributeGet(gcomp, name="stop_option", value=stop_option, rc=rc) @@ -385,124 +397,124 @@ subroutine med_diag_init(gcomp, rc) alarmname='alarm_stop', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + end subroutine med_diag_init + + integer function get_diag_attribute(gcomp, name, rc) + type(ESMF_GridComp) , intent(inout) :: gcomp + character(len=*), intent(in) :: name + integer, intent(out) :: rc + + character(CS) :: cvalue + logical :: isPresent - contains - integer function get_diag_attribute(gcomp, name, rc) - type(ESMF_GridComp) , intent(inout) :: gcomp - character(len=*), intent(in) :: name - integer, intent(out) :: rc - - character(CS) :: cvalue - logical :: isPresent - - rc = ESMF_SUCCESS - get_diag_attribute = 0 - call NUOPC_CompAttributeGet(gcomp, name=name, isPresent=isPresent, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (isPresent) then - call NUOPC_CompAttributeGet(gcomp, name=name, value=cvalue, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) get_diag_attribute - else - call NUOPC_CompAttributeAdd(gcomp, (/name/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, name=name, value='0', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - end function get_diag_attribute - - end subroutine med_diag_init + rc = ESMF_SUCCESS + get_diag_attribute = 0 + call NUOPC_CompAttributeGet(gcomp, name=name, isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name=name, value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) get_diag_attribute + else + call NUOPC_CompAttributeAdd(gcomp, (/name/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, name=name, value='0', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + end function get_diag_attribute !=============================================================================== - subroutine med_diag_zero( gcomp, mode, rc) + subroutine med_diag_zero_mode(mode, rc) ! ------------------------------------------------------------------ ! Zero out global budget diagnostic data. ! ------------------------------------------------------------------ ! input/output variables - type(ESMF_GridComp) :: gcomp - character(len=*), intent(in),optional :: mode - integer, intent(out) :: rc + character(len=*) , intent(in) :: mode + integer , intent(out) :: rc ! local variables - type(ESMF_Clock) :: clock - type(ESMF_Time) :: currTime - integer :: ip - integer :: curr_year, curr_mon, curr_day, curr_tod character(*), parameter :: subName = '(med_diag_zero) ' ! ------------------------------------------------------------------ - call t_startf('MED:'//subname) - if (present(mode)) then - - if (trim(mode) == 'inst') then - budget_local(:,:,period_inst) = 0.0_r8 - budget_global(:,:,period_inst) = 0.0_r8 - budget_counter(:,:,period_inst) = 0.0_r8 - elseif (trim(mode) == 'day') then - budget_local(:,:,period_day) = 0.0_r8 - budget_global(:,:,period_day) = 0.0_r8 - budget_counter(:,:,period_day) = 0.0_r8 - elseif (trim(mode) == 'mon') then - budget_local(:,:,period_mon) = 0.0_r8 - budget_global(:,:,period_mon) = 0.0_r8 - budget_counter(:,:,period_mon) = 0.0_r8 - elseif (trim(mode) == 'ann') then - budget_local(:,:,period_ann) = 0.0_r8 - budget_global(:,:,period_ann) = 0.0_r8 - budget_counter(:,:,period_ann) = 0.0_r8 - elseif (trim(mode) == 'inf') then - budget_local(:,:,period_inf) = 0.0_r8 - budget_global(:,:,period_inf) = 0.0_r8 - budget_counter(:,:,period_inf) = 0.0_r8 - elseif (trim(mode) == 'all') then - budget_local(:,:,:) = 0.0_r8 - budget_global(:,:,:) = 0.0_r8 - budget_counter(:,:,:) = 0.0_r8 - else - call ESMF_LogWrite(trim(subname)//' mode '//trim(mode)//& - ' not recognized', & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - endif + rc = ESMF_SUCCESS + if (trim(mode) == 'inst') then + budget_local(:,:,period_inst) = 0.0_r8 + budget_global(:,:,period_inst) = 0.0_r8 + budget_counter(:,:,period_inst) = 0.0_r8 + elseif (trim(mode) == 'day') then + budget_local(:,:,period_day) = 0.0_r8 + budget_global(:,:,period_day) = 0.0_r8 + budget_counter(:,:,period_day) = 0.0_r8 + elseif (trim(mode) == 'mon') then + budget_local(:,:,period_mon) = 0.0_r8 + budget_global(:,:,period_mon) = 0.0_r8 + budget_counter(:,:,period_mon) = 0.0_r8 + elseif (trim(mode) == 'ann') then + budget_local(:,:,period_ann) = 0.0_r8 + budget_global(:,:,period_ann) = 0.0_r8 + budget_counter(:,:,period_ann) = 0.0_r8 + elseif (trim(mode) == 'inf') then + budget_local(:,:,period_inf) = 0.0_r8 + budget_global(:,:,period_inf) = 0.0_r8 + budget_counter(:,:,period_inf) = 0.0_r8 + elseif (trim(mode) == 'all') then + budget_local(:,:,:) = 0.0_r8 + budget_global(:,:,:) = 0.0_r8 + budget_counter(:,:,period_inst) = 0.0_r8 + budget_counter(:,:,period_inst+1:) = 1.0_r8 else - call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(trim(subname)//' mode '//trim(mode)//& + ' not recognized', & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + end subroutine med_diag_zero_mode - call ESMF_ClockGet( clock, currTime=currTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !=============================================================================== + subroutine med_diag_zero_select(year, mon, day, tod) - call ESMF_TimeGet( currTime, yy=curr_year, mm=curr_mon, dd=curr_day, s=curr_tod, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! ------------------------------------------------------------------ + ! Zero out global budget diagnostic data. + ! ------------------------------------------------------------------ - do ip = 1,size(budget_diags%periods) - if (ip == period_inst) then - budget_local(:,:,ip) = 0.0_r8 - budget_global(:,:,ip) = 0.0_r8 - budget_counter(:,:,ip) = 0.0_r8 - endif - if (ip==period_day .and. curr_tod==0) then - budget_local(:,:,ip) = 0.0_r8 - budget_global(:,:,ip) = 0.0_r8 - budget_counter(:,:,ip) = 0.0_r8 - endif - if (ip==period_mon .and. curr_day==1 .and. curr_tod==0) then - budget_local(:,:,ip) = 0.0_r8 - budget_global(:,:,ip) = 0.0_r8 - budget_counter(:,:,ip) = 0.0_r8 - endif - if (ip==period_ann .and. curr_mon==1 .and. curr_day==1 .and. curr_tod==0) then - budget_local(:,:,ip) = 0.0_r8 - budget_global(:,:,ip) = 0.0_r8 - budget_counter(:,:,ip) = 0.0_r8 - endif - enddo - end if - call t_stopf('MED:'//subname) - end subroutine med_diag_zero + ! input/output variables + integer, intent(in) :: year + integer, intent(in) :: mon + integer, intent(in) :: day + integer, intent(in) :: tod + + ! local variables + integer :: ip + character(*), parameter :: subName = '(med_diag_zero_select) ' + ! ------------------------------------------------------------------ + + do ip = 1,size(budget_diags%periods) + if (ip == period_inst) then + budget_local(:,:,ip) = 0.0_r8 + budget_global(:,:,ip) = 0.0_r8 + budget_counter(:,:,ip) = 0.0_r8 + endif + if (ip==period_day .and. tod==0) then + budget_local(:,:,ip) = 0.0_r8 + budget_global(:,:,ip) = 0.0_r8 + budget_counter(:,:,ip) = 0.0_r8 + endif + if (ip==period_mon .and. day==1 .and. tod==0) then + budget_local(:,:,ip) = 0.0_r8 + budget_global(:,:,ip) = 0.0_r8 + budget_counter(:,:,ip) = 0.0_r8 + endif + if (ip==period_ann .and. mon==1 .and. day==1 .and. tod==0) then + budget_local(:,:,ip) = 0.0_r8 + budget_global(:,:,ip) = 0.0_r8 + budget_counter(:,:,ip) = 0.0_r8 + endif + enddo + end subroutine med_diag_zero_select !=============================================================================== subroutine med_phases_diag_accum(gcomp, rc) @@ -526,6 +538,7 @@ subroutine med_phases_diag_accum(gcomp, rc) budget_local(:,:,ip) = budget_local(:,:,ip) + budget_local(:,:,period_inst) enddo budget_counter(:,:,:) = budget_counter(:,:,:) + 1.0_r8 + call t_stopf('MED:'//subname) end subroutine med_phases_diag_accum @@ -562,11 +575,11 @@ subroutine med_diag_sum_master(gcomp, rc) count = size(budget_global) budget_global_1d(:) = 0.0_r8 - call ESMF_VMReduce(vm, reshape(budget_local,(/count/)) , budget_global_1d, count, ESMF_REDUCE_SUM, 0, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return budget_global = reshape(budget_global_1d,(/f_size,c_size,p_size/)) - budget_local(:,:,:) = 0.0_r8 + + budget_local(:,:,period_inst) = 0.0_r8 call t_stopf('MED:'//subname) @@ -706,197 +719,195 @@ subroutine med_phases_diag_atm(gcomp, rc) f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, & areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + deallocate(afrac) call t_stopf('MED:'//subname) + end subroutine med_phases_diag_atm - contains - - subroutine diag_atm_recv(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: afrac(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(in) :: ofrac(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1,size(data) - budget(nf,c_atm_recv,ip) = budget(nf,c_atm_recv,ip) - areas(n)*data(n)*afrac(n) - budget(nf,c_lnd_arecv,ip) = budget(nf,c_lnd_arecv,ip) + areas(n)*data(n)*lfrac(n) - budget(nf,c_ocn_arecv,ip) = budget(nf,c_ocn_arecv,ip) + areas(n)*data(n)*ofrac(n) - if (lats(n) > 0.0_r8) then - budget(nf,c_inh_arecv,ip) = budget(nf,c_inh_arecv,ip) + areas(n)*data(n)*ifrac(n) - else - budget(nf,c_ish_arecv,ip) = budget(nf,c_ish_arecv,ip) + areas(n)*data(n)*ifrac(n) - end if - end do - end if - end subroutine diag_atm_recv - - subroutine diag_atm_send(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: afrac(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(in) :: ofrac(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1,size(data) - budget(nf,c_atm_send,ip) = budget(nf,c_atm_send,ip) - areas(n)*data(n)*afrac(n) - budget(nf,c_lnd_asend,ip) = budget(nf,c_lnd_asend,ip) + areas(n)*data(n)*lfrac(n) - budget(nf,c_ocn_asend,ip) = budget(nf,c_ocn_asend,ip) + areas(n)*data(n)*ofrac(n) - if (lats(n) > 0.0_r8) then - budget(nf,c_inh_asend,ip) = budget(nf,c_inh_asend,ip) + areas(n)*data(n)*ifrac(n) - else - budget(nf,c_ish_asend,ip) = budget(nf,c_ish_asend,ip) + areas(n)*data(n)*ifrac(n) - end if - end do - end if - end subroutine diag_atm_send - - subroutine diag_atm_wiso_recv(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, & - afrac, lfrac, ofrac, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: afrac(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(in) :: ofrac(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1,size(data, dim=2) - budget(nf_16O,c_atm_recv,ip) = budget(nf_16O,c_atm_recv,ip) - areas(n)*afrac(n)*data(1,n) - budget(nf_16O,c_lnd_arecv,ip) = budget(nf_16O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(1,n) - budget(nf_16O,c_ocn_arecv,ip) = budget(nf_16O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(1,n) - if (lats(n) > 0.0_r8) then - budget(nf_16O,c_inh_arecv,ip) = budget(nf_16O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(1,n) - else - budget(nf_16O,c_ish_arecv,ip) = budget(nf_16O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(1,n) - end if - - budget(nf_18O,c_atm_recv,ip) = budget(nf_18O,c_atm_recv,ip) - areas(n)*afrac(n)*data(2,n) - budget(nf_18O,c_lnd_arecv,ip) = budget(nf_18O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(2,n) - budget(nf_18O,c_ocn_arecv,ip) = budget(nf_18O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(2,n) - if (lats(n) > 0.0_r8) then - budget(nf_18O,c_inh_arecv,ip) = budget(nf_18O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(2,n) - else - budget(nf_18O,c_ish_arecv,ip) = budget(nf_18O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(2,n) - end if - - budget(nf_HDO,c_atm_recv,ip) = budget(nf_HDO,c_atm_recv,ip) - areas(n)*afrac(n)*data(3,n) - budget(nf_HDO,c_lnd_arecv,ip) = budget(nf_HDO,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(3,n) - budget(nf_HDO,c_ocn_arecv,ip) = budget(nf_HDO,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(3,n) - if (lats(n) > 0.0_r8) then - budget(nf_HDO,c_inh_arecv,ip) = budget(nf_HDO,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(3,n) - else - budget(nf_HDO,c_ish_arecv,ip) = budget(nf_HDO,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_atm_wiso_recv - - subroutine diag_atm_wiso_send(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, & - afrac, lfrac, ofrac, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: afrac(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(in) :: ofrac(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1,size(data, dim=2) - budget(nf_16O,c_atm_send,ip) = budget(nf_16O,c_atm_send,ip) - areas(n)*afrac(n)*data(1,n) - budget(nf_16O,c_lnd_asend,ip) = budget(nf_16O,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(1,n) - budget(nf_16O,c_ocn_asend,ip) = budget(nf_16O,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(1,n) - if (lats(n) > 0.0_r8) then - budget(nf_16O,c_inh_asend,ip) = budget(nf_16O,c_inh_asend,ip) + areas(n)*ifrac(n)*data(1,n) - else - budget(nf_16O,c_ish_asend,ip) = budget(nf_16O,c_ish_asend,ip) + areas(n)*ifrac(n)*data(1,n) - end if - - budget(nf_18O,c_atm_send,ip) = budget(nf_18O,c_atm_send,ip) - areas(n)*afrac(n)*data(2,n) - budget(nf_18O,c_lnd_asend,ip) = budget(nf_18O,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(2,n) - budget(nf_18O,c_ocn_asend,ip) = budget(nf_18O,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(2,n) - if (lats(n) > 0.0_r8) then - budget(nf_18O,c_inh_asend,ip) = budget(nf_18O,c_inh_asend,ip) + areas(n)*ifrac(n)*data(2,n) - else - budget(nf_18O,c_ish_asend,ip) = budget(nf_18O,c_ish_asend,ip) + areas(n)*ifrac(n)*data(2,n) - end if - - budget(nf_HDO,c_atm_send,ip) = budget(nf_HDO,c_atm_send,ip) - areas(n)*afrac(n)*data(3,n) - budget(nf_HDO,c_lnd_asend,ip) = budget(nf_HDO,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(3,n) - budget(nf_HDO,c_ocn_asend,ip) = budget(nf_HDO,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(3,n) - if (lats(n) > 0.0_r8) then - budget(nf_HDO,c_inh_asend,ip) = budget(nf_HDO,c_inh_asend,ip) + areas(n)*ifrac(n)*data(3,n) - else - budget(nf_HDO,c_ish_asend,ip) = budget(nf_HDO,c_ish_asend,ip) + areas(n)*ifrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_atm_wiso_send + subroutine diag_atm_recv(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifrac, budget, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: afrac(:) + real(r8) , intent(in) :: lfrac(:) + real(r8) , intent(in) :: ofrac(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1,size(data) + budget(nf,c_atm_recv,ip) = budget(nf,c_atm_recv,ip) - areas(n)*data(n)*afrac(n) + budget(nf,c_lnd_arecv,ip) = budget(nf,c_lnd_arecv,ip) + areas(n)*data(n)*lfrac(n) + budget(nf,c_ocn_arecv,ip) = budget(nf,c_ocn_arecv,ip) + areas(n)*data(n)*ofrac(n) + if (lats(n) > 0.0_r8) then + budget(nf,c_inh_arecv,ip) = budget(nf,c_inh_arecv,ip) + areas(n)*data(n)*ifrac(n) + else + budget(nf,c_ish_arecv,ip) = budget(nf,c_ish_arecv,ip) + areas(n)*data(n)*ifrac(n) + end if + end do + end if + end subroutine diag_atm_recv - end subroutine med_phases_diag_atm + subroutine diag_atm_send(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifrac, budget, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: afrac(:) + real(r8) , intent(in) :: lfrac(:) + real(r8) , intent(in) :: ofrac(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1,size(data) + budget(nf,c_atm_send,ip) = budget(nf,c_atm_send,ip) - areas(n)*data(n)*afrac(n) + budget(nf,c_lnd_asend,ip) = budget(nf,c_lnd_asend,ip) + areas(n)*data(n)*lfrac(n) + budget(nf,c_ocn_asend,ip) = budget(nf,c_ocn_asend,ip) + areas(n)*data(n)*ofrac(n) + if (lats(n) > 0.0_r8) then + budget(nf,c_inh_asend,ip) = budget(nf,c_inh_asend,ip) + areas(n)*data(n)*ifrac(n) + else + budget(nf,c_ish_asend,ip) = budget(nf,c_ish_asend,ip) + areas(n)*data(n)*ifrac(n) + end if + end do + end if + end subroutine diag_atm_send + + subroutine diag_atm_wiso_recv(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, & + afrac, lfrac, ofrac, ifrac, budget, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf_16O + integer , intent(in) :: nf_18O + integer , intent(in) :: nf_HDO + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: afrac(:) + real(r8) , intent(in) :: lfrac(:) + real(r8) , intent(in) :: ofrac(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_Field) :: lfield + real(r8), pointer :: data(:,:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1,size(data, dim=2) + budget(nf_16O,c_atm_recv,ip) = budget(nf_16O,c_atm_recv,ip) - areas(n)*afrac(n)*data(1,n) + budget(nf_16O,c_lnd_arecv,ip) = budget(nf_16O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(1,n) + budget(nf_16O,c_ocn_arecv,ip) = budget(nf_16O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(1,n) + if (lats(n) > 0.0_r8) then + budget(nf_16O,c_inh_arecv,ip) = budget(nf_16O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(1,n) + else + budget(nf_16O,c_ish_arecv,ip) = budget(nf_16O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(1,n) + end if + + budget(nf_18O,c_atm_recv,ip) = budget(nf_18O,c_atm_recv,ip) - areas(n)*afrac(n)*data(2,n) + budget(nf_18O,c_lnd_arecv,ip) = budget(nf_18O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(2,n) + budget(nf_18O,c_ocn_arecv,ip) = budget(nf_18O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(2,n) + if (lats(n) > 0.0_r8) then + budget(nf_18O,c_inh_arecv,ip) = budget(nf_18O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(2,n) + else + budget(nf_18O,c_ish_arecv,ip) = budget(nf_18O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(2,n) + end if + + budget(nf_HDO,c_atm_recv,ip) = budget(nf_HDO,c_atm_recv,ip) - areas(n)*afrac(n)*data(3,n) + budget(nf_HDO,c_lnd_arecv,ip) = budget(nf_HDO,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(3,n) + budget(nf_HDO,c_ocn_arecv,ip) = budget(nf_HDO,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(3,n) + if (lats(n) > 0.0_r8) then + budget(nf_HDO,c_inh_arecv,ip) = budget(nf_HDO,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(3,n) + else + budget(nf_HDO,c_ish_arecv,ip) = budget(nf_HDO,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(3,n) + end if + end do + end if + end subroutine diag_atm_wiso_recv + + subroutine diag_atm_wiso_send(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, & + afrac, lfrac, ofrac, ifrac, budget, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf_16O + integer , intent(in) :: nf_18O + integer , intent(in) :: nf_HDO + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: afrac(:) + real(r8) , intent(in) :: lfrac(:) + real(r8) , intent(in) :: ofrac(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_Field) :: lfield + real(r8), pointer :: data(:,:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1,size(data, dim=2) + budget(nf_16O,c_atm_send,ip) = budget(nf_16O,c_atm_send,ip) - areas(n)*afrac(n)*data(1,n) + budget(nf_16O,c_lnd_asend,ip) = budget(nf_16O,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(1,n) + budget(nf_16O,c_ocn_asend,ip) = budget(nf_16O,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(1,n) + if (lats(n) > 0.0_r8) then + budget(nf_16O,c_inh_asend,ip) = budget(nf_16O,c_inh_asend,ip) + areas(n)*ifrac(n)*data(1,n) + else + budget(nf_16O,c_ish_asend,ip) = budget(nf_16O,c_ish_asend,ip) + areas(n)*ifrac(n)*data(1,n) + end if + + budget(nf_18O,c_atm_send,ip) = budget(nf_18O,c_atm_send,ip) - areas(n)*afrac(n)*data(2,n) + budget(nf_18O,c_lnd_asend,ip) = budget(nf_18O,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(2,n) + budget(nf_18O,c_ocn_asend,ip) = budget(nf_18O,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(2,n) + if (lats(n) > 0.0_r8) then + budget(nf_18O,c_inh_asend,ip) = budget(nf_18O,c_inh_asend,ip) + areas(n)*ifrac(n)*data(2,n) + else + budget(nf_18O,c_ish_asend,ip) = budget(nf_18O,c_ish_asend,ip) + areas(n)*ifrac(n)*data(2,n) + end if + + budget(nf_HDO,c_atm_send,ip) = budget(nf_HDO,c_atm_send,ip) - areas(n)*afrac(n)*data(3,n) + budget(nf_HDO,c_lnd_asend,ip) = budget(nf_HDO,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(3,n) + budget(nf_HDO,c_ocn_asend,ip) = budget(nf_HDO,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(3,n) + if (lats(n) > 0.0_r8) then + budget(nf_HDO,c_inh_asend,ip) = budget(nf_HDO,c_inh_asend,ip) + areas(n)*ifrac(n)*data(3,n) + else + budget(nf_HDO,c_ish_asend,ip) = budget(nf_HDO,c_ish_asend,ip) + areas(n)*ifrac(n)*data(3,n) + end if + end do + end if + end subroutine diag_atm_wiso_send !=============================================================================== subroutine med_phases_diag_lnd( gcomp, rc) @@ -949,7 +960,7 @@ subroutine med_phases_diag_lnd( gcomp, rc) call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_sen' , f_heat_sen , ic, areas, lfrac, budget_local, rc=rc) call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_evap' , f_watr_evap , ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsur', f_watr_roff, ic, & + call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsur', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofgwl', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) @@ -969,6 +980,8 @@ subroutine med_phases_diag_lnd( gcomp, rc) call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi_wiso', & f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, lfrac, budget_local, rc=rc) + budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice + !------------------------------- ! to land from mediator !------------------------------- @@ -997,83 +1010,80 @@ subroutine med_phases_diag_lnd( gcomp, rc) call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Flrl_flood_wiso', & f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, minus=.true., rc=rc) - budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice call t_stopf('MED:'//subname) + end subroutine med_phases_diag_lnd - contains - subroutine diag_lnd(FB, fldname, nf, ic, areas, lfrac, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data) - if (present(minus)) then - budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*lfrac(n)*data(n) - else - budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*lfrac(n)*data(n) - end if - end do - end if - end subroutine diag_lnd - - subroutine diag_lnd_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, lfrac, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lfrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:,:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (present(minus)) then - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*lfrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*lfrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*lfrac(n)*data(3,n) - else - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*lfrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*lfrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*lfrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_lnd_wiso + subroutine diag_lnd(FB, fldname, nf, ic, areas, lfrac, budget, minus, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + integer , intent(in) :: ic + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lfrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + logical, optional , intent(in) :: minus + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS - end subroutine med_phases_diag_lnd + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data) + if (present(minus)) then + budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*lfrac(n)*data(n) + else + budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*lfrac(n)*data(n) + end if + end do + end if + end subroutine diag_lnd + + subroutine diag_lnd_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, lfrac, budget, minus, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf_16O + integer , intent(in) :: nf_18O + integer , intent(in) :: nf_HDO + integer , intent(in) :: ic + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lfrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + logical, optional , intent(in) :: minus + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:,:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data, dim=2) + if (present(minus)) then + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*lfrac(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*lfrac(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*lfrac(n)*data(3,n) + else + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*lfrac(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*lfrac(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*lfrac(n)*data(3,n) + end if + end do + end if + end subroutine diag_lnd_wiso !=============================================================================== subroutine med_phases_diag_rof( gcomp, rc) @@ -1108,7 +1118,7 @@ subroutine med_phases_diag_rof( gcomp, rc) ! from river to mediator !------------------------------- - ic = c_rof_send + ic = c_rof_recv ip = period_inst call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Flrr_flood', f_watr_roff, ic, areas, budget_local, rc=rc) @@ -1129,7 +1139,7 @@ subroutine med_phases_diag_rof( gcomp, rc) ! to river from mediator !------------------------------- - ic = c_rof_recv + ic = c_rof_send ip = period_inst call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofsur', f_watr_roff, ic, areas, budget_local, rc=rc) @@ -1147,79 +1157,77 @@ subroutine med_phases_diag_rof( gcomp, rc) budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice call t_stopf('MED:'//subname) + end subroutine med_phases_diag_rof - contains - subroutine diag_rof(FB, fldname, nf, ic, areas, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data) - if (present(minus)) then - budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*data(n) - else - budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*data(n) - end if - end do - end if - end subroutine diag_rof - - subroutine diag_rof_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:,:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (present(minus)) then - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*data(3,n) - else - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*data(3,n) - end if - end do - end if - end subroutine diag_rof_wiso + subroutine diag_rof(FB, fldname, nf, ic, areas, budget, minus, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + integer , intent(in) :: ic + real(r8) , intent(in) :: areas(:) + real(r8) , intent(inout) :: budget(:,:,:) + logical, optional , intent(in) :: minus + integer , intent(out) :: rc - end subroutine med_phases_diag_rof + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data) + if (present(minus)) then + budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*data(n) + else + budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*data(n) + end if + end do + end if + end subroutine diag_rof + + subroutine diag_rof_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, budget, minus, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf_16O + integer , intent(in) :: nf_18O + integer , intent(in) :: nf_HDO + integer , intent(in) :: ic + real(r8) , intent(in) :: areas(:) + real(r8) , intent(inout) :: budget(:,:,:) + logical, optional , intent(in) :: minus + integer , intent(out) :: rc + + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:,:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data, dim=2) + if (present(minus)) then + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*data(3,n) + else + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*data(3,n) + end if + end do + end if + end subroutine diag_rof_wiso !=============================================================================== subroutine med_phases_diag_glc( gcomp, rc) @@ -1254,7 +1262,7 @@ subroutine med_phases_diag_glc( gcomp, rc) !------------------------------- ! TODO: this will not be correct if there is more than 1 ice sheet - ic = c_glc_send + ic = c_glc_recv ip = period_inst do ns = 1,num_icesheets @@ -1267,40 +1275,38 @@ subroutine med_phases_diag_glc( gcomp, rc) budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice call t_stopf('MED:'//subname) - - contains - subroutine diag_glc(FB, fldname, nf, ic, areas, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data) - if (present(minus)) then - budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*data(n) - else - budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*data(n) - end if - end do - end if - end subroutine diag_glc - end subroutine med_phases_diag_glc + subroutine diag_glc(FB, fldname, nf, ic, areas, budget, minus, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + integer , intent(in) :: ic + real(r8) , intent(in) :: areas(:) + real(r8) , intent(inout) :: budget(:,:,:) + logical, optional , intent(in) :: minus + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data) + if (present(minus)) then + budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*data(n) + else + budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*data(n) + end if + end do + end if + end subroutine diag_glc + !=============================================================================== subroutine med_phases_diag_ocn( gcomp, rc) @@ -1415,74 +1421,73 @@ subroutine med_phases_diag_ocn( gcomp, rc) budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice + deallocate(sfrac) call t_stopf('MED:'//subname) - contains - - subroutine diag_ocn(FB, fldname, nf, ic, areas, frac, budget, scale, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: frac(:) - real(r8) , intent(inout) :: budget(:,:,:) - real(r8), optional , intent(in) :: scale - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data) - if (present(scale)) then - budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*frac(n)*data(n)*scale - else - budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*frac(n)*data(n) - end if - end do - end if - end subroutine diag_ocn - - subroutine diag_ocn_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, frac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - integer , intent(in) :: ic - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: frac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - - ! local variables - integer :: n, ip - type(ESMF_field) :: lfield - real(r8), pointer :: data(:,:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*frac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*frac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*frac(n)*data(3,n) - end do - end if - end subroutine diag_ocn_wiso - end subroutine med_phases_diag_ocn + subroutine diag_ocn(FB, fldname, nf, ic, areas, frac, budget, scale, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + integer , intent(in) :: ic + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: frac(:) + real(r8) , intent(inout) :: budget(:,:,:) + real(r8), optional , intent(in) :: scale + integer , intent(out) :: rc + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data) + if (present(scale)) then + budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*frac(n)*data(n)*scale + else + budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*frac(n)*data(n) + end if + end do + end if + end subroutine diag_ocn + + subroutine diag_ocn_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, frac, budget, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf_16O + integer , intent(in) :: nf_18O + integer , intent(in) :: nf_HDO + integer , intent(in) :: ic + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: frac(:) + real(r8) , intent(inout) :: budget(:,:,:) + integer , intent(out) :: rc + + ! local variables + integer :: n, ip + type(ESMF_field) :: lfield + real(r8), pointer :: data(:,:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data, dim=2) + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*frac(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*frac(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*frac(n)*data(3,n) + end do + end if + end subroutine diag_ocn_wiso + !=============================================================================== subroutine med_phases_diag_ice_ice2med( gcomp, rc) @@ -1558,98 +1563,95 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, areas, lats, ifrac, budget_local, rc=rc) call t_stopf('MED:'//subname) + end subroutine med_phases_diag_ice_ice2med - contains - - subroutine diag_ice_recv(FB, fldname, nf, areas, lats, ifrac, budget, minus, scale, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - real(r8), optional , intent(in) :: scale - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_Field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1,size(data) - if (lats(n) > 0.0_r8) then - ic = c_inh_recv - else - ic = c_ish_recv - endif - if (present(minus)) then - if (present(scale)) then - budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n)*scale - else - budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n) - end if - else - if (present(scale)) then - budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n)*scale - else - budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n) - end if - end if - end do - end if - end subroutine diag_ice_recv - - subroutine diag_ice_recv_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, minus, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - logical, optional , intent(in) :: minus - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (lats(n) > 0.0_r8) then - ic = c_inh_recv - else - ic = c_ish_recv - endif - if (present(minus)) then - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*ifrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*ifrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*ifrac(n)*data(3,n) - else - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n) - end if - end do - end if - end subroutine diag_ice_recv_wiso + subroutine diag_ice_recv(FB, fldname, nf, areas, lats, ifrac, budget, minus, scale, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + logical, optional , intent(in) :: minus + real(r8), optional , intent(in) :: scale + integer , intent(out) :: rc + ! local variables + integer :: n, ic, ip + type(ESMF_Field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1,size(data) + if (lats(n) > 0.0_r8) then + ic = c_inh_recv + else + ic = c_ish_recv + endif + if (present(minus)) then + if (present(scale)) then + budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n)*scale + else + budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n) + end if + else + if (present(scale)) then + budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n)*scale + else + budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n) + end if + end if + end do + end if + end subroutine diag_ice_recv - end subroutine med_phases_diag_ice_ice2med + subroutine diag_ice_recv_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, minus, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf_16O + integer , intent(in) :: nf_18O + integer , intent(in) :: nf_HDO + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + logical, optional , intent(in) :: minus + integer , intent(out) :: rc + ! local variables + integer :: n, ic, ip + type(ESMF_Field) :: lfield + real(r8), pointer :: data(:,:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data, dim=2) + if (lats(n) > 0.0_r8) then + ic = c_inh_recv + else + ic = c_ish_recv + endif + if (present(minus)) then + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*ifrac(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*ifrac(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*ifrac(n)*data(3,n) + else + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n) + end if + end do + end if + end subroutine diag_ice_recv_wiso !=============================================================================== subroutine med_phases_diag_ice_med2ice( gcomp, rc) @@ -1739,77 +1741,74 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, areas, lats, ifrac, budget_local, rc=rc) call t_stopf('MED:'//subname) + end subroutine med_phases_diag_ice_med2ice + + subroutine diag_ice_send(FB, fldname, nf, areas, lats, ifrac, budget, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + integer , intent(out) :: rc + ! local variables + integer :: n, ic, ip + type(ESMF_Field) :: lfield + real(r8), pointer :: data(:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + ip = period_inst + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(data) + if (lats(n) > 0.0_r8) then + ic = c_inh_send + else + ic = c_ish_send + endif + budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*ifrac(n)*data(n) + end do + end if + end subroutine diag_ice_send - contains - - subroutine diag_ice_send(FB, fldname, nf, areas, lats, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - ! local variables - integer :: n, ip - type(ESMF_Field) :: lfield - real(r8), pointer :: data(:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - ip = period_inst - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - do n = 1,size(data) - if (lats(n) > 0.0_r8) then - ic = c_inh_send - else - ic = c_ish_send - endif - budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*ifrac(n)*data(n) - end do - end if - end subroutine diag_ice_send - - subroutine diag_ice_send_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, rc) - ! input/output variables - type(ESMF_FieldBundle) , intent(in) :: FB - character(len=*) , intent(in) :: fldname - integer , intent(in) :: nf_16O - integer , intent(in) :: nf_18O - integer , intent(in) :: nf_HDO - real(r8) , intent(in) :: areas(:) - real(r8) , intent(in) :: lats(:) - real(r8) , intent(in) :: ifrac(:) - real(r8) , intent(inout) :: budget(:,:,:) - integer , intent(out) :: rc - - ! local variables - integer :: n, ip - type(ESMF_Field) :: lfield - real(r8), pointer :: data(:,:) => null() - ! ------------------------------------------------------------------ - rc = ESMF_SUCCESS - if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then - call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - ip = period_inst - do n = 1, size(data, dim=2) - if (lats(n) > 0.0_r8) then - ic = c_inh_send - else - ic = c_ish_send - endif - budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n) - budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n) - budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n) - end do - end if - end subroutine diag_ice_send_wiso + subroutine diag_ice_send_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, rc) + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fldname + integer , intent(in) :: nf_16O + integer , intent(in) :: nf_18O + integer , intent(in) :: nf_HDO + real(r8) , intent(in) :: areas(:) + real(r8) , intent(in) :: lats(:) + real(r8) , intent(in) :: ifrac(:) + real(r8) , intent(inout) :: budget(:,:,:) + integer , intent(out) :: rc - end subroutine med_phases_diag_ice_med2ice + ! local variables + integer :: n, ic, ip + type(ESMF_Field) :: lfield + real(r8), pointer :: data(:,:) => null() + ! ------------------------------------------------------------------ + rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then + call fldbun_getdata2d(FB, trim(fldname), data, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ip = period_inst + do n = 1, size(data, dim=2) + if (lats(n) > 0.0_r8) then + ic = c_inh_send + else + ic = c_ish_send + endif + budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n) + budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n) + budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n) + end do + end if + end subroutine diag_ice_send_wiso !=============================================================================== subroutine med_phases_diag_print(gcomp, rc) @@ -1825,12 +1824,12 @@ subroutine med_phases_diag_print(gcomp, rc) ! local variables type(ESMF_Clock) :: clock type(ESMF_Alarm) :: stop_alarm - type(ESMF_Time) :: currTime - integer :: cdate ! coded date, seconds - integer :: curr_year - integer :: curr_mon - integer :: curr_day - integer :: curr_tod + type(ESMF_Time) :: nextTime + integer :: date ! coded date, seconds + integer :: year + integer :: mon + integer :: day + integer :: tod integer :: output_level ! print level logical :: sumdone ! has a sum been computed yet character(CS) :: cvalue @@ -1839,10 +1838,8 @@ subroutine med_phases_diag_print(gcomp, rc) integer :: f_size ! number of fields integer :: p_size ! number of period types real(r8), allocatable :: datagpr(:,:,:) - character(len=20) :: name + character(len=64) :: timestr logical, save :: firstcall = .true. - integer :: yr,mon,day,sec ! time units - character(len=64) :: currtimestr character(*), parameter :: subName = '(med_phases_diag_print) ' ! ------------------------------------------------------------------ @@ -1853,17 +1850,23 @@ subroutine med_phases_diag_print(gcomp, rc) !------------------------------------------------------------------------------- ! Get clock and alarm info - call ESMF_GridCompGet(gcomp, clock=clock, name=name, rc=rc) + call ESMF_GridCompGet(gcomp, clock=clock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGet( clock, currTime=currTime, rc=rc) + + ! NOTE - we are using the next time to ensure that budgets are + ! written at the end of the run correctly This duplicates the + ! behavior in the restart and history file output in that the time + ! stamp is the next time and not the actual current time + call ESMF_ClockGetNextTime(clock, nextTime=nexttime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet( currTime, yy=curr_year, mm=curr_mon, dd=curr_day, s=curr_tod, rc=rc) + call ESMF_TimeGet( nextTime, yy=year, mm=mon, dd=day, s=tod, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - cdate = curr_year*10000 + curr_mon*100 + curr_day + date = year*10000 + mon*100 + day + #ifdef DEBUG if(mastertask) then - write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') curr_year,'-',curr_mon,'-',curr_day,'-',curr_tod - write(logunit,' (a)') trim(subname)//": currtime = "//trim(currtimestr) + write(timestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') year,'-',mon,'-',day,'-',tod + write(logunit,' (a)') trim(subname)//": time = "//trim(timestr) endif #endif @@ -1880,16 +1883,16 @@ subroutine med_phases_diag_print(gcomp, rc) if (ip == period_inst) then output_level = max(output_level, budget_print_inst) end if - if (ip == period_day .and. curr_tod == 0) then + if (ip == period_day .and. tod == 0) then output_level = max(output_level, budget_print_daily) end if - if (ip == period_mon .and. curr_day == 1 .and. curr_tod == 0) then + if (ip == period_mon .and. day == 1 .and. tod == 0) then output_level = max(output_level, budget_print_month) end if - if (ip == period_ann .and. curr_mon == 1 .and. curr_day == 1 .and. curr_tod == 0) then + if (ip == period_ann .and. mon == 1 .and. day == 1 .and. tod == 0) then output_level = max(output_level, budget_print_ann) end if - if (ip == period_inf .and. curr_mon == 1 .and. curr_day == 1 .and. curr_tod == 0) then + if (ip == period_inf .and. mon == 1 .and. day == 1 .and. tod == 0) then output_level = max(output_level, budget_print_ltann) end if if (ip == period_inf) then @@ -1901,67 +1904,66 @@ subroutine med_phases_diag_print(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif endif - if (output_level > 0) exit - enddo ! ip = 1, period_types - - ! Currently output_level is limited to levels of 0,1,2, 3 - ! (see comment for print options at top) - - if (output_level > 0) then - if (.not. sumdone) then - ! Some budgets will be printed for this period type - ! Determine sums if not already done - call med_diag_sum_master(gcomp, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - sumdone = .true. - end if + ! Currently output_level is limited to levels of 0,1,2, 3 + ! (see comment for print options at top) - if (mastertask) then - c_size = size(budget_diags%comps) - f_size = size(budget_diags%fields) - p_size = size(budget_diags%periods) - allocate(datagpr(f_size, c_size, p_size)) - datagpr(:,:,:) = budget_global(:,:,:) - - ! budget normalizations (global area and 1e6 for water) - datagpr = datagpr/(4.0_r8*shr_const_pi) - datagpr(f_watr_beg:f_watr_end,:,:) = datagpr(f_watr_beg:f_watr_end,:,:) * 1.0e6_r8 - if ( flds_wiso ) then - datagpr(iso0(1):isof(nisotopes),:,:) = datagpr(iso0(1):isof(nisotopes),:,:) * 1.0e6_r8 - end if - datagpr(:,:,:) = datagpr(:,:,:)/budget_counter(:,:,:) + if (output_level > 0) then + if (.not. sumdone) then + ! Some budgets will be printed for this period type + ! Determine sums if not already done + call med_diag_sum_master(gcomp, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Write diagnostic tables to logunit (mastertask only) - if (output_level >= 3) then - ! detail atm budgets and breakdown into components --- - call med_diag_print_atm(datagpr, ip, cdate, curr_tod) + sumdone = .true. end if - if (output_level >= 2) then - ! detail lnd/ocn/ice component budgets ---- - call med_diag_print_lnd_ice_ocn(datagpr, ip, cdate, curr_tod) - end if - if (output_level >= 1) then - ! net summary budgets - call med_diag_print_summary(datagpr, ip, cdate, curr_tod) - endif - write(logunit,*) ' ' - deallocate(datagpr) - endif ! output_level > 0 and mastertask - end if ! if mastertask + if (mastertask) then + c_size = size(budget_diags%comps) + f_size = size(budget_diags%fields) + p_size = size(budget_diags%periods) + allocate(datagpr(f_size, c_size, p_size)) + datagpr(:,:,:) = budget_global(:,:,:) + + ! budget normalizations (global area and 1e6 for water) + datagpr = datagpr/(4.0_r8*shr_const_pi) + datagpr(f_watr_beg:f_watr_end,:,:) = datagpr(f_watr_beg:f_watr_end,:,:) * 1.0e6_r8 + if ( flds_wiso ) then + datagpr(iso0(1):isof(nisotopes),:,:) = datagpr(iso0(1):isof(nisotopes),:,:) * 1.0e6_r8 + end if + datagpr(:,:,:) = datagpr(:,:,:)/budget_counter(:,:,:) + + ! Write diagnostic tables to logunit (mastertask only) + if (output_level >= 3) then + ! detail atm budgets and breakdown into components --- + call med_diag_print_atm(datagpr, ip, date, tod) + end if + if (output_level >= 2) then + ! detail lnd/ocn/ice component budgets ---- + call med_diag_print_lnd_ice_ocn(datagpr, ip, date, tod) + end if + if (output_level >= 1) then + ! net summary budgets + call med_diag_print_summary(datagpr, ip, date, tod) + endif + write(diagunit,*) ' ' + + deallocate(datagpr) + + endif ! output_level > 0 and mastertask + end if ! if mastertask + enddo ! ip = 1, period_types !------------------------------------------------------------------------------- ! Zero budget data !------------------------------------------------------------------------------- - call med_diag_zero(gcomp, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_diag_zero(year, mon, day, tod) end subroutine med_phases_diag_print !=============================================================================== - subroutine med_diag_print_atm(data, ip, cdate, curr_tod) + subroutine med_diag_print_atm(data, ip, date, tod) ! --------------------------------------------------------- ! detail atm budgets and breakdown into components @@ -1970,8 +1972,8 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) ! intput/output variables real(r8), intent(in) :: data(:,:,:) ! values to print, scaled and such integer , intent(in) :: ip ! period index - integer , intent(in) :: cdate - integer , intent(in) :: curr_tod + integer , intent(in) :: date + integer , intent(in) :: tod ! local variables integer :: ic,nf,is ! data array indicies @@ -1998,16 +2000,16 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) str = "CPL_TO_ATM" endif - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//' AREA BUDGET (m2/m2): period = ', & - trim(budget_diags%periods(ip)%name), ': date = ', cdate, curr_tod - write(logunit,FA0) & + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//' AREA BUDGET (m2/m2): period = ', & + trim(budget_diags%periods(ip)%name), ': date = ', date, tod + write(diagunit,FA0) & budget_diags%comps(ica)%name,& budget_diags%comps(icl)%name,& budget_diags%comps(icn)%name,& budget_diags%comps(ics)%name,& budget_diags%comps(ico)%name,' *SUM* ' - write(logunit,FA1) budget_diags%fields(f_area)%name,& + write(diagunit,FA1) budget_diags%fields(f_area)%name,& data(f_area,ica,ip), & data(f_area,icl,ip), & data(f_area,icn,ip), & @@ -2016,17 +2018,17 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) data(f_area,ica,ip) + data(f_area,icl,ip) + & data(f_area,icn,ip) + data(f_area,ics,ip) + data(f_area,ico,ip) - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',& - trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod - write(logunit,FA0) & + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',& + trim(budget_diags%periods(ip)%name),': date = ',date,tod + write(diagunit,FA0) & budget_diags%comps(ica)%name,& budget_diags%comps(icl)%name,& budget_diags%comps(icn)%name,& budget_diags%comps(ics)%name,& budget_diags%comps(ico)%name,' *SUM* ' do nf = f_heat_beg, f_heat_end - write(logunit,FA1) budget_diags%fields(nf)%name,& + write(diagunit,FA1) budget_diags%fields(nf)%name,& data(nf,ica,ip), & data(nf,icl,ip), & data(nf,icn,ip), & @@ -2034,7 +2036,7 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) data(nf,ico,ip), & data(nf,ica,ip) + data(nf,icl,ip) + data(nf,icn,ip) + data(nf,ics,ip) + data(nf,ico,ip) enddo - write(logunit,FA1) ' *SUM*' ,& + write(diagunit,FA1) ' *SUM*' ,& sum(data(f_heat_beg:f_heat_end,ica,ip)), & sum(data(f_heat_beg:f_heat_end,icl,ip)), & sum(data(f_heat_beg:f_heat_end,icn,ip)), & @@ -2044,17 +2046,17 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) sum(data(f_heat_beg:f_heat_end,icn,ip)) + sum(data(f_heat_beg:f_heat_end,ics,ip)) + & sum(data(f_heat_beg:f_heat_end,ico,ip)) - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',& - trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod - write(logunit,FA0) & + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',& + trim(budget_diags%periods(ip)%name),': date = ',date,tod + write(diagunit,FA0) & budget_diags%comps(ica)%name,& budget_diags%comps(icl)%name,& budget_diags%comps(icn)%name,& budget_diags%comps(ics)%name,& budget_diags%comps(ico)%name,' *SUM* ' do nf = f_watr_beg, f_watr_end - write(logunit,FA1) budget_diags%fields(nf)%name,& + write(diagunit,FA1) budget_diags%fields(nf)%name,& data(nf,ica,ip), & data(nf,icl,ip), & data(nf,icn,ip), & @@ -2062,7 +2064,7 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) data(nf,ico,ip), & data(nf,ica,ip) + data(nf,icl,ip) + data(nf,icn,ip) + data(nf,ics,ip) + data(nf,ico,ip) enddo - write(logunit,FA1) ' *SUM*' ,& + write(diagunit,FA1) ' *SUM*' ,& sum(data(f_watr_beg:f_watr_end,ica,ip)), & sum(data(f_watr_beg:f_watr_end,icl,ip)), & sum(data(f_watr_beg:f_watr_end,icn,ip)), & @@ -2074,17 +2076,17 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) if ( flds_wiso ) then do is = 1, nisotopes - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//' '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', & - trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod - write(logunit,FA0) & + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//' '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', & + trim(budget_diags%periods(ip)%name),': date = ',date,tod + write(diagunit,FA0) & budget_diags%comps(ica)%name,& budget_diags%comps(icl)%name,& budget_diags%comps(icn)%name,& budget_diags%comps(ics)%name,& budget_diags%comps(ico)%name,' *SUM* ' do nf = iso0(is), isof(is) - write(logunit,FA1) budget_diags%fields(nf)%name,& + write(diagunit,FA1) budget_diags%fields(nf)%name,& data(nf,ica,ip), & data(nf,icl,ip), & data(nf,icn,ip), & @@ -2092,7 +2094,7 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) data(nf,ico,ip), & data(nf,ica,ip) + data(nf,icl,ip) + data(nf,icn,ip) + data(nf,ics,ip) + data(nf,ico,ip) enddo - write(logunit,FA1) ' *SUM*', & + write(diagunit,FA1) ' *SUM*', & sum(data(iso0(is):isof(is),ica,ip)), & sum(data(iso0(is):isof(is),icl,ip)), & sum(data(iso0(is):isof(is),icn,ip)), & @@ -2109,7 +2111,7 @@ subroutine med_diag_print_atm(data, ip, cdate, curr_tod) end subroutine med_diag_print_atm !=============================================================================== - subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod) + subroutine med_diag_print_lnd_ice_ocn(data, ip, date, tod) ! --------------------------------------------------------- ! detail lnd/ocn/ice component budgets @@ -2118,8 +2120,8 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod) ! intput/output variables real(r8), intent(in) :: data(:,:,:) ! values to print, scaled and such integer , intent(in) :: ip - integer , intent(in) :: cdate - integer , intent(in) :: curr_tod + integer , intent(in) :: date + integer , intent(in) :: tod ! local variables integer :: ic,nf,is ! data array indicies @@ -2159,22 +2161,22 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod) ! heat budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh, - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',& - trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod - write(logunit,FA0) budget_diags%comps(icar)%name,& + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',& + trim(budget_diags%periods(ip)%name),': date = ',date,tod + write(diagunit,FA0) budget_diags%comps(icar)%name,& budget_diags%comps(icxs)%name,& budget_diags%comps(icxr)%name,& budget_diags%comps(icas)%name,' *SUM* ' do nf = f_heat_beg, f_heat_end - write(logunit,FA1) budget_diags%fields(nf)%name,& + write(diagunit,FA1) budget_diags%fields(nf)%name,& -data(nf,icar,ip), & data(nf,icxs,ip), & data(nf,icxr,ip), & -data(nf,icas,ip), & -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip) enddo - write(logunit,FA1)' *SUM*',& + write(diagunit,FA1)' *SUM*',& -sum(data(f_heat_beg:f_heat_end,icar,ip)), & sum(data(f_heat_beg:f_heat_end,icxs,ip)), & sum(data(f_heat_beg:f_heat_end,icxr,ip)), & @@ -2184,23 +2186,23 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod) ! water budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh, - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',& - trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod - write(logunit,FA0) & + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',& + trim(budget_diags%periods(ip)%name),': date = ',date,tod + write(diagunit,FA0) & budget_diags%comps(icar)%name,& budget_diags%comps(icxs)%name,& budget_diags%comps(icxr)%name,& budget_diags%comps(icas)%name,' *SUM* ' do nf = f_watr_beg, f_watr_end - write(logunit,FA1) budget_diags%fields(nf)%name,& + write(diagunit,FA1) budget_diags%fields(nf)%name,& -data(nf,icar,ip),& data(nf,icxs,ip), & data(nf,icxr,ip),& -data(nf,icas,ip), & -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip) enddo - write(logunit,FA1) ' *SUM*',& + write(diagunit,FA1) ' *SUM*',& -sum(data(f_watr_beg:f_watr_end,icar,ip)), & sum(data(f_watr_beg:f_watr_end,icxs,ip)), & sum(data(f_watr_beg:f_watr_end,icxr,ip)), & @@ -2213,24 +2215,24 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod) ! heat budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh for water isotopes - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',& + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',& trim(budget_diags%periods(ip)%name), & - ': date = ',cdate,curr_tod - write(logunit,FA0) & + ': date = ',date,tod + write(diagunit,FA0) & budget_diags%comps(icar)%name,& budget_diags%comps(icxs)%name,& budget_diags%comps(icxr)%name,& budget_diags%comps(icas)%name,' *SUM* ' do nf = iso0(is), isof(is) - write(logunit,FA1) budget_diags%fields(nf)%name,& + write(diagunit,FA1) budget_diags%fields(nf)%name,& -data(nf,icar,ip), & data(nf,icxs,ip), & data(nf,icxr,ip), & -data(nf,icas,ip), & -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip) enddo - write(logunit,FA1) ' *SUM*',& + write(diagunit,FA1) ' *SUM*',& -sum(data(iso0(is):isof(is),icar,ip)),& sum(data(iso0(is):isof(is),icxs,ip)), & sum(data(iso0(is):isof(is),icxr,ip)), & @@ -2240,24 +2242,24 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod) ! water budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh for water isotopes - write(logunit,*) ' ' - write(logunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',& + write(diagunit,*) ' ' + write(diagunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',& trim(budget_diags%periods(ip)%name),& - ': date = ',cdate,curr_tod - write(logunit,FA0) & + ': date = ',date,tod + write(diagunit,FA0) & budget_diags%comps(icar)%name,& budget_diags%comps(icxs)%name,& budget_diags%comps(icxr)%name,& budget_diags%comps(icas)%name,' *SUM* ' do nf = iso0(is), isof(is) - write(logunit,FA1) budget_diags%fields(nf)%name,& + write(diagunit,FA1) budget_diags%fields(nf)%name,& -data(nf,icar,ip), & data(nf,icxs,ip), & data(nf,icxr,ip), & -data(nf,icas,ip), & -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip) enddo - write(logunit,FA1) ' *SUM*', & + write(diagunit,FA1) ' *SUM*', & -sum(data(iso0(is):isof(is), icar, ip)), & sum(data(iso0(is):isof(is), icxs, ip)), & sum(data(iso0(is):isof(is), icxr, ip)), & @@ -2271,7 +2273,7 @@ subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod) end subroutine med_diag_print_lnd_ice_ocn !=============================================================================== - subroutine med_diag_print_summary(data, ip, cdate, curr_tod) + subroutine med_diag_print_summary(data, ip, date, tod) ! --------------------------------------------------------- ! net summary budgets @@ -2280,8 +2282,8 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) ! intput/output variables real(r8), intent(in) :: data(:,:,:) ! values to print, scaled and such integer , intent(in) :: ip - integer , intent(in) :: cdate - integer , intent(in) :: curr_tod + integer , intent(in) :: date + integer , intent(in) :: tod ! local variables integer :: ic,nf,is ! data array indicies @@ -2311,25 +2313,24 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) call t_startf('MED:'//subname) ! write out areas - write(logunit,*) ' ' - write(logunit,FAH) subname,'NET AREA BUDGET (m2/m2): period = ',& + write(diagunit,*) ' ' + write(diagunit,FAH) subname,'NET AREA BUDGET (m2/m2): period = ',& trim(budget_diags%periods(ip)%name),& - ': date = ',cdate,curr_tod - write(logunit,FA0) ' atm',' lnd',' ocn',' ice nh',' ice sh',' *SUM* ' + ': date = ',date,tod + write(diagunit,FA0) ' atm',' lnd',' ocn',' ice nh',' ice sh',' *SUM* ' atm_area = data(f_area,c_atm_recv,ip) lnd_area = data(f_area,c_lnd_recv,ip) ocn_area = data(f_area,c_ocn_recv,ip) ice_area_nh = data(f_area,c_inh_recv,ip) ice_area_sh = data(f_area,c_ish_recv,ip) sum_area = atm_area + lnd_area + ocn_area + ice_area_nh + ice_area_sh - write(logunit,FA1) budget_diags%fields(f_area)%name, atm_area, lnd_area, ocn_area, ice_area_nh, ice_area_sh, sum_area - + write(diagunit,FA1) budget_diags%fields(f_area)%name, atm_area, lnd_area, ocn_area, ice_area_nh, ice_area_sh, sum_area ! write out net heat budgets - write(logunit,*) ' ' - write(logunit,FAH) subname,'NET HEAT BUDGET (W/m2): period = ',& - trim(budget_diags%periods(ip)%name), ': date = ',cdate,curr_tod - write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + write(diagunit,*) ' ' + write(diagunit,FAH) subname,'NET HEAT BUDGET (W/m2): period = ',& + trim(budget_diags%periods(ip)%name), ': date = ',date,tod + write(diagunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' do nf = f_heat_beg, f_heat_end net_heat_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip) net_heat_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip) @@ -2341,7 +2342,7 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) net_heat_tot = net_heat_atm + net_heat_lnd + net_heat_rof + net_heat_ocn + & net_heat_ice_nh + net_heat_ice_sh + net_heat_glc - write(logunit,FA1r) budget_diags%fields(nf)%name,& + write(diagunit,FA1r) budget_diags%fields(nf)%name,& net_heat_atm, net_heat_lnd, net_heat_rof, net_heat_ocn, & net_heat_ice_nh, net_heat_ice_sh, net_heat_glc, net_heat_tot end do @@ -2365,16 +2366,16 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) sum_net_heat_tot = sum_net_heat_atm + sum_net_heat_lnd + sum_net_heat_rof + sum_net_heat_ocn + & sum_net_heat_ice_nh + sum_net_heat_ice_sh + sum_net_heat_glc - write(logunit,FA1r)' *SUM*',& + write(diagunit,FA1r)' *SUM*',& sum_net_heat_atm, sum_net_heat_lnd, sum_net_heat_rof, sum_net_heat_ocn, & sum_net_heat_ice_nh, sum_net_heat_ice_sh, sum_net_heat_glc, sum_net_heat_tot ! write out net water budgets - write(logunit,*) ' ' - write(logunit,FAH) subname,'NET WATER BUDGET (kg/m2s*1e6): period = ',& - trim(budget_diags%periods(ip)%name), ': date = ',cdate,curr_tod - write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + write(diagunit,*) ' ' + write(diagunit,FAH) subname,'NET WATER BUDGET (kg/m2s*1e6): period = ',& + trim(budget_diags%periods(ip)%name), ': date = ',date,tod + write(diagunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' do nf = f_watr_beg, f_watr_end net_water_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip) net_water_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip) @@ -2386,7 +2387,7 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) net_water_tot = net_water_atm + net_water_lnd + net_water_rof + net_water_ocn + & net_water_ice_nh + net_water_ice_sh + net_water_glc - write(logunit,FA1r) budget_diags%fields(nf)%name,& + write(diagunit,FA1r) budget_diags%fields(nf)%name,& net_water_atm, net_water_lnd, net_water_rof, net_water_ocn, & net_water_ice_nh, net_water_ice_sh, net_water_glc, net_water_tot enddo @@ -2410,7 +2411,7 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) sum_net_water_tot = sum_net_water_atm + sum_net_water_lnd + sum_net_water_rof + sum_net_water_ocn + & sum_net_water_ice_nh + sum_net_water_ice_sh + sum_net_water_glc - write(logunit,FA1r)' *SUM*',& + write(diagunit,FA1r)' *SUM*',& sum_net_water_atm, sum_net_water_lnd, sum_net_water_rof, sum_net_water_ocn, & sum_net_water_ice_nh, sum_net_water_ice_sh, sum_net_water_glc, sum_net_water_tot @@ -2419,10 +2420,10 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) if ( flds_wiso ) then do is = 1, nisotopes - write(logunit,*) ' ' - write(logunit,FAH) subname,'NET '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', & - trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod - write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + write(diagunit,*) ' ' + write(diagunit,FAH) subname,'NET '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', & + trim(budget_diags%periods(ip)%name),': date = ',date,tod + write(diagunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' do nf = iso0(is), isof(is) net_water_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip) net_water_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip) @@ -2434,7 +2435,7 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) net_water_tot = net_water_atm + net_water_lnd + net_water_rof + net_water_ocn + & net_water_ice_nh + net_water_ice_sh + net_water_glc - write(logunit,FA1r) budget_diags%fields(nf)%name,& + write(diagunit,FA1r) budget_diags%fields(nf)%name,& net_water_atm, net_water_lnd, net_water_rof, net_water_ocn, & net_water_ice_nh, net_water_ice_sh, net_water_glc, net_water_tot enddo @@ -2457,7 +2458,7 @@ subroutine med_diag_print_summary(data, ip, cdate, curr_tod) sum_net_water_ocn + sum_net_water_ice_nh + sum_net_water_ice_sh + & sum_net_water_glc - write(logunit,FA1r)' *SUM*',& + write(diagunit,FA1r)' *SUM*',& sum_net_water_atm, sum_net_water_lnd, sum_net_water_rof, sum_net_water_ocn, & sum_net_water_ice_nh, sum_net_water_ice_sh, sum_net_water_glc, sum_net_water_tot end do @@ -2500,7 +2501,7 @@ subroutine add_to_budget_diag(entries, index, name) ! create new entry if fldname is not in original list if (.not. found) then - + if(mastertask) write(logunit,*) ' Add ',trim(name),' to budgets with index ',index ! 1) allocate newfld to be size (one element larger than input flds) allocate(new_entries(index)) diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90 index d1bc1c4b6..da21c30f5 100644 --- a/mediator/med_internalstate_mod.F90 +++ b/mediator/med_internalstate_mod.F90 @@ -13,6 +13,7 @@ module med_internalstate_mod private integer, public :: logunit ! logunit for mediator log output + integer, public :: diagunit ! diagunit for budget output (med master only) integer, public :: loglevel ! loglevel for mediator log output logical, public :: mastertask=.false. ! is this the mastertask integer, public :: med_id ! needed currently in med_io_mod and set in esm.F90 @@ -62,6 +63,7 @@ module med_internalstate_mod integer :: flds_scalar_index_ny = 0 integer :: flds_scalar_index_nextsw_cday = 0 integer :: flds_scalar_index_precip_factor = 0 + real(r8) :: flds_scalar_precip_factor = 1._r8 ! actual value of precip factor from ocn ! Import/export States and field bundles (the field bundles have the scalar fields removed) type(ESMF_State) :: NStateImp(ncomps) ! Import data from various component, on their grid @@ -96,6 +98,7 @@ module med_internalstate_mod ! Component Mesh info type(mesh_info_type) :: mesh_info(ncomps) + type(ESMF_FieldBundle) :: FBArea(ncomps) ! needed for mediator history writes end type InternalStateStruct diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90 index d4f767d6e..bb156258e 100644 --- a/mediator/med_io_mod.F90 +++ b/mediator/med_io_mod.F90 @@ -1053,7 +1053,7 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, & do k = 1,nf call FB_getNameN(FB, k, itemc, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - + call FB_getFldPtr(FB, itemc, & fldptr1=fldptr1, fldptr2=fldptr2, rank=rank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index ee9371550..e1dab5e84 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -817,7 +817,7 @@ subroutine med_map_packed_field_create(destcomp, flds_scalar_name, & //', mapnorm '//trim(mapnorm_mapindex) & //' set; cannot set mapnorm to '//trim(packed_data(mapindex)%mapnorm) & //' '//trim(fieldnamelist(nf)) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_ERROR) call ESMF_Finalize(endflag=ESMF_END_ABORT) end if end if @@ -989,7 +989,7 @@ subroutine med_map_field_packed(FBSrc, FBDst, FBFracSrc, field_normOne, packed_d ! ----------------------------------- ! Copy the src fields into the packed field bundle ! ----------------------------------- - + call t_startf('MED:'//trim(subname)//' copy from src') ! First get the pointer for the packed source data diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 7cfe09b57..893393d2c 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -409,6 +409,7 @@ subroutine med_phases_history_write(gcomp, rc) nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre=trim(compname(n))//'Exp', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + ! write component mediator fractions if (ESMF_FieldBundleIsCreated(is_local%wrap%FBFrac(n),rc=rc)) then nx = is_local%wrap%nx(n) ny = is_local%wrap%ny(n) @@ -416,7 +417,12 @@ subroutine med_phases_history_write(gcomp, rc) nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='Med_frac_'//trim(compname(n)), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - endif + ! write component mediator areas + nx = is_local%wrap%nx(n) + ny = is_local%wrap%ny(n) + call med_io_write(hist_file, iam, is_local%wrap%FBArea(n), & + nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='MED_'//trim(compname(n)), rc=rc) + end if enddo if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_o,rc=rc)) then nx = is_local%wrap%nx(compocn) diff --git a/mediator/med_phases_prep_atm_mod.F90 b/mediator/med_phases_prep_atm_mod.F90 index ba1a18962..e26f3b5f1 100644 --- a/mediator/med_phases_prep_atm_mod.F90 +++ b/mediator/med_phases_prep_atm_mod.F90 @@ -44,6 +44,8 @@ subroutine med_phases_prep_atm(gcomp, rc) type(InternalState) :: is_local real(R8), pointer :: dataPtr1(:) => null() real(R8), pointer :: dataPtr2(:) => null() + real(R8), pointer :: ifrac(:) => null() + real(R8), pointer :: ofrac(:) => null() integer :: i, j, n, n1, ncnt character(len=*),parameter :: subname='(med_phases_prep_atm)' !------------------------------------------------------------------------------- @@ -190,6 +192,33 @@ subroutine med_phases_prep_atm(gcomp, rc) end do end if + ! Note - the following needs a custom merge since Faoo_fco2_ocn is scaled by (ifrac+ofrac) + ! in the merge to the atm + if ( FB_FldChk(is_local%wrap%FBExp(compatm) , 'Faoo_fco2_ocn', rc=rc) .and. & + FB_FldChk(is_local%wrap%FBImp(compocn,compocn), 'Faoo_fco2_ocn', rc=rc)) then + call ESMF_FieldGet(lfield, farrayPtr=dataptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compatm), fieldName='ifrac', field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=ifrac, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compatm), fieldName='ofrac', field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=ofrac, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compatm), fieldName='Faoo_fco2_ocn', field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldBundleGet(is_local%wrap%FBExp(compatm), fieldName='Faoo_fco2_ocn', field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataptr2, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,size(dataptr2) + dataptr2(n) = (ifrac(n) + ofrac(n)) * dataptr1(n) + end do + end if + if (dbug_flag > 5) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) end if diff --git a/mediator/med_phases_prep_ice_mod.F90 b/mediator/med_phases_prep_ice_mod.F90 index 7ec38e877..4f12f97ad 100644 --- a/mediator/med_phases_prep_ice_mod.F90 +++ b/mediator/med_phases_prep_ice_mod.F90 @@ -29,10 +29,12 @@ subroutine med_phases_prep_ice(gcomp, rc) use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldGet, ESMF_Field use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_FAILURE use ESMF , only : ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND - use med_utils_mod , only : chkerr => med_utils_ChkErr - use med_methods_mod , only : fldchk => med_methods_FB_FldChk - use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose - use med_constants_mod , only : dbug_flag => med_constants_dbug_flag + use ESMF , only : ESMF_VMBroadCast + use med_utils_mod , only : chkerr => med_utils_ChkErr + use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk + use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose + use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr + use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_merge_mod , only : med_merge_auto use med_internalstate_mod , only : InternalState, logunit, mastertask use esmFlds , only : compatm, compice, compocn, comprof, compglc, ncomps, compname @@ -45,18 +47,17 @@ subroutine med_phases_prep_ice(gcomp, rc) integer, intent(out) :: rc ! local variables - type(ESMF_StateItem_Flag) :: itemType type(InternalState) :: is_local type(ESMF_Field) :: lfield integer :: i,n - real(R8), pointer :: dataptr1d(:) => null() - real(R8) :: precip_fact + real(R8), pointer :: dataptr(:) => null() + real(R8), pointer :: dataptr_scalar_ocn(:,:) => null() + real(R8) :: precip_fact(1) character(len=CS) :: cvalue character(len=64), allocatable :: fldnames(:) real(r8) :: nextsw_cday integer :: scalar_id real(r8) :: tmp(1) - logical :: first_call = .true. logical :: first_precip_fact_call = .true. character(len=*),parameter :: subname='(med_phases_prep_ice)' !--------------------------------------- @@ -87,33 +88,46 @@ subroutine med_phases_prep_ice(gcomp, rc) fldListTo(compice), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - ! apply precipitation factor from ocean - ! TODO (mvertens, 2019-03-18): precip_fact here is not valid if - ! the component does not send it - hardwire it to 1 until this is resolved - if (trim(coupling_mode) == 'cesm') then - 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_ice): Scaling rain, snow, liquid and ice runoff by precip_fact ' - first_precip_fact_call = .false. + ! Apply precipitation factor from ocean (that scales atm rain and snow to ice) if appropriate + if (trim(coupling_mode) == 'cesm' .and. is_local%wrap%flds_scalar_index_precip_factor /= 0) then + + ! Note that in med_internal_mod.F90 all is_local%wrap%flds_scalar_index_precip_factor + ! is initialized to 0. + ! In addition, in med.F90, if this attribute is not present as a mediator component attribute, + ! it is set to 0. + if (mastertask) then + call ESMF_StateGet(is_local%wrap%NstateImp(compocn), & + itemName=trim(is_local%wrap%flds_scalar_name), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataptr_scalar_ocn, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + scalar_id=is_local%wrap%flds_scalar_index_precip_factor + precip_fact(1) = dataptr_scalar_ocn(scalar_id,1) + if (precip_fact(1) /= 1._r8) then + write(logunit,'(a,f21.13)')& + '(merge_to_ice): Scaling rain, snow, liquid and ice runoff by non-unity precip_fact ',& + precip_fact(1) end if - write(cvalue,*) precip_fact + end if + call ESMF_VMBroadCast(is_local%wrap%vm, precip_fact, 1, 0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + is_local%wrap%flds_scalar_precip_factor = precip_fact(1) + if (dbug_flag > 5) then + write(cvalue,*) precip_fact(1) call ESMF_LogWrite(trim(subname)//" precip_fact is "//trim(cvalue), ESMF_LOGMSG_INFO) - - allocate(fldnames(3)) - fldnames = (/'Faxa_rain', 'Faxa_snow', 'Fixx_rofi'/) - do n = 1,size(fldnames) - if (fldchk(is_local%wrap%FBExp(compice), trim(fldnames(n)), rc=rc)) then - call ESMF_FieldBundleGet(is_local%wrap%FBExp(compice), fieldname=trim(fldnames(n)), & - field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr1d(:) = dataptr1d(:) * precip_fact - end if - end do - deallocate(fldnames) end if + + ! Scale rain and snow to ice from atm by the precipitation factor received from the ocean + allocate(fldnames(3)) + fldnames = (/'Faxa_rain', 'Faxa_snow', 'Fixx_rofi'/) + do n = 1,size(fldnames) + if (FB_fldchk(is_local%wrap%FBExp(compice), trim(fldnames(n)), rc=rc)) then + call FB_GetFldPtr(is_local%wrap%FBExp(compice), trim(fldnames(n)), dataptr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + dataptr(:) = dataptr(:) * is_local%wrap%flds_scalar_precip_factor + end if + end do + deallocate(fldnames) end if ! obtain nextsw_cday from atm if it is in the import state and send it to ice @@ -137,9 +151,6 @@ subroutine med_phases_prep_ice(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if - ! Set first call logical to false - first_call = .false. - if (dbug_flag > 5) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) endif diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90 index e924058f8..705d8a595 100644 --- a/mediator/med_phases_prep_ocn_mod.F90 +++ b/mediator/med_phases_prep_ocn_mod.F90 @@ -69,7 +69,7 @@ subroutine med_phases_prep_ocn_accum(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! auto merges to ocn - if (trim(coupling_mode) == 'cesm' .or. & + if ( trim(coupling_mode) == 'cesm' .or. & trim(coupling_mode) == 'nems_orig_data' .or. & trim(coupling_mode) == 'hafs') then call med_merge_auto(compocn, & @@ -193,7 +193,8 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) ! custom calculations for cesm !--------------------------------------- - use ESMF , only : ESMF_GridComp + use ESMF , only : ESMF_GridComp, ESMF_StateGet, ESMF_Field, ESMF_FieldGet + use ESMF , only : ESMF_VMBroadCast use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR @@ -203,6 +204,7 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) ! local variables type(InternalState) :: is_local + type(ESMF_Field) :: lfield real(R8), pointer :: ifrac(:) => null() real(R8), pointer :: ofrac(:) => null() real(R8), pointer :: ifracr(:) => null() @@ -227,17 +229,17 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) real(R8), pointer :: Fioi_swpen_idf(:) => null() real(R8), pointer :: Fioi_swpen(:) => null() real(R8), pointer :: dataptr(:) => null() - real(R8), pointer :: dataptr_o(:) => null() + real(R8), pointer :: dataptr_scalar_ocn(:,:) => null() 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 + real(R8) :: precip_fact(1) character(CS) :: cvalue real(R8) :: fswabsv, fswabsi + integer :: scalar_id integer :: n integer :: lsize real(R8) :: c1,c2,c3,c4 @@ -359,8 +361,8 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) 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 + ! Swnet without swpen from sea-ice 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. @@ -416,14 +418,14 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) ! 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) + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Sf_afrac', fldptr1=dataptr, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - dataptr_o(:) = ofrac(:) + dataptr(:) = 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) + call FB_GetFldPtr(is_local%wrap%FBExp(compocn), 'Sf_afracr', fldptr1=dataptr, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - dataptr_o(:) = ofracr(:) + dataptr(:) = ofracr(:) end if end if ! if sea-ice is present @@ -433,25 +435,43 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc) 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. + ! Apply precipitation factor from ocean (that scales atm rain and snow back to ocn ) if appropriate + if (trim(coupling_mode) == 'cesm' .and. is_local%wrap%flds_scalar_index_precip_factor /= 0) then + + ! Note that in med_internal_mod.F90 all is_local%wrap%flds_scalar_index_precip_factor + ! is initialized to 0. + ! In addition, in med.F90, if this attribute is not present as a mediator component attribute, + ! it is set to 0. + if (mastertask) then + call ESMF_StateGet(is_local%wrap%NstateImp(compocn), & + itemName=trim(is_local%wrap%flds_scalar_name), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataptr_scalar_ocn, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + scalar_id=is_local%wrap%flds_scalar_index_precip_factor + precip_fact(1) = dataptr_scalar_ocn(scalar_id,1) + if (precip_fact(1) /= 1._r8) then + write(logunit,'(a,f21.13)')& + '(merge_to_ocn): Scaling rain, snow, liquid and ice runoff by non-unity precip_fact ',& + precip_fact(1) + end if + end if + call ESMF_VMBroadCast(is_local%wrap%vm, precip_fact, 1, 0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + is_local%wrap%flds_scalar_precip_factor = precip_fact(1) + if (dbug_flag > 5) then + write(cvalue,*) precip_fact(1) + call ESMF_LogWrite(trim(subname)//" precip_fact is "//trim(cvalue), ESMF_LOGMSG_INFO) end if - write(cvalue,*) precip_fact - call ESMF_LogWrite(trim(subname)//" precip_fact is "//trim(cvalue), ESMF_LOGMSG_INFO) + ! Scale rain and snow to ocn from atm by the precipitation factor received from the ocean allocate(fldnames(4)) - fldnames = (/'Faxa_rain','Faxa_snow', 'Foxx_rofl', 'Foxx_rofi'/) + 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 + dataptr(:) = dataptr(:) * is_local%wrap%flds_scalar_precip_factor end if end do deallocate(fldnames) diff --git a/mediator/med_time_mod.F90 b/mediator/med_time_mod.F90 index 99d19cc4c..09dbaffb9 100644 --- a/mediator/med_time_mod.F90 +++ b/mediator/med_time_mod.F90 @@ -9,9 +9,9 @@ module med_time_mod use ESMF , only : ESMF_CALKIND_NOLEAP, ESMF_CALKIND_GREGORIAN use ESMF , only : ESMF_Time, ESMF_TimeGet, ESMF_TimeSet use ESMF , only : ESMF_TimeInterval, ESMF_TimeIntervalSet, ESMF_TimeIntervalGet - use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_FAILURE use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_VMBroadcast - use ESMF , only : ESMF_LOGMSG_INFO, ESMF_FAILURE + use ESMF , only : ESMF_LOGMSG_INFO, ESMF_FAILURE, ESMF_LOGMSG_ERROR use ESMF , only : operator(<), operator(/=), operator(+) use ESMF , only : operator(-), operator(*) , operator(>=) use ESMF , only : operator(<=), operator(>), operator(==) @@ -116,12 +116,12 @@ subroutine med_time_alarmInit( clock, alarm, option, & ! Error checks if (trim(option) == optdate) then if (.not. present(opt_ymd)) then - call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//trim(option)//' requires opt_ymd', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if if (lymd < 0 .or. ltod < 0) then - call ESMF_LogWrite(subname//trim(option)//'opt_ymd, opt_tod invalid', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//trim(option)//'opt_ymd, opt_tod invalid', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if @@ -133,12 +133,12 @@ subroutine med_time_alarmInit( clock, alarm, option, & trim(option) == optNMonths .or. & trim(option) == optNYears) then if (.not.present(opt_n)) then - call ESMF_LogWrite(subname//trim(option)//' requires opt_n', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//trim(option)//' requires opt_n', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if if (opt_n <= 0) then - call ESMF_LogWrite(subname//trim(option)//' invalid opt_n', ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//trim(option)//' invalid opt_n', ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return end if @@ -154,6 +154,15 @@ subroutine med_time_alarmInit( clock, alarm, option, & if (ChkErr(rc,__LINE__,u_FILE_u)) return update_nextalarm = .false. + case (optDate) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_time_date2ymd(opt_ymd, cyy, cmm, cdd) + + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=cdd, s=ltod, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + case (optNever) call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -217,7 +226,7 @@ subroutine med_time_alarmInit( clock, alarm, option, & update_nextalarm = .true. case default - call ESMF_LogWrite(subname//'unknown option '//trim(option), ESMF_LOGMSG_INFO) + call ESMF_LogWrite(subname//'unknown option '//trim(option), ESMF_LOGMSG_ERROR) rc = ESMF_FAILURE return @@ -243,4 +252,26 @@ subroutine med_time_alarmInit( clock, alarm, option, & end subroutine med_time_alarmInit + subroutine med_time_date2ymd (date, year, month, day) + + ! input/output variables + integer, intent(in) :: date ! coded-date (yyyymmdd) + integer, intent(out) :: year,month,day ! calendar year,month,day + + ! local variables + integer :: tdate ! temporary date + character(*),parameter :: subName = "(med_time_date2ymd)" + !------------------------------------------------------------------------------- + + tdate = abs(date) + year = int(tdate/10000) + if (date < 0) then + year = -year + end if + month = int( mod(tdate,10000)/ 100) + day = mod(tdate, 100) + + end subroutine med_time_date2ymd + + !=============================================================================== end module med_time_mod diff --git a/mediator/med_utils_mod.F90 b/mediator/med_utils_mod.F90 index 6c3b59638..9e34d1d40 100644 --- a/mediator/med_utils_mod.F90 +++ b/mediator/med_utils_mod.F90 @@ -33,7 +33,7 @@ end subroutine med_memcheck !=============================================================================== logical function med_utils_ChkErr(rc, line, file, mpierr) -#ifdef USE_MPI2 +#ifndef NO_MPI2 use mpi , only : MPI_ERROR_STRING, MPI_MAX_ERROR_STRING, MPI_SUCCESS #else use mpi, only : MPI_SUCCESS @@ -46,7 +46,7 @@ logical function med_utils_ChkErr(rc, line, file, mpierr) character(len=*), intent(in) :: file logical, optional, intent(in) :: mpierr -#ifndef USE_MPI2 +#ifdef NO_MPI2 integer, parameter :: MPI_MAX_ERROR_STRING=80 #endif character(MPI_MAX_ERROR_STRING) :: lstring