diff --git a/cime_config/config_component_cesm.xml b/cime_config/config_component_cesm.xml index 0472a0b5e..3d6ec3ccb 100644 --- a/cime_config/config_component_cesm.xml +++ b/cime_config/config_component_cesm.xml @@ -122,7 +122,7 @@ Activates additional CO2-related fields to be exchanged between components. Possible values are: CO2A: sets the driver namelist variable flds_co2a = .true.; this adds - prognostic CO2 and diagnostic CO2 at the lowest model level to be sent from + diagnostic CO2 at the lowest model level to be sent from the atmosphere to the land and ocean. CO2B: sets the driver namelist variable flds_co2b = .true.; this adds diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index b3f372765..c9729c344 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -1513,7 +1513,7 @@ Auxiliary mediator a2x dynamic, radiation, and precipitation fields history output every 3 hours - Sa_z:Sa_topo:Sa_u:Sa_v:Sa_tbot:Sa_ptem:Sa_shum:Sa_dens:Sa_pbot:Sa_pslv:Faxa_lwdn:Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl:Faxa_swndr:Faxa_swvdr:Faxa_swndf:Faxa_swvdf:Sa_co2diag:Sa_co2prog + Sa_z:Sa_topo:Sa_u:Sa_v:Sa_tbot:Sa_ptem:Sa_shum:Sa_dens:Sa_pbot:Sa_pslv:Faxa_lwdn:Faxa_rainc:Faxa_rainl:Faxa_snowc:Faxa_snowl:Faxa_swndr:Faxa_swvdr:Faxa_swndf:Faxa_swvdf:Sa_co2prog @@ -1578,7 +1578,7 @@ MED_attributes Auxiliary mediator a2x aerosol and ghg history output daily or endofrun - Faxa_bcph:Faxa_ocph:Faxa_dstwet:Faxa_dstdry:Sa_co2prog:Sa_co2diag + Faxa_bcph:Faxa_ocph:Faxa_dstwet:Faxa_dstdry:Faxa_ndep:Sa_co2diag @@ -1587,7 +1587,7 @@ MED_attributes history option type - nhours + ndays @@ -1596,7 +1596,7 @@ MED_attributes history option span - 3 + 1 @@ -1614,7 +1614,7 @@ MED_attributes Number of time samples per file. - 2 + 1 @@ -2217,6 +2217,7 @@ ALLCOMP_attributes .false. + .true. Auxiliary mediator wav2med average history output every day. Note that ww3dev will use this configuration variable and send @@ -2228,6 +2229,7 @@ MED_attributes Sw_hs_avg:Sw_Tm1_avg:Sw_thm_avg:Sw_u_avg:Sw_v_avg:Sw_ustokes_avg:Sw_vstokes_avg:Sw_tusx_avg:Sw_tusy_avg:Sw_thp0_avg:Sw_fp0_avg:Sw_phs0_avg:Sw_phs1_avg:Sw_pdir0_avg:Sw_pdir1_avg:Sw_pTm10_avg:Sw_pTm11_avg + Sw_Hs:Sw_t01:Sw_t0m1:Sw_thm:Sw_lamult:Sw_ustokes:Sw_vstokes Auxiliary mediator wav2med file1 colon delimited output fields. NOTE: these are assumed to be time averaged over a day in @@ -2259,6 +2261,7 @@ MED_attributes .false. + .true. Auxiliary mediator wav2med file1 time averaged flag for file output. If this flag is set to .false. only instantaneous output will be created in the auxiliary file. @@ -2269,6 +2272,7 @@ MED_attributes wav.24h.avg + ww3 diff --git a/med_test_comps/xatm/cime_config/buildlib b/med_test_comps/xatm/cime_config/buildlib new file mode 120000 index 000000000..ba1b3b80a --- /dev/null +++ b/med_test_comps/xatm/cime_config/buildlib @@ -0,0 +1 @@ +../../xshare/cime_config/buildlib \ No newline at end of file diff --git a/med_test_comps/xatm/cime_config/buildnml b/med_test_comps/xatm/cime_config/buildnml new file mode 100755 index 000000000..e7efcd46b --- /dev/null +++ b/med_test_comps/xatm/cime_config/buildnml @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +""" +build data model library +""" + +import sys, os + +_CIMEROOT = os.path.join( + os.path.dirname(os.path.abspath(__file__)), "..", "..", "..", "..", ".." +) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildnml import build_xcpl_nml, parse_input +from CIME.case import Case + + +def buildnml(case, caseroot, compname): + if compname != "xatm": + raise AttributeError + build_xcpl_nml(case, caseroot, compname) + + +def _main_func(): + caseroot = parse_input(sys.argv) + with Case(caseroot) as case: + buildnml(case, caseroot, "xatm") + + +if __name__ == "__main__": + _main_func() diff --git a/med_test_comps/xatm/cime_config/config_component.xml b/med_test_comps/xatm/cime_config/config_component.xml new file mode 100644 index 000000000..76c8be8c7 --- /dev/null +++ b/med_test_comps/xatm/cime_config/config_component.xml @@ -0,0 +1,25 @@ + + + + + + + Dead atm component + + + + char + xatm + xatm + case_comp + env_case.xml + Name of atmosphere component + + + + ========================================= + XATM naming conventions in compset name + ========================================= + + + diff --git a/med_test_comps/xatm/src/atm_comp_nuopc.F90 b/med_test_comps/xatm/src/atm_comp_nuopc.F90 new file mode 100644 index 000000000..64cd5b768 --- /dev/null +++ b/med_test_comps/xatm/src/atm_comp_nuopc.F90 @@ -0,0 +1,529 @@ +module atm_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for XATM + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use dead_methods_mod , only : chkerr, state_setscalar, state_diagnose, alarmInit, memcheck + use dead_methods_mod , only : set_component_logging, get_component_instance, log_clock_advance + use dead_nuopc_mod , only : dead_read_inparms, ModelInitPhase, ModelSetRunClock + use dead_nuopc_mod , only : fld_list_add, fld_list_realize, fldsMax, fld_list_type + + implicit none + private ! except + + public :: SetServices + public :: SetVM + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_nextsw_cday = 0 + + integer :: fldsToAtm_num = 0 + integer :: fldsFrAtm_num = 0 + type (fld_list_type) :: fldsToAtm(fldsMax) + type (fld_list_type) :: fldsFrAtm(fldsMax) + integer, parameter :: gridTofieldMap = 2 ! ungridded dimension is innermost + + type(ESMF_Mesh) :: mesh + integer :: nxg ! global dim i-direction + integer :: nyg ! global dim j-direction + integer :: my_task ! my task in mpi communicator mpicom + integer :: inst_index ! number of current instance (ie. 1) + character(len=5) :: inst_suffix ! char string associated with instance (ie. "_0001" or "") + integer :: logunit ! logging unit number + logical :: mastertask + integer :: dbug = 0 + character(*),parameter :: modName = "(xatm_comp_nuopc)" + character(*),parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=ModelInitPhase, phase=0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, specRoutine=ModelAdvance, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, specRoutine=ModelSetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, specRoutine=ModelFinalize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetServices + + !=============================================================================== + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + character(CS) :: stdname + integer :: n + integer :: lsize ! local array size + integer :: shrlogunit ! original log unit + character(CL) :: cvalue + character(len=CL) :: logmsg + logical :: isPresent, isSet + character(len=*),parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localpet=my_task, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + mastertask = (my_task==0) + + ! determine instance information + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! set logunit and set shr logging to my log file + call set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Initialize xatm + call dead_read_inparms('atm', inst_suffix, logunit, nxg, nyg) + + ! advertise import and export fields + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldName') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldCount') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNX') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNY') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxNextSwCday", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nextsw_cday + write(logmsg,*) flds_scalar_index_nextsw_cday + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nextsw_cday = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxNextSwCday') + endif + + if (nxg /= 0 .and. nyg /= 0) then + + call fld_list_add(fldsFrAtm_num, fldsFrAtm, trim(flds_scalar_name)) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_topo' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_z' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_u' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_v' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_tbot' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_ptem' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_shum' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_pbot' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_dens' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Sa_pslv' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainc' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_rainl' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowc' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_snowl' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_lwdn' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndr' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdr' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swndf' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swvdf' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_swnet' ) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_bcph' , ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_ocph' , ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_dstwet', ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsFrAtm_num, fldsFrAtm, 'Faxa_dstdry', ungridded_lbound=1, ungridded_ubound=4) + + call fld_list_add(fldsToAtm_num, fldsToAtm, trim(flds_scalar_name)) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_anidr' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_avsdf' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_anidf' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_avsdr' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sl_lfrac' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Si_ifrac' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'So_ofrac' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_tref' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_qref' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_t' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'So_t' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sl_fv' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sl_ram1' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sl_snowh' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Si_snowh' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'So_ssq' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'So_re' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Sx_u10' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Faxx_taux' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Faxx_tauy' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Faxx_lat' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Faxx_sen' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Faxx_lwup' ) + call fld_list_add(fldsToAtm_num, fldsToAtm, 'Faxx_evap' ) + + do n = 1,fldsFrAtm_num + if(mastertask) write(logunit,*)'Advertising From Xatm ',trim(fldsFrAtm(n)%stdname) + call NUOPC_Advertise(exportState, standardName=fldsFrAtm(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + + do n = 1,fldsToAtm_num + if(mastertask) write(logunit,*)'Advertising To Xatm',trim(fldsToAtm(n)%stdname) + call NUOPC_Advertise(importState, standardName=fldsToAtm(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + end if + + ! Reset shr logging to original values + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeAdvertise + + !=============================================================================== + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + ! input/output arguments + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_Time) :: nextTime + real(r8) :: nextsw_cday + integer :: n + integer :: shrlogunit ! original log unit + character(ESMF_MAXSTR) :: cvalue ! config data + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize: xatm) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Reset shr logging to my log file + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logUnit) + + ! generate the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_atm', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + mesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! realize the actively coupled fields, now that a mesh is established + ! NUOPC_Realize "realizes" a previously advertised field in the importState and exportState + ! by replacing the advertised fields with the newly created fields of the same name. + call fld_list_realize( & + state=exportState, & + fldList=fldsFrAtm, & + numflds=fldsFrAtm_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':xatmExport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call fld_list_realize( & + state=importState, & + fldList=fldsToAtm, & + numflds=fldsToAtm_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':xatmImport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Pack export state + call state_setexport(exportState, rc=rc) + call State_SetScalar(dble(nxg),flds_scalar_index_nx, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(nyg),flds_scalar_index_ny, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Set time of next radiation computation + call ESMF_ClockGetNextTime(clock, nextTime) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nextTime, dayOfYear_r8=nextsw_cday) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(nextsw_cday, flds_scalar_index_nextsw_cday, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! diagnostics + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeRealize + + !=============================================================================== + subroutine ModelAdvance(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: exportState + real(r8) :: nextsw_cday + integer :: shrlogunit ! original log unit + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (dbug > 1) then + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + end if + call memcheck(subname, 3, mastertask) + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + !-------------------------------- + ! Pack export state + !-------------------------------- + + call NUOPC_ModelGet(gcomp, modelClock=clock, exportState=exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call State_SetScalar(nextsw_cday, flds_scalar_index_nextsw_cday, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call state_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + call log_clock_advance(clock, 'XATM', logunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine ModelAdvance + + !=============================================================================== + subroutine state_setexport(exportState, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: exportState + integer, intent(out) :: rc + + ! local variables + integer :: n, nf, nind + real(r8), pointer :: lat(:) + real(r8), pointer :: lon(:) + integer :: spatialDim + integer :: numOwnedElements + real(R8), pointer :: ownedElemCoords(:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(lon(numownedElements)) + allocate(lat(numownedElements)) + do n = 1,numownedElements + lon(n) = ownedElemCoords(2*n-1) + lat(n) = ownedElemCoords(2*n) + end do + + ! Start from index 2 in order to Skip the scalar field here + do nf = 2,fldsFrAtm_num + if (fldsFrAtm(nf)%ungridded_ubound == 0) then + call field_setexport(exportState, trim(fldsFrAtm(nf)%stdname), lon, lat, nf=nf, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + do nind = 1,fldsFrAtm(nf)%ungridded_ubound + call field_setexport(exportState, trim(fldsFrAtm(nf)%stdname), lon, lat, nf=nf+nind-1, & + ungridded_index=nind, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + end do + + deallocate(lon) + deallocate(lat) + + end subroutine state_setexport + + !=============================================================================== + subroutine field_setexport(exportState, fldname, lon, lat, nf, ungridded_index, rc) + + use shr_const_mod , only : pi=>shr_const_pi + + ! intput/otuput variables + type(ESMF_State) , intent(inout) :: exportState + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: lon(:) + real(r8) , intent(in) :: lat(:) + integer , intent(in) :: nf + integer, optional , intent(in) :: ungridded_index + integer , intent(out) :: rc + + ! local variables + integer :: i, ncomp + type(ESMF_Field) :: lfield + real(r8), pointer :: data1d(:) + real(r8), pointer :: data2d(:,:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ncomp = 1 + if (present(ungridded_index)) then + call ESMF_FieldGet(lfield, farrayPtr=data2d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (gridToFieldMap == 1) then + do i = 1,size(data2d, dim=1) + data2d(i,ungridded_index) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + else if (gridToFieldMap == 2) then + do i = 1,size(data2d, dim=2) + data2d(ungridded_index,i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + else + call ESMF_FieldGet(lfield, farrayPtr=data1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do i = 1,size(data1d) + data1d(i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + + end subroutine field_setexport + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (mastertask) then + write(logunit,*) + write(logunit,*) 'xatm: end of main integration loop' + write(logunit,*) + end if + end subroutine ModelFinalize + +end module atm_comp_nuopc diff --git a/med_test_comps/xglc/cime_config/buildlib b/med_test_comps/xglc/cime_config/buildlib new file mode 120000 index 000000000..ba1b3b80a --- /dev/null +++ b/med_test_comps/xglc/cime_config/buildlib @@ -0,0 +1 @@ +../../xshare/cime_config/buildlib \ No newline at end of file diff --git a/med_test_comps/xglc/cime_config/buildnml b/med_test_comps/xglc/cime_config/buildnml new file mode 100755 index 000000000..a90f7a189 --- /dev/null +++ b/med_test_comps/xglc/cime_config/buildnml @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +""" +build data model library +""" + +import sys, os + +_CIMEROOT = os.path.join( + os.path.dirname(os.path.abspath(__file__)), "..", "..", "..", "..", ".." +) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildnml import build_xcpl_nml, parse_input +from CIME.case import Case + + +def buildnml(case, caseroot, compname): + if compname != "xglc": + raise AttributeError + build_xcpl_nml(case, caseroot, compname) + + +def _main_func(): + caseroot = parse_input(sys.argv) + with Case(caseroot) as case: + buildnml(case, caseroot, "xglc") + + +if __name__ == "__main__": + _main_func() diff --git a/med_test_comps/xglc/cime_config/config_component.xml b/med_test_comps/xglc/cime_config/config_component.xml new file mode 100644 index 000000000..f1765811b --- /dev/null +++ b/med_test_comps/xglc/cime_config/config_component.xml @@ -0,0 +1,26 @@ + + + + + + + Dead land-ice component + + + + char + xglc + xglc + case_comp + env_case.xml + Name of land-ice component + + + + + ========================================= + XGLC naming conventions in compset name + ========================================= + + + diff --git a/med_test_comps/xglc/src/glc_comp_nuopc.F90 b/med_test_comps/xglc/src/glc_comp_nuopc.F90 new file mode 100644 index 000000000..4b498f8d9 --- /dev/null +++ b/med_test_comps/xglc/src/glc_comp_nuopc.F90 @@ -0,0 +1,457 @@ +module glc_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for XGLC + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_AddNestedState + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use dead_methods_mod , only : chkerr, state_setscalar, state_diagnose, alarmInit, memcheck + use dead_methods_mod , only : set_component_logging, get_component_instance, log_clock_advance + use dead_nuopc_mod , only : dead_read_inparms, ModelInitPhase, ModelSetRunClock + use dead_nuopc_mod , only : fld_list_add, fld_list_realize, fldsMax, fld_list_type + + implicit none + private ! except + + public :: SetServices + public :: SetVM + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + + integer :: fldsToGlc_num = 0 + integer :: fldsFrGlc_num = 0 + type (fld_list_type) :: fldsToGlc(fldsMax) + type (fld_list_type) :: fldsFrGlc(fldsMax) + integer, parameter :: gridTofieldMap = 2 ! ungridded dimension is innermost + + type(ESMF_Mesh) :: mesh + integer :: nxg ! global dim i-direction + integer :: nyg ! global dim j-direction + integer :: my_task ! my task in mpi communicator mpicom + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_suffix = "" ! char string associated with instance (ie. "_0001" or "") + integer :: logunit ! logging unit number + integer ,parameter :: master_task=0 ! task number of master task + logical :: mastertask + integer :: dbug = 0 + character(*),parameter :: modName = "(xglc_comp_nuopc)" + character(*),parameter :: u_FILE_u = & + __FILE__ + + ! TODO: this must be generalized - but for now is just hard-wired + integer, parameter :: max_icesheets = 1 + integer :: num_icesheets = 1 + type(ESMF_State) :: NStateImp(max_icesheets) + type(ESMF_State) :: NStateExp(max_icesheets) + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=ModelInitPhase, phase=0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, specRoutine=ModelAdvance, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, specRoutine=ModelSetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, specRoutine=ModelFinalize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetServices + + !=============================================================================== + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + character(CS) :: stdname + integer :: n, ns, nf + integer :: lsize ! local array size + integer :: shrlogunit ! original log unit + character(CL) :: cvalue + character(len=CL) :: logmsg + character(len=CS) :: cnum + logical :: isPresent, isSet + character(len=*),parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localpet=my_task, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + mastertask = (my_task == master_task) + + ! determine instance information + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set logunit and set shr logging to my log file + call set_component_logging(gcomp, my_task==master_task, logunit, shrlogunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Initialize xglc + call dead_read_inparms('glc', inst_suffix, logunit, nxg, nyg) + + ! advertise import and export fields + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldName') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldCount') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNX') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNY') + endif + + ! Create nested state for each active ice sheet + do ns = 1,num_icesheets + write(cnum,'(i0)') ns + call NUOPC_AddNestedState(importState, CplSet="GLC"//trim(cnum), nestedState=NStateImp(ns), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_AddNestedState(exportState, CplSet="GLC"//trim(cnum), nestedState=NStateExp(ns), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end do + + if (nxg /= 0 .and. nyg /= 0) then + + call fld_list_add(fldsFrGlc_num, fldsFrGlc, trim(flds_scalar_name)) + call fld_list_add(fldsFrGlc_num, fldsFrGlc, 'Sg_icemask' ) + call fld_list_add(fldsFrGlc_num, fldsFrGlc, 'Sg_icemask_coupled_fluxes' ) + call fld_list_add(fldsFrGlc_num, fldsFrGlc, 'Sg_ice_covered' ) + call fld_list_add(fldsFrGlc_num, fldsFrGlc, 'Sg_topo' ) + call fld_list_add(fldsFrGlc_num, fldsFrGlc, 'Flgg_hflx' ) + + call fld_list_add(fldsToGlc_num, fldsToGlc, trim(flds_scalar_name)) + call fld_list_add(fldsToGlc_num, fldsToGlc, 'Sl_tsrf') + call fld_list_add(fldsToGlc_num, fldsToGlc, 'Flgl_qice') + + ! Now advertise import and export fields fields + do ns = 1,num_icesheets + if (mastertask) write(logunit,*)'Advertising To Xglc ',trim(fldsToGlc(ns)%stdname) + do nf = 1,fldsToGlc_num + call NUOPC_Advertise(NStateImp(ns), standardName=fldsToGlc(nf)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return + end do + if (mastertask) write(logunit,*)'Advertising From Xglc ',trim(fldsFrGlc(ns)%stdname) + do nf = 1,fldsFrGlc_num + call NUOPC_Advertise(NStateExp(ns), standardName=fldsFrGlc(nf)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return + end do + enddo + + end if + + end subroutine InitializeAdvertise + + !=============================================================================== + + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + integer :: n, ns + character(ESMF_MAXSTR) :: cvalue ! config data + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! generate the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_glc', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + mesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! realize the actively coupled fields, now that a mesh is established + ! NUOPC_Realize "realizes" a previously advertised field in the importState and exportState + ! by replacing the advertised fields with the newly created fields of the same name. + do ns = 1,num_icesheets + call fld_list_realize( & + state=NStateExp(ns), & + fldList=fldsFrGlc, & + numflds=fldsFrGlc_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':dglcExport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call fld_list_realize( & + state=NStateImp(ns), & + fldList=fldsToGlc, & + numflds=fldsToGlc_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':dglcImport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + + ! Pack export state and set the coupling scalars + call state_setexport(rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do ns = 1,num_icesheets + call state_setscalar(dble(nxg),flds_scalar_index_nx, NStateExp(ns), flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call state_setscalar(dble(nyg),flds_scalar_index_ny, NStateExp(ns), flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + + end subroutine InitializeRealize + + !=============================================================================== + + subroutine ModelAdvance(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call memcheck(subname, 3, mastertask) + + call state_setexport(rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine ModelAdvance + + !=============================================================================== + subroutine state_setexport(rc) + + ! input/output variables + integer, intent(out) :: rc + + ! local variables + integer :: n, nf, nind, ns + real(r8), pointer :: lat(:) + real(r8), pointer :: lon(:) + integer :: spatialDim + integer :: numOwnedElements + real(R8), pointer :: ownedElemCoords(:) + character(len=*),parameter :: subname=trim(modName)//':(state_setexport) ' + !-------------------------------------------------- + rc = ESMF_SUCCESS + + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(lon(numownedElements)) + allocate(lat(numownedElements)) + do n = 1,numownedElements + lon(n) = ownedElemCoords(2*n-1) + lat(n) = ownedElemCoords(2*n) + end do + + ! Start from index 2 in order to skip the scalar field + do ns = 1,num_icesheets + do nf = 2,fldsFrGlc_num + if (fldsFrGlc(nf)%ungridded_ubound == 0) then + call field_setexport(NStateExp(ns), trim(fldsFrGlc(nf)%stdname), lon, lat, nf=nf, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + do nind = 1,fldsFrGlc(nf)%ungridded_ubound + call field_setexport(NStateExp(ns), trim(fldsFrGlc(nf)%stdname), lon, lat, nf=nf+nind-1, & + ungridded_index=nind, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + end do + if (dbug > 1) then + call State_diagnose(NStateExp(ns), trim(subname)//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + end do + + deallocate(lon) + deallocate(lat) + + end subroutine state_setexport + + !=============================================================================== + + subroutine field_setexport(exportState, fldname, lon, lat, nf, ungridded_index, rc) + + use shr_const_mod , only : pi=>shr_const_pi + + ! intput/otuput variables + type(ESMF_State) , intent(inout) :: exportState + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: lon(:) + real(r8) , intent(in) :: lat(:) + integer , intent(in) :: nf + integer, optional , intent(in) :: ungridded_index + integer , intent(out) :: rc + + ! local variables + integer :: i, ncomp + type(ESMF_Field) :: lfield + real(r8), pointer :: data1d(:) + real(r8), pointer :: data2d(:,:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ncomp = 5 + if (present(ungridded_index)) then + call ESMF_FieldGet(lfield, farrayPtr=data2d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (gridToFieldMap == 1) then + do i = 1,size(data2d, dim=1) + data2d(i,ungridded_index) = (nf*100) & + * cos (pi*lat(i)/180.0_R8) * cos (pi*lat(i)/180.0_R8) & + * sin (pi*lon(i)/180.0_R8) * sin (pi*lon(i)/180.0_R8) & + + (ncomp*10.0_R8) + enddo + else if (gridToFieldMap == 2) then + do i = 1,size(data2d, dim=2) + data2d(ungridded_index,i) = (nf*100) & + * cos (pi*lat(i)/180.0_R8) * cos (pi*lat(i)/180.0_R8) & + * sin (pi*lon(i)/180.0_R8) * sin (pi*lon(i)/180.0_R8) & + + (ncomp*10.0_R8) + end do + end if + else + call ESMF_FieldGet(lfield, farrayPtr=data1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (fldname == 'Sg_icemask' .or. fldname == 'Sg_icemask_coupled_fluxes' .or. fldname == 'Sg_ice_covered') then + data1d(:) = 1._r8 + else + do i = 1,size(data1d) + data1d(i) = (nf*100) & + * cos (pi*lat(i)/180.0_R8) * cos (pi*lat(i)/180.0_R8) & + * sin (pi*lon(i)/180.0_R8) * sin (pi*lon(i)/180.0_R8) & + + (ncomp*10.0_R8) + end do + end if + end if + + end subroutine field_setexport + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (mastertask) then + write(logunit,*) + write(logunit,*) 'xglc: end of main integration loop' + write(logunit,*) + end if + end subroutine ModelFinalize + +end module glc_comp_nuopc diff --git a/med_test_comps/xice/cime_config/buildlib b/med_test_comps/xice/cime_config/buildlib new file mode 120000 index 000000000..ba1b3b80a --- /dev/null +++ b/med_test_comps/xice/cime_config/buildlib @@ -0,0 +1 @@ +../../xshare/cime_config/buildlib \ No newline at end of file diff --git a/med_test_comps/xice/cime_config/buildnml b/med_test_comps/xice/cime_config/buildnml new file mode 100755 index 000000000..7d141edd6 --- /dev/null +++ b/med_test_comps/xice/cime_config/buildnml @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +""" +build data model library +""" + +import sys, os + +_CIMEROOT = os.path.join( + os.path.dirname(os.path.abspath(__file__)), "..", "..", "..", "..", ".." +) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildnml import build_xcpl_nml, parse_input +from CIME.case import Case + + +def buildnml(case, caseroot, compname): + if compname != "xice": + raise AttributeError + build_xcpl_nml(case, caseroot, compname) + + +def _main_func(): + caseroot = parse_input(sys.argv) + with Case(caseroot) as case: + buildnml(case, caseroot, "xice") + + +if __name__ == "__main__": + _main_func() diff --git a/med_test_comps/xice/cime_config/config_component.xml b/med_test_comps/xice/cime_config/config_component.xml new file mode 100644 index 000000000..a3263a0ee --- /dev/null +++ b/med_test_comps/xice/cime_config/config_component.xml @@ -0,0 +1,26 @@ + + + + + + + Dead ice component + + + + char + xice + xice + case_comp + env_case.xml + Name of sea-ice component + + + + + ========================================= + XICE naming conventions in compset name + ========================================= + + + diff --git a/med_test_comps/xice/src/ice_comp_nuopc.F90 b/med_test_comps/xice/src/ice_comp_nuopc.F90 new file mode 100644 index 000000000..9185b8e53 --- /dev/null +++ b/med_test_comps/xice/src/ice_comp_nuopc.F90 @@ -0,0 +1,552 @@ +module ice_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for XICE + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use dead_methods_mod , only : chkerr, state_setscalar, state_diagnose, alarmInit, memcheck + use dead_methods_mod , only : set_component_logging, get_component_instance, log_clock_advance + use dead_nuopc_mod , only : dead_read_inparms, ModelInitPhase, ModelSetRunClock + use dead_nuopc_mod , only : fld_list_add, fld_list_realize, fldsMax, fld_list_type + + implicit none + private ! except + + public :: SetServices + public :: SetVM + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + + integer :: fldsToIce_num = 0 + integer :: fldsFrIce_num = 0 + type (fld_list_type) :: fldsToIce(fldsMax) + type (fld_list_type) :: fldsFrIce(fldsMax) + integer, parameter :: gridTofieldMap = 2 ! ungridded dimension is innermost + + type(ESMF_Mesh) :: mesh + integer :: nxg ! global dim i-direction + integer :: nyg ! global dim j-direction + integer :: my_task ! my task in mpi communicator mpicom + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_suffix = "" ! char string associated with instance (ie. "_0001" or "") + integer :: logunit ! logging unit number + integer ,parameter :: master_task=0 ! task number of master task + logical :: mastertask + integer :: dbug = 0 + character(*),parameter :: modName = "(xice_comp_nuopc)" + character(*),parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=ModelInitPhase, phase=0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, specRoutine=ModelAdvance, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, specRoutine=ModelSetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, specRoutine=ModelFinalize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetServices + + !=============================================================================== + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + character(CL) :: cvalue + character(CS) :: stdname + integer :: n + integer :: lsize ! local array size + integer :: shrlogunit ! original log unit + character(len=CL) :: logmsg + logical :: isPresent, isSet + character(len=*),parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localpet=my_task, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + mastertask = my_task == master_task + + !---------------------------------------------------------------------------- + ! determine instance information + !---------------------------------------------------------------------------- + + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !---------------------------------------------------------------------------- + ! set logunit and set shr logging to my log file + !---------------------------------------------------------------------------- + + call set_component_logging(gcomp, my_task==master_task, logunit, shrlogunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !---------------------------------------------------------------------------- + ! Initialize xice + !---------------------------------------------------------------------------- + + call dead_read_inparms('ice', inst_suffix, logunit, nxg, nyg) + + !-------------------------------- + ! advertise import and export fields + !-------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldName') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldCount') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNX') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNY') + endif + + if (nxg /= 0 .and. nyg /= 0) then + + call fld_list_add(fldsFrIce_num, fldsFrIce, trim(flds_scalar_name)) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_imask' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_ifrac' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_t' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_tref' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_qref' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_snowh' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_u10' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_avsdr' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_anidr' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_avsdf' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Si_anidf' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Faii_taux' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Faii_tauy' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Faii_lat' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Faii_sen' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Faii_lwup' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Faii_evap' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Faii_swnet' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_melth' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_swpen' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_meltw' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_salt' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_taux' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_tauy' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_bcpho' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_bcphi' ) + call fld_list_add(fldsFrIce_num, fldsFrIce, 'Fioi_flxdst' ) + + call fld_list_add(fldsToIce_num, fldsToIce, trim(flds_scalar_name)) + call fld_list_add(fldsToIce_num, fldsToIce, 'So_dhdx' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'So_dhdy' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'So_t' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'So_s' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'So_u' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'So_v' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Fioo_q' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Sa_z' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Sa_u' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Sa_v' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Sa_ptem' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Sa_shum' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Sa_dens' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Sa_tbot' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_swvdr' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_swndr' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_swvdf' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_swndf' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_lwdn' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_rain' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_snow' ) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_bcph' , ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_ocph' , ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_dstwet', ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsToIce_num, fldsToIce, 'Faxa_dstdry', ungridded_lbound=1, ungridded_ubound=4) + + do n = 1,fldsFrIce_num + if(mastertask) write(logunit,*)'Advertising From Xice ',trim(fldsFrIce(n)%stdname) + call NUOPC_Advertise(exportState, standardName=fldsFrIce(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + + do n = 1,fldsToIce_num + if(mastertask) write(logunit,*)'Advertising To Xice ',trim(fldsToIce(n)%stdname) + call NUOPC_Advertise(importState, standardName=fldsToIce(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + + + if (dbug > 5) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeAdvertise + + !=============================================================================== + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + integer :: shrlogunit ! original log unit + integer :: n + character(ESMF_MAXSTR) :: cvalue ! config data + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logUnit) + + !-------------------------------- + ! generate the mesh + !-------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name='mesh_ice', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + mesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! realize the actively coupled fields, now that a mesh is established + ! NUOPC_Realize "realizes" a previously advertised field in the importState and exportState + ! by replacing the advertised fields with the newly created fields of the same name. + !-------------------------------- + + call fld_list_realize( & + state=ExportState, & + fldlist=fldsFrIce, & + numflds=fldsFrIce_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':diceExport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call fld_list_realize( & + state=importState, & + fldList=fldsToIce, & + numflds=fldsToIce_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':diceImport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! Pack export state + !-------------------------------- + + call State_SetExport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call State_SetScalar(dble(nxg),flds_scalar_index_nx, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call State_SetScalar(dble(nyg),flds_scalar_index_ny, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeRealize + + !=============================================================================== + subroutine ModelAdvance(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: exportState + integer :: shrlogunit ! original log unit + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + call memcheck(subname, 3, mastertask) + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + !-------------------------------- + ! Pack export state + !-------------------------------- + + call NUOPC_ModelGet(gcomp, modelClock=clock, exportState=exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (my_task == master_task) then + call log_clock_advance(clock, 'XICE', logunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + endif + + call shr_log_setLogUnit (shrlogunit) + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + + end subroutine ModelAdvance + + !=============================================================================== + subroutine state_setexport(exportState, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: exportState + integer, intent(out) :: rc + + ! local variables + integer :: n, nf, nind + real(r8), pointer :: lat(:) + real(r8), pointer :: lon(:) + integer :: spatialDim + integer :: numOwnedElements + real(R8), pointer :: ownedElemCoords(:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(lon(numownedElements)) + allocate(lat(numownedElements)) + do n = 1,numownedElements + lon(n) = ownedElemCoords(2*n-1) + lat(n) = ownedElemCoords(2*n) + end do + + ! Start from index 2 in order to skip the scalar field + do nf = 2,fldsFrIce_num + if (fldsFrIce(nf)%ungridded_ubound == 0) then + call field_setexport(exportState, trim(fldsFrIce(nf)%stdname), lon, lat, nf=nf, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + do nind = 1,fldsFrIce(nf)%ungridded_ubound + call field_setexport(exportState, trim(fldsFrIce(nf)%stdname), lon, lat, nf=nf+nind-1, & + ungridded_index=nind, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + end do + + deallocate(lon) + deallocate(lat) + + end subroutine state_setexport + + !=============================================================================== + subroutine field_setexport(exportState, fldname, lon, lat, nf, ungridded_index, rc) + + use shr_const_mod , only : pi=>shr_const_pi + + ! intput/otuput variables + type(ESMF_State) , intent(inout) :: exportState + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: lon(:) + real(r8) , intent(in) :: lat(:) + integer , intent(in) :: nf + integer, optional , intent(in) :: ungridded_index + integer , intent(out) :: rc + + ! local variables + integer :: i, ncomp + type(ESMF_Field) :: lfield + real(r8), pointer :: data1d(:) + real(r8), pointer :: data2d(:,:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ncomp = 3 + if (present(ungridded_index)) then + call ESMF_FieldGet(lfield, farrayPtr=data2d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (gridToFieldMap == 1) then + do i = 1,size(data2d, dim=1) + data2d(i,ungridded_index) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + else if (gridToFieldMap == 2) then + do i = 1,size(data2d, dim=2) + data2d(ungridded_index,i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + else + call ESMF_FieldGet(lfield, farrayPtr=data1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do i = 1,size(data1d) + data1d(i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + ! Reset some fields + if (fldname == 'Si_ifrac') then + do i = 1,size(data1d) + data1d(i) = min(1.0_R8,max(0.0_R8,data1d(i))) + end do + else if (fldname == 'Si_imask') then + do i = 1,size(data1d) + data1d(i) = float(nint(min(1.0_R8,max(0.0_R8,data1d(i))))) + end do + end if + end if + + end subroutine field_setexport + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (mastertask) then + write(logunit,*) + write(logunit,*) 'xice: end of main integration loop' + write(logunit,*) + end if + end subroutine ModelFinalize + +end module ice_comp_nuopc diff --git a/med_test_comps/xlnd/cime_config/buildlib b/med_test_comps/xlnd/cime_config/buildlib new file mode 120000 index 000000000..ba1b3b80a --- /dev/null +++ b/med_test_comps/xlnd/cime_config/buildlib @@ -0,0 +1 @@ +../../xshare/cime_config/buildlib \ No newline at end of file diff --git a/med_test_comps/xlnd/cime_config/buildnml b/med_test_comps/xlnd/cime_config/buildnml new file mode 100755 index 000000000..72e822771 --- /dev/null +++ b/med_test_comps/xlnd/cime_config/buildnml @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +""" +build data model library +""" + +import sys, os + +_CIMEROOT = os.path.join( + os.path.dirname(os.path.abspath(__file__)), "..", "..", "..", "..", ".." +) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildnml import build_xcpl_nml, parse_input +from CIME.case import Case + + +def buildnml(case, caseroot, compname): + if compname != "xlnd": + raise AttributeError + build_xcpl_nml(case, caseroot, compname) + + +def _main_func(): + caseroot = parse_input(sys.argv) + with Case(caseroot) as case: + buildnml(case, caseroot, "xlnd") + + +if __name__ == "__main__": + _main_func() diff --git a/med_test_comps/xlnd/cime_config/config_component.xml b/med_test_comps/xlnd/cime_config/config_component.xml new file mode 100644 index 000000000..8179d0310 --- /dev/null +++ b/med_test_comps/xlnd/cime_config/config_component.xml @@ -0,0 +1,26 @@ + + + + + + + Dead land component + + + + + char + xlnd + xlnd + case_comp + env_case.xml + Name of land component + + + + ========================================= + XLND naming conventions in compset name + ========================================= + + + diff --git a/med_test_comps/xlnd/src/lnd_comp_nuopc.F90 b/med_test_comps/xlnd/src/lnd_comp_nuopc.F90 new file mode 100644 index 000000000..a43215939 --- /dev/null +++ b/med_test_comps/xlnd/src/lnd_comp_nuopc.F90 @@ -0,0 +1,564 @@ +module lnd_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for XLND + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use dead_methods_mod , only : chkerr, state_setscalar, state_diagnose, alarmInit, memcheck + use dead_methods_mod , only : set_component_logging, get_component_instance, log_clock_advance + use dead_nuopc_mod , only : dead_read_inparms, ModelInitPhase, ModelSetRunClock + use dead_nuopc_mod , only : fld_list_add, fld_list_realize, fldsMax, fld_list_type + + implicit none + private ! except + + public :: SetServices + public :: SetVM + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_nextsw_cday = 0._r8 + + integer :: fldsToLnd_num = 0 + integer :: fldsFrLnd_num = 0 + type (fld_list_type) :: fldsToLnd(fldsMax) + type (fld_list_type) :: fldsFrLnd(fldsMax) + integer, parameter :: gridTofieldMap = 2 ! ungridded dimension is innermost + integer :: glc_nec + + type(ESMF_Mesh) :: mesh + integer :: nxg ! global dim i-direction + integer :: nyg ! global dim j-direction + integer :: my_task ! my task in mpi communicator mpicom + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_suffix = "" ! char string associated with instance (ie. "_0001" or "") + integer :: logunit ! logging unit number + integer ,parameter :: master_task=0 ! task number of master task + logical :: mastertask + integer :: dbug = 1 + character(*),parameter :: modName = "(xlnd_comp_nuopc)" + character(*),parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=ModelInitPhase, phase=0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, specRoutine=ModelAdvance, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, specRoutine=ModelSetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, specRoutine=ModelFinalize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetServices + + !=============================================================================== + + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + character(CS) :: stdname + integer :: n + integer :: lsize ! local array size + integer :: shrlogunit ! original log unit + character(CL) :: cvalue + character(CL) :: logmsg + logical :: isPresent, isSet + character(len=*),parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localpet=my_task, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + mastertask = (my_task == master_task) + + !---------------------------------------------------------------------------- + ! determine instance information + !---------------------------------------------------------------------------- + + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !---------------------------------------------------------------------------- + ! set logunit and set shr logging to my log file + !---------------------------------------------------------------------------- + + call set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !---------------------------------------------------------------------------- + ! Initialize xlnd + !---------------------------------------------------------------------------- + + call dead_read_inparms('lnd', inst_suffix, logunit, nxg, nyg) + + !-------------------------------- + ! advertise import and export fields + !-------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldName') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldCount') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNX') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNY') + end if + + if (nxg /= 0 .and. nyg /= 0) then + + call NUOPC_CompAttributeGet(gcomp, name='glc_nec', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) glc_nec + call ESMF_LogWrite('glc_nec = '// trim(cvalue), ESMF_LOGMSG_INFO) + + call fld_list_add(fldsFrLnd_num, fldsFrlnd, trim(flds_scalar_name)) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_lfrin' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_t' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_tref' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_qref' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_avsdr' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_anidr' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_avsdf' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_anidf' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_snowh' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_u10' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_fv' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_ram1' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Flrl_rofsur' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Flrl_rofgwl' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Flrl_rofsub' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Flrl_rofi' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Flrl_irrig' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_taux' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_tauy' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_lat' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_sen' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_lwup' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_evap' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_swnet' ) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Fall_flxdst' , ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Flgl_qice_elev', ungridded_lbound=1, ungridded_ubound=glc_nec+1) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_tsrf_elev' , ungridded_lbound=1, ungridded_ubound=glc_nec+1) + call fld_list_add(fldsFrLnd_num, fldsFrlnd, 'Sl_topo_elev' , ungridded_lbound=1, ungridded_ubound=glc_nec+1) + + call fld_list_add(fldsToLnd_num, fldsToLnd, trim(flds_scalar_name)) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_z' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_topo' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_u' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_v' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_ptem' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_pbot' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_tbot' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Sa_shum' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Flrr_volr' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Flrr_volrmch' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_lwdn' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_rainc' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_rainl' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_snowc' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_snowl' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_swndr' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_swvdr' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_swndf' ) + call fld_list_add(fldsToLnd_num, fldsToLnd, 'Faxa_swvdf' ) + call fld_list_add(fldsTolnd_num, fldsTolnd, 'Faxa_bcph' , ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsTolnd_num, fldsTolnd, 'Faxa_ocph' , ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsTolnd_num, fldsTolnd, 'Faxa_dstwet' , ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsTolnd_num, fldsTolnd, 'Faxa_dstdry' , ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsToLnd_num, fldsTolnd, 'Sg_topo_elev' , ungridded_lbound=1, ungridded_ubound=glc_nec+1) + call fld_list_add(fldsToLnd_num, fldsTolnd, 'Sg_ice_covered_elev' , ungridded_lbound=1, ungridded_ubound=glc_nec+1) + call fld_list_add(fldsToLnd_num, fldsTolnd, 'Flgg_hflx_elev' , ungridded_lbound=1, ungridded_ubound=glc_nec+1) + call fld_list_add(fldsToLnd_num, fldsTolnd, 'Sg_icemask') + call fld_list_add(fldsToLnd_num, fldsTolnd, 'Sg_icemask_coupled_fluxes') + + do n = 1,fldsFrLnd_num + if (mastertask) write(logunit,*)'Advertising From Xlnd ',trim(fldsFrLnd(n)%stdname) + call NUOPC_Advertise(exportState, standardName=fldsFrLnd(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + + do n = 1,fldsToLnd_num + if(mastertask) write(logunit,*)'Advertising To Xlnd',trim(fldsToLnd(n)%stdname) + call NUOPC_Advertise(importState, standardName=fldsToLnd(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + + end if + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeAdvertise + + !=============================================================================== + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + ! intput/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + integer :: shrlogunit ! original log unit + integer :: n + character(ESMF_MAXSTR) :: cvalue ! config data + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + if (dbug > 5) call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + + !---------------------------------------------------------------------------- + ! Reset shr logging to my log file + !---------------------------------------------------------------------------- + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logUnit) + + !-------------------------------- + ! generate the mesh + !-------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name='mesh_lnd', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + mesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! realize the actively coupled fields, now that a mesh is established + ! NUOPC_Realize "realizes" a previously advertised field in the importState and exportState + ! by replacing the advertised fields with the newly created fields of the same name. + !-------------------------------- + + call fld_list_realize( & + state=ExportState, & + fldlist=fldsFrLnd, & + numflds=fldsFrLnd_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':dlndExport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call fld_list_realize( & + state=importState, & + fldList=fldsToLnd, & + numflds=fldsToLnd_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':dlndImport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! Pack export state + !-------------------------------- + + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call State_SetScalar(dble(nxg),flds_scalar_index_nx, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call State_SetScalar(dble(nyg),flds_scalar_index_ny, exportState, & + flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call state_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_log_setLogUnit (shrlogunit) + + if (dbug > 5) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + + end subroutine InitializeRealize + + !=============================================================================== + subroutine ModelAdvance(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: exportState + integer :: shrlogunit ! original log unit + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + call memcheck(subname, 3, mastertask) + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + !-------------------------------- + ! Pack export state + !-------------------------------- + + call NUOPC_ModelGet(gcomp, modelClock=clock, exportState=exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call state_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + call log_clock_advance(clock, 'LND', logunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + endif + + call shr_log_setLogUnit (shrlogunit) + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + + end subroutine ModelAdvance + + !=============================================================================== + + subroutine state_setexport(exportState, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: exportState + integer, intent(out) :: rc + + ! local variables + integer :: n, nf, nind + real(r8), pointer :: lat(:) + real(r8), pointer :: lon(:) + integer :: spatialDim + integer :: numOwnedElements + real(R8), pointer :: ownedElemCoords(:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(lon(numownedElements)) + allocate(lat(numownedElements)) + do n = 1,numownedElements + lon(n) = ownedElemCoords(2*n-1) + lat(n) = ownedElemCoords(2*n) + end do + + ! Start from index 2 in order to Skip the scalar field here + do nf = 2,fldsFrLnd_num + if (fldsFrLnd(nf)%ungridded_ubound == 0) then + call field_setexport(exportState, trim(fldsFrLnd(nf)%stdname), lon, lat, nf=nf, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + do nind = 1,fldsFrLnd(nf)%ungridded_ubound + call field_setexport(exportState, trim(fldsFrLnd(nf)%stdname), lon, lat, nf=nf+nind-1, & + ungridded_index=nind, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + end do + + deallocate(lon) + deallocate(lat) + + end subroutine state_setexport + + !=============================================================================== + + subroutine field_setexport(exportState, fldname, lon, lat, nf, ungridded_index, rc) + + use shr_const_mod , only : pi=>shr_const_pi + + ! intput/otuput variables + type(ESMF_State) , intent(inout) :: exportState + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: lon(:) + real(r8) , intent(in) :: lat(:) + integer , intent(in) :: nf + integer, optional , intent(in) :: ungridded_index + integer , intent(out) :: rc + + ! local variables + integer :: i, ncomp + type(ESMF_Field) :: lfield + real(r8), pointer :: data1d(:) + real(r8), pointer :: data2d(:,:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ncomp = 2 + if (present(ungridded_index)) then + call ESMF_FieldGet(lfield, farrayPtr=data2d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (gridToFieldMap == 1) then + do i = 1,size(data2d, dim=1) + data2d(i,ungridded_index) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + else if (gridToFieldMap == 2) then + do i = 1,size(data2d, dim=2) + data2d(ungridded_index,i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + else + call ESMF_FieldGet(lfield, farrayPtr=data1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (fldname == 'Sl_lfrin') then + data1d(:) = 1._r8 + else + do i = 1,size(data1d) + data1d(i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + end if + + end subroutine field_setexport + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (mastertask) then + write(logunit,*) + write(logunit,*) 'xlnd: end of main integration loop' + write(logunit,*) + end if + end subroutine ModelFinalize + +end module lnd_comp_nuopc diff --git a/med_test_comps/xocn/cime_config/buildlib b/med_test_comps/xocn/cime_config/buildlib new file mode 120000 index 000000000..ba1b3b80a --- /dev/null +++ b/med_test_comps/xocn/cime_config/buildlib @@ -0,0 +1 @@ +../../xshare/cime_config/buildlib \ No newline at end of file diff --git a/med_test_comps/xocn/cime_config/buildnml b/med_test_comps/xocn/cime_config/buildnml new file mode 100755 index 000000000..7158056b4 --- /dev/null +++ b/med_test_comps/xocn/cime_config/buildnml @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +""" +build data model library +""" + +import sys, os + +_CIMEROOT = os.path.join( + os.path.dirname(os.path.abspath(__file__)), "..", "..", "..", "..", ".." +) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildnml import build_xcpl_nml, parse_input +from CIME.case import Case + + +def buildnml(case, caseroot, compname): + if compname != "xocn": + raise AttributeError + build_xcpl_nml(case, caseroot, compname) + + +def _main_func(): + caseroot = parse_input(sys.argv) + with Case(caseroot) as case: + buildnml(case, caseroot, "xocn") + + +if __name__ == "__main__": + _main_func() diff --git a/med_test_comps/xocn/cime_config/config_component.xml b/med_test_comps/xocn/cime_config/config_component.xml new file mode 100644 index 000000000..f68d1ff47 --- /dev/null +++ b/med_test_comps/xocn/cime_config/config_component.xml @@ -0,0 +1,27 @@ + + + + + + + Dead ocean component + + + + char + xocn + xocn + case_comp + env_case.xml + Name of ocean component + + + + + + ========================================= + XOCN naming conventions in compset name + ========================================= + + + diff --git a/med_test_comps/xocn/src/ocn_comp_nuopc.F90 b/med_test_comps/xocn/src/ocn_comp_nuopc.F90 new file mode 100644 index 000000000..87f8ca251 --- /dev/null +++ b/med_test_comps/xocn/src/ocn_comp_nuopc.F90 @@ -0,0 +1,475 @@ +module ocn_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for XOCN + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use dead_methods_mod , only : chkerr, state_setscalar, state_diagnose, alarmInit, memcheck + use dead_methods_mod , only : set_component_logging, get_component_instance, log_clock_advance + use dead_nuopc_mod , only : dead_read_inparms, ModelInitPhase, ModelSetRunClock + use dead_nuopc_mod , only : fld_list_add, fld_list_realize, fldsMax, fld_list_type + + implicit none + private ! except + + public :: SetServices + public :: SetVM + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_nextsw_cday = 0._r8 + + integer :: fldsToOcn_num = 0 + integer :: fldsFrOcn_num = 0 + type (fld_list_type) :: fldsToOcn(fldsMax) + type (fld_list_type) :: fldsFrOcn(fldsMax) + integer, parameter :: gridTofieldMap = 2 ! ungridded dimension is innermost + + type(ESMF_Mesh) :: mesh + integer :: nxg ! global dim i-direction + integer :: nyg ! global dim j-direction + integer :: my_task ! my task in mpi communicator mpicom + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_name ! fullname of current instance (ie. "ocn_0001") + character(len=16) :: inst_suffix = "" ! char string associated with instance (ie. "_0001" or "") + integer :: logunit ! logging unit number + integer ,parameter :: master_task=0 ! task number of master task + logical :: mastertask + integer :: dbug = 0 + character(*),parameter :: modName = "(xocn_comp_nuopc)" + character(*),parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=ModelInitPhase, phase=0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, specRoutine=ModelAdvance, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, specRoutine=ModelSetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, specRoutine=ModelFinalize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetServices + + !=============================================================================== + + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + integer :: n + integer :: lsize ! local array size + integer :: shrlogunit ! original log unit + character(CL) :: cvalue + character(len=CL) :: logmsg + logical :: isPresent, isSet + character(len=*),parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localpet=my_task, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + mastertask = (my_task == master_task) + + ! determine instance information + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set logunit and set shr logging to my log file + call set_component_logging(gcomp, my_task==master_task, logunit, shrlogunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Initialize xocn + call dead_read_inparms('ocn', inst_suffix, logunit, nxg, nyg) + + ! advertise import and export fields + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldName') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldCount') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNX') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNY') + endif + + if (nxg /= 0 .and. nyg /= 0) then + + call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(flds_scalar_name)) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_omask" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_t" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_s" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_u" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_v" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdx" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdy" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" ) + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "Fioo_q" ) + + call fld_list_add(fldsToOcn_num, fldsToOcn, trim(flds_scalar_name)) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_rain" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_snow" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_lwdn" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_swndr" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_swvdr" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_swndf" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_swvdf" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_taux" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_tauy" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_sen" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_lat" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_lwup" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_evap" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_salt" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" ) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_pslv" ) + + do n = 1,fldsFrOcn_num + if(mastertask) write(logunit,*)'Advertising From Xocn ',trim(fldsFrOcn(n)%stdname) + call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + + do n = 1,fldsToOcn_num + if(mastertask) write(logunit,*)'Advertising To Xocn',trim(fldsToOcn(n)%stdname) + call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + end if + + ! Reset shr logging to original values + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeAdvertise + + !=============================================================================== + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + integer :: shrlogunit ! original log unit + character(ESMF_MAXSTR) :: cvalue ! config data + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize: xocn) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Reset shr logging to my log file + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + ! generate the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + mesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! realize the actively coupled fields, now that a mesh is established + ! NUOPC_Realize "realizes" a previously advertised field in the importState and exportState + ! by replacing the advertised fields with the newly created fields of the same name. + call fld_list_realize( & + state=ExportState, & + fldlist=fldsFrOcn, & + numflds=fldsFrOcn_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':docnExport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call fld_list_realize( & + state=importState, & + fldList=fldsToOcn, & + numflds=fldsToOcn_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':docnImport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Pack export state + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(nxg),flds_scalar_index_nx, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(nyg),flds_scalar_index_ny, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! diagnostics + if (dbug > 1) then + call state_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeRealize + + !=============================================================================== + subroutine ModelAdvance(gcomp, rc) + + ! intput/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: exportState + integer :: shrlogunit ! original log unit + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call memcheck(subname, 3, mastertask) + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + ! Pack export state + call NUOPC_ModelGet(gcomp, modelClock=clock, exportState=exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! diagnostics + if (dbug > 1) then + call state_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine ModelAdvance + + !=============================================================================== + subroutine state_setexport(exportState, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: exportState + integer, intent(out) :: rc + + ! local variables + integer :: n, nf, nind + real(r8), pointer :: lat(:) + real(r8), pointer :: lon(:) + integer :: spatialDim + integer :: numOwnedElements + real(R8), pointer :: ownedElemCoords(:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(lon(numownedElements)) + allocate(lat(numownedElements)) + do n = 1,numownedElements + lon(n) = ownedElemCoords(2*n-1) + lat(n) = ownedElemCoords(2*n) + end do + + ! Start from index 2 in order to Skip the scalar field here + do nf = 2,fldsFrOcn_num + if (fldsFrOcn(nf)%ungridded_ubound == 0) then + call field_setexport(exportState, trim(fldsFrOcn(nf)%stdname), lon, lat, nf=nf, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + do nind = 1,fldsFrOcn(nf)%ungridded_ubound + call field_setexport(exportState, trim(fldsFrOcn(nf)%stdname), lon, lat, nf=nf, & + ungridded_index=nind, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + end do + + deallocate(lon) + deallocate(lat) + + end subroutine state_setexport + + !=============================================================================== + + subroutine field_setexport(exportState, fldname, lon, lat, nf, ungridded_index, rc) + + use shr_const_mod , only : pi=>shr_const_pi + + ! intput/otuput variables + type(ESMF_State) , intent(inout) :: exportState + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: lon(:) + real(r8) , intent(in) :: lat(:) + integer , intent(in) :: nf + integer, optional , intent(in) :: ungridded_index + integer , intent(out) :: rc + + ! local variables + integer :: i, ncomp + type(ESMF_Field) :: lfield + real(r8), pointer :: data1d(:) + real(r8), pointer :: data2d(:,:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ncomp = 4 + if (present(ungridded_index)) then + call ESMF_FieldGet(lfield, farrayPtr=data2d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (gridToFieldMap == 1) then + do i = 1,size(data2d, dim=1) + data2d(i,ungridded_index) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + else if (gridToFieldMap == 2) then + do i = 1,size(data2d, dim=2) + data2d(ungridded_index,i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + else + call ESMF_FieldGet(lfield, farrayPtr=data1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do i = 1,size(data1d) + data1d(i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + + if (fldname == 'So_omask') then + do i = 1,size(data1d) + !data1d(i) = float(nint(min(1.0_R8,max(0.0_R8,data1d(i))))) + data1d(i) = 0._r8 + end do + end if + + end subroutine field_setexport + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (mastertask) then + write(logunit,*) + write(logunit,*) 'xocn: end of main integration loop' + write(logunit,*) + end if + end subroutine ModelFinalize + +end module ocn_comp_nuopc diff --git a/med_test_comps/xrof/cime_config/buildlib b/med_test_comps/xrof/cime_config/buildlib new file mode 120000 index 000000000..ba1b3b80a --- /dev/null +++ b/med_test_comps/xrof/cime_config/buildlib @@ -0,0 +1 @@ +../../xshare/cime_config/buildlib \ No newline at end of file diff --git a/med_test_comps/xrof/cime_config/buildnml b/med_test_comps/xrof/cime_config/buildnml new file mode 100755 index 000000000..bf23e8913 --- /dev/null +++ b/med_test_comps/xrof/cime_config/buildnml @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +""" +build data model library +""" + +import sys, os + +_CIMEROOT = os.path.join( + os.path.dirname(os.path.abspath(__file__)), "..", "..", "..", "..", ".." +) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildnml import build_xcpl_nml, parse_input +from CIME.case import Case + + +def buildnml(case, caseroot, compname): + if compname != "xrof": + raise AttributeError + build_xcpl_nml(case, caseroot, compname) + + +def _main_func(): + caseroot = parse_input(sys.argv) + with Case(caseroot) as case: + buildnml(case, caseroot, "xrof") + + +if __name__ == "__main__": + _main_func() diff --git a/med_test_comps/xrof/cime_config/config_component.xml b/med_test_comps/xrof/cime_config/config_component.xml new file mode 100644 index 000000000..e1663cbbb --- /dev/null +++ b/med_test_comps/xrof/cime_config/config_component.xml @@ -0,0 +1,39 @@ + + + + + + + Dead river component + + + + char + xrof + xrof + case_comp + env_case.xml + Name of river component + + + + char + ACTIVE,NULL + NULL + + ACTIVE + ACTIVE + + build_component_xrof + env_build.xml + mode for xrof flood feature, NULL means xrof flood is turned off + + + + + ========================================= + XROF naming conventions in compset name + ========================================= + + + diff --git a/med_test_comps/xrof/src/rof_comp_nuopc.F90 b/med_test_comps/xrof/src/rof_comp_nuopc.F90 new file mode 100644 index 000000000..1b5b9dd49 --- /dev/null +++ b/med_test_comps/xrof/src/rof_comp_nuopc.F90 @@ -0,0 +1,473 @@ +module rof_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for XROF + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use dead_methods_mod , only : chkerr, state_setscalar, state_diagnose, alarmInit, memcheck + use dead_methods_mod , only : set_component_logging, get_component_instance, log_clock_advance + use dead_nuopc_mod , only : dead_read_inparms, ModelInitPhase, ModelSetRunClock + use dead_nuopc_mod , only : fld_list_add, fld_list_realize, fldsMax, fld_list_type + + implicit none + private ! except + + public :: SetServices + public :: SetVM + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_nextsw_cday = 0 + + integer :: fldsToRof_num = 0 + integer :: fldsFrRof_num = 0 + type (fld_list_type) :: fldsToRof(fldsMax) + type (fld_list_type) :: fldsFrRof(fldsMax) + integer, parameter :: gridTofieldMap = 2 ! ungridded dimension is innermost + + type(ESMF_Mesh) :: mesh + integer :: nxg ! global dim i-direction + integer :: nyg ! global dim j-direction + integer :: my_task ! my task in mpi + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_suffix = "" ! char string associated with instance (ie. "_0001" or "") + integer :: logunit ! logging unit number + integer ,parameter :: master_task=0 ! task number of master task + logical :: mastertask + integer :: dbug = 0 + character(*),parameter :: modName = "(xrof_comp_nuopc)" + character(*),parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=ModelInitPhase, phase=0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, specRoutine=ModelAdvance, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, specRoutine=ModelSetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, specRoutine=ModelFinalize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetServices + + !=============================================================================== + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + character(CS) :: stdname + integer :: n + integer :: lsize ! local array size + integer :: shrlogunit ! original log unit + character(CL) :: cvalue + character(len=CL) :: logmsg + logical :: isPresent, isSet + character(len=*),parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localpet=my_task, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + mastertask = (my_task == master_task) + + ! determine instance information + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! set logunit and set shr logging to my log file + call set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Initialize xrof + call dead_read_inparms('rof', inst_suffix, logunit, nxg, nyg) + + !-------------------------------- + ! advertise import and export fields + !-------------------------------- + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldName') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldCount') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNX') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNY') + endif + + if (nxg /= 0 .and. nyg /= 0) then + + call fld_list_add(fldsFrRof_num, fldsFrRof, trim(flds_scalar_name)) + call fld_list_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl') + call fld_list_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi') + call fld_list_add(fldsFrRof_num, fldsFrRof, 'Flrr_flood') + call fld_list_add(fldsFrRof_num, fldsFrRof, 'Flrr_volr') + call fld_list_add(fldsFrRof_num, fldsFrRof, 'Flrr_volrmch') + + call fld_list_add(fldsToRof_num, fldsToRof, trim(flds_scalar_name)) + call fld_list_add(fldsToRof_num, fldsToRof, 'Flrl_rofsur') + call fld_list_add(fldsToRof_num, fldsToRof, 'Flrl_rofgwl') + call fld_list_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') + call fld_list_add(fldsToRof_num, fldsToRof, 'Flrl_rofdto') + call fld_list_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') + call fld_list_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') + + do n = 1,fldsFrRof_num + if(mastertask) write(logunit,*)'Advertising From Xrof ',trim(fldsFrRof(n)%stdname) + call NUOPC_Advertise(exportState, standardName=fldsFrRof(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + + do n = 1,fldsToRof_num + if(mastertask) write(logunit,*)'Advertising To Xrof',trim(fldsToRof(n)%stdname) + call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + end if + + if (dbug > 5) call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + + !---------------------------------------------------------------------------- + ! Reset shr logging to original values + !---------------------------------------------------------------------------- + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeAdvertise + + !=============================================================================== + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + ! input/output arguments + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + integer :: shrlogunit ! original log unit + character(ESMF_MAXSTR) :: cvalue ! config data + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Reset shr logging to my log file + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logUnit) + + + ! generate the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_rof', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + mesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! realize the actively coupled fields, now that a mesh is established + ! NUOPC_Realize "realizes" a previously advertised field in the importState and exportState + ! by replacing the advertised fields with the newly created fields of the same name. + call fld_list_realize( & + state=ExportState, & + fldlist=fldsFrRof, & + numflds=fldsFrRof_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':drofExport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call fld_list_realize( & + state=importState, & + fldList=fldsToRof, & + numflds=fldsToRof_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':drofImport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! Pack export state + !-------------------------------- + + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(nxg),flds_scalar_index_nx, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(nyg),flds_scalar_index_ny, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! diagnostics + !-------------------------------- + + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeRealize + + !=============================================================================== + subroutine ModelAdvance(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: exportState + integer :: shrlogunit ! original log unit + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (dbug > 5) then + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + end if + call memcheck(subname, 3, mastertask) + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + ! Pack export state + call NUOPC_ModelGet(gcomp, modelClock=clock, exportState=exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetExport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! diagnostics + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + call log_clock_advance(clock, 'XROF', logunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + endif + + call shr_log_setLogUnit (shrlogunit) + + if (dbug > 5) then + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + end if + + end subroutine ModelAdvance + + !=============================================================================== + subroutine state_setexport(exportState, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: exportState + integer, intent(out) :: rc + + ! local variables + integer :: n, nf, nind + real(r8), pointer :: lat(:) + real(r8), pointer :: lon(:) + integer :: spatialDim + integer :: numOwnedElements + real(R8), pointer :: ownedElemCoords(:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(lon(numownedElements)) + allocate(lat(numownedElements)) + do n = 1,numownedElements + lon(n) = ownedElemCoords(2*n-1) + lat(n) = ownedElemCoords(2*n) + end do + + ! Start from index 2 in order to skip the scalar field + do nf = 2,fldsFrRof_num + if (fldsFrRof(nf)%ungridded_ubound == 0) then + call field_setexport(exportState, trim(fldsFrRof(nf)%stdname), lon, lat, nf=nf, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + do nind = 1,fldsFrRof(nf)%ungridded_ubound + call field_setexport(exportState, trim(fldsFrRof(nf)%stdname), lon, lat, nf=nf+nind-1, & + ungridded_index=nind, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + end do + + deallocate(lon) + deallocate(lat) + + end subroutine state_setexport + + !=============================================================================== + subroutine field_setexport(exportState, fldname, lon, lat, nf, ungridded_index, rc) + + use shr_const_mod , only : pi=>shr_const_pi + + ! intput/otuput variables + type(ESMF_State) , intent(inout) :: exportState + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: lon(:) + real(r8) , intent(in) :: lat(:) + integer , intent(in) :: nf + integer, optional , intent(in) :: ungridded_index + integer , intent(out) :: rc + + ! local variables + integer :: i, ncomp + type(ESMF_Field) :: lfield + real(r8), pointer :: data1d(:) + real(r8), pointer :: data2d(:,:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ncomp = 6 + if (present(ungridded_index)) then + call ESMF_FieldGet(lfield, farrayPtr=data2d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (gridToFieldMap == 1) then + do i = 1,size(data2d, dim=1) + data2d(i,ungridded_index) = (nf+1) * 1.0_r8 + end do + else if (gridToFieldMap == 2) then + do i = 1,size(data2d, dim=2) + data2d(ungridded_index,i) = (nf+1) * 1.0_r8 + end do + end if + else + call ESMF_FieldGet(lfield, farrayPtr=data1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do i = 1,size(data1d) + data1d(i) = (nf+1) * 1.0_r8 + end do + end if + + end subroutine field_setexport + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (mastertask) then + write(logunit,*) + write(logunit,*) 'xrof: end of main integration loop' + write(logunit,*) + end if + end subroutine ModelFinalize + +end module rof_comp_nuopc diff --git a/med_test_comps/xshare/cime_config/buildlib b/med_test_comps/xshare/cime_config/buildlib new file mode 100755 index 000000000..f7f597d77 --- /dev/null +++ b/med_test_comps/xshare/cime_config/buildlib @@ -0,0 +1,39 @@ +#!/usr/bin/env python3 + +""" +build cime component model library. This buildlib script is used by all cime internal +components. +""" + +import sys, os + +_CIMEROOT = os.environ.get("CIMEROOT") +if _CIMEROOT == None: + raise ValueError("ERROR: CIMEROOT not defined in buildlib.internal_components.") +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildlib import build_cime_component_lib, parse_input +from CIME.case import Case + + +def buildlib(bldroot, libroot, case, compname=None): + if compname is None: + thisdir = os.path.dirname(os.path.abspath(__file__)) + path, dir1 = os.path.split(thisdir) + _, dir2 = os.path.split(path) + if dir1 == "cime_config": + compname = dir2 + else: + compname = dir1.split(".")[1] + build_cime_component_lib(case, compname, libroot, bldroot) + + +def _main_func(args): + caseroot, libroot, bldroot = parse_input(args) + with Case(caseroot) as case: + buildlib(bldroot, libroot, case) + + +if __name__ == "__main__": + _main_func(sys.argv) diff --git a/med_test_comps/xshare/dead_methods_mod.F90 b/med_test_comps/xshare/dead_methods_mod.F90 new file mode 100644 index 000000000..a9ad38e24 --- /dev/null +++ b/med_test_comps/xshare/dead_methods_mod.F90 @@ -0,0 +1,853 @@ +module dead_methods_mod + + use ESMF , only : operator(<), operator(/=), operator(+) + use ESMF , only : operator(-), operator(*) , operator(>=) + use ESMF , only : operator(<=), operator(>), operator(==) + use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_LogFoundError, ESMF_LOGMSG_ERROR, ESMF_MAXSTR + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_FAILURE + use ESMF , only : ESMF_State, ESMF_StateGet + use ESMF , only : ESMF_Field, ESMF_FieldGet + use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_GridCompSet + use ESMF , only : ESMF_GeomType_Flag, ESMF_FieldStatus_Flag + use ESMF , only : ESMF_Mesh, ESMF_MeshGet + use ESMF , only : ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_FIELDSTATUS_COMPLETE + use ESMF , only : ESMF_Clock, ESMF_ClockCreate, ESMF_ClockGet, ESMF_ClockSet + use ESMF , only : ESMF_ClockPrint, ESMF_ClockAdvance + use ESMF , only : ESMF_Alarm, ESMF_AlarmCreate, ESMF_AlarmGet, ESMF_AlarmSet + use ESMF , only : ESMF_Calendar, 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_VM, ESMF_VMGet, ESMF_VMBroadcast, ESMF_VMGetCurrent + use NUOPC , only : NUOPC_CompAttributeGet + use NUOPC_Model , only : NUOPC_ModelGet + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : shr_log_setlogunit, shr_log_getLogUnit + + implicit none + private + + public :: memcheck + public :: get_component_instance + public :: set_component_logging + public :: log_clock_advance + public :: state_getscalar + public :: state_setscalar + public :: state_diagnose + public :: alarmInit + public :: chkerr + + private :: timeInit + private :: field_getfldptr + + ! Clock and alarm options + character(len=*), private, parameter :: & + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nsteps" , & + optNStep = "nstep" , & + optNSeconds = "nseconds" , & + optNSecond = "nsecond" , & + optNMinutes = "nminutes" , & + optNMinute = "nminute" , & + optNHours = "nhours" , & + optNHour = "nhour" , & + optNDays = "ndays" , & + optNDay = "nday" , & + optNMonths = "nmonths" , & + optNMonth = "nmonth" , & + optNYears = "nyears" , & + optNYear = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optDate = "date" , & + optIfdays0 = "ifdays0" + + ! Module data + integer, parameter :: SecPerDay = 86400 ! Seconds per day + integer, parameter :: memdebug_level=1 + character(len=1024) :: msgString + character(len=*), parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine memcheck(string, level, mastertask) + + ! input/output variables + character(len=*) , intent(in) :: string + integer , intent(in) :: level + logical , intent(in) :: mastertask + + ! local variables + integer :: ierr + integer, external :: GPTLprint_memusage + !----------------------------------------------------------------------- + + if ((mastertask .and. memdebug_level > level) .or. memdebug_level > level+1) then + ierr = GPTLprint_memusage(string) + endif + + end subroutine memcheck + +!=============================================================================== + + subroutine get_component_instance(gcomp, inst_suffix, inst_index, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + character(len=*) , intent(out) :: inst_suffix + integer , intent(out) :: inst_index + integer , intent(out) :: rc + + ! local variables + logical :: isPresent + character(len=4) :: cvalue + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (isPresent) then + call NUOPC_CompAttributeGet(gcomp, name="inst_suffix", value=inst_suffix, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + cvalue = inst_suffix(2:) + read(cvalue, *) inst_index + else + inst_suffix = "" + inst_index=1 + endif + + end subroutine get_component_instance + +!=============================================================================== + + subroutine set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + use ESMF, only : ESMF_GridCompGet, ESMF_LogWrite + use NUOPC, only: NUOPC_CompAttributeAdd, NUOPC_CompAttributeSet + ! input/output variables + type(ESMF_GridComp) :: gcomp + logical, intent(in) :: mastertask + integer, intent(out) :: logunit + integer, intent(out) :: shrlogunit + integer, intent(out) :: rc + + ! local variables + character(len=CL) :: diro, name + character(len=CL) :: logfile + character(len=*), parameter :: subname ='('//__FILE__//': set_component_logging)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + shrlogunit = 6 + + if (mastertask) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) + else + logUnit = 6 + endif + + call shr_log_setLogUnit (logunit) + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(trim(subname)//": setting logunit for component: "//trim(name), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeAdd(gcomp, attrList=(/'logunit'/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, name='logunit',value=logunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + + end subroutine set_component_logging + +!=============================================================================== + + subroutine log_clock_advance(clock, component, logunit, rc) + + ! input/output variables + type(ESMF_Clock) :: clock + character(len=*) , intent(in) :: component + integer , intent(in) :: logunit + integer , intent(out) :: rc + + ! local variables + character(len=CL) :: cvalue, prestring + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + write(prestring, *) "------>Advancing ",trim(component)," from: " + call ESMF_ClockPrint(clock, options="currTime", unit=cvalue, preString=trim(prestring), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(logunit, *) trim(cvalue) + + call ESMF_ClockPrint(clock, options="stopTime", unit=cvalue, & + preString="--------------------------------> to: ", rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(logunit, *) trim(cvalue) + + end subroutine log_clock_advance + +!=============================================================================== + + subroutine state_getscalar(state, scalar_id, scalar_value, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Get scalar data from State for a particular name and broadcast it to all other pets + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_State), intent(in) :: state + integer, intent(in) :: scalar_id + real(r8), intent(out) :: scalar_value + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask, ierr, len + type(ESMF_VM) :: vm + type(ESMF_Field) :: field + real(r8), pointer :: farrayptr(:,:) + real(r8) :: tmp(1) + character(len=*), parameter :: subname='(state_getscalar)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=field, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(field, farrayPtr = farrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then + call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + endif + tmp(:) = farrayptr(scalar_id,:) + endif + call ESMF_VMBroadCast(vm, tmp, 1, 0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + scalar_value = tmp(1) + + end subroutine state_getscalar + +!================================================================================ + + subroutine state_setscalar(scalar_value, scalar_id, State, flds_scalar_name, flds_scalar_num, rc) + + ! ---------------------------------------------- + ! Set scalar data from State for a particular name + ! ---------------------------------------------- + + ! input/output arguments + real(r8), intent(in) :: scalar_value + integer, intent(in) :: scalar_id + type(ESMF_State), intent(inout) :: State + character(len=*), intent(in) :: flds_scalar_name + integer, intent(in) :: flds_scalar_num + integer, intent(inout) :: rc + + ! local variables + integer :: mytask + type(ESMF_Field) :: lfield + type(ESMF_VM) :: vm + real(r8), pointer :: farrayptr(:,:) + character(len=*), parameter :: subname='(state_setscalar)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localPet=mytask, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_StateGet(State, itemName=trim(flds_scalar_name), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (mytask == 0) then + call ESMF_FieldGet(lfield, farrayPtr = farrayptr, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (scalar_id < 0 .or. scalar_id > flds_scalar_num) then + call ESMF_LogWrite(trim(subname)//": ERROR in scalar_id", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + endif + farrayptr(scalar_id,1) = scalar_value + endif + + end subroutine state_setscalar + +!=============================================================================== + + subroutine state_diagnose(State, string, rc) + + ! ---------------------------------------------- + ! Diagnose status of State + ! ---------------------------------------------- + + type(ESMF_State), intent(in) :: state + character(len=*), intent(in) :: string + integer , intent(out) :: rc + + ! local variables + integer :: i,j,n + type(ESMf_Field) :: lfield + integer :: fieldCount, lrank + character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) + real(r8), pointer :: dataPtr1d(:) + real(r8), pointer :: dataPtr2d(:,:) + character(len=*),parameter :: subname='(state_diagnose)' + ! ---------------------------------------------- + + call ESMF_StateGet(state, itemCount=fieldCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(lfieldnamelist(fieldCount)) + + call ESMF_StateGet(state, itemNameList=lfieldnamelist, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + do n = 1, fieldCount + + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + enddo + + deallocate(lfieldnamelist) + + end subroutine state_diagnose + +!=============================================================================== + + subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) + + ! ---------------------------------------------- + ! for a field, determine rank and return fldptr1 or fldptr2 + ! abort is true by default and will abort if fldptr is not yet allocated in field + ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false + ! ---------------------------------------------- + + ! input/output variables + type(ESMF_Field) , intent(in) :: field + real(r8), pointer , intent(inout), optional :: fldptr1(:) + real(r8), pointer , intent(inout), optional :: fldptr2(:,:) + integer , intent(out) , optional :: rank + logical , intent(in) , optional :: abort + integer , intent(out) , optional :: rc + + ! local variables + type(ESMF_GeomType_Flag) :: geomtype + type(ESMF_FieldStatus_Flag) :: status + type(ESMF_Mesh) :: lmesh + integer :: lrank, nnodes, nelements + logical :: labort + character(len=*), parameter :: subname='(field_getfldptr)' + ! ---------------------------------------------- + + if (.not.present(rc)) then + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + rc = ESMF_SUCCESS + + labort = .true. + if (present(abort)) then + labort = abort + endif + lrank = -99 + + call ESMF_FieldGet(field, status=status, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (status /= ESMF_FIELDSTATUS_COMPLETE) then + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO, rc=rc) + endif + else + + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO, rc=rc) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif + + endif ! status + + if (present(rank)) then + rank = lrank + endif + + end subroutine field_getfldptr + +!=============================================================================== + + subroutine alarmInit( clock, alarm, option, & + opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + + ! Setup an alarm in a clock + ! Notes: The ringtime sent to AlarmCreate MUST be the next alarm + ! time. If you send an arbitrary but proper ringtime from the + ! past and the ring interval, the alarm will always go off on the + ! next clock advance and this will cause serious problems. Even + ! if it makes sense to initialize an alarm with some reference + ! time and the alarm interval, that reference time has to be + ! advance forward to be >= the current time. In the logic below + ! we set an appropriate "NextAlarm" and then we make sure to + ! advance it properly based on the ring interval. + + ! input/output variables + type(ESMF_Clock) , intent(inout) :: clock ! clock + type(ESMF_Alarm) , intent(inout) :: alarm ! alarm + character(len=*) , intent(in) :: option ! alarm option + integer , optional , intent(in) :: opt_n ! alarm freq + integer , optional , intent(in) :: opt_ymd ! alarm ymd + integer , optional , intent(in) :: opt_tod ! alarm tod (sec) + type(ESMF_Time) , optional , intent(in) :: RefTime ! ref time + character(len=*) , optional , intent(in) :: alarmname ! alarm name + integer , intent(inout) :: rc ! Return code + + ! local variables + type(ESMF_Calendar) :: cal ! calendar + integer :: lymd ! local ymd + integer :: ltod ! local tod + integer :: cyy,cmm,cdd,csec ! time info + character(len=64) :: lalarmname ! local alarm name + logical :: update_nextalarm ! update next alarm + type(ESMF_Time) :: CurrTime ! Current Time + type(ESMF_Time) :: NextAlarm ! Next restart alarm time + type(ESMF_TimeInterval) :: AlarmInterval ! Alarm interval + integer :: sec + character(len=*), parameter :: subname = '(set_alarmInit): ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + lalarmname = 'alarm_unknown' + if (present(alarmname)) lalarmname = trim(alarmname) + ltod = 0 + if (present(opt_tod)) ltod = opt_tod + lymd = -1 + if (present(opt_ymd)) lymd = opt_ymd + + call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(CurrTime, yy=cyy, mm=cmm, dd=cdd, s=csec, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! initial guess of next alarm, this will be updated below + if (present(RefTime)) then + NextAlarm = RefTime + else + NextAlarm = CurrTime + endif + + ! Determine calendar + call ESMF_ClockGet(clock, calendar=cal) + + ! Determine inputs for call to create alarm + selectcase (trim(option)) + + case (optNONE) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optNever) + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optDate) + if (.not. present(opt_ymd)) then + call shr_sys_abort(subname//trim(option)//' requires opt_ymd') + end if + if (lymd < 0 .or. ltod < 0) then + call shr_sys_abort(subname//trim(option)//'opt_ymd, opt_tod invalid') + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call timeInit(NextAlarm, lymd, cal, ltod, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. + + case (optIfdays0) + if (.not. present(opt_ymd)) then + call shr_sys_abort(subname//trim(option)//' requires opt_ymd') + end if + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case (optNSteps) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNStep) + if (.not.present(opt_n)) call shr_sys_abort(subname//trim(option)//' requires opt_n') + if (opt_n <= 0) call shr_sys_abort(subname//trim(option)//' invalid opt_n') + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNSeconds) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNSecond) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMinutes) + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMinute) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNHours) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNHour) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNDays) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNDay) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMonths) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNMonth) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optMonthly) + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case (optNYears) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optNYear) + if (.not.present(opt_n)) then + call shr_sys_abort(subname//trim(option)//' requires opt_n') + end if + if (opt_n <= 0) then + call shr_sys_abort(subname//trim(option)//' invalid opt_n') + end if + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. + + case (optYearly) + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. + + case default + call shr_sys_abort(subname//'unknown option '//trim(option)) + + end select + + ! -------------------------------------------------------------------------------- + ! --- AlarmInterval and NextAlarm should be set --- + ! -------------------------------------------------------------------------------- + + ! --- advance Next Alarm so it won't ring on first timestep for + ! --- most options above. go back one alarminterval just to be careful + + if (update_nextalarm) then + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo + endif + + alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, & + ringInterval=AlarmInterval, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine alarmInit + +!=============================================================================== + + subroutine timeInit( Time, ymd, cal, tod, rc) + + ! Create the ESMF_Time object corresponding to the given input time, + ! given in YMD (Year Month Day) and TOD (Time-of-day) format. + ! Set the time by an integer as YYYYMMDD and integer seconds in the day + + ! input/output parameters: + type(ESMF_Time) , intent(inout) :: Time ! ESMF time + integer , intent(in) :: ymd ! year, month, day YYYYMMDD + type(ESMF_Calendar) , intent(in) :: cal ! ESMF calendar + integer , intent(in) :: tod ! time of day in seconds + integer , intent(out) :: rc + + ! local variables + integer :: year, mon, day ! year, month, day as integers + integer :: tdate ! temporary date + integer :: date ! coded-date (yyyymmdd) + character(len=*), parameter :: subname='(timeInit)' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if ( (ymd < 0) .or. (tod < 0) .or. (tod > SecPerDay) )then + call shr_sys_abort( subname//'ERROR yymmdd is a negative number or time-of-day out of bounds' ) + end if + + tdate = abs(date) + year = int(tdate/10000) + if (date < 0) year = -year + mon = int( mod(tdate,10000)/ 100) + day = mod(tdate, 100) + + call ESMF_TimeSet( Time, yy=year, mm=mon, dd=day, s=tod, calendar=cal, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine timeInit + +!=============================================================================== + + logical function chkerr(rc, line, file) + + integer, intent(in) :: rc + integer, intent(in) :: line + character(len=*), intent(in) :: file + + integer :: lrc + + chkerr = .false. + lrc = rc + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then + chkerr = .true. + endif + end function chkerr + +!=============================================================================== + +end module dead_methods_mod diff --git a/med_test_comps/xshare/dead_nuopc_mod.F90 b/med_test_comps/xshare/dead_nuopc_mod.F90 new file mode 100644 index 000000000..ee3ca6b68 --- /dev/null +++ b/med_test_comps/xshare/dead_nuopc_mod.F90 @@ -0,0 +1,346 @@ +module dead_nuopc_mod + + use ESMF , only : ESMF_Gridcomp, ESMF_State, ESMF_StateGet + use ESMF , only : ESMF_Clock, ESMF_Time, ESMF_TimeInterval, ESMF_Alarm + use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_ClockSet, ESMF_ClockAdvance, ESMF_AlarmSet + use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_METHOD_INITIALIZE + use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMBroadcast, ESMF_VMGet + use ESMF , only : ESMF_VM, ESMF_VMGetCurrent, ESMF_VmGet + use ESMF , only : operator(/=), operator(==), operator(+) + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use dead_methods_mod , only : chkerr, alarmInit + + implicit none + private + + public :: dead_read_inparms + public :: ModelInitPhase + public :: ModelSetRunClock + public :: fld_list_add + public :: fld_list_realize + + ! !PUBLIC DATA MEMBERS: + type fld_list_type + character(len=128) :: stdname + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 + end type fld_list_type + public :: fld_list_type + + integer, parameter, public :: fldsMax = 100 + integer :: dbug_flag = 0 + character(*), parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine dead_read_inparms(model, inst_suffix, logunit, nxg, nyg) + + ! input/output variables + character(len=*) , intent(in) :: model + character(len=*) , intent(in) :: inst_suffix ! char string associated with instance + integer , intent(in) :: logunit ! logging unit number + integer , intent(out) :: nxg ! global dim i-direction + integer , intent(out) :: nyg ! global dim j-direction + + ! local variables + type(ESMF_VM) :: vm + character(CL) :: fileName ! generic file name + integer :: nunit ! unit number + integer :: unitn ! Unit for namelist file + integer :: tmp(2) ! array for broadcast + integer :: localPet ! mpi id of current task in current context + integer :: rc ! return code + character(*), parameter :: F00 = "('(dead_read_inparms) ',8a)" + character(*), parameter :: F01 = "('(dead_read_inparms) ',a,a,4i8)" + character(*), parameter :: F03 = "('(dead_read_inparms) ',a,a,i8,a)" + character(*), parameter :: subName = "(dead_read_inpamrs) " + !------------------------------------------------------------------------------- + + ! read the input parms (used to configure model) + call ESMF_VMGetCurrent(vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + nxg = -9999 + nyg = -9999 + + if (localPet==0) then + open(newunit=unitn, file='x'//model//'_in'//trim(inst_suffix), status='old' ) + read(unitn,*) nxg + read(unitn,*) nyg + close (unitn) + endif + + tmp(1) = nxg + tmp(2) = nyg + call ESMF_VMBroadcast(vm, tmp, 3, 0, rc=rc) + nxg = tmp(1) + nyg = tmp(2) + + if (localPet==0) then + write(logunit,*)' Read in X'//model//' input from file= x'//model//'_in' + write(logunit,F00) model + write(logunit,F00) model,' Model : ',model + write(logunit,F01) model,' NGX : ',nxg + write(logunit,F01) model,' NGY : ',nyg + write(logunit,F00) model,' inst_suffix : ',trim(inst_suffix) + write(logunit,F00) model + end if + + end subroutine dead_read_inparms + + !=============================================================================== + subroutine fld_list_add(num, fldlist, stdname, ungridded_lbound, ungridded_ubound) + + ! input/output variables + integer , intent(inout) :: num + type(fld_list_type) , intent(inout) :: fldlist(:) + character(len=*) , intent(in) :: stdname + integer, optional , intent(in) :: ungridded_lbound + integer, optional , intent(in) :: ungridded_ubound + + ! local variables + character(len=*), parameter :: subname='(dead_nuopc_mod:fld_list_add)' + !------------------------------------------------------------------------------- + + ! Set up a list of field information + num = num + 1 + if (num > fldsMax) then + call ESMF_LogWrite(trim(subname)//": ERROR num > fldsMax "//trim(stdname), & + ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) + return + endif + fldlist(num)%stdname = trim(stdname) + + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + end if + + end subroutine fld_list_add + + !=============================================================================== + subroutine fld_list_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, tag, rc) + + use NUOPC , only : NUOPC_IsConnected, NUOPC_Realize + use ESMF , only : ESMF_MeshLoc_Element, ESMF_FieldCreate, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_MAXSTR, ESMF_Field, ESMF_State, ESMF_Mesh, ESMF_StateRemove + use ESMF , only : ESMF_LogFoundError, ESMF_LOGMSG_INFO, ESMF_SUCCESS + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LOGERR_PASSTHRU + + type(ESMF_State) , intent(inout) :: state + type(fld_list_type) , intent(in) :: fldList(:) + integer , intent(in) :: numflds + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + character(len=*) , intent(in) :: tag + type(ESMF_Mesh) , intent(in) :: mesh + integer , intent(inout) :: rc + + ! local variables + integer :: n + type(ESMF_Field) :: field + character(len=80) :: stdname + integer :: gridtoFieldMap=2 + character(len=*),parameter :: subname='(dead_nuopc_mod:fld_list_realize)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + do n = 1, numflds + stdname = fldList(n)%stdname + if (NUOPC_IsConnected(state, fieldName=stdname)) then + if (stdname == trim(flds_scalar_name)) then + call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected on root pe", & + ESMF_LOGMSG_INFO) + ! Create the scalar field + call SetScalarField(field, flds_scalar_name, flds_scalar_num, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected using mesh", & + ESMF_LOGMSG_INFO) + ! Create the field + if (fldlist(n)%ungridded_lbound > 0 .and. fldlist(n)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, & + ungriddedLbound=(/fldlist(n)%ungridded_lbound/), & + ungriddedUbound=(/fldlist(n)%ungridded_ubound/), & + gridToFieldMap=(/gridToFieldMap/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + end if + endif + + ! NOW call NUOPC_Realize + call NUOPC_Realize(state, field=field, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + else + if (stdname /= trim(flds_scalar_name)) then + call ESMF_LogWrite(subname // trim(tag) // " Field = "// trim(stdname) // " is not connected.", & + ESMF_LOGMSG_INFO) + call ESMF_StateRemove(state, (/stdname/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + end if + end if + end do + + contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + subroutine SetScalarField(field, flds_scalar_name, flds_scalar_num, rc) + ! ---------------------------------------------- + ! create a field with scalar data on the root pe + ! ---------------------------------------------- + + use ESMF, only : ESMF_Field, ESMF_DistGrid, ESMF_Grid + use ESMF, only : ESMF_DistGridCreate, ESMF_GridCreate, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU + use ESMF, only : ESMF_FieldCreate, ESMF_GridCreate, ESMF_TYPEKIND_R8 + + type(ESMF_Field) , intent(inout) :: field + character(len=*) , intent(in) :: flds_scalar_name + integer , intent(in) :: flds_scalar_num + integer , intent(inout) :: rc + + ! local variables + type(ESMF_Distgrid) :: distgrid + type(ESMF_Grid) :: grid + character(len=*), parameter :: subname='(dead_nuopc_mod:SetScalarField)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + ! create a DistGrid with a single index space element, which gets mapped onto DE 0. + distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + grid = ESMF_GridCreate(distgrid, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + field = ESMF_FieldCreate(name=trim(flds_scalar_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & + ungriddedLBound=(/1/), ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return + + end subroutine SetScalarField + + end subroutine fld_list_realize + + !=============================================================================== + subroutine ModelInitPhase(gcomp, importState, exportState, clock, rc) + + use NUOPC, only : NUOPC_CompFilterPhaseMap + + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Switch to IPDv01 by filtering all other phaseMap entries + call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, acceptStringList=(/"IPDv01p"/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine ModelInitPhase + + !=============================================================================== + subroutine ModelSetRunClock(gcomp, rc) + + use ESMF , only : ESMF_ClockGetAlarmList, ESMF_ALARMLIST_ALL + use NUOPC_Model , only : NUOPC_ModelGet + use NUOPC , only : NUOPC_CompAttributeGet + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: mclock, dclock + type(ESMF_Time) :: mcurrtime, dcurrtime + type(ESMF_Time) :: mstoptime + type(ESMF_TimeInterval) :: mtimestep, dtimestep + character(len=256) :: cvalue + character(len=256) :: restart_option ! Restart option units + integer :: restart_n ! Number until restart interval + integer :: restart_ymd ! Restart date (YYYYMMDD) + type(ESMF_ALARM) :: restart_alarm + character(len=128) :: name + integer :: alarmcount + character(len=*),parameter :: subname='dead_nuopc_mod:(ModelSetRunClock) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! query the Component for its clocks + call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(dclock, currTime=dcurrtime, timeStep=dtimestep, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! force model clock currtime and timestep to match driver and set stoptime + !-------------------------------- + + mstoptime = mcurrtime + dtimestep + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + !-------------------------------- + ! set restart alarm + !-------------------------------- + + call ESMF_ClockGetAlarmList(mclock, alarmlistflag=ESMF_ALARMLIST_ALL, alarmCount=alarmCount, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (alarmCount == 0) then + + call ESMF_GridCompGet(gcomp, name=name, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//'setting alarms for' // trim(name), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) restart_n + + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) restart_ymd + + call alarmInit(mclock, restart_alarm, restart_option, & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'alarm_restart', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end if + + !-------------------------------- + ! Advance model clock to trigger alarms then reset model clock back to currtime + !-------------------------------- + + call ESMF_ClockAdvance(mclock,rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine ModelSetRunClock + +end module dead_nuopc_mod diff --git a/med_test_comps/xwav/cime_config/buildlib b/med_test_comps/xwav/cime_config/buildlib new file mode 120000 index 000000000..ba1b3b80a --- /dev/null +++ b/med_test_comps/xwav/cime_config/buildlib @@ -0,0 +1 @@ +../../xshare/cime_config/buildlib \ No newline at end of file diff --git a/med_test_comps/xwav/cime_config/buildnml b/med_test_comps/xwav/cime_config/buildnml new file mode 100755 index 000000000..1ea9dc3a5 --- /dev/null +++ b/med_test_comps/xwav/cime_config/buildnml @@ -0,0 +1,32 @@ +#!/usr/bin/env python3 + +""" +build data model library +""" + +import sys, os + +_CIMEROOT = os.path.join( + os.path.dirname(os.path.abspath(__file__)), "..", "..", "..", "..", ".." +) +sys.path.append(os.path.join(_CIMEROOT, "CIME", "Tools")) + +from standard_script_setup import * +from CIME.buildnml import build_xcpl_nml, parse_input +from CIME.case import Case + + +def buildnml(case, caseroot, compname): + if compname != "xwav": + raise AttributeError + build_xcpl_nml(case, caseroot, compname) + + +def _main_func(): + caseroot = parse_input(sys.argv) + with Case(caseroot) as case: + buildnml(case, caseroot, "xwav") + + +if __name__ == "__main__": + _main_func() diff --git a/med_test_comps/xwav/cime_config/config_component.xml b/med_test_comps/xwav/cime_config/config_component.xml new file mode 100644 index 000000000..e82944fd3 --- /dev/null +++ b/med_test_comps/xwav/cime_config/config_component.xml @@ -0,0 +1,26 @@ + + + + + + + Dead wave component + + + + + char + xwav + xwav + case_comp + env_case.xml + Name of wave component + + + + ========================================= + XWAV naming conventions in compset name + ========================================= + + + diff --git a/med_test_comps/xwav/src/wav_comp_nuopc.F90 b/med_test_comps/xwav/src/wav_comp_nuopc.F90 new file mode 100644 index 000000000..aa4d982e5 --- /dev/null +++ b/med_test_comps/xwav/src/wav_comp_nuopc.F90 @@ -0,0 +1,465 @@ +module wav_comp_nuopc + + !---------------------------------------------------------------------------- + ! This is the NUOPC cap for XWAV + !---------------------------------------------------------------------------- + + use ESMF + use NUOPC , only : NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize + use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise + use NUOPC_Model , only : model_routine_SS => SetServices + use NUOPC_Model , only : model_label_Advance => label_Advance + use NUOPC_Model , only : model_label_SetRunClock => label_SetRunClock + use NUOPC_Model , only : model_label_Finalize => label_Finalize + use NUOPC_Model , only : NUOPC_ModelGet, SetVM + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8=>shr_kind_r8, i8=>shr_kind_i8, cl=>shr_kind_cl, cs=>shr_kind_cs + use shr_log_mod , only : shr_log_getlogunit, shr_log_setlogunit + use dead_methods_mod , only : chkerr, state_setscalar, state_diagnose, alarmInit, memcheck + use dead_methods_mod , only : set_component_logging, get_component_instance, log_clock_advance + use dead_nuopc_mod , only : dead_read_inparms, ModelInitPhase, ModelSetRunClock + use dead_nuopc_mod , only : fld_list_add, fld_list_realize, fldsMax, fld_list_type + + implicit none + private ! except + + public :: SetServices + public :: SetVM + !-------------------------------------------------------------------------- + ! Private module data + !-------------------------------------------------------------------------- + + character(len=CL) :: flds_scalar_name = '' + integer :: flds_scalar_num = 0 + integer :: flds_scalar_index_nx = 0 + integer :: flds_scalar_index_ny = 0 + integer :: flds_scalar_index_nextsw_cday = 0 + + integer :: fldsToWav_num = 0 + integer :: fldsFrWav_num = 0 + type (fld_list_type) :: fldsToWav(fldsMax) + type (fld_list_type) :: fldsFrWav(fldsMax) + integer, parameter :: gridTofieldMap = 2 ! ungridded dimension is innermost + + type(ESMF_Mesh) :: mesh + integer :: nxg ! global dim i-direction + integer :: nyg ! global dim j-direction + integer :: my_task ! my task in mpi communicator mpicom + integer :: inst_index ! number of current instance (ie. 1) + character(len=16) :: inst_suffix = "" ! char string associated with instance (ie. "_0001" or "") + integer :: logunit ! logging unit number + logical :: mastertask + integer :: dbug = 1 + character(*),parameter :: modName = "(xwav_comp_nuopc)" + character(*),parameter :: u_FILE_u = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine SetServices(gcomp, rc) + + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + character(len=*),parameter :: subname=trim(modName)//':(SetServices) ' + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! the NUOPC gcomp component will register the generic methods + call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! switching to IPD versions + call ESMF_GridCompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, & + userRoutine=ModelInitPhase, phase=0, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set entry point for methods that require specific implementation + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p1"/), & + userRoutine=InitializeAdvertise, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_INITIALIZE, phaseLabelList=(/"IPDv01p3"/), & + userRoutine=InitializeRealize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! attach specializing method(s) + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Advance, specRoutine=ModelAdvance, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_MethodRemove(gcomp, label=model_label_SetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_SetRunClock, specRoutine=ModelSetRunClock, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, specRoutine=ModelFinalize, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine SetServices + + !=============================================================================== + subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + type(ESMF_VM) :: vm + character(CS) :: stdname + integer :: n + integer :: lsize ! local array size + integer :: shrlogunit ! original log unit + character(CL) :: cvalue + character(len=CL) :: logmsg + logical :: isPresent, isSet + character(len=*),parameter :: subname=trim(modName)//':(InitializeAdvertise) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call ESMF_VMGet(vm, localpet=my_task, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + mastertask = (my_task == 0) + + ! determine instance information + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! set logunit and set shr logging to my log file + call set_component_logging(gcomp, mastertask, logunit, shrlogunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Initialize xwav + call dead_read_inparms('wav', inst_suffix, logunit, nxg, nyg) + + ! advertise import and export fields + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + flds_scalar_name = trim(cvalue) + call ESMF_LogWrite(trim(subname)//' flds_scalar_name = '//trim(flds_scalar_name), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldName') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldCount", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue, *) flds_scalar_num + write(logmsg,*) flds_scalar_num + call ESMF_LogWrite(trim(subname)//' flds_scalar_num = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldCount') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNX", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_nx + write(logmsg,*) flds_scalar_index_nx + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_nx = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNX') + endif + + call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldIdxGridNY", value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) flds_scalar_index_ny + write(logmsg,*) flds_scalar_index_ny + call ESMF_LogWrite(trim(subname)//' : flds_scalar_index_ny = '//trim(logmsg), ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call shr_sys_abort(subname//'Need to set attribute ScalarFieldIdxGridNY') + endif + + if (nxg /= 0 .and. nyg /= 0) then + + call fld_list_add(fldsFrWav_num, fldsFrWav, trim(flds_scalar_name)) + call fld_list_add(fldsFrWav_num, fldsFrWav, 'Sw_lamult' ) + call fld_list_add(fldsFrWav_num, fldsFrWav, 'Sw_ustokes' ) + call fld_list_add(fldsFrWav_num, fldsFrWav, 'Sw_vstokes' ) + call fld_list_add(fldsFrWav_num, fldsFrWav, 'Sw_hstokes' ) + + call fld_list_add(fldsToWav_num, fldsToWav, trim(flds_scalar_name)) + call fld_list_add(fldsToWav_num, fldsToWav, 'Sa_u' ) + call fld_list_add(fldsToWav_num, fldsToWav, 'Sa_v' ) + call fld_list_add(fldsToWav_num, fldsToWav, 'Sa_tbot' ) + call fld_list_add(fldsToWav_num, fldsToWav, 'Si_ifrac' ) + call fld_list_add(fldsToWav_num, fldsToWav, 'So_t' ) + call fld_list_add(fldsToWav_num, fldsToWav, 'So_u' ) + call fld_list_add(fldsToWav_num, fldsToWav, 'So_v' ) + call fld_list_add(fldsToWav_num, fldsToWav, 'So_bldepth' ) + + do n = 1,fldsFrWav_num + if (mastertask) write(logunit,*)'Advertising From Xwav ',trim(fldsFrWav(n)%stdname) + call NUOPC_Advertise(exportState, standardName=fldsFrWav(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + + do n = 1,fldsToWav_num + if(mastertask) write(logunit,*)'Advertising To Xwav ',trim(fldsToWav(n)%stdname) + call NUOPC_Advertise(importState, standardName=fldsToWav(n)%stdname, & + TransferOfferGeomObject='will provide', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + enddo + end if + + call ESMF_LogWrite(subname//' done', ESMF_LOGMSG_INFO, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Reset shr logging to original values + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeAdvertise + + !=============================================================================== + subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + type(ESMF_State) :: importState, exportState + type(ESMF_Clock) :: clock + integer, intent(out) :: rc + + ! local variables + integer :: shrlogunit ! original log unit + character(ESMF_MAXSTR) :: cvalue ! config data + character(len=*),parameter :: subname=trim(modName)//':(InitializeRealize) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! Reset shr logging to my log file + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + ! generate the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_wav', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + mesh = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! realize the actively coupled fields, now that a mesh is established + ! NUOPC_Realize "realizes" a previously advertised field in the importState and exportState + ! by replacing the advertised fields with the newly created fields of the same name. + call fld_list_realize( & + state=ExportState, & + fldlist=fldsFrWav, & + numflds=fldsFrWav_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':dwavExport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + call fld_list_realize( & + state=importState, & + fldList=fldsToWav, & + numflds=fldsToWav_num, & + flds_scalar_name=flds_scalar_name, & + flds_scalar_num=flds_scalar_num, & + tag=subname//':dwavImport',& + mesh=mesh, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! Pack export state + call State_SetExport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(nxg),flds_scalar_index_nx, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(dble(nyg),flds_scalar_index_ny, exportState, flds_scalar_name, flds_scalar_num, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! diagnostics + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine InitializeRealize + + !=============================================================================== + subroutine ModelAdvance(gcomp, rc) + + ! input/output variables + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + + ! local variables + type(ESMF_Clock) :: clock + type(ESMF_State) :: exportState + integer :: shrlogunit ! original log unit + character(len=*),parameter :: subname=trim(modName)//':(ModelAdvance) ' + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call memcheck(subname, 3, mastertask) + + call shr_log_getLogUnit (shrlogunit) + call shr_log_setLogUnit (logunit) + + ! Pack export state + call NUOPC_ModelGet(gcomp, modelClock=clock, exportState=exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call state_setexport(exportState, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! diagnostics + if (dbug > 1) then + call State_diagnose(exportState,subname//':ES',rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if ( mastertask) then + call log_clock_advance(clock, 'XWAV', logunit, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + endif + + call shr_log_setLogUnit (shrlogunit) + + end subroutine ModelAdvance + + !=============================================================================== + subroutine state_setexport(exportState, rc) + + ! input/output variables + type(ESMF_State) , intent(inout) :: exportState + integer , intent(out) :: rc + + ! local variables + integer :: nfstart, ubound + integer :: n, nf, nind + real(r8), pointer :: lat(:) + real(r8), pointer :: lon(:) + integer :: spatialDim + integer :: numOwnedElements + real(R8), pointer :: ownedElemCoords(:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_MeshGet(mesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(lon(numownedElements)) + allocate(lat(numownedElements)) + do n = 1,numownedElements + lon(n) = ownedElemCoords(2*n-1) + lat(n) = ownedElemCoords(2*n) + end do + + nfstart = 0 ! for fields that have ubound > 0 + do nf = 2,fldsFrWav_num ! Start from index 2 in order to skip the scalar field + ubound = fldsFrWav(nf)%ungridded_ubound + if (ubound == 0) then + call field_setexport(exportState, trim(fldsFrWav(nf)%stdname), lon, lat, nf=nf, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + nfstart = nfstart + nf + ubound - 1 + do nind = 1,ubound + call field_setexport(exportState, trim(fldsFrWav(nf)%stdname), lon, lat, nf=nfstart+nind-1, & + ungridded_index=nind, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end do + end if + end do + + deallocate(lon) + deallocate(lat) + + end subroutine state_setexport + + !=============================================================================== + + subroutine field_setexport(exportState, fldname, lon, lat, nf, ungridded_index, rc) + + use shr_const_mod , only : pi=>shr_const_pi + + ! intput/otuput variables + type(ESMF_State) , intent(inout) :: exportState + character(len=*) , intent(in) :: fldname + real(r8) , intent(in) :: lon(:) + real(r8) , intent(in) :: lat(:) + integer , intent(in) :: nf + integer, optional , intent(in) :: ungridded_index + integer , intent(out) :: rc + + ! local variables + integer :: i, ncomp + type(ESMF_Field) :: lfield + real(r8), pointer :: data1d(:) + real(r8), pointer :: data2d(:,:) + !-------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_StateGet(exportState, itemName=trim(fldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ncomp = 7 + if (present(ungridded_index)) then + call ESMF_FieldGet(lfield, farrayPtr=data2d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (gridToFieldMap == 1) then + do i = 1,size(data2d, dim=1) + data2d(i,ungridded_index) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + else if (gridToFieldMap == 2) then + do i = 1,size(data2d, dim=2) + data2d(ungridded_index,i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + else + call ESMF_FieldGet(lfield, farrayPtr=data1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do i = 1,size(data1d) + data1d(i) = (nf*100) * cos(pi*lat(i)/180.0_R8) * & + sin((pi*lon(i)/180.0_R8) - (ncomp-1)*(pi/3.0_R8) ) + (ncomp*10.0_R8) + end do + end if + + end subroutine field_setexport + + !=============================================================================== + subroutine ModelFinalize(gcomp, rc) + type(ESMF_GridComp) :: gcomp + integer, intent(out) :: rc + !------------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + if (mastertask) then + write(logunit,*) + write(logunit,*) 'xwav: end of main integration loop' + write(logunit,*) + end if + end subroutine ModelFinalize + +end module wav_comp_nuopc diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index dbf0f84f0..8850d3c70 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -2296,7 +2296,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) call addmrg_to(compocn, 'Sw_lamult', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') end if end if - if (ocn_name == 'mpaso') then + if (ocn_name == 'mpaso' .or. ocn_name == 'mom') then !----------------------------- ! to ocn: !----------------------------- @@ -2326,6 +2326,45 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) !----------------------------- ! to ocn: !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_t0m1') + call addfld_to(compocn, 'Sw_t0m1') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_t0m1', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_t0m1', rc=rc)) then + call addmap_from(compwav, 'Sw_t0m1', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_t0m1', mrg_from=compwav, mrg_fld='Sw_t0m1', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_t01') + call addfld_to(compocn, 'Sw_t01') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_t01', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_t01', rc=rc)) then + call addmap_from(compwav, 'Sw_t01', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_t01', mrg_from=compwav, mrg_fld='Sw_t01', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- + if (phase == 'advertise') then + call addfld_from(compwav, 'Sw_thm') + call addfld_to(compocn, 'Sw_thm') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_thm', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_thm', rc=rc)) then + call addmap_from(compwav, 'Sw_thm', compocn, mapbilnr_nstod, 'one', wav2ocn_map) + call addmrg_to(compocn, 'Sw_thm', mrg_from=compwav, mrg_fld='Sw_thm', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: + !----------------------------- if (phase == 'advertise') then call addfld_from(compwav, 'Sw_ustokes_wavenumber_1') call addfld_to(compocn, 'Sw_ustokes_wavenumber_1') diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index 6a0e2be80..fb8f1f06d 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -1139,6 +1139,18 @@ canonical_units: m description: ocean import - Significant wave height # + - standard_name: Sw_t0m1 + canonical_units: s + description: Wind sea mean wave period (Tm0,-1) + # + - standard_name: Sw_t01 + canonical_units: s + description: Wind sea mean wave period (Tm0,1) + # + - standard_name: Sw_thm + canonical_units: radians + description: Mean wave direction + # - standard_name: Sw_Fp canonical_units: 1 description: ocean import - Peak wave frequency diff --git a/mediator/med_field_info_mod.F90 b/mediator/med_field_info_mod.F90 index 197f0a1b1..9f04ccb0f 100644 --- a/mediator/med_field_info_mod.F90 +++ b/mediator/med_field_info_mod.F90 @@ -5,8 +5,10 @@ module med_field_info_mod ! used to create an ESMF FieldBundle. !----------------------------------------------------------------------------- - use ESMF , only : ESMF_MAXSTR, ESMF_SUCCESS - use ESMF , only : ESMF_Field, ESMF_State, ESMF_AttributeGet, ESMF_StateGet + use ESMF , only : ESMF_MAXSTR, ESMF_SUCCESS, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_Field, ESMF_State, ESMF_StateGet + use ESMF , only : ESMF_Mesh, ESMF_MeshLoc + use ESMF , only : ESMF_FieldCreate, ESMF_FieldGet use med_utils_mod , only : ChkErr => med_utils_ChkErr use shr_log_mod , only : shr_log_error use wtracers_mod , only : wtracers_is_wtracer_field @@ -18,8 +20,11 @@ module med_field_info_mod ! Public methods !----------------------------------------------- - ! Create a single field - public :: med_field_info_create + ! Create a single field_info object from direct specification of values + public :: med_field_info_create_directly + + ! Create a single field_info object from information in an ESMF_Field + public :: med_field_info_create_from_field ! Create an array of field_info objects based on an array of names, where water tracers ! are treated specially (being given an ungridded dimension) @@ -28,6 +33,9 @@ module med_field_info_mod ! Create an array of field_info objects based on the fields in an ESMF State public :: med_field_info_array_from_state + ! Create an ESMF Field (using ESMF_FieldCreate) based on a field_info object + public :: med_field_info_esmf_fieldcreate + !----------------------------------------------- ! Types !----------------------------------------------- @@ -48,8 +56,8 @@ module med_field_info_mod contains !================================================================================ - function med_field_info_create(name, ungridded_lbound, ungridded_ubound, rc) result(field_info) - ! Create a single field + function med_field_info_create_directly(name, ungridded_lbound, ungridded_ubound, rc) result(field_info) + ! Create a single field_info object from direct specification of values ! input/output variables character(len=*), intent(in) :: name @@ -64,7 +72,7 @@ function med_field_info_create(name, ungridded_lbound, ungridded_ubound, rc) res ! local variables integer :: n_ungridded - character(len=*), parameter :: subname = '(med_field_info_create)' + character(len=*), parameter :: subname = '(med_field_info_create_directly)' ! ---------------------------------------------- rc = ESMF_SUCCESS @@ -95,7 +103,61 @@ function med_field_info_create(name, ungridded_lbound, ungridded_ubound, rc) res field_info%n_ungridded = 0 end if - end function med_field_info_create + end function med_field_info_create_directly + + !----------------------------------------------------------------------------- + + function med_field_info_create_from_field(field, name, rc) result(field_info) + ! Create a single field_info object from information in an ESMF_Field + + ! input/output variables + ! We get information other than the name from this ESMF_Field object + type(ESMF_Field), intent(in) :: field + + ! We should be able to get the name from the field, but in all current uses of this + ! function, we already have the name available, so it's easy enough to just pass it in + ! rather than making this function query it again. If future users did not already + ! have the name readily available, we could either change this to optional or remove + ! it entirely and just always get the name from querying the field. + character(len=*), intent(in) :: name + + integer, intent(out) :: rc + type(med_field_info_type) :: field_info ! function result + + ! local variables + integer :: n_ungridded + integer, allocatable :: ungridded_lbound(:) + integer, allocatable :: ungridded_ubound(:) + + character(len=*), parameter :: subname = '(med_field_info_create_from_field)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_FieldGet(field, ungriddedDimCount=n_ungridded, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (n_ungridded == 0) then + field_info = med_field_info_create_directly( & + name=name, & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + allocate(ungridded_lbound(n_ungridded)) + allocate(ungridded_ubound(n_ungridded)) + call ESMF_FieldGet(field, & + ungriddedLBound=ungridded_lbound, ungriddedUBound=ungridded_ubound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + field_info = med_field_info_create_directly( & + name=name, & + ungridded_lbound=ungridded_lbound, & + ungridded_ubound=ungridded_ubound, & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + deallocate(ungridded_lbound) + deallocate(ungridded_ubound) + end if + end function med_field_info_create_from_field !----------------------------------------------------------------------------- @@ -134,7 +196,7 @@ subroutine med_field_info_array_from_names_wtracers(field_names, field_info_arra is_tracer = wtracers_is_wtracer_field(field_names(i)) if (is_tracer) then ! Field is a water tracer; assume a single ungridded dimension - field_info_array(i) = med_field_info_create( & + field_info_array(i) = med_field_info_create_directly( & name=field_names(i), & ungridded_lbound=[1], & ungridded_ubound=[n_tracers], & @@ -142,7 +204,7 @@ subroutine med_field_info_array_from_names_wtracers(field_names, field_info_arra if (chkerr(rc,__LINE__,u_FILE_u)) return else ! Not a water tracer; assume no ungridded dimensions - field_info_array(i) = med_field_info_create( & + field_info_array(i) = med_field_info_create_directly( & name=field_names(i), & rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -168,10 +230,6 @@ subroutine med_field_info_array_from_state(state, field_info_array, rc) integer :: i, n_fields character(ESMF_MAXSTR), allocatable :: field_names(:) type(ESMF_Field) :: field - logical :: is_present - integer :: n_ungridded - integer, allocatable :: ungridded_lbound(:) - integer, allocatable :: ungridded_ubound(:) character(len=*), parameter :: subname = '(med_field_info_array_from_state)' ! ---------------------------------------------- @@ -188,38 +246,48 @@ subroutine med_field_info_array_from_state(state, field_info_array, rc) call ESMF_StateGet(state, itemName=trim(field_names(i)), field=field, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_AttributeGet(field, name="UngriddedUBound", convention="NUOPC", & - purpose="Instance", itemCount=n_ungridded, isPresent=is_present, rc=rc) + field_info_array(i) = med_field_info_create_from_field( & + field=field, & + name=field_names(i), & + rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (.not. is_present) then - n_ungridded = 0 - end if - - if (n_ungridded == 0) then - field_info_array(i) = med_field_info_create( & - name=field_names(i), & - rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - else - allocate(ungridded_lbound(n_ungridded)) - allocate(ungridded_ubound(n_ungridded)) - call ESMF_AttributeGet(field, name="UngriddedLBound", convention="NUOPC", & - purpose="Instance", valueList=ungridded_lbound, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_AttributeGet(field, name="UngriddedUBound", convention="NUOPC", & - purpose="Instance", valueList=ungridded_ubound, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - field_info_array(i) = med_field_info_create( & - name=field_names(i), & - ungridded_lbound=ungridded_lbound, & - ungridded_ubound=ungridded_ubound, & - rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - deallocate(ungridded_lbound) - deallocate(ungridded_ubound) - end if end do end subroutine med_field_info_array_from_state + !----------------------------------------------------------------------------- + + subroutine med_field_info_esmf_fieldcreate(field_info, mesh, meshloc, field, rc) + ! Create an ESMF Field (using ESMF_FieldCreate) based on a field_info object + + ! input/output variables + type(med_field_info_type), intent(in) :: field_info + type(ESMF_Mesh), intent(in) :: mesh + type(ESMF_MeshLoc), intent(in) :: meshloc + type(ESMF_Field), intent(out) :: field + integer, intent(out) :: rc + + ! local variables + character(len=*), parameter :: subname = '(med_field_info_esmf_fieldcreate)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + + if (field_info%n_ungridded > 0) then + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, meshloc=meshloc, & + name=field_info%name, & + ungriddedLbound=field_info%ungridded_lbound, & + ungriddedUbound=field_info%ungridded_ubound, & + gridToFieldMap=[field_info%n_ungridded+1], & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else + field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, meshloc=meshloc, & + name=field_info%name, & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if + + end subroutine med_field_info_esmf_fieldcreate + end module med_field_info_mod diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90 index c86f87c72..2365dce4e 100644 --- a/mediator/med_io_mod.F90 +++ b/mediator/med_io_mod.F90 @@ -729,7 +729,7 @@ subroutine med_io_write_FB(io_file, FB, whead, wdata, nx, ny, nt, & type(ESMF_CoordSys_Flag) :: coordsys integer :: rcode integer :: nf,ns,ng - integer :: k,n + integer :: k,n,n2 integer :: ndims, nelements integer ,target :: dimid2(2) integer ,target :: dimid3(3) @@ -754,15 +754,22 @@ subroutine med_io_write_FB(io_file, FB, whead, wdata, nx, ny, nt, & integer, pointer :: Dof(:) real(r8), pointer :: fldptr1(:) real(r8), pointer :: fldptr2(:,:) + real(r8), pointer :: fldptr3(:,:,:) real(r8), allocatable :: ownedElemCoords(:), ownedElemCoords_x(:), ownedElemCoords_y(:) character(CS) :: cnumber + character(CS) :: cnumber2 character(CL) :: tmpstr type(ESMF_Field) :: lfield integer :: rank - integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields - integer :: gridToFieldMap(1) ! currently the size must equal 1 for rank 2 fields logical :: tiles character(CL), allocatable :: fieldNameList(:) + + ! For a single ungridded dimension, there will be 1 element in ungriddedUBound and 1 + ! element in gridToFieldMap; for two ungridded dimensions, there will be 2 elements in + ! ungriddedUBound but still 1 element in gridToFieldMap. + integer :: ungriddedUBound(2) + integer :: gridToFieldMap(1) + character(*),parameter :: subName = '(med_io_write_FB) ' !------------------------------------------------------------------------------- @@ -935,12 +942,47 @@ subroutine med_io_write_FB(io_file, FB, whead, wdata, nx, ny, nt, & ! TODO (mvertens, 2019-03-13): this is a temporary mod to NOT write hgt if (trim(itemc) /= "hgt") then - if (rank == 2) then + if (rank == 3) then call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return write(cnumber,'(i0)') ungriddedUbound(1) + write(cnumber2,'(i0)') ungriddedUbound(2) call ESMF_LogWrite(trim(subname)//':'//'field '//trim(itemc)// & - ' has an griddedUBound of '//trim(cnumber), ESMF_LOGMSG_INFO) + ' has an ungriddedUBound of '//trim(cnumber)//' x '//trim(cnumber2), ESMF_LOGMSG_INFO) + + ! Create a new output variable for each element of the 2 ungridded dimensions + do n2 = 1,ungriddedUBound(2) + do n = 1,ungriddedUBound(1) + write(cnumber,'(i0)') n + write(cnumber2,'(i0)') n2 + name1 = trim(lpre)//'_'//trim(itemc)//trim(cnumber)//'_'//trim(cnumber2) + call ESMF_LogWrite(trim(subname)//': defining '//trim(name1), ESMF_LOGMSG_INFO) + if (luse_float) then + rcode = pio_def_var(io_file, trim(name1), PIO_REAL, dimid, varid) + rcode = pio_put_att(io_file, varid,"_FillValue",real(lfillvalue,r4)) + else + rcode = pio_def_var(io_file, trim(name1), PIO_DOUBLE, dimid, varid) + rcode = pio_put_att(io_file,varid,"_FillValue",lfillvalue) + end if + if (NUOPC_FieldDictionaryHasEntry(trim(itemc))) then + call NUOPC_FieldDictionaryGetEntry(itemc, canonicalUnits=cunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + rcode = pio_put_att(io_file, varid, "units", trim(cunit)) + end if + rcode = pio_put_att(io_file, varid, "standard_name", trim(name1)) + if (present(tavg)) then + if (tavg) then + rcode = pio_put_att(io_file, varid, "cell_methods", "time: mean") + endif + endif + end do + end do + else if (rank == 2) then + call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + write(cnumber,'(i0)') ungriddedUbound(1) + call ESMF_LogWrite(trim(subname)//':'//'field '//trim(itemc)// & + ' has an ungriddedUBound of '//trim(cnumber), ESMF_LOGMSG_INFO) ! Create a new output variable for each element of the undistributed dimension do n = 1,ungriddedUBound(1) @@ -958,7 +1000,7 @@ subroutine med_io_write_FB(io_file, FB, whead, wdata, nx, ny, nt, & if (NUOPC_FieldDictionaryHasEntry(trim(itemc))) then call NUOPC_FieldDictionaryGetEntry(itemc, canonicalUnits=cunit, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - rcode = pio_put_att(io_file, varid, "units" , trim(cunit)) + rcode = pio_put_att(io_file, varid, "units", trim(cunit)) end if rcode = pio_put_att(io_file, varid, "standard_name", trim(name1)) if (present(tavg)) then @@ -968,15 +1010,15 @@ subroutine med_io_write_FB(io_file, FB, whead, wdata, nx, ny, nt, & endif end if end do - else + else if (rank == 1) then name1 = trim(lpre)//'_'//trim(itemc) - call ESMF_LogWrite(trim(subname)//':'//trim(itemc)//':'//trim(name1),ESMF_LOGMSG_INFO) + call ESMF_LogWrite(trim(subname)//': defining '//trim(name1), ESMF_LOGMSG_INFO) if (luse_float) then rcode = pio_def_var(io_file, trim(name1), PIO_REAL, dimid, varid) - rcode = pio_put_att(io_file, varid, "_FillValue", real(lfillvalue, r4)) + rcode = pio_put_att(io_file, varid,"_FillValue",real(lfillvalue,r4)) else rcode = pio_def_var(io_file, trim(name1), PIO_DOUBLE, dimid, varid) - rcode = pio_put_att(io_file, varid, "_FillValue", lfillvalue) + rcode = pio_put_att(io_file,varid,"_FillValue",lfillvalue) end if if (NUOPC_FieldDictionaryHasEntry(trim(itemc))) then call NUOPC_FieldDictionaryGetEntry(itemc, canonicalUnits=cunit, rc=rc) @@ -988,7 +1030,10 @@ subroutine med_io_write_FB(io_file, FB, whead, wdata, nx, ny, nt, & if (tavg) then rcode = pio_put_att(io_file, varid, "cell_methods", "time: mean") endif - end if + endif + else + call shr_log_error(subname//' ERROR: unhandled rank', line=__LINE__, file=u_FILE_u, rc=rc) + return end if end if end do @@ -1039,12 +1084,43 @@ subroutine med_io_write_FB(io_file, FB, whead, wdata, nx, ny, nt, & end if call FB_getFldPtr(FB, itemc, & - fldptr1=fldptr1, fldptr2=fldptr2, rank=rank, rc=rc) + fldptr1=fldptr1, fldptr2=fldptr2, fldptr3=fldptr3, rank=rank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! TODO (mvertens, 2019-03-13): this is a temporary mod to NOT write hgt if (trim(itemc) /= "hgt") then - if (rank == 2) then + if (rank == 3) then + + ! Determine the size of the ungridded dimensions and the index where the distributed dimension is located + call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, gridToFieldMap=gridToFieldMap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (gridToFieldMap(1) /= 3) then + call shr_log_error( & + subname//' ERROR: For rank-3 fields, currently only gridToFieldMap(1)==3 is supported', & + line=__LINE__, file=u_FILE_u, rc=rc) + return + end if + + ! Output for each combination of ungriddedUbound indices + do n2 = 1,ungriddedUBound(2) + do n = 1,ungriddedUBound(1) + write(cnumber,'(i0)') n + write(cnumber2,'(i0)') n2 + name1 = trim(lpre)//'_'//trim(itemc)//trim(cnumber)//'_'//trim(cnumber2) + rcode = pio_inq_varid(io_file, trim(name1), varid) + call pio_setframe(io_file,varid,frame) + + if (luse_float) then + call pio_write_darray(io_file, varid, iodesc, real(fldptr3(n,n2,:),r4), rcode, fillval=real(lfillvalue,r4)) + else + call pio_write_darray(io_file, varid, iodesc, fldptr3(n,n2,:), rcode, fillval=lfillvalue) + end if + end do + end do + else if (rank == 2) then ! Determine the size of the ungridded dimension and the index where the undistributed dimension is located call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc) @@ -1489,7 +1565,7 @@ subroutine med_io_read_FB(filename, vm, FB, pre, frame, rc) type(ESMF_Field) :: lfield integer :: rcode integer :: nf - integer :: k,n,l + integer :: k,n,n2,l type(file_desc_t) :: pioid type(var_desc_t) :: varid type(io_desc_t) :: iodesc @@ -1500,11 +1576,18 @@ subroutine med_io_read_FB(filename, vm, FB, pre, frame, rc) integer :: rank, lsize real(r8), pointer :: fldptr1(:), fldptr1_tmp(:) real(r8), pointer :: fldptr2(:,:) + real(r8), pointer :: fldptr3(:,:,:) character(CL) :: tmpstr character(len=16) :: cnumber + character(len=16) :: cnumber2 integer(kind=Pio_Offset_Kind) :: lframe - integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fieldds - integer :: gridToFieldMap(1) ! currently the size must equal 1 for rank 2 fieldds + + ! For a single ungridded dimension, there will be 1 element in ungriddedUBound and 1 + ! element in gridToFieldMap; for two ungridded dimensions, there will be 2 elements in + ! ungriddedUBound but still 1 element in gridToFieldMap. + integer :: ungriddedUBound(2) + integer :: gridToFieldMap(1) + character(*),parameter :: subName = '(med_io_read_FB) ' !------------------------------------------------------------------------------- rc = ESMF_Success @@ -1569,7 +1652,9 @@ subroutine med_io_read_FB(filename, vm, FB, pre, frame, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldGet(lfield, rank=rank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (rank == 2) then + if (rank == 3) then + name1 = trim(lpre)//'_'//trim(itemc)//'1_1' + else if (rank == 2) then name1 = trim(lpre)//'_'//trim(itemc)//'1' else if (rank == 1) then name1 = trim(lpre)//'_'//trim(itemc) @@ -1582,12 +1667,61 @@ subroutine med_io_read_FB(filename, vm, FB, pre, frame, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Get pointer to field bundle field - ! Field bundle might be 2d or 1d - but field on mediator history or restart file will always be 1d + ! Field bundle might be 3d, 2d or 1d - but field on mediator history or restart file will always be 1d call FB_getFldPtr(FB, itemc, & - fldptr1=fldptr1, fldptr2=fldptr2, rank=rank, rc=rc) + fldptr1=fldptr1, fldptr2=fldptr2, fldptr3=fldptr3, rank=rank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (rank == 2) then + if (rank == 3) then + + ! Determine the size of the ungridded dimensions and the + ! index where the distributed dimension is located + call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, gridToFieldMap=gridToFieldMap, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + if (gridToFieldMap(1) /= 3) then + call shr_log_error( & + subname//' ERROR: For rank-3 fields, currently only gridToFieldMap(1)==3 is supported', & + line=__LINE__, file=u_FILE_u, rc=rc) + return + end if + + lsize = size(fldptr3, dim=3) + allocate(fldptr1_tmp(lsize)) + + do n2 = 1,ungriddedUBound(2) + do n = 1,ungriddedUBound(1) + ! Create a name for the 1d field on the mediator history or restart file based on the + ! ungridded dimension indices of the field bundle 3d field + write(cnumber,'(i0)') n + write(cnumber2,'(i0)') n2 + name1 = trim(lpre)//'_'//trim(itemc)//trim(cnumber)//'_'//trim(cnumber2) + + rcode = pio_inq_varid(pioid, trim(name1), varid) + if (rcode == pio_noerr) then + call ESMF_LogWrite(trim(subname)//' read field '//trim(name1), ESMF_LOGMSG_INFO) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call pio_setframe(pioid, varid, lframe) + call pio_read_darray(pioid, varid, iodesc, fldptr1_tmp, rcode) + rcode = pio_get_att(pioid, varid, "_FillValue", lfillvalue) + if (rcode /= pio_noerr) then + lfillvalue = fillvalue + endif + do l = 1,size(fldptr1_tmp) + if (fldptr1_tmp(l) == lfillvalue) fldptr1_tmp(l) = 0.0_r8 + enddo + else + fldptr1_tmp = 0.0_r8 + endif + fldptr3(n,n2,:) = fldptr1_tmp(:) + end do + end do + + deallocate(fldptr1_tmp) + + else if (rank == 2) then ! Determine the size of the ungridded dimension and the ! index where the undistributed dimension is located diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index daacdd4af..7dc27ace6 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -1301,6 +1301,9 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, ! local variables integer :: n + real(r8), pointer :: data_src3d(:,:,:) + real(r8), pointer :: data_dst3d(:,:,:) + real(r8), pointer :: data_srctmp3d(:,:,:) real(r8), pointer :: data_src2d(:,:) real(r8), pointer :: data_dst2d(:,:) real(r8), pointer :: data_srctmp2d(:,:) @@ -1309,7 +1312,7 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, real(r8), pointer :: data_srctmp1d(:) real(r8), pointer :: data_normsrc(:) real(r8), pointer :: data_normdst(:) - integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields + integer :: fieldrank integer :: lsize_src integer :: lsize_dst character(len=*), parameter :: subname=' (med_map_mod:med_map_field_normalized) ' @@ -1318,19 +1321,24 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, call t_startf('MED:'//subname) rc = ESMF_SUCCESS - ! get a pointer (data_fracsrc) to the normalization array - ! get a pointer (data_src) to source field data in FBSrc - ! copy data_src to data_srctmp - - ! normalize data_src by data_fracsrc - call ESMF_FieldGet(field_normsrc, farrayPtr=data_normsrc, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return lsize_src = size(data_normsrc) - call ESMF_FieldGet(field_src, ungriddedUBound=ungriddedUBound, rc=rc) + call ESMF_FieldGet(field_src, rank=fieldrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (ungriddedUbound(1) > 0) then + + ! Pre-normalization: multiply source data by the normalization field, + ! saving a copy so the source can be restored after regridding. + if (fieldrank == 3) then + call ESMF_FieldGet(field_src, farrayPtr=data_src3d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + allocate(data_srctmp3d(size(data_src3d,dim=1), size(data_src3d,dim=2), lsize_src)) + data_srctmp3d(:,:,:) = data_src3d(:,:,:) + do n = 1,lsize_src + data_src3d(:,:,n) = data_src3d(:,:,n) * data_normsrc(n) + end do + else if (fieldrank == 2) then call ESMF_FieldGet(field_src, farrayPtr=data_src2d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return allocate(data_srctmp2d(size(data_src2d,dim=1), lsize_src)) @@ -1338,7 +1346,7 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, do n = 1,lsize_src data_src2d(:,n) = data_src2d(:,n) * data_normsrc(n) end do - else + else if (fieldrank == 1) then call ESMF_FieldGet(field_src, farrayPtr=data_src1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return allocate(data_srctmp1d(lsize_src)) @@ -1346,32 +1354,52 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, do n = 1,lsize_src data_src1d(n) = data_src1d(n) * data_normsrc(n) end do + else + call shr_log_error(subname//' ERROR: only ranks 1, 2, and 3 are supported', & + line=__LINE__, file=u_FILE_u, rc=rc) + return end if - ! regrid normalized packed source field + ! Regrid normalized source field to destination call med_map_field (field_src=field_src, field_dst=field_dst, routehandles=routehandles, maptype=maptype, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - ! restore original value to packed source field - if (ungriddedUbound(1) > 0) then + ! Restore original values to source field + if (fieldrank == 3) then + data_src3d(:,:,:) = data_srctmp3d(:,:,:) + deallocate(data_srctmp3d) + else if (fieldrank == 2) then data_src2d(:,:) = data_srctmp2d(:,:) deallocate(data_srctmp2d) - else + else if (fieldrank == 1) then data_src1d(:) = data_srctmp1d(:) deallocate(data_srctmp1d) + else + call shr_log_error(subname//' ERROR: only ranks 1, 2, and 3 are supported', & + line=__LINE__, file=u_FILE_u, rc=rc) + return end if - ! regrid normalization field from source to destination + ! Regrid normalization field from source to destination call med_map_field(field_src=field_normsrc, field_dst=field_normdst, routehandles=routehandles, maptype=maptype, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - ! get pointer to mapped fraction and normalize - ! destination mapped values by the reciprocal of the mapped fraction + ! Post-normalization: divide destination data by the mapped normalization field call ESMF_FieldGet(field_normdst, farrayPtr=data_normdst, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return lsize_dst = size(data_normdst) - if (ungriddedUbound(1) > 0) then + if (fieldrank == 3) then + call ESMF_FieldGet(field_dst, farrayPtr=data_dst3d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + do n = 1,lsize_dst + if (data_normdst(n) == 0.0_r8) then + data_dst3d(:,:,n) = 0.0_r8 + else + data_dst3d(:,:,n) = data_dst3d(:,:,n)/data_normdst(n) + end if + end do + else if (fieldrank == 2) then call ESMF_FieldGet(field_dst, farrayPtr=data_dst2d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return do n = 1,lsize_dst @@ -1381,7 +1409,7 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, data_dst2d(:,n) = data_dst2d(:,n)/data_normdst(n) end if end do - else + else if (fieldrank == 1) then call ESMF_FieldGet(field_dst, farrayPtr=data_dst1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return do n = 1,lsize_dst @@ -1391,6 +1419,10 @@ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, data_dst1d(n) = data_dst1d(n)/data_normdst(n) end if end do + else + call shr_log_error(subname//' ERROR: only ranks 1, 2, and 3 are supported', & + line=__LINE__, file=u_FILE_u, rc=rc) + return end if call t_stopf('MED:'//subname) diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90 index 26dfa773b..5ab81a490 100644 --- a/mediator/med_methods_mod.F90 +++ b/mediator/med_methods_mod.F90 @@ -15,19 +15,21 @@ module med_methods_mod use med_constants_mod , only : czero => med_constants_czero use med_constants_mod , only : spval_init => med_constants_spval_init use med_utils_mod , only : ChkErr => med_utils_ChkErr - use med_field_info_mod , only : med_field_info_type + use med_field_info_mod , only : med_field_info_type, med_field_info_esmf_fieldcreate use shr_log_mod , only : shr_log_error implicit none private interface med_methods_FieldPtr_compare ; module procedure & med_methods_FieldPtr_compare1, & - med_methods_FieldPtr_compare2 + med_methods_FieldPtr_compare2, & + med_methods_FieldPtr_compare3 end interface interface med_methods_check_for_nans module procedure med_methods_check_for_nans_1d module procedure med_methods_check_for_nans_2d + module procedure med_methods_check_for_nans_3d end interface med_methods_check_for_nans ! used/reused in module @@ -53,8 +55,9 @@ module med_methods_mod public med_methods_FB_getNumflds public med_methods_FB_Field_diagnose public med_methods_FB_GeomPrint - public med_methods_FB_getdata2d public med_methods_FB_getdata1d + public med_methods_FB_getdata2d + public med_methods_FB_getdata3d public med_methods_FB_getmesh public med_methods_FB_check_for_nans @@ -67,6 +70,7 @@ module med_methods_mod public med_methods_Field_getdata1d public med_methods_Field_getdata2d + public med_methods_Field_getdata3d public med_methods_Field_diagnose public med_methods_Field_GeomPrint public med_methods_FieldPtr_compare @@ -113,10 +117,11 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r integer :: lrank integer :: fieldCount integer :: ungriddedCount - integer :: ungriddedLBound(1) - integer :: ungriddedUBound(1) + integer :: ungriddedLBound(2) + integer :: ungriddedUBound(2) real(R8), pointer :: dataptr1d(:) real(R8), pointer :: dataptr2d(:,:) + real(R8), pointer :: dataptr3d(:,:,:) character(ESMF_MAXSTR), allocatable :: lfieldNameList(:) character(len=*), parameter :: subname='(med_methods_FB_init_pointer)' ! ---------------------------------------------- @@ -161,15 +166,15 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r call ESMF_FieldGet(lfield, rank=lrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (lrank == 2) then + if (lrank == 3) then ! determine ungridded lower and upper bounds for lfield call ESMF_AttributeGet(lfield, name="UngriddedLBound", convention="NUOPC", & purpose="Instance", itemCount=ungriddedCount, isPresent=isPresent, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (ungriddedCount /= 1) then + if (ungriddedCount /= 2) then call shr_log_error(trim(subname)//": ERROR ungriddedCount for "// & - trim(lfieldnamelist(n))//" must be 1 if rank is 2 ", rc=rc) + trim(lfieldnamelist(n))//" must be 2 if rank is 3 ", rc=rc) return end if @@ -181,6 +186,36 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r purpose="Instance", valueList=ungriddedUBound, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + ! get 3d pointer for field + call ESMF_FieldGet(lfield, farrayptr=dataptr3d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! create new field with two ungridded dimensions + newfield = ESMF_FieldCreate(lmesh, dataptr3d, ESMF_INDEX_DELOCAL, & + meshloc=meshloc, name=lfieldNameList(n), & + ungriddedLbound=ungriddedLbound, ungriddedUbound=ungriddedUbound, gridToFieldMap=(/3/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + else if (lrank == 2) then + + ! determine ungridded lower and upper bounds for lfield + call ESMF_AttributeGet(lfield, name="UngriddedLBound", convention="NUOPC", & + purpose="Instance", itemCount=ungriddedCount, isPresent=isPresent, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (ungriddedCount /= 1) then + call shr_log_error(trim(subname)//": ERROR ungriddedCount for "// & + trim(lfieldnamelist(n))//" must be 1 if rank is 2 ", rc=rc) + return + end if + + ! set ungridded dimensions for field + call ESMF_AttributeGet(lfield, name="UngriddedLBound", convention="NUOPC", & + purpose="Instance", valueList=ungriddedLBound(1:1), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_AttributeGet(lfield, name="UngriddedUBound", convention="NUOPC", & + purpose="Instance", valueList=ungriddedUBound(1:1), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + ! get 2d pointer for field call ESMF_FieldGet(lfield, farrayptr=dataptr2d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return @@ -188,7 +223,7 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r ! create new field with an ungridded dimension newfield = ESMF_FieldCreate(lmesh, dataptr2d, ESMF_INDEX_DELOCAL, & meshloc=meshloc, name=lfieldNameList(n), & - ungriddedLbound=ungriddedLbound, ungriddedUbound=ungriddedUbound, gridToFieldMap=(/2/), rc=rc) + ungriddedLbound=ungriddedLbound(1:1), ungriddedUbound=ungriddedUbound(1:1), gridToFieldMap=(/2/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return else if (lrank == 1) then @@ -203,7 +238,7 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r if (chkerr(rc,__LINE__,u_FILE_u)) return else - call shr_log_error(trim(subname)//": ERROR only rank1 and rank2 are supported for rank of fields ", rc=rc) + call shr_log_error(trim(subname)//": ERROR only rank1, rank2, and rank3 are supported for rank of fields ", rc=rc) return end if @@ -237,7 +272,7 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, field_info_array, FBgeom use ESMF , only : ESMF_Field, ESMF_FieldBundle, ESMF_FieldBundleCreate, ESMF_FieldBundleGet use ESMF , only : ESMF_State, ESMF_Mesh, ESMF_StaggerLoc, ESMF_MeshLoc use ESMF , only : ESMF_StateGet, ESMF_FieldGet, ESMF_FieldBundleAdd, ESMF_FieldCreate - use ESMF , only : ESMF_TYPEKIND_R8, ESMF_FIELDSTATUS_EMPTY, ESMF_AttributeGet + use ESMF , only : ESMF_FIELDSTATUS_EMPTY, ESMF_AttributeGet ! input/output variables type(ESMF_FieldBundle), intent(inout) :: FBout ! output field bundle @@ -366,20 +401,8 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, field_info_array, FBgeom end if ! Create the field - if (field_info_array(n)%n_ungridded > 0) then - field = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, meshloc=meshloc, & - name=field_info_array(n)%name, & - ungriddedLbound=field_info_array(n)%ungridded_lbound, & - ungriddedUbound=field_info_array(n)%ungridded_ubound, & - gridToFieldMap=[field_info_array(n)%n_ungridded+1], & - rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - else - field = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, meshloc=meshloc, & - name=field_info_array(n)%name, & - rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end if + call med_field_info_esmf_fieldcreate(field_info_array(n), lmesh, meshloc, field, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! Add the created field to field bundle FBout if (dbug_flag > 1) then @@ -595,6 +618,7 @@ subroutine med_methods_FB_reset(FB, value, rc) integer :: lrank real(R8), pointer :: fldptr1(:) real(R8), pointer :: fldptr2(:,:) + real(R8), pointer :: fldptr3(:,:,:) character(len=*),parameter :: subname='(med_methods_FB_reset)' ! ---------------------------------------------- @@ -621,7 +645,7 @@ subroutine med_methods_FB_reset(FB, value, rc) do n = 1, fieldCount call ESMF_FieldBundleGet(FB, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, fldptr3=fldptr3, rank=lrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lrank == 0) then @@ -630,6 +654,8 @@ subroutine med_methods_FB_reset(FB, value, rc) fldptr1 = lvalue elseif (lrank == 2) then fldptr2 = lvalue + elseif (lrank == 3) then + fldptr3 = lvalue else call shr_log_error(trim(subname)//": ERROR in rank "//trim(lfieldnamelist(n)), & line=__LINE__, file=u_FILE_u, rc=rc) @@ -672,6 +698,7 @@ subroutine med_methods_State_reset(State, value, rc) integer :: lrank real(R8), pointer :: fldptr1(:) real(R8), pointer :: fldptr2(:,:) + real(R8), pointer :: fldptr3(:,:,:) character(len=*),parameter :: subname='(med_methods_State_reset)' ! ---------------------------------------------- @@ -693,7 +720,7 @@ subroutine med_methods_State_reset(State, value, rc) do n = 1, fieldCount call ESMF_StateGet(State, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, fldptr3=fldptr3, rank=lrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lrank == 0) then ! no local data @@ -701,6 +728,8 @@ subroutine med_methods_State_reset(State, value, rc) fldptr1 = lvalue elseif (lrank == 2) then fldptr2 = lvalue + elseif (lrank == 3) then + fldptr3 = lvalue else call shr_log_error(trim(subname)//": ERROR in rank "//trim(lfieldnamelist(n)), & line=__LINE__, file=u_FILE_u, rc=rc) @@ -720,7 +749,8 @@ end subroutine med_methods_State_reset subroutine med_methods_FB_average(FB, count, rc) ! ---------------------------------------------- - ! Set all fields to zero in FB + ! Divide all fields in FB by count + ! If count is 0, nothing is done ! ---------------------------------------------- use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field @@ -731,11 +761,12 @@ subroutine med_methods_FB_average(FB, count, rc) integer , intent(out) :: rc ! local variables - integer :: i,j,n + integer :: i,j,k,n integer :: fieldCount, lrank character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) real(R8), pointer :: dataPtr1(:) real(R8), pointer :: dataPtr2(:,:) + real(R8), pointer :: dataPtr3(:,:,:) type(ESMF_Field) :: lfield character(len=*),parameter :: subname='(med_methods_FB_average)' ! ---------------------------------------------- @@ -764,7 +795,7 @@ subroutine med_methods_FB_average(FB, count, rc) do n = 1, fieldCount call ESMF_FieldBundleGet(FB, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1, fldptr2=dataptr2, rank=lrank, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1, fldptr2=dataptr2, fldptr3=dataptr3, rank=lrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lrank == 0) then @@ -779,6 +810,14 @@ subroutine med_methods_FB_average(FB, count, rc) dataptr2(i,j) = dataptr2(i,j) / real(count, R8) enddo enddo + elseif (lrank == 3) then + do k=lbound(dataptr3,3),ubound(dataptr3,3) + do j=lbound(dataptr3,2),ubound(dataptr3,2) + do i=lbound(dataptr3,1),ubound(dataptr3,1) + dataptr3(i,j,k) = dataptr3(i,j,k) / real(count, R8) + enddo + enddo + enddo else call shr_log_error(trim(subname)//": ERROR rank not supported ", rc=rc) return @@ -814,6 +853,7 @@ subroutine med_methods_FB_diagnose(FB, string, rc) character(len=CL) :: lstring real(R8), pointer :: dataPtr1d(:) real(R8), pointer :: dataPtr2d(:,:) + real(R8), pointer :: dataPtr3d(:,:,:) type(ESMF_Field) :: lfield character(len=*), parameter :: subname='(med_methods_FB_diagnose)' ! ---------------------------------------------- @@ -839,7 +879,7 @@ subroutine med_methods_FB_diagnose(FB, string, rc) do n = 1, fieldCount call ESMF_FieldBundleGet(FB, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1d, fldptr2=dataptr2d, rank=lrank, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1d, fldptr2=dataptr2d, fldptr3=dataptr3d, rank=lrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lrank == 0) then @@ -862,6 +902,15 @@ subroutine med_methods_FB_diagnose(FB, string, rc) " no data" endif + elseif (lrank == 3) then + if (size(dataPtr3d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n))//' ', & + minval(dataPtr3d), maxval(dataPtr3d), sum(dataPtr3d), size(dataPtr3d) + else + write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), & + " no data" + endif + else call shr_log_error(trim(subname)//": ERROR rank not supported ", rc=rc) return @@ -1012,6 +1061,7 @@ subroutine med_methods_State_diagnose(State, string, rc) character(len=CS) :: lstring real(R8), pointer :: dataPtr1d(:) real(R8), pointer :: dataPtr2d(:,:) + real(R8), pointer :: dataPtr3d(:,:,:) type(ESMF_Field) :: lfield character(len=*),parameter :: subname='(med_methods_State_diagnose)' ! ---------------------------------------------- @@ -1033,7 +1083,7 @@ subroutine med_methods_State_diagnose(State, string, rc) do n = 1, fieldCount call ESMF_StateGet(State, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1d, fldptr2=dataptr2d, rank=lrank, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1d, fldptr2=dataptr2d, fldptr3=dataptr3d, rank=lrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lrank == 0) then @@ -1054,6 +1104,14 @@ subroutine med_methods_State_diagnose(State, string, rc) write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), & " no data" endif + elseif (lrank == 3) then + if (size(dataPtr3d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr3d), maxval(dataPtr3d), sum(dataPtr3d), size(dataPtr3d) + else + write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), & + " no data" + endif else call shr_log_error(trim(subname)//": ERROR rank not supported ", rc=rc) return @@ -1091,8 +1149,9 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc) character(len=CS) :: lstring real(R8), pointer :: dataPtr1d(:) real(R8), pointer :: dataPtr2d(:,:) + real(R8), pointer :: dataPtr3d(:,:,:) type(ESMF_Field) :: lfield - integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields + integer :: fieldrank character(len=*),parameter :: subname='(med_methods_FB_Field_diagnose)' ! ---------------------------------------------- @@ -1108,9 +1167,18 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc) call ESMF_FieldBundleGet(FB, fieldName=fieldname, field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) + call ESMF_FieldGet(lfield, rank=fieldrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (ungriddedUBound(1) > 0) then + if (fieldrank == 3) then + call ESMF_FieldGet(lfield, farrayptr=dataptr3d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (size(dataptr3d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname), & + minval(dataPtr3d), maxval(dataPtr3d), sum(dataPtr3d), size(dataPtr3d) + else + write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname)," no data" + endif + elseif (fieldrank == 2) then call ESMF_FieldGet(lfield, farrayptr=dataptr2d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (size(dataptr2d) > 0) then @@ -1119,7 +1187,7 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc) else write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname)," no data" endif - else + elseif (fieldrank == 1) then call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (size(dataPtr1d) > 0) then @@ -1128,6 +1196,10 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc) else write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname)," no data" endif + else + call shr_log_error(subname//": ERROR: unhandled field rank", & + line=__LINE__, file=u_FILE_u, rc=rc) + return end if call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) @@ -1158,6 +1230,7 @@ subroutine med_methods_Field_diagnose(field, fieldname, string, rc) character(len=CS) :: lstring real(R8), pointer :: dataPtr1d(:) real(R8), pointer :: dataPtr2d(:,:) + real(R8), pointer :: dataPtr3d(:,:,:) character(len=*),parameter :: subname='(med_methods_Field_diagnose)' ! ---------------------------------------------- @@ -1194,6 +1267,15 @@ subroutine med_methods_Field_diagnose(field, fieldname, string, rc) else write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname)," no data" endif + elseif (lrank == 3) then + call ESMF_FieldGet(field, farrayPtr=dataPtr3d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + if (size(dataPtr3d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname), & + minval(dataPtr3d), maxval(dataPtr3d), sum(dataPtr3d), size(dataPtr3d) + else + write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname)," no data" + endif else call shr_log_error(trim(subname)//": ERROR rank not supported ", rc=rc) return @@ -1240,7 +1322,9 @@ subroutine med_methods_FB_accum(FBout, FBin, copy, rc) ! ---------------------------------------------- ! Accumulate common field names from FBin to FBout - ! If copy is passed in and true, the this is a copy + ! + ! If copy is passed in and true, then data is copied from FBin to FBout, overwriting + ! values in FBout, rather than accumulating ! ---------------------------------------------- use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field @@ -1252,7 +1336,7 @@ subroutine med_methods_FB_accum(FBout, FBin, copy, rc) integer , intent(out) :: rc ! local variables - integer :: i,j,n + integer :: i,j,k,n integer :: fieldCount, lranki, lranko character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) logical :: exists @@ -1261,6 +1345,8 @@ subroutine med_methods_FB_accum(FBout, FBin, copy, rc) real(R8), pointer :: dataPtro1(:) real(R8), pointer :: dataPtri2(:,:) real(R8), pointer :: dataPtro2(:,:) + real(R8), pointer :: dataPtri3(:,:,:) + real(R8), pointer :: dataPtro3(:,:,:) type(ESMF_Field) :: lfield character(len=*), parameter :: subname='(med_methods_FB_accum)' ! ---------------------------------------------- @@ -1287,12 +1373,12 @@ subroutine med_methods_FB_accum(FBout, FBin, copy, rc) if (exists) then call ESMF_FieldBundleGet(FBin, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptri1, fldptr2=dataptri2, rank=lranki, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptri1, fldptr2=dataptri2, fldptr3=dataptri3, rank=lranki, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldBundleGet(FBout, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptro1, fldptr2=dataptro2, rank=lranko, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptro1, fldptr2=dataptro2, fldptr3=dataptro3, rank=lranko, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lranki == 0 .and. lranko == 0) then @@ -1336,6 +1422,31 @@ subroutine med_methods_FB_accum(FBout, FBin, copy, rc) enddo endif + elseif (lranki == 3 .and. lranko == 3) then + + if (.not.med_methods_FieldPtr_Compare(dataPtro3, dataPtri3, subname, rc)) then + call shr_log_error(trim(subname)//": ERROR in dataPtr3 size ", rc=rc) + return + endif + + if (lcopy) then + do k=lbound(dataPtri3,3),ubound(dataPtri3,3) + do j=lbound(dataPtri3,2),ubound(dataPtri3,2) + do i=lbound(dataPtri3,1),ubound(dataPtri3,1) + dataPtro3(i,j,k) = dataPtri3(i,j,k) + enddo + enddo + enddo + else + do k=lbound(dataPtri3,3),ubound(dataPtri3,3) + do j=lbound(dataPtri3,2),ubound(dataPtri3,2) + do i=lbound(dataPtri3,1),ubound(dataPtri3,1) + dataPtro3(i,j,k) = dataPtro3(i,j,k) + dataPtri3(i,j,k) + enddo + enddo + enddo + endif + else write(msgString,'(a,2i8)') trim(subname)//": ranki, ranko = ",lranki,lranko call shr_log_error(trim(subname)//": ERROR ranki ranko not supported "//trim(msgstring)//"\n"//trim(lfieldnamelist(n)), rc=rc) @@ -1404,12 +1515,12 @@ end function med_methods_FB_FldChk !----------------------------------------------------------------------------- - subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, rank, abort, rc) + subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, fldptr3, rank, abort, rc) ! ---------------------------------------------- - ! for a field, determine rank and return fldptr1 or fldptr2 + ! for a field, determine rank and return fldptr1, fldptr2, or fldptr3 ! abort is true by default and will abort if fldptr is not yet allocated in field - ! rank returns 0, 1, or 2. 0 means fldptr not allocated and abort=false + ! rank returns 0, 1, 2, or 3. 0 means fldptr not allocated and abort=false ! ---------------------------------------------- use ESMF , only : ESMF_Field,ESMF_Mesh, ESMF_FieldGet, ESMF_MeshGet @@ -1420,6 +1531,7 @@ subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, rank, abort, rc) type(ESMF_Field) , intent(in) :: field real(R8), pointer , intent(inout), optional :: fldptr1(:) real(R8), pointer , intent(inout), optional :: fldptr2(:,:) + real(R8), pointer , intent(inout), optional :: fldptr3(:,:,:) integer , intent(out) , optional :: rank logical , intent(in) , optional :: abort integer , intent(out) , optional :: rc @@ -1504,6 +1616,15 @@ subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, rank, abort, rc) call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 3) then + if (.not.present(fldptr3)) then + call shr_log_error(trim(subname)//": ERROR missing rank=3 array ", & + line=__LINE__, file=u_FILE_u, rc=rc) + return + endif + call ESMF_FieldGet(field, farrayPtr=fldptr3, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + else call shr_log_error(trim(subname)//": ERROR in rank ", & line=__LINE__, file=u_FILE_u, rc=rc) @@ -1524,7 +1645,7 @@ end subroutine med_methods_Field_GetFldPtr !----------------------------------------------------------------------------- - subroutine med_methods_FB_GetFldPtr(FB, fldname, fldptr1, fldptr2, rank, field, rc) + subroutine med_methods_FB_GetFldPtr(FB, fldname, fldptr1, fldptr2, fldptr3, rank, field, rc) use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field @@ -1536,6 +1657,7 @@ subroutine med_methods_FB_GetFldPtr(FB, fldname, fldptr1, fldptr2, rank, field, character(len=*) , intent(in) :: fldname real(R8), pointer , intent(inout), optional :: fldptr1(:) real(R8), pointer , intent(inout), optional :: fldptr2(:,:) + real(R8), pointer , intent(inout), optional :: fldptr3(:,:,:) integer , intent(out), optional :: rank integer , intent(out), optional :: rc type(ESMF_Field) , intent(out), optional :: field @@ -1566,7 +1688,7 @@ subroutine med_methods_FB_GetFldPtr(FB, fldname, fldptr1, fldptr2, rank, field, call ESMF_FieldBundleGet(FB, fieldName=trim(fldname), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc) + call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, fldptr3=fldptr3, rank=lrank, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (present(rank)) then @@ -1654,6 +1776,43 @@ end function med_methods_FieldPtr_Compare2 !----------------------------------------------------------------------------- + logical function med_methods_FieldPtr_Compare3(fldptr1, fldptr2, cstring, rc) + + ! input/output variables + real(R8), pointer , intent(in) :: fldptr1(:,:,:) + real(R8), pointer , intent(in) :: fldptr2(:,:,:) + character(len=*) , intent(in) :: cstring + integer , intent(out) :: rc + + ! local variables + character(len=*), parameter :: subname='(med_methods_FieldPtr_Compare3)' + ! ---------------------------------------------- + + if (dbug_flag > 10) then + call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO) + endif + rc = ESMF_SUCCESS + + med_methods_FieldPtr_Compare3 = .false. + if (lbound(fldptr2,3) /= lbound(fldptr1,3) .or. lbound(fldptr2,2) /= lbound(fldptr1,2) .or. & + lbound(fldptr2,1) /= lbound(fldptr1,1) .or. ubound(fldptr2,3) /= ubound(fldptr1,3) .or. & + ubound(fldptr2,2) /= ubound(fldptr1,2) .or. ubound(fldptr2,1) /= ubound(fldptr1,1)) then + write(msgString,*) trim(subname)//': fldptr2 ',lbound(fldptr2),ubound(fldptr2),': fldptr1 ',lbound(fldptr1),ubound(fldptr1),& + ": ERROR in data size "//trim(cstring) + call shr_log_error(trim(msgString),rc=rc) + return + else + med_methods_FieldPtr_Compare3 = .true. + endif + + if (dbug_flag > 10) then + call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) + endif + + end function med_methods_FieldPtr_Compare3 + + !----------------------------------------------------------------------------- + subroutine med_methods_State_GeomPrint(state, string, rc) use ESMF, only : ESMF_State, ESMF_Field, ESMF_StateGet @@ -1752,6 +1911,7 @@ subroutine med_methods_Field_GeomPrint(field, string, rc) integer :: lrank real(R8), pointer :: dataPtr1(:) real(R8), pointer :: dataPtr2(:,:) + real(R8), pointer :: dataPtr3(:,:,:) type(ESMF_GeomType_Flag) :: geomtype character(len=*),parameter :: subname='(med_methods_Field_GeomPrint)' ! ---------------------------------------------- @@ -1784,7 +1944,7 @@ subroutine med_methods_Field_GeomPrint(field, string, rc) endif call med_methods_Field_GetFldPtr(field, & - fldptr1=dataPtr1, fldptr2=dataPtr2, rank=lrank, abort=.false., rc=rc) + fldptr1=dataPtr1, fldptr2=dataPtr2, fldptr3=dataPtr3, rank=lrank, abort=.false., rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lrank == 0) then @@ -1797,6 +1957,13 @@ subroutine med_methods_Field_GeomPrint(field, string, rc) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) write (msgString,*) trim(subname)//":"//trim(string)//": dataptr bounds dim=2 ",lbound(dataptr2,2),ubound(dataptr2,2) call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) + elseif (lrank == 3) then + write (msgString,*) trim(subname)//":"//trim(string)//": dataptr bounds dim=1 ",lbound(dataptr3,1),ubound(dataptr3,1) + call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) + write (msgString,*) trim(subname)//":"//trim(string)//": dataptr bounds dim=2 ",lbound(dataptr3,2),ubound(dataptr3,2) + call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) + write (msgString,*) trim(subname)//":"//trim(string)//": dataptr bounds dim=3 ",lbound(dataptr3,3),ubound(dataptr3,3) + call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO) elseif (lrank == 0) then ! means data allocation does not exist yet continue @@ -2318,6 +2485,29 @@ subroutine med_methods_FB_getNumFlds(FB, string, nflds, rc) end subroutine med_methods_FB_getNumFlds + !----------------------------------------------------------------------------- + subroutine med_methods_FB_getdata1d(FB, fieldname, dataptr1d, rc) + + use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field, ESMF_FieldGet + + ! input/output variables + type(ESMF_FieldBundle) , intent(in) :: FB + character(len=*) , intent(in) :: fieldname + real(r8) , pointer :: dataptr1d(:) + integer , intent(inout) :: rc + + ! local variables + type(ESMF_Field) :: lfield + ! ---------------------------------------------- + rc = ESMF_SUCCESS + + call ESMF_FieldBundleGet(FB, fieldname=trim(fieldname), field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine med_methods_FB_getdata1d + !----------------------------------------------------------------------------- subroutine med_methods_FB_getdata2d(FB, fieldname, dataptr2d, rc) @@ -2342,14 +2532,14 @@ subroutine med_methods_FB_getdata2d(FB, fieldname, dataptr2d, rc) end subroutine med_methods_FB_getdata2d !----------------------------------------------------------------------------- - subroutine med_methods_FB_getdata1d(FB, fieldname, dataptr1d, rc) + subroutine med_methods_FB_getdata3d(FB, fieldname, dataptr3d, rc) use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field, ESMF_FieldGet ! input/output variables type(ESMF_FieldBundle) , intent(in) :: FB character(len=*) , intent(in) :: fieldname - real(r8) , pointer :: dataptr1d(:) + real(r8) , pointer :: dataptr3d(:,:,:) integer , intent(inout) :: rc ! local variables @@ -2359,10 +2549,27 @@ subroutine med_methods_FB_getdata1d(FB, fieldname, dataptr1d, rc) call ESMF_FieldBundleGet(FB, fieldname=trim(fieldname), field=lfield, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc) + call ESMF_FieldGet(lfield, farrayptr=dataptr3d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - end subroutine med_methods_FB_getdata1d + end subroutine med_methods_FB_getdata3d + + !----------------------------------------------------------------------------- + subroutine med_methods_Field_getdata1d(field, dataptr1d, rc) + + use ESMF, only : ESMF_Field, ESMF_FieldGet + + ! input/output variables + type(ESMF_Field) , intent(in) :: field + real(r8) , pointer :: dataptr1d(:) + integer , intent(inout) :: rc + ! ---------------------------------------------- + rc = ESMF_SUCCESS + + call ESMF_FieldGet(field, farrayptr=dataptr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + end subroutine med_methods_Field_getdata1d !----------------------------------------------------------------------------- subroutine med_methods_Field_getdata2d(field, dataptr2d, rc) @@ -2382,21 +2589,21 @@ subroutine med_methods_Field_getdata2d(field, dataptr2d, rc) end subroutine med_methods_Field_getdata2d !----------------------------------------------------------------------------- - subroutine med_methods_Field_getdata1d(field, dataptr1d, rc) + subroutine med_methods_Field_getdata3d(field, dataptr3d, rc) use ESMF, only : ESMF_Field, ESMF_FieldGet ! input/output variables type(ESMF_Field) , intent(in) :: field - real(r8) , pointer :: dataptr1d(:) + real(r8) , pointer :: dataptr3d(:,:,:) integer , intent(inout) :: rc ! ---------------------------------------------- rc = ESMF_SUCCESS - call ESMF_FieldGet(field, farrayptr=dataptr1d, rc=rc) + call ESMF_FieldGet(field, farrayptr=dataptr3d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - end subroutine med_methods_Field_getdata1d + end subroutine med_methods_Field_getdata3d !----------------------------------------------------------------------------- subroutine med_methods_FB_getmesh(FB, mesh, rc) @@ -2442,6 +2649,7 @@ subroutine med_methods_FB_check_for_nans(FB, maintask, logunit, rc) character(len=CL) :: fieldname real(r8) , pointer :: dataptr1d(:) real(r8) , pointer :: dataptr2d(:,:) + real(r8) , pointer :: dataptr3d(:,:,:) integer :: nancount character(len=CS) :: nancount_char character(len=CL) :: msg_error @@ -2468,10 +2676,18 @@ subroutine med_methods_FB_check_for_nans(FB, maintask, logunit, rc) call ESMF_FieldGet(field, farrayPtr=dataptr1d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call med_methods_check_for_nans(dataptr1d, nancount) - else + elseif (fieldrank == 2) then call ESMF_FieldGet(field, farrayPtr=dataptr2d, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call med_methods_check_for_nans(dataptr2d, nancount) + elseif (fieldrank == 3) then + call ESMF_FieldGet(field, farrayPtr=dataptr3d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call med_methods_check_for_nans(dataptr3d, nancount) + else + call shr_log_error(subname//": ERROR: unhandled field rank", & + line=__LINE__, file=u_FILE_u, rc=rc) + return end if if (nancount > 0) then write(nancount_char, '(i0)') nancount @@ -2494,11 +2710,11 @@ subroutine med_methods_check_for_nans_1d(dataptr, nancount) real(r8) , intent(in) :: dataptr(:) integer , intent(out) :: nancount ! local variables - integer :: n + integer :: i nancount = 0 - do n = 1,size(dataptr) - if (shr_infnan_isnan(dataptr(n))) then + do i = 1,size(dataptr) + if (shr_infnan_isnan(dataptr(i))) then nancount = nancount + 1 end if end do @@ -2510,16 +2726,36 @@ subroutine med_methods_check_for_nans_2d(dataptr, nancount) real(r8) , intent(in) :: dataptr(:,:) integer , intent(out) :: nancount ! local variables - integer :: n,k + integer :: i,j nancount = 0 - do k = 1,size(dataptr, dim=1) - do n = 1,size(dataptr, dim=2) - if (shr_infnan_isnan(dataptr(k,n))) then + do j = 1,size(dataptr, dim=2) + do i = 1,size(dataptr, dim=1) + if (shr_infnan_isnan(dataptr(i,j))) then nancount = nancount + 1 end if end do end do end subroutine med_methods_check_for_nans_2d + subroutine med_methods_check_for_nans_3d(dataptr, nancount) + use shr_infnan_mod, only: shr_infnan_isnan + ! input/output variables + real(r8) , intent(in) :: dataptr(:,:,:) + integer , intent(out) :: nancount + ! local variables + integer :: i,j,k + + nancount = 0 + do k = 1,size(dataptr, dim=3) + do j = 1,size(dataptr, dim=2) + do i = 1,size(dataptr, dim=1) + if (shr_infnan_isnan(dataptr(i,j,k))) then + nancount = nancount + 1 + end if + end do + end do + end do + end subroutine med_methods_check_for_nans_3d + end module med_methods_mod diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 8530d5223..6017869b1 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -130,7 +130,7 @@ module med_phases_history_mod character(CL) :: case_name = 'unset' ! case name character(CS) :: inst_tag = 'unset' ! instance tag - logical :: debug_alarms = .true. + logical :: debug_alarms = .false. character(*), parameter :: u_FILE_u = & __FILE__ diff --git a/mediator/med_phases_post_rof_mod.F90 b/mediator/med_phases_post_rof_mod.F90 index 7aa8bcb3e..5d623fc76 100644 --- a/mediator/med_phases_post_rof_mod.F90 +++ b/mediator/med_phases_post_rof_mod.F90 @@ -8,7 +8,7 @@ module med_phases_post_rof_mod use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use ESMF , only : ESMF_GridComp, ESMF_GridCompGet use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8 - use ESMF , only : ESMF_Field, ESMF_FieldCreate, ESMF_FieldGet + use ESMF , only : ESMF_Field use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleCreate use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldBundleAdd use ESMF , only : ESMF_VM, ESMF_VMAllreduce, ESMF_REDUCE_SUM @@ -19,9 +19,11 @@ module med_phases_post_rof_mod use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_phases_history_mod, only : med_phases_history_write_comp use med_map_mod , only : med_map_field_packed - use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d + use med_methods_mod , only : fldbun_copy => med_methods_FB_copy use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh + use med_field_info_mod , only : med_field_info_type, med_field_info_create_from_field + use med_field_info_mod , only : med_field_info_esmf_fieldcreate use perf_mod , only : t_startf, t_stopf use shr_log_mod , only : shr_log_error @@ -107,7 +109,6 @@ subroutine med_phases_post_rof_init(gcomp, rc) end subroutine med_phases_post_rof_init !================================================================================================ - subroutine med_phases_post_rof(gcomp, rc) !--------------------------------------------------------------- ! Post runoff phase @@ -119,14 +120,8 @@ subroutine med_phases_post_rof(gcomp, rc) ! local variables type(InternalState) :: is_local type(ESMF_Clock) :: dClock - type(ESMF_field) :: lfield - real(r8), pointer :: data_orig(:) - real(r8), pointer :: data_copy(:) - real(r8), pointer :: data_orig2d(:,:) - real(r8), pointer :: data_copy2d(:,:) integer :: n logical :: exists - integer :: ungriddedUBound(1) character(len=*), parameter :: subname='(med_phases_post_rof)' !--------------------------------------- @@ -142,23 +137,8 @@ subroutine med_phases_post_rof(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1, num_rof_fields - call ESMF_FieldBundleGet(is_local%wrap%FBImp(comprof,comprof), rof_field_names(n), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) + call fldbun_copy(FBrof_r, is_local%wrap%FBImp(comprof,comprof), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ungriddedUBound(1) > 0) then - call fldbun_getdata2d(is_local%wrap%FBImp(comprof,comprof), trim(rof_field_names(n)), data_orig2d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call fldbun_getdata2d(FBrof_r, trim(rof_field_names(n)), data_copy2d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - data_copy2d(:,:) = data_orig2d(:,:) - else - call fldbun_getdata1d(is_local%wrap%FBImp(comprof,comprof), trim(rof_field_names(n)), data_orig, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call fldbun_getdata1d(FBrof_r, trim(rof_field_names(n)), data_copy, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - data_copy(:) = data_orig(:) - end if end do if (remove_negative_runoff_lnd) then @@ -238,7 +218,6 @@ subroutine med_phases_post_rof(gcomp, rc) end subroutine med_phases_post_rof !================================================================================================ - subroutine med_phases_post_rof_create_rof_field_bundle(gcomp, rc) !--------------------------------------------------------------- ! Create FBrof_r @@ -249,10 +228,11 @@ subroutine med_phases_post_rof_create_rof_field_bundle(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: n - type(ESMF_Mesh) :: mesh - type(ESMF_Field) :: field - integer :: ungriddedUBound(1) + integer :: n + type(ESMF_Mesh) :: mesh + type(ESMF_Field) :: field_template + type(ESMF_Field) :: field + type(med_field_info_type) :: field_info integer, parameter :: dbug_threshold = 20 ! threshold for writing debug information in this subroutine character(len=*), parameter :: subname='(med_phases_post_rof_mod: med_phases_post_rof_create_rof_field_bundle)' !--------------------------------------- @@ -282,18 +262,21 @@ subroutine med_phases_post_rof_create_rof_field_bundle(gcomp, rc) FBrof_r = ESMF_FieldBundleCreate(name='FBrof_r', rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return do n = 1, num_rof_fields - call ESMF_FieldBundleGet(is_local%wrap%FBImp(comprof,comprof), rof_field_names(n), field=field, rc=rc) + ! Add a Field to FBrof_r that matches the equivalent Field in + ! is_local%wrap%FBImp(comprof,comprof), particularly in terms of the sizes of any + ! ungridded dimensions. + call ESMF_FieldBundleGet(is_local%wrap%FBImp(comprof,comprof), & + fieldName=rof_field_names(n), & + field=field_template, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(field, ungriddedUBound=ungriddedUBound, rc=rc) + field_info = med_field_info_create_from_field( & + field=field_template, & + name=rof_field_names(n), & + rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call med_field_info_esmf_fieldcreate(field_info=field_info, & + mesh=mesh, meshloc=ESMF_MESHLOC_ELEMENT, field=field, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ungriddedUBound(1) > 0) then - field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=rof_field_names(n), meshloc=ESMF_MESHLOC_ELEMENT, & - ungriddedLbound=(/1/), ungriddedUbound=ungriddedUBound, gridToFieldMap=(/2/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=rof_field_names(n), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if call ESMF_FieldBundleAdd(FBrof_r, (/field/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end do @@ -306,7 +289,6 @@ subroutine med_phases_post_rof_create_rof_field_bundle(gcomp, rc) end subroutine med_phases_post_rof_create_rof_field_bundle !================================================================================================ - subroutine med_phases_post_rof_remove_negative_runoff(gcomp, field_name, rc) !--------------------------------------------------------------- ! For one runoff field, remove negative runoff by downweighting all positive runoff to diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index f566382a9..d9635a692 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -628,7 +628,7 @@ subroutine med_phases_prep_glc_avg(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (lndAccum2glc_cnt > 0) then ! If accumulation count is greater than 0, do the averaging - data2d(:,:) = data2d(:,:) / real(lndAccum2glc_cnt) + data2d(:,:) = data2d(:,:) / real(lndAccum2glc_cnt, R8) else ! If accumulation count is 0, then simply set the averaged field bundle values from the land ! to the import field bundle values @@ -646,7 +646,7 @@ subroutine med_phases_prep_glc_avg(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return if (ocnAccum2glc_cnt > 0) then ! If accumulation count is greater than 0, do the averaging - data2d(:,:) = data2d(:,:) / real(ocnAccum2glc_cnt) + data2d(:,:) = data2d(:,:) / real(ocnAccum2glc_cnt, R8) else ! If accumulation count is 0, then simply set the averaged field bundle values from the ocn ! to the import field bundle values @@ -764,7 +764,6 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) type(InternalState) :: is_local real(r8), pointer :: topolnd_g_ec(:,:) ! topo in elevation classes real(r8), pointer :: topoglc_g(:) ! ice topographic height on the glc grid extracted from glc import - real(r8), pointer :: data_ice_covered_g(:) ! data for ice-covered regions on the GLC grid real(r8), pointer :: ice_covered_g(:) ! if points on the glc grid is ice-covered (1) or ice-free (0) integer , pointer :: elevclass_g(:) ! elevation classes glc grid real(r8), pointer :: dataexp_g(:) ! pointer into @@ -772,6 +771,10 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) real(r8) :: elev_l, elev_u ! lower and upper elevations in interpolation range real(r8) :: d_elev ! elev_u - elev_l integer :: nfld, ec + integer, allocatable :: index_lower(:) ! lower EC index for vertical interpolation, per glc gridcell + integer, allocatable :: index_upper(:) ! upper EC index for vertical interpolation, per glc gridcell + real(r8), allocatable :: weight_lower(:) ! weight for lower EC, per glc gridcell + real(r8), allocatable :: weight_upper(:) ! weight for upper EC, per glc gridcell integer :: n,lsize_g,ns type(ESMF_Field) :: field_lfrac_l integer :: fieldCount @@ -878,6 +881,60 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) call fldbun_getdata2d(toglc_frlnd(ns)%FBlndAccum2glc_g, 'Sl_topo_elev', topolnd_g_ec, rc=rc) if (chkErr(rc,__LINE__,u_FILE_u)) return + ! ------------------------------------------------------------------------ + ! Pre-compute vertical interpolation indices and weights for each glc gridcell. + ! These depend only on topography (not on the field being interpolated), so we + ! compute them once here and reuse them for each field below. + ! ------------------------------------------------------------------------ + + allocate(index_lower(lsize_g)) + allocate(index_upper(lsize_g)) + allocate(weight_lower(lsize_g)) + allocate(weight_upper(lsize_g)) + + do n = 1, lsize_g + if (topoglc_g(n) < topolnd_g_ec(2,n)) then + ! lower than lowest mean EC elevation: use lowest EC value + ! (note that index 1 is bare land, so index 2 is lowest EC) + index_lower(n) = 2 + index_upper(n) = 2 + weight_lower(n) = 0._r8 + weight_upper(n) = 1._r8 + else if (topoglc_g(n) >= topolnd_g_ec(ungriddedCount,n)) then + ! higher than highest mean EC elevation: use highest EC value + index_lower(n) = ungriddedCount + index_upper(n) = ungriddedCount + weight_lower(n) = 1._r8 + weight_upper(n) = 0._r8 + else + ! find bounding ECs and linearly interpolate + do ec = 3, ungriddedCount + if (topoglc_g(n) < topolnd_g_ec(ec,n)) then + elev_l = topolnd_g_ec(ec-1,n) + elev_u = topolnd_g_ec(ec ,n) + d_elev = elev_u - elev_l + index_lower(n) = ec-1 + index_upper(n) = ec + if (d_elev <= 0._r8) then + ! This shouldn't happen, but handle it in case it does. In this case, + ! let's arbitrarily use the mean of the two elevation classes, rather + ! than the weighted mean. + write(logunit,*) subname//' WARNING: topo diff between elevation classes <= 0' + write(logunit,*) 'n, ec, elev_l, elev_u = ', n, ec, elev_l, elev_u + write(logunit,*) 'Simply using mean of the two elevation classes,' + write(logunit,*) 'rather than the weighted mean.' + weight_lower(n) = 0.5_r8 + weight_upper(n) = 0.5_r8 + else + weight_lower(n) = (elev_u - topoglc_g(n)) / d_elev + weight_upper(n) = (topoglc_g(n) - elev_l) / d_elev + end if + exit + end if + end do + end if + end do + ! ------------------------------------------------------------------------ ! Loop over fields in export field bundle to glc for ice sheet ns and ! perform vertical interpolation of data onto ice sheet topography @@ -889,7 +946,6 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! current glint implementation, which sets acab and artm to 0 over ocean (although ! notes that this could lead to a loss of conservation). Figure out how to handle this case. - allocate(data_ice_covered_g(lsize_g)) do nfld = 1, size(fldnames_to_glc) ! Get a pointer to the land data in multiple elevation classes on the glc grid @@ -900,58 +956,16 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) call fldbun_getdata1d(is_local%wrap%FBExp(compglc(ns)), fldnames_to_glc(nfld), dataexp_g, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - ! First set data_ice_covered_g to bare land everywehre - data_ice_covered_g(:) = 0._r8 - - ! Loop over land points and overwrite with valid values + ! Apply pre-computed vertical interpolation indices and weights do n = 1, lsize_g - - ! For each ice sheet point, find bounding EC values... - if (topoglc_g(n) < topolnd_g_ec(2,n)) then - - ! lower than lowest mean EC elevation value - data_ice_covered_g(n) = dataptr2d(2,n) - - else if (topoglc_g(n) >= topolnd_g_ec(ungriddedCount, n)) then - - ! higher than highest mean EC elevation value - data_ice_covered_g(n) = dataptr2d(ungriddedCount,n) - - else - - ! do linear interpolation of data in the vertical - do ec = 3, ungriddedCount - if (topoglc_g(n) < topolnd_g_EC(ec,n)) then - elev_l = topolnd_g_EC(ec-1,n) - elev_u = topolnd_g_EC(ec ,n) - d_elev = elev_u - elev_l - if (d_elev <= 0) then - ! This shouldn't happen, but handle it in case it does. In this case, - ! let's arbitrarily use the mean of the two elevation classes, rather - ! than the weighted mean. - write(logunit,*) subname//' WARNING: topo diff between elevation classes <= 0' - write(logunit,*) 'n, ec, elev_l, elev_u = ', n, ec, elev_l, elev_u - write(logunit,*) 'Simply using mean of the two elevation classes,' - write(logunit,*) 'rather than the weighted mean.' - data_ice_covered_g(n) = dataptr2d(ec-1,n) * 0.5_r8 & - + dataptr2d(ec ,n) * 0.5_r8 - else - data_ice_covered_g(n) = dataptr2d(ec-1,n) * (elev_u - topoglc_g(n)) / d_elev & - + dataptr2d(ec ,n) * (topoglc_g(n) - elev_l) / d_elev - end if - exit - end if - end do - end if ! topoglc_g(n) - if (elevclass_g(n) /= 0) then - ! ice-covered cells have interpolated values - dataexp_g(n) = data_ice_covered_g(n) + ! ice-covered cells: vertically interpolate between bounding ECs + dataexp_g(n) = dataptr2d(index_lower(n), n) * weight_lower(n) & + + dataptr2d(index_upper(n), n) * weight_upper(n) else - ! non ice-covered cells have bare land value - dataexp_g(n) = real(dataptr2d(1,n)) + ! non ice-covered cells: use bare land value (EC index 1) + dataexp_g(n) = dataptr2d(1, n) end if - end do ! end of loop over land points end do ! end loop over fields (nflds) @@ -973,7 +987,10 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! clean up memory that is ice sheet dependent deallocate(elevclass_g) - deallocate(data_ice_covered_g) + deallocate(index_lower) + deallocate(index_upper) + deallocate(weight_lower) + deallocate(weight_upper) end do ! end of loop over ice sheets diff --git a/mediator/med_phases_prep_rof_mod.F90 b/mediator/med_phases_prep_rof_mod.F90 index 696cd76e6..465a03158 100644 --- a/mediator/med_phases_prep_rof_mod.F90 +++ b/mediator/med_phases_prep_rof_mod.F90 @@ -21,11 +21,14 @@ module med_phases_prep_rof_mod use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_diagnose => med_methods_FB_diagnose use med_methods_mod , only : fldbun_reset => med_methods_FB_reset + use med_methods_mod , only : fldbun_accum => med_methods_FB_accum use med_methods_mod , only : fldbun_average => med_methods_FB_average + use med_methods_mod , only : fldbun_fldChk => med_methods_FB_FldChk use med_methods_mod , only : field_getdata1d => med_methods_Field_getdata1d - use med_methods_mod , only : field_getdata2d => med_methods_Field_getdata2d - use med_methods_mod , only : fldbun_fldchk => med_methods_FB_fldchk use med_methods_mod , only : FB_check_for_nans => med_methods_FB_check_for_nans + use med_field_info_mod , only : med_field_info_type + use med_field_info_mod , only : med_field_info_create_directly, med_field_info_create_from_field + use med_field_info_mod , only : med_field_info_esmf_fieldcreate use perf_mod , only : t_startf, t_stopf use shr_log_mod , only : shr_log_error @@ -64,8 +67,6 @@ module med_phases_prep_rof_mod type(ESMF_FieldBundle), public :: FBlndAccum2rof_l type(ESMF_FieldBundle), public :: FBlndAccum2rof_r - character(len=9) :: fldnames_fr_glc(2) = (/'Fgrg_rofl', 'Fgrg_rofi'/) - character(*) , parameter :: u_FILE_u = & __FILE__ @@ -81,7 +82,7 @@ subroutine med_phases_prep_rof_init(gcomp, rc) !--------------------------------------- use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate + use ESMF , only : ESMF_Field, ESMF_FieldGet use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleCreate, ESMF_FieldBundleGet, ESMF_FieldBundleAdd use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS @@ -96,12 +97,13 @@ subroutine med_phases_prep_rof_init(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: lrank integer :: n, nflds + logical :: is_present type(ESMF_Mesh) :: mesh_l type(ESMF_Mesh) :: mesh_r + type(ESMF_Field) :: lfield_template type(ESMF_Field) :: lfield - integer :: ungriddedUBound(1) + type(med_field_info_type) :: field_info type(med_fldList_type), pointer :: fldList type(med_fldList_entry_type), pointer :: fldptr character(len=CS) :: fldname @@ -151,37 +153,48 @@ subroutine med_phases_prep_rof_init(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return do n = 1,size(lnd2rof_flds) - ! Obtain import field on land grid and determine its rank - call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, rank=lrank, rc=rc) + ! Determine information about this Field - particularly the sizes of any ungridded + ! dimensions - so that we can create a correctly-sized Field in the accumulation + ! FieldBundles. + call ESMF_FieldBundleGet(is_local%wrap%FBExp(comprof), & + fieldName=lnd2rof_flds(n), & + isPresent=is_present, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (lrank == 2) then - call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc) + if (is_present) then + call ESMF_FieldBundleGet(is_local%wrap%FBExp(comprof), & + fieldName=lnd2rof_flds(n), & + field=lfield_template, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - end if - - if (lrank == 2) then - lfield = ESMF_FieldCreate(mesh_l, ESMF_TYPEKIND_R8, name=lnd2rof_flds(n), meshloc=ESMF_MESHLOC_ELEMENT, & - ungriddedLbound=(/1/), ungriddedUbound=ungriddedUBound, gridToFieldMap=(/2/), rc=rc) + field_info = med_field_info_create_from_field( & + field=lfield_template, & + name=lnd2rof_flds(n), & + rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return else - lfield = ESMF_FieldCreate(mesh_l, ESMF_TYPEKIND_R8, name=lnd2rof_flds(n), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) + ! If this Field isn't in FBExp(comprof), then it could probably be left out of + ! the Accumulator FieldBundles. But we're leaving it in there to maintain + ! earlier behavior of the code and avoid the need to determine if it's safe to + ! leave it out. However, in this case, we don't bother determining the sizes of + ! any ungridded dimensions (because it shouldn't matter and we don't have an + ! obvious place to get this information from). + field_info = med_field_info_create_directly( & + name=lnd2rof_flds(n), & + rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return end if + + call med_field_info_esmf_fieldcreate(field_info=field_info, & + mesh=mesh_l, meshloc=ESMF_MESHLOC_ELEMENT, & + field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldBundleAdd(FBlndAccum2rof_l, (/lfield/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(trim(subname)//' adding field '//trim(lnd2rof_flds(n))//' to FBLndAccum2rof_l', & ESMF_LOGMSG_INFO) - - if (lrank == 2) then - lfield = ESMF_FieldCreate(mesh_r, ESMF_TYPEKIND_R8, name=lnd2rof_flds(n), meshloc=ESMF_MESHLOC_ELEMENT, & - ungriddedLbound=(/1/), ungriddedUbound=ungriddedUBound, gridToFieldMap=(/2/), rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - else - lfield = ESMF_FieldCreate(mesh_r, ESMF_TYPEKIND_R8, name=lnd2rof_flds(n), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - end if + call med_field_info_esmf_fieldcreate(field_info=field_info, & + mesh=mesh_r, meshloc=ESMF_MESHLOC_ELEMENT, & + field=lfield, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_FieldBundleAdd(FBlndAccum2rof_r, (/lfield/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(trim(subname)//' adding field '//trim(lnd2rof_flds(n))//' to FBLndAccum2rof_r', & @@ -219,11 +232,8 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) ! Mapping from the land to the rof grid is then done with the time averaged fields !------------------------------------ - use NUOPC , only : NUOPC_IsConnected use ESMF , only : ESMF_GridComp, ESMF_GridCompGet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS - use ESMF , only : ESMF_FieldBundleGet, ESMF_StateIsCreated, ESMF_StateGet - use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_Field, ESMF_FieldGet ! input/output variables type(ESMF_GridComp) :: gcomp @@ -231,15 +241,6 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: n - integer :: lrank - logical :: exists - real(r8), pointer :: dataptr1d(:) - real(r8), pointer :: dataptr1d_accum(:) - real(r8), pointer :: dataptr2d(:,:) - real(r8), pointer :: dataptr2d_accum(:,:) - type(ESMF_Field) :: lfield - type(ESMF_Field) :: lfield_accum character(len=*), parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof_accum)' !--------------------------------------- @@ -256,34 +257,8 @@ subroutine med_phases_prep_rof_accum(gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return ! Accumulate lnd input on lnd grid for fields that will be sent to rof - do n = 1,size(lnd2rof_flds) - call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & - isPresent=exists, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (exists) then - call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), & - field=lfield_accum, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & - field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (lrank == 2) then - call field_getdata2d(lfield, dataptr2d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata2d(lfield_accum, dataptr2d_accum, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr2d_accum(:,:) = dataptr2d_accum(:,:) + dataptr2d(:,:) - else - call field_getdata1d(lfield, dataptr1d, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata1d(lfield_accum, dataptr1d_accum, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr1d_accum(:) = dataptr1d_accum(:) + dataptr1d(:) - end if - end if - end do + call fldbun_accum(FBout=FBlndAccum2rof_l, FBin=is_local%wrap%FBImp(complnd,complnd), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! Accumulate counter lndAccum2rof_cnt = lndAccum2rof_cnt + 1 @@ -309,7 +284,6 @@ subroutine med_phases_prep_rof(gcomp, rc) use NUOPC , only : NUOPC_IsConnected use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldGet use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS use esmFlds , only : med_fldList_GetfldListTo, med_fldList_type use med_map_mod , only : med_map_field_packed @@ -322,14 +296,9 @@ subroutine med_phases_prep_rof(gcomp, rc) ! local variables type(InternalState) :: is_local - integer :: n,ns,nf + integer :: ns integer :: count - logical :: exists - integer :: lrank - real(r8), pointer :: dataptr_in(:) real(r8), pointer :: dataptr_out(:) - real(r8), pointer :: dataptr2d_out(:,:) - type(ESMF_Field) :: lfield type(med_fldList_type), pointer :: fldList character(len=*),parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof)' !--------------------------------------- @@ -359,35 +328,12 @@ subroutine med_phases_prep_rof(gcomp, rc) write(logunit,'(a)')trim(subname)//'accumulation count for land input averging to river is 0 '// & ' accumulation field is set to zero' end if - end if - - do n = 1,size(lnd2rof_flds) - call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), isPresent=exists, rc=rc) + call fldbun_reset(FB=FBlndAccum2rof_l, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - if (exists) then - call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (lrank == 2) then - call field_getdata2d(lfield, dataptr2d_out, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (count == 0) then - dataptr2d_out(:,:) = czero - else - dataptr2d_out(:,:) = dataptr2d_out(:,:) / real(count, r8) - end if - else - call field_getdata1d(lfield, dataptr_out, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (count == 0) then - dataptr_out(:) = czero - else - dataptr_out(:) = dataptr_out(:) / real(count, r8) - end if - end if - end if - end do + else + call fldbun_average(FB=FBlndAccum2rof_l, count=count, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if if (dbug_flag > 1) then call fldbun_diagnose(FBlndAccum2rof_l, string=trim(subname)//' FBlndAccum2rof_l after avg ', rc=rc) @@ -442,25 +388,24 @@ subroutine med_phases_prep_rof(gcomp, rc) ! custom merge for glc->rof ! glc->rof is mapped in med_phases_post_glc do ns = 1,is_local%wrap%num_icesheets - if (is_local%wrap%med_coupling_active(compglc(ns),comprof)) then - do nf = 1,size(fldnames_fr_glc) - if ( fldbun_fldchk(is_local%wrap%FBImp(compglc(ns),comprof), fldnames_fr_glc(nf), rc=rc) .and. & - fldbun_fldchk(is_local%wrap%FBExp(comprof), fldnames_fr_glc(nf), rc=rc) ) then - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),comprof), & - trim(fldnames_fr_glc(nf)), dataptr_in, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call fldbun_getdata1d(is_local%wrap%FBExp(comprof), & - trim(fldnames_fr_glc(nf)), dataptr_out , rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Determine export data - if (ns == 1) then - dataptr_out(:) = dataptr_in(:) - else - dataptr_out(:) = dataptr_out(:) + dataptr_in(:) - end if - end if - end do - end if + if (is_local%wrap%med_coupling_active(compglc(ns),comprof)) then + ! This fldbun_accum call is used to sum the inputs from each ice sheet - so it + ! is an accumulation in space (as opposed to the accumulation in time done in + ! med_phases_prep_rof_accum). This accumulation acts over all of the fields that + ! are common to FBExp(comprof) and FBImp(compglc(ns),comprof), which is the set + ! of fields sent from glc to rof. Note that the 'copy' argument is set to true + ! for the first loop iteration and false for subsequent loop iterations; this + ! serves to initialize the export field bundle in the first loop iteration + ! (simply copying the import fields to the export) and then iteratively + ! accumulating the imports from the other ice sheets in subsequent loop + ! iterations. + call fldbun_accum( & + FBout=is_local%wrap%FBExp(comprof), & + FBin=is_local%wrap%FBImp(compglc(ns),comprof), & + copy=(ns==1), & + rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + end if end do ! Check for nans in fields export to rof @@ -481,26 +426,8 @@ subroutine med_phases_prep_rof(gcomp, rc) lndAccum2rof_cnt = 0 ! zero lnd2rof fields in FBlndAccum2rof_l - do n = 1,size(lnd2rof_flds) - call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldName=trim(lnd2rof_flds(n)), & - isPresent=exists, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (exists) then - call ESMF_FieldBundleGet(FBlndAccum2rof_l, fieldName=trim(lnd2rof_flds(n)), field=lfield, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, rank=lrank, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - if (lrank == 2) then - call field_getdata2d(lfield, dataptr2d_out, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr2d_out(:,:) = czero - else - call field_getdata1d(lfield, dataptr_out, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - dataptr_out(:) = czero - end if - end if - end do + call fldbun_reset(FBlndAccum2rof_l, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return if (dbug_flag > 20) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)