diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 index 69d73008e..89d9f9214 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 @@ -31,7 +31,7 @@ module GEOS_LandGridCompMod use GEOS_CatchGridCompMod, only : CatchSetServices => SetServices use GEOS_CatchCNGridCompMod, only : CatchCNSetServices => SetServices use GEOS_IgniGridCompMod, only : IgniSetServices => SetServices -! use GEOS_RouteGridCompMod, only : RouteSetServices => SetServices + use GEOS_RouteGridCompMod, only : RouteSetServices => SetServices implicit none private @@ -45,7 +45,7 @@ module GEOS_LandGridCompMod integer :: VEGDYN - integer, allocatable :: CATCH(:), ROUTE (:), CATCHCN (:) + integer, allocatable :: CATCH(:), CATCHCN(:), ROUTE(:) integer :: LSM_CHOICE, RUN_ROUTE, DO_GOSWIM integer :: IGNI logical :: DO_FIRE_DANGER @@ -84,7 +84,7 @@ subroutine SetServices ( GC, RC ) character(len=ESMF_MAXSTR) :: GCName type(ESMF_Config) :: CF, SCF - integer :: NUM_CATCH + integer :: NUM_CATCH_ENS integer :: I character(len=ESMF_MAXSTR) :: TMP type(MAPL_MetaComp),pointer :: MAPL=>null() @@ -134,7 +134,7 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) VERIFY_(STATUS) - call ESMF_ConfigGetAttribute ( CF, NUM_CATCH, Label="NUM_CATCH_ENSEMBLES:", default=1, RC=STATUS) + call ESMF_ConfigGetAttribute ( CF, NUM_CATCH_ENS, Label="NUM_CATCH_ENSEMBLES:", default=1, RC=STATUS) VERIFY_(STATUS) !------------------------------------------------------------ @@ -163,13 +163,13 @@ subroutine SetServices ( GC, RC ) CASE (1) - allocate (CATCH(NUM_CATCH), stat=status) + allocate (CATCH(NUM_CATCH_ENS), stat=status) VERIFY_(STATUS) - if (NUM_CATCH == 1) then + if (NUM_CATCH_ENS == 1) then CATCH(1) = MAPL_AddChild(GC, NAME='CATCH'//trim(tmp), SS=CatchSetServices, RC=STATUS) VERIFY_(STATUS) else - do I = 1, NUM_CATCH + do I = 1, NUM_CATCH_ENS WRITE(TMP,'(I3.3)') I GCName = 'ens' // trim(TMP) // ':CATCH' CATCH(I) = MAPL_AddChild(GC, NAME=GCName, SS=CatchSetServices, RC=STATUS) @@ -179,13 +179,13 @@ subroutine SetServices ( GC, RC ) CASE (2,3) - allocate (CATCHCN(NUM_CATCH), stat=status) + allocate (CATCHCN(NUM_CATCH_ENS), stat=status) VERIFY_(STATUS) - if (NUM_CATCH == 1) then + if (NUM_CATCH_ENS == 1) then CATCHCN(1) = MAPL_AddChild(GC, NAME='CATCHCN'//trim(tmp), SS=CatchCNSetServices, RC=STATUS) VERIFY_(STATUS) else - do I = 1, NUM_CATCH + do I = 1, NUM_CATCH_ENS WRITE(TMP,'(I3.3)') I GCName = 'ens' // trim(TMP) // ':CATCHCN' CATCHCN(I) = MAPL_AddChild(GC, NAME=GCName, SS=CatchCNSetServices, RC=STATUS) @@ -195,19 +195,21 @@ subroutine SetServices ( GC, RC ) END SELECT -! IF(RUN_ROUTE == 1) THEN -! if (NUM_CATCH == 1) then -! ROUTE(1) = MAPL_AddChild(GC, NAME='ROUTE', SS=RouteSetServices, RC=STATUS) -! VERIFY_(STATUS) -! else -! do I = 1, NUM_CATCH -! WRITE(TMP,'(I3.3)') I -! GCName = 'ens' // trim(TMP) // ':ROUTE' -! ROUTE(I) = MAPL_AddChild(GC, NAME=GCName, SS=RouteSetServices, RC=STATUS) -! VERIFY_(STATUS) -! end do -! end if -! ENDIF + allocate (ROUTE(NUM_CATCH_ENS), stat=status) + VERIFY_(STATUS) + IF(RUN_ROUTE == 1) THEN + if (NUM_CATCH_ENS == 1) then + ROUTE(1) = MAPL_AddChild(GC, NAME='ROUTE', SS=RouteSetServices, RC=STATUS) + VERIFY_(STATUS) + else + do I = 1, NUM_CATCH_ENS + WRITE(TMP,'(I3.3)') I + GCName = 'ens' // trim(TMP) // ':ROUTE' + ROUTE(I) = MAPL_AddChild(GC, NAME=GCName, SS=RouteSetServices, RC=STATUS) + VERIFY_(STATUS) + end do + end if + ENDIF if (DO_FIRE_DANGER) then IGNI = MAPL_AddChild(GC, NAME='IGNI'//trim(tmp), SS=IgniSetServices, RC=STATUS) @@ -1426,7 +1428,7 @@ subroutine SetServices ( GC, RC ) ! !CONNECTIONS: - DO I = 1, NUM_CATCH + DO I = 1, NUM_CATCH_ENS SELECT CASE (LSM_CHOICE) @@ -1453,16 +1455,16 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) end if -! IF(RUN_ROUTE == 1) THEN -! call MAPL_AddConnectivity ( & -! GC ,& -! SHORT_NAME = (/'RUNOFF '/) ,& -! SRC_ID = CATCH(I) ,& -! DST_ID = ROUTE(I) ,& -! -! RC=STATUS ) -! VERIFY_(STATUS) -! ENDIF + IF(RUN_ROUTE == 1) THEN + call MAPL_AddConnectivity ( & + GC ,& + SHORT_NAME = (/'RUNOFF '/) ,& ! RUNOFF = total runoff = surface runoff + baseflow + SRC_ID = CATCH(I) ,& + DST_ID = ROUTE(I) ,& + + RC=STATUS ) + VERIFY_(STATUS) + ENDIF CASE (2,3) call MAPL_AddConnectivity ( & @@ -1486,19 +1488,19 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) end if -! IF(RUN_ROUTE == 1) THEN -! call MAPL_AddConnectivity ( & -! GC ,& -! SHORT_NAME = (/'RUNOFF '/) ,& -! SRC_ID = CATCHCN(I) ,& -! DST_ID = ROUTE(I) ,& -! -! RC=STATUS ) -! VERIFY_(STATUS) -! ENDIF + IF(RUN_ROUTE == 1) THEN + call MAPL_AddConnectivity ( & + GC ,& + SHORT_NAME = (/'RUNOFF '/) ,& ! RUNOFF = total runoff = surface runoff + baseflow + SRC_ID = CATCHCN(I) ,& + DST_ID = ROUTE(I) ,& + + RC=STATUS ) + VERIFY_(STATUS) + ENDIF END SELECT END DO - + call MAPL_TimerAdd(GC, name="INITIALIZE" ,RC=STATUS) VERIFY_(STATUS) @@ -1669,6 +1671,7 @@ subroutine Run1(GC, IMPORT, EXPORT, CLOCK, RC ) !-------------------------------- DO I = 1, size(GCS) + if (trim(GCnames(i)) == "ROUTE") cycle call MAPL_TimerOn(MAPL,trim(GCnames(i)), RC=STATUS ); VERIFY_(STATUS) call ESMF_GridCompRun(GCS(I), importState=GIM(I), exportState=GEX(I), & CLOCK=CLOCK, PHASE=1, userRC=STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt index 8a502e3e7..cc018b928 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt @@ -1,10 +1,11 @@ esma_set_this () set (srcs - #GEOS_RouteGridComp.F90 + GEOS_RouteGridComp.F90 routing_model.F90 + reservoir.F90 ) -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL ESMF::ESMF NetCDF::NetCDF_Fortran) +esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_LandShared ESMF::ESMF NetCDF::NetCDF_Fortran) install(PROGRAMS build_rivernetwork.py DESTINATION bin) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 4a28c0da2..37fcc825a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -18,39 +18,96 @@ module GEOS_RouteGridCompMod ! All of its calculations are done on Pfafstetter watershed space. {\tt GEOS\_Route} has no children. \\ ! ! IMPORTS : RUNOFF \\ -! INTERNALS : AREACAT, LENGSC2, DNSTR, WSTREAM, WRIVER, LRIVERMOUTH, ORIVERMOUTH \\ -! EXPORTS : QSFLOW, QINFLOW, QOUTFLOW \\ ! !USES: use ESMF use MAPL_Mod use MAPL_ConstantsMod - use ROUTING_MODEL, ONLY: & - river_routing, ROUTE_DT -#if 0 - USE catch_constants, ONLY: & - N_CatG => N_Pfaf_Catchs -#endif + use ROUTING_MODEL, ONLY: river_routing_lin, river_routing_hyd, ROUTE_DT + use reservoir, ONLY: res_init, res_cal + use catch_constants, ONLY: N_CatG => CATCH_N_PFAFS + + use, intrinsic :: iso_c_binding implicit none - integer, parameter :: N_CatG = 291284 + + integer, parameter :: upmax = 34 + logical, parameter :: use_res = .True. + integer, save :: nmax + private - type T_RROUTE_STATE + type RES_STATE !reserver related variables + integer, pointer :: active_res(:) + integer, pointer :: active_up(:,:) + real, pointer :: Wr_res(:) !m3 + integer, pointer :: type_res(:) + real, pointer :: cap_res(:) !m3 + real, pointer :: wid_res(:) !m + integer, pointer :: fld_res(:) + real, pointer :: Qfld_thres(:) !m3/s + integer, pointer :: cat2res(:) + real, pointer :: qres_acc(:) + end type RES_STATE + + type T_RROUTE_STATE !routing related variables private type (ESMF_RouteHandle) :: routeHandle type (ESMF_Field) :: field + type (RES_STATE) :: reservoir integer :: nTiles + integer :: nt_global + integer :: nt_local integer :: comm integer :: nDes integer :: myPe integer :: minCatch integer :: maxCatch - integer, pointer :: pfaf(:) => NULL() - real, pointer :: tile_area(:) => NULL() + integer, pointer :: pfaf(:) => NULL() + real, pointer :: tile_area(:) => NULL() ! m2 + integer, pointer :: nsub(:) => NULL() + integer, pointer :: subi(:,:) => NULL() + real, pointer :: subarea(:,:) => NULL() ! m2 + + integer, pointer :: scounts_global(:) => NULL() + integer, pointer :: rdispls_global(:) => NULL() + integer, pointer :: scounts_cat(:) => NULL() + integer, pointer :: rdispls_cat(:) => NULL() + + real, pointer :: runoff_save(:) => NULL() + real, pointer :: areacat(:) => NULL() ! m2 + real, pointer :: lengsc(:) => NULL() ! m + + real, pointer :: wstream(:) => NULL() ! m3 + real, pointer :: wriver(:) => NULL() ! m3 + integer, pointer :: downid(:) => NULL() + integer, pointer :: upid(:,:) => NULL() + + real, pointer :: wriver_acc(:) => NULL() + real, pointer :: wstream_acc(:) => NULL() + real, pointer :: qoutflow_acc(:) => NULL() + real, pointer :: qsflow_acc(:) => NULL() + + real, pointer :: lstr(:) => NULL() ! m + real, pointer :: qri_clmt(:) => NULL() ! m3/s + real, pointer :: qin_clmt(:) => NULL() ! m3/s + real, pointer :: qstr_clmt(:) => NULL() ! m3/s + real, pointer :: K(:) => NULL() + real, pointer :: Kstr(:) => NULL() + end type T_RROUTE_STATE + + interface + function mkdir(path,mode) bind(c,name="mkdir") + use iso_c_binding + integer(c_int) :: mkdir + character(kind=c_char,len=1) :: path(*) + integer(c_int16_t), value :: mode + end function mkdir + end interface + ! Wrapper for extracting internal state ! ------------------------------------- type RROUTE_WRAP @@ -104,8 +161,8 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config ) :: CF - type (T_RROUTE_STATE), pointer :: route_internal_state => null() - type (RROUTE_wrap) :: wrap + type (T_RROUTE_STATE), pointer :: route_internal_state => null() + type (RROUTE_wrap) :: wrap integer :: RUN_DT real :: DT @@ -118,8 +175,8 @@ subroutine SetServices ( GC, RC ) ! Get my name and set-up traceback handle !------------------------------------------------------------ - call ESMF_GridCompGet(GC ,& - NAME=COMP_NAME ,& + call ESMF_GridCompGet(GC ,& + NAME=COMP_NAME ,& RC=STATUS ) VERIFY_(STATUS) @@ -132,12 +189,12 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, RC=STATUS ) VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint (GC, ESMF_METHOD_RUN, Run, RC=STATUS) +! call MAPL_GridCompSetEntryPoint (GC, ESMF_METHOD_RUN, Run, RC=STATUS) +! VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN1, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN2, RC=STATUS ) VERIFY_(STATUS) - -!------------------------------------------------------------ -! Set generic final method -!------------------------------------------------------------ ! ----------------------------------------------------------- @@ -177,7 +234,7 @@ subroutine SetServices ( GC, RC ) ! Import States ! ----------------------------------------------------------- - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& @@ -186,104 +243,8 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) -! ----------------------------------------------------------- -! INTERNAL STATE -! ----------------------------------------------------------- - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'area_of_catchment' ,& - UNITS = 'km+2' ,& - SHORT_NAME = 'AREACAT' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'length_of_channel_segment',& - UNITS = 'km+2' ,& - SHORT_NAME = 'LENGSC' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'index_of_downtream_catchment',& - UNITS = '1' ,& - SHORT_NAME = 'DNSTR' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'volume_of_water_in_local_stream',& - UNITS = 'm+3' ,& - SHORT_NAME = 'WSTREAM' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'volume_of_water_in_river' ,& - UNITS = 'm+3' ,& - SHORT_NAME = 'WRIVER' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'TileID_of_the_lake_tile_at_the_river_mouth' ,& - UNITS = '1' ,& - SHORT_NAME = 'LRIVERMOUTH' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'TileID_of_the_ocean_tile_at_the_river_mouth' ,& - UNITS = '1' ,& - SHORT_NAME = 'ORIVERMOUTH' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) -! ----------------------------------------------------------- -! EXPORT STATE: -! ----------------------------------------------------------- - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transfer_of_moisture_from_stream_variable_to_river_variable' ,& - UNITS = 'm+3 s-1' ,& - SHORT_NAME = 'QSFLOW' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transfer_of_river_water_from_upstream_catchments' ,& - UNITS = 'm+3 s-1' ,& - SHORT_NAME = 'QINFLOW' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transfer_of_river_water_to_downstream_catchments' ,& - UNITS = 'm+3 s-1' ,& - SHORT_NAME = 'QOUTFLOW' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - !EOS - call MAPL_TimerAdd(GC, name="RUN" ,RC=STATUS) - VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="-RRM" ,RC=STATUS) VERIFY_(STATUS) @@ -305,9 +266,11 @@ subroutine SetServices ( GC, RC ) ! Clocks !------- - call MAPL_TimerAdd(GC, name="INITIALIZE" ,RC=STATUS) + call MAPL_TimerAdd(GC, name="INITIALIZE" ,RC=STATUS) VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="RUN" ,RC=STATUS) + call MAPL_TimerAdd(GC, name="RUN1" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="RUN2" ,RC=STATUS) VERIFY_(STATUS) ! All done @@ -355,34 +318,66 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) integer :: beforeMe, minCatch, maxCatch, pf, i integer :: ntiles, nt_global - type(ESMF_Grid) :: tileGrid - type(ESMF_Grid) :: newTileGrid - type(ESMF_Grid) :: catchGrid + type(ESMF_Grid) :: tileGrid + type(ESMF_Grid) :: newTileGrid + type(ESMF_Grid) :: catchGrid type(ESMF_DistGrid) :: distGrid - type(ESMF_Field) :: field, field0 + type(ESMF_Field) :: field, field0 type(MAPL_MetaComp), pointer :: MAPL - type(MAPL_LocStream) :: locstream + type(MAPL_LocStream) :: locstream + + character(len=ESMF_MAXSTR) :: River_RoutingFile integer, pointer :: ims(:) => NULL() integer, pointer :: pfaf(:) => NULL() integer, pointer :: arbSeq(:) => NULL() + integer, pointer :: arbSeq_pf(:) => NULL() + integer, pointer :: arbSeq_ori(:) => NULL() integer, allocatable :: arbIndex(:,:) - real, pointer :: tile_area_src(:) => NULL() - real, pointer :: tile_area(:) => NULL() - real, pointer :: ptr2(:) => NULL() + real, pointer :: tile_area_src(:) => NULL() + integer, pointer :: local_id(:) => NULL() + real, pointer :: tile_area_local(:) => NULL(), tile_area_global(:) => NULL() + real, pointer :: tile_area(:) => NULL() + real, pointer :: ptr2(:) => NULL() + + real, pointer :: subarea_global(:,:)=> NULL(),subarea(:,:)=> NULL() ! Arrays for sub-area and fractions + integer, pointer :: subi_global(:,:)=> NULL(),subi(:,:)=> NULL() + integer, pointer :: nsub_global(:)=> NULL(),nsub(:)=> NULL() + real, pointer :: area_cat_global(:)=> NULL(),area_cat(:)=> NULL() + integer, pointer :: scounts(:)=>NULL() + integer, pointer :: scounts_global(:)=>NULL(),rdispls_global(:)=>NULL() + integer, pointer :: scounts_cat(:)=>NULL(),rdispls_cat(:)=>NULL() + + real, pointer :: runoff_save(:)=>NULL(), areacat(:)=>NULL() + real, pointer :: lengsc_global(:)=>NULL(), lengsc(:)=>NULL(), buff_global(:)=>NULL() + integer, pointer :: downid_global(:)=>NULL(), downid(:)=>NULL() + integer, pointer :: upid_global(:,:)=>NULL(), upid(:,:)=>NULL() + + real, pointer :: wstream(:)=>NULL(),wriver(:)=>NULL(),wres(:)=>NULL() + real, pointer :: wstream_global(:)=>NULL(),wriver_global(:)=>NULL(),wres_global(:)=>NULL() - type (T_RROUTE_STATE), pointer :: route => null() - type (RROUTE_wrap) :: wrap + type (T_RROUTE_STATE), pointer :: route => null() + type (RES_STATE), pointer :: res => NULL() + type (RROUTE_wrap) :: wrap + + type(ESMF_Time) :: CurrentTime + integer :: YY,MM,DD,HH,MMM,SS + character(len=4) :: yr_s + character(len=2) :: mon_s,day_s + character(len=3) :: resname + + real, pointer :: dataPtr(:) + integer :: j,nt_local,mpierr,it ! ------------------ ! begin + call ESMF_UserCompGetInternalState ( GC, 'RiverRoute_state',wrap,status ) VERIFY_(STATUS) route => wrap%ptr - ! get vm ! extract comm call ESMF_VMGetCurrent(VM, RC=STATUS) @@ -398,153 +393,302 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%comm = comm route%ndes = ndes route%mype = mype - - ! define minCatch, maxCatch + + allocate(ims(1:ndes)) + ! define catchment space for this processor call MAPL_DecomposeDim ( n_catg,ims,ndes ) ! ims(mype+1) gives the size of my partition ! myPE is 0-based! beforeMe = sum(ims(1:mype)) minCatch = beforeMe + 1 maxCatch = beforeMe + ims(myPe+1) - ! get LocStream call MAPL_Get(MAPL, LocStream = locstream, RC=status) - VERIFY_(STATUS) - ! extract Pfaf (TILEI on the "other" grid) - call MAPL_LocStreamGet(locstream, tilei=pfaf, OnAttachedGrid=.false., & + VERIFY_(STATUS) + ! extract Pfaf (TILEI on the "other" grid) + call MAPL_LocStreamGet(locstream, & tileGrid=tilegrid, nt_global=nt_global, RC=status) - VERIFY_(STATUS) - + VERIFY_(STATUS) + route%nt_global = nt_global + ! Determine the resolution + if(nt_global==112573)then + resname="M36" + nmax=150 + else if(nt_global==1684725)then + resname="M09" + nmax=458 + else + if(mapl_am_I_root())then + print *,"unknown grid for routing model" + stop + endif + endif ! exchange Pfaf across PEs - - ntiles = 0 - !loop over total_n_tiles - do i = 1, nt_global - pf = pfaf(i) - if (pf >= minCatch .and. pf <= maxCatch) then ! I want this! - ntiles = ntiles+1 - !realloc if needed - arbSeq(ntiles) = i - end if - end do ! global tile loop - - distgrid = ESMF_DistGridCreate(arbSeqIndexList=arbSeq, rc=status) - VERIFY_(STATUS) - - newTileGRID = ESMF_GridEmptyCreate(rc=status) - VERIFY_(STATUS) - - allocate(arbIndex(nTiles,1), stat=status) - VERIFY_(STATUS) - - arbIndex(:,1) = arbSeq - - call ESMF_GridSet(newTileGrid, & - name='redist_tile_grid_for_'//trim(COMP_NAME), & - distgrid=distgrid, & - gridMemLBound=(/1/), & - indexFlag=ESMF_INDEX_USER, & - distDim = (/1/), & - localArbIndexCount=ntiles, & - localArbIndex=arbIndex, & - minIndex=(/1/), & - maxIndex=(/NT_GLOBAL/), & - rc=status) - VERIFY_(STATUS) - - deallocate(arbIndex) - - call ESMF_GridCommit(newTileGrid, rc=status) - VERIFY_(STATUS) - - - ! now create a "catch" grid to be the "native" grid for this component - distgrid = ESMF_DistGridCreate(arbSeqIndexList=(/minCatch:maxCatch/), & - rc=status) - VERIFY_(STATUS) - - catchGRID = ESMF_GridEmptyCreate(rc=status) - VERIFY_(STATUS) - - allocate(arbIndex(ims(myPE+1),1), stat=status) - VERIFY_(STATUS) - - arbIndex(:,1) = (/minCatch:maxCatch/) - - call ESMF_GridSet(catchGrid, & - name='catch_grid_for_'//trim(COMP_NAME), & - distgrid=distgrid, & - gridMemLBound=(/1/), & - indexFlag=ESMF_INDEX_USER, & - distDim = (/1/), & - localArbIndexCount=ims(myPE+1), & - localArbIndex=arbIndex, & - minIndex=(/1/), & - maxIndex=(/N_CatG/), & - rc=status) - VERIFY_(STATUS) - - deallocate(arbIndex) - - call ESMF_GridCommit(catchGrid, rc=status) - VERIFY_(STATUS) - - call ESMF_GridCompSet(gc, grid=catchGrid, RC=status) - VERIFY_(STATUS) - - call MAPL_LocStreamGet(locstream, TILEAREA = tile_area_src, RC=status) - VERIFY_(STATUS) - - field0 = ESMF_FieldCreate(grid=tilegrid, datacopyflag=ESMF_DATACOPY_VALUE, & - farrayPtr=tile_area_src, name='TILE_AREA_SRC', RC=STATUS) - VERIFY_(STATUS) - ! create field on the "new" tile grid - allocate(tile_area(ntiles), stat=status) - VERIFY_(STATUS) - field = ESMF_FieldCreate(grid=newtilegrid, datacopyflag=ESMF_DATACOPY_VALUE, & - farrayPtr=tile_area, name='TILE_AREA', RC=STATUS) - VERIFY_(STATUS) - - ! create routehandle - call ESMF_FieldRedistStore(srcField=field0, dstField=field, & - routehandle=route%routehandle, rc=status) - VERIFY_(STATUS) - - ! redist tile_area - call ESMF_FieldRedist(srcField=FIELD0, dstField=FIELD, & - routehandle=route%routehandle, rc=status) - VERIFY_(STATUS) - - call ESMF_FieldDestroy(field, rc=status) - VERIFY_(STATUS) - call ESMF_FieldDestroy(field0, rc=status) - VERIFY_(STATUS) - - ! redist pfaf (NOTE: me might need a second routehandle for integers) - - route%pfaf => arbSeq - route%ntiles = ntiles + call MAPL_LocStreamGet(locstream, TILEAREA = tile_area_src, LOCAL_ID=local_id, RC=status) + VERIFY_(STATUS) + nt_local=size(tile_area_src,1) + route%nt_local=nt_local + ntiles = maxCatch-minCatch+1 + allocate(arbSeq_pf(maxCatch-minCatch+1)) + arbSeq_pf = [(i, i = minCatch, maxCatch)] + route%pfaf => arbSeq_pf + route%ntiles = ntiles route%minCatch = minCatch - route%maxCatch = maxCatch + route%maxCatch = maxCatch + + + call MAPL_GetResource (MAPL, River_RoutingFile, label = 'River_Routing_FILE:', default = 'river_input', RC=STATUS ) + + ! Read sub-catchment data + allocate(nsub_global(N_CatG),subarea_global(nmax,N_CatG)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_nsub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)nsub_global; close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_asub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)subarea_global; close(77) + allocate(nsub(ntiles),subarea(nmax,ntiles)) + nsub=nsub_global(minCatch:maxCatch) + subarea=subarea_global(:,minCatch:maxCatch) + subarea=subarea*1.e6 !km2->m2 + deallocate(nsub_global,subarea_global) + + route%nsub => nsub + route%subarea => subarea + + allocate(subi_global(nmax,N_CatG),subi(nmax,ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_isub_"//trim(resname)//".txt",status="old",action="read");read(77,*)subi_global;close(77) + subi=subi_global(:,minCatch:maxCatch) + route%subi => subi + deallocate(subi_global) + + ! Set variables used in MPI + allocate(scounts(ndes),scounts_global(ndes),rdispls_global(ndes)) + scounts=0 + scounts(mype+1)=nt_local + call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_global, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) + rdispls_global(1)=0 + do i=2,nDes + rdispls_global(i)=rdispls_global(i-1)+scounts_global(i-1) + enddo + deallocate(scounts) + route%scounts_global=>scounts_global + route%rdispls_global=>rdispls_global + + allocate(scounts(ndes),scounts_cat(ndes),rdispls_cat(ndes)) + scounts=0 + scounts(mype+1)=ntiles + call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_cat, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) + rdispls_cat(1)=0 + do i=2,nDes + rdispls_cat(i)=rdispls_cat(i-1)+scounts_cat(i-1) + enddo + deallocate(scounts) + route%scounts_cat=>scounts_cat + route%rdispls_cat=>rdispls_cat + + allocate(runoff_save(1:nt_local)) + route%runoff_save => runoff_save + route%runoff_save=0. + + ! Read tile area data + allocate(tile_area_local(nt_local),tile_area_global(nt_global)) + open(77,file=trim(River_RoutingFile)//"/area_"//trim(resname)//"_1d.txt",status="old",action="read");read(77,*)tile_area_global;close(77) + tile_area_local=tile_area_global(rdispls_global(mype+1)+1:rdispls_global(mype+1)+nt_local)*1.e6 !km2->m2 + route%tile_area => tile_area_local + deallocate(tile_area_global) + + allocate(areacat(1:ntiles)) + areacat=0. + do i=1,ntiles + do j=1,nmax + it=route%subi(j,i) + if(it>0)then + areacat(i)=areacat(i)+route%subarea(j,i) + endif + if(it==0)exit + enddo + enddo + route%areacat=>areacat + + ! Read river network-realated data + allocate(lengsc_global(n_catg),lengsc(ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_lriv_PR.txt",status="old",action="read");read(77,*)lengsc_global;close(77) + lengsc=lengsc_global(minCatch:maxCatch)*1.e3 !km->m + route%lengsc=>lengsc + deallocate(lengsc_global) + + allocate(downid_global(n_catg),downid(ntiles)) + open(77,file=trim(River_RoutingFile)//"/downstream_1D_new_noadj.txt",status="old",action="read");read(77,*)downid_global;close(77) + downid=downid_global(minCatch:maxCatch) + route%downid=>downid + deallocate(downid_global) + + allocate(upid_global(upmax,n_catg),upid(upmax,ntiles)) + open(77,file=trim(River_RoutingFile)//"/upstream_1D.txt",status="old",action="read");read(77,*)upid_global;close(77) + upid=upid_global(:,minCatch:maxCatch) + route%upid=>upid + deallocate(upid_global) + + ! Read restart data + call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) + call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) + write(yr_s,'(I4.4)')YY + write(mon_s,'(I2.2)')MM + write(day_s,'(I2.2)')DD + if(mapl_am_I_root())print *, "init time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS + allocate(wriver(ntiles),wstream(ntiles),wres(ntiles)) + allocate(wriver_global(n_catg),wstream_global(n_catg),wres_global(n_catg)) + open(77,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(77,*)wriver_global;close(77) + else + close(77) + open(78,file=trim(River_RoutingFile)//"/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wriver_global;close(78) + else + close(78) + open(79,file=trim(River_RoutingFile)//"/river_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wriver_global;close(79) + else + close(79) + wriver_global=0. + endif + endif + endif + open(77,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(77,*)wstream_global;close(77) + else + close(77) + open(78,file=trim(River_RoutingFile)//"/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wstream_global;close(78) + else + close(78) + open(79,file=trim(River_RoutingFile)//"/stream_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wstream_global;close(79) + else + close(79) + wstream_global=0. + endif + endif + endif + open(77,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(77,*)wres_global;close(77) + else + close(77) + open(78,file=trim(River_RoutingFile)//"/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wres_global;close(78) + else + close(78) + open(79,file=trim(River_RoutingFile)//"/res_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wres_global;close(79) + else + close(79) + wres_global=0. + endif + endif + endif + if(mapl_am_I_root())print *, "init river storage is: ",sum(wriver_global)/1.e9 + if(mapl_am_I_root())print *, "init stream storage is: ",sum(wstream_global)/1.e9 + if(mapl_am_I_root())print *, "init reservoir storage is: ",sum(wres_global)/1.e9 + wriver=wriver_global(minCatch:maxCatch) + wstream=wstream_global(minCatch:maxCatch) + wres=wres_global(minCatch:maxCatch) + deallocate(wriver_global,wstream_global,wres_global) + route%wstream=>wstream + route%wriver=>wriver + route%reservoir%Wr_res=>wres + + ! accumulated variables for output + allocate(route%wriver_acc(ntiles),route%wstream_acc(ntiles),route%qoutflow_acc(ntiles),route%qsflow_acc(ntiles),route%reservoir%qres_acc(ntiles)) + route%wriver_acc=0. + route%wstream_acc=0. + route%qoutflow_acc=0. + route%qsflow_acc=0. + route%reservoir%qres_acc=0. + + !Read input specially for geometry hydraulic (not required by linear model) + allocate(buff_global(n_catg),route%lstr(ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_lstr_PR.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%lstr=buff_global(minCatch:maxCatch)*1.e3 !km->m + deallocate(buff_global) + + allocate(buff_global(n_catg),route%K(ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%K=buff_global(minCatch:maxCatch) + deallocate(buff_global) + + allocate(buff_global(n_catg),route%Kstr(ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%Kstr=buff_global(minCatch:maxCatch) + deallocate(buff_global) + + allocate(buff_global(n_catg),route%qri_clmt(ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_qri.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%qri_clmt=buff_global(minCatch:maxCatch) !m3/s + deallocate(buff_global) + + allocate(buff_global(n_catg),route%qin_clmt(ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_qin.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%qin_clmt=buff_global(minCatch:maxCatch) !m3/s + deallocate(buff_global) + + allocate(buff_global(n_catg),route%qstr_clmt(ntiles)) + open(77,file=trim(River_RoutingFile)//"/Pfaf_qstr.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%qstr_clmt=buff_global(minCatch:maxCatch) !m3/s + deallocate(buff_global) + + !Initial reservoir module + res => route%reservoir + call res_init(River_RoutingFile,n_catg,ntiles,minCatch,maxCatch,use_res,res%active_res,res%type_res,res%cap_res,res%fld_res,res%Qfld_thres,res%cat2res,res%wid_res) + if(mapl_am_I_root()) print *,"reservoir init success" + + !if (mapl_am_I_root())then + ! open(88,file="nsub.txt",action="write") + ! open(89,file="subarea.txt",action="write") + ! open(90,file="subi.txt",action="write") + ! open(91,file="tile_area.txt",action="write") + ! do i=1,nTiles + ! write(88,*)route%nsub(i) + ! write(89,'(150(1x,f10.4))')route%subarea(:,i) + ! write(90,'(150(i7))')route%subi(:,i) + ! write(91,*)route%tile_area(i) + ! enddo + ! stop + !endif - allocate(ptr2(ntiles), stat=status) - VERIFY_(STATUS) - route%field = ESMF_FieldCreate(grid=newtilegrid, datacopyflag=ESMF_DATACOPY_VALUE, & - farrayPtr=ptr2, name='RUNOFF', RC=STATUS) - VERIFY_(STATUS) - deallocate(ims) call MAPL_GenericInitialize ( GC, import, export, clock, rc=status ) VERIFY_(STATUS) - RETURN_(ESMF_SUCCESS) + RETURN_(ESMF_SUCCESS) end subroutine INITIALIZE + + ! -------------------------------------------------------------------------------- ! ----------------------------------------------------------- ! RUN -- Run method for the route component ! ----------------------------------------------------------- + subroutine RUN1 (GC,IMPORT, EXPORT, CLOCK, RC ) - subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) +! ----------------------------------------------------------- +! !ARGUMENTS: +! ----------------------------------------------------------- + type(ESMF_GridComp), intent(inout) :: GC + type(ESMF_State), intent(inout) :: IMPORT + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(inout) :: CLOCK + integer, optional, intent( out) :: RC + end subroutine RUN1 + + ! -------------------------------------------------------------------------------- + + subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) + ! ----------------------------------------------------------- ! !ARGUMENTS: ! ----------------------------------------------------------- @@ -559,7 +703,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) ! ErrLog Variables ! ----------------------------------------------------------- - character(len=ESMF_MAXSTR) :: IAm="Run" + character(len=ESMF_MAXSTR) :: IAm="Run2" integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME @@ -578,6 +722,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) ! ----------------------------------------------------- real, dimension(:), pointer :: RUNOFF + real, dimension(:), pointer :: RUNOFF_SRC0 ! ----------------------------------------------------- ! INTERNAL pointers @@ -607,6 +752,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Grid) :: TILEGRID type (MAPL_LocStream) :: LOCSTREAM + integer :: NTILES, N_CatL, N_CYC logical, save :: FirstTime=.true. real, pointer, dimension(:) :: tile_area @@ -615,502 +761,462 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) INTEGER, DIMENSION(:,:), POINTER, SAVE :: AllActive,DstCatchID INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: srcProcsID, LocDstCatchID integer, dimension (:),allocatable, SAVE :: GlbActive - INTEGER, SAVE :: N_Active, ThisCycle + INTEGER, SAVE :: N_Active, ThisCycle=1 INTEGER :: Local_Min, Local_Max integer :: K, N, I, req REAL :: mm2m3, rbuff, HEARTBEAT REAL, ALLOCATABLE, DIMENSION(:) :: RUNOFF_CATCH, RUNOFF_ACT,AREACAT_ACT,& - LENGSC_ACT, WSTREAM_ACT,WRIVER_ACT, QSFLOW_ACT,QOUTFLOW_ACT, runoff_save + LENGSC_ACT, QSFLOW_ACT,QOUTFLOW_ACT,QRES_ACT,QOUT_CAT INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_index type(ESMF_Field) :: runoff_src integer :: ndes, mype type (T_RROUTE_STATE), pointer :: route => null() type (RROUTE_wrap) :: wrap - - ! ------------------ - ! begin + INTEGER, DIMENSION(:) ,ALLOCATABLE :: scounts, scounts_global,rdispls, rcounts + real, dimension(:), pointer :: runoff_global,runoff_local,area_local,runoff_cat_global + + integer :: mpierr, nt_global,nt_local, it, j, upid,cid,temp(1),tid,istat + integer,save :: nstep_per_day + + type(ESMF_Time) :: CurrentTime, nextTime + integer :: YY,MM,DD,HH,MMM,SS,YY_next,MM_next,DD_next + character(len=4) :: yr_s + character(len=2) :: mon_s,day_s + + real, pointer :: runoff_save(:)=>NULL() + real, pointer :: WSTREAM_ACT(:)=>NULL() + real, pointer :: WRIVER_ACT(:) =>NULL() + type (RES_STATE), pointer :: res => NULL() + + real, allocatable :: runoff_save_m3(:),runoff_global_m3(:),QOUTFLOW_GLOBAL(:),Qres_global(:) + real, allocatable :: WTOT_BEFORE(:),WTOT_AFTER(:),QINFLOW_LOCAL(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) + real, allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) + real, allocatable :: wriver_global(:),wstream_global(:),qsflow_global(:),wres_global(:) + ! ------------------ + ! begin call ESMF_UserCompGetInternalState ( GC, 'RiverRoute_state',wrap,status ) VERIFY_(STATUS) - route => wrap%ptr ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- call ESMF_GridCompGet(GC, name=COMP_NAME, CONFIG=CF, RC=STATUS ) - VERIFY_(STATUS) - - Iam = trim(COMP_NAME) // "RUN" + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // "RUN2" ! Get my internal MAPL_Generic state ! ----------------------------------------------------------- call MAPL_GetObjectFromGC(GC, MAPL, STATUS) VERIFY_(STATUS) - call MAPL_Get(MAPL, HEARTBEAT = HEARTBEAT, RC=STATUS) VERIFY_(STATUS) - + !if (mapl_am_I_root()) print *, "HEARTBEAT=",HEARTBEAT ! Start timers ! ------------ - call MAPL_TimerOn(MAPL,"RUN") - + call MAPL_TimerOn(MAPL,"RUN2") ! Get parameters from generic state ! --------------------------------- - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS) - VERIFY_(STATUS) - + ! call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS) + ! VERIFY_(STATUS) ! get pointers to inputs variables ! ---------------------------------- + ndes = route%ndes + mype = route%mype + ntiles = route%ntiles + nt_global = route%nt_global + runoff_save => route%runoff_save + nt_local = route%nt_local + res => route%reservoir + ! get the field from IMPORT call ESMF_StateGet(IMPORT, 'RUNOFF', field=runoff_src, RC=STATUS) - VERIFY_(STATUS) - - ! redist RunOff - call ESMF_FieldRedist(srcField=runoff_src, dstField=route%field, & - routehandle=route%routehandle, rc=status) - VERIFY_(STATUS) - - call ESMF_FieldGet(route%field, farrayPtr=RUNOFF, rc=status) - VERIFY_(STATUS) - - pfaf_code => route%pfaf - tile_area => route%tile_area + VERIFY_(STATUS) + call ESMF_FieldGet(runoff_src, farrayPtr=RUNOFF_SRC0, rc=status) + VERIFY_(STATUS) -! get pointers to internal variables -! ---------------------------------- - - call MAPL_GetPointer(INTERNAL, AREACAT , 'AREACAT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, LENGSC , 'LENGSC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DNSTR , 'DNSTR' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, WSTREAM , 'WSTREAM', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, WRIVER , 'WRIVER' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, LRIVERMOUTH, 'LRIVERMOUTH' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ORIVERMOUTH, 'ORIVERMOUTH' , RC=STATUS) - VERIFY_(STATUS) - -! get pointers to EXPORTS -! ----------------------- - - call MAPL_GetPointer(EXPORT, QSFLOW, 'QSFLOW' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QINFLOW, 'QINFLOW' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QOUTFLOW, 'QOUTFLOW', RC=STATUS) - VERIFY_(STATUS) - call MAPL_Get(MAPL, LocStream=LOCSTREAM, RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_LocStreamGet(LOCSTREAM, TILEGRID=TILEGRID, RC=STATUS) VERIFY_(STATUS) - call MAPL_TimerOn ( MAPL, "-RRM" ) + + ! For efficiency, the time step to call the river routing model is set at ROUTE_DT + + N_CYC = ROUTE_DT/HEARTBEAT + RUN_MODEL : if (ThisCycle == N_CYC) then + + !accumulates runoff + runoff_save = runoff_save + RUNOFF_SRC0/real (N_CYC) + + !Gets time used for output and restart + call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) + call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) + call ESMF_ClockGetNextTime(clock, nextTime=nextTime, rc=status) + call ESMF_TimeGet(nextTime, yy=YY_next, mm=MM_next, dd=DD_next, rc=status) + write(yr_s, '(I4.4)')YY + write(mon_s,'(I2.2)')MM + write(day_s,'(I2.2)')DD + + !Collect runoff from all processors + allocate(runoff_global(nt_global)) + call MPI_allgatherv ( & + runoff_save, route%scounts_global(mype+1) ,MPI_REAL, & + runoff_global, route%scounts_global, route%rdispls_global,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + + !Distribute runoff from tile space to catchment space + if(FirstTime.and.mapl_am_I_root()) print *,"nmax=",nmax + allocate(RUNOFF_ACT(ntiles)) + RUNOFF_ACT=0. + do i=1,ntiles + do j=1,nmax + it=route%subi(j,i) + if(it>0)then + RUNOFF_ACT(i)=RUNOFF_ACT(i)+route%subarea(j,i)*runoff_global(it)/1000. + endif + if(it==0)exit + enddo + enddo + + deallocate(runoff_global) - call MAPL_LocStreamGet(LocStream, NT_LOCAL=NTILES, RC=STATUS ) - N_CatL = size(AREACAT) - -!@@ ALLOCATE (pfaf_code (1:NTILES)) ! 9th_coulumn_in_TILFILE - - ! NOTES : - !Need below area and pfaf_index from the .til file (Maybe, they are already in LocStream) - ! - ! TILFILE: /discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0090x6C_DE1440xPE0720/CF0090x6C_DE1440xPE0720-Pfafstetter.til - ! The 8-line header is followed by 1061481 number of rows. - ! do n = 1,475330 - ! read (10,*)type,area, longitude, latitude, ig, jg, cell_frac, integer, & - ! pfaf_code, pfaf_index, pfaf_frac - ! end do - ! - ! where for each tile: - ! (1) type [-] tile type (100-land; 19-lakes; 20-ice) - ! (2) area [x EarthRadius^2 km2] tile area - ! (3) longitude [degree] longitude at the centroid of the tile - ! (4) latitude [degree] latitude at the centroid of the tile - ! (5) ig [-] i-index of the AGCM grid cell where the tile is located - ! (6) jg [-] j-index of the AGCM grid cell where the tile is located - ! (7) cell_frac [-] fraction of the AGCM grid cell - ! (8) integer some integer that matters only for OGCM tiles, I suppose. - ! (9) pfaf_code [-] catchment index (1-291284) after sorting Pfafstetter codes in ascending order - ! (10) pfaf_index[-] catchment index (1-290188) after sorting Pfafstetter codes - ! and removing submerged in ascending order - ! (11) pfaf_frac [-] fraction of the pfafstetter catchment - - !call MAPL_LocStreamGet(LocStream, 9th_coulumn_in_TILFILE=pfaf_code, RC=STATUS ) - - Local_Min = route%minCatch - Local_Max = route%maxCatch - - FIRST_TIME : IF (FirstTime) THEN - - ! Pfafstetter catchment Domain Decomposition : - ! -------------------------------------------- - - ! AllActive : Processor(s) where the catchment is active (identical in any processor). - ! srcProcsID : For all active catchments anywhere tells which processor is the principal owner of the catchment (identical in any processor). - ! DstCatchID : 2-D array contains downstream catchID and downstream processor (identical in any processor) - ! LocDstCatchID : Downstream catchID when for catchments that are local to the processor. - - ndes = route%ndes - mype = route%mype - allocate (AllActive (1:N_CatG, 1: nDEs)) - allocate (DstCatchID(1:N_CatG, 1: nDEs)) - allocate (srcProcsID (1:N_CatG )) - allocate (LocDstCatchID(1:N_CatG )) - - AllActive = -9999 - srcProcsID = -9999 - DstCatchID = -9999 - LocDstCatchID = NINT(DNSTR) + ! Prepares to conduct routing model + allocate (AREACAT_ACT (ntiles)) + allocate (LENGSC_ACT (ntiles)) + allocate (QSFLOW_ACT (ntiles)) + allocate (QOUTFLOW_ACT(ntiles),QRES_ACT(ntiles),QOUT_CAT(ntiles)) - call InitializeRiverRouting(MYPE, nDEs, MAPL_am_I_root(vm),pfaf_code, & - AllActive, DstCatchID, srcProcsID, LocDstCatchID, rc=STATUS) + QRES_ACT=0. + LENGSC_ACT=route%lengsc/1.e3 !m->km + AREACAT_ACT=route%areacat/1.e6 !m2->km2 - VERIFY_(STATUS) + WSTREAM_ACT => route%wstream + WRIVER_ACT => route%wriver - N_Active = count (srcProcsID == MYPE) - allocate (GlbActive(1 : N_Active)) - allocate (tmp_index(1 : N_CatG )) + allocate(WTOT_BEFORE(ntiles)) + WTOT_BEFORE=WSTREAM_ACT+WRIVER_ACT+res%Wr_res - forall (N=1:N_CatG) tmp_index(N) = N + ! Call river_routing_model + ! ------------------------ + !CALL RIVER_ROUTING_LIN (ntiles, RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT, & + ! WSTREAM_ACT,WRIVER_ACT, QSFLOW_ACT,QOUTFLOW_ACT) + + CALL RIVER_ROUTING_HYD (ntiles, & + RUNOFF_ACT, route%lengsc, route%lstr, & + route%qstr_clmt, route%qri_clmt, route%qin_clmt, & + route%K, route%Kstr, & + WSTREAM_ACT,WRIVER_ACT, & + QSFLOW_ACT,QOUTFLOW_ACT) + ! Call reservoir module + do i=1,ntiles + call res_cal(res%active_res(i),QOUTFLOW_ACT(i),res%type_res(i),res%cat2res(i),& + QRES_ACT(i),res%wid_res(i),res%fld_res(i),res%Wr_res(i),res%Qfld_thres(i),res%cap_res(i),real(route_dt)) + enddo + QOUT_CAT = QOUTFLOW_ACT + where(res%active_res==1) QOUT_CAT=QRES_ACT + + ! Collects dishcarge (routing model output) from all processors + allocate(QOUTFLOW_GLOBAL(n_catg)) + call MPI_allgatherv ( & + QOUT_CAT, route%scounts_cat(mype+1) ,MPI_REAL, & + QOUTFLOW_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + + ! Linking discharge as inflow to downstream catchment to adjust river storage + allocate(QINFLOW_LOCAL(ntiles)) + QINFLOW_LOCAL=0. + do i=1,nTiles + do j=1,upmax + if(route%upid(j,i)>0)then + upid=route%upid(j,i) + WRIVER_ACT(i)=WRIVER_ACT(i)+QOUTFLOW_GLOBAL(upid)*real(route_dt) + QINFLOW_LOCAL(i)=QINFLOW_LOCAL(i)+QOUTFLOW_GLOBAL(upid) + else + exit + endif + enddo + enddo - GlbActive = pack (tmp_index, mask = (srcProcsID == MYPE)) + ! Check balance if needed + !call check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUT_CAT,FirstTime,yr_s,mon_s) - ! Initialize the cycle counter and sum (runoff) + ! Update accumulated variables for output + if(FirstTime) nstep_per_day = 86400/route_dt + route%wriver_acc = route%wriver_acc + WRIVER_ACT/real(nstep_per_day) + route%wstream_acc = route%wstream_acc + WSTREAM_ACT/real(nstep_per_day) + route%qoutflow_acc = route%qoutflow_acc + QOUTFLOW_ACT/real(nstep_per_day) + route%qsflow_acc = route%qsflow_acc + QSFLOW_ACT/real(nstep_per_day) + res%qres_acc = res%qres_acc + QRES_ACT/real(nstep_per_day) - allocate (runoff_save (1:NTILES)) + deallocate(RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT,QOUTFLOW_ACT,QINFLOW_LOCAL,QOUTFLOW_GLOBAL,QSFLOW_ACT,WTOT_BEFORE,QRES_ACT,QOUT_CAT) + !initialize the cycle counter and sum (runoff_tile) + WSTREAM_ACT=>NULL() + WRIVER_ACT=>NULL() runoff_save = 0. - ThisCycle = 1 - - FirstTime = .false. - - deallocate (tmp_index) - - ENDIF FIRST_TIME + ThisCycle = 1 - ! For efficiency, the time step to call the river routing model is set at ROUTE_DT - - N_CYC = ROUTE_DT/HEARTBEAT - - RUN_MODEL : if (ThisCycle == N_CYC) then - - runoff_save = runoff_save + runoff/real (N_CYC) + ! output variables + !if(mapl_am_I_root())print *, "nstep_per_day=",nstep_per_day + if(mapl_am_I_root())print *, "Current time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS, ", next MM_next:",MM_next + if(FirstTime)then + if(mapl_am_I_root()) istat = mkdir("../river", int(o'755',c_int16_t)) + endif + if(HH==23)then + allocate(wriver_global(n_catg),wstream_global(n_catg),qoutflow_global(n_catg),qsflow_global(n_catg)) + !call MPI_allgatherv ( & + ! route%wriver_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + !call MPI_allgatherv ( & + ! route%wstream_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + route%qoutflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + qoutflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + !call MPI_allgatherv ( & + ! route%qsflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! qsflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + !open(88,file="../river/river_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + !open(89,file="../river/stream_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(90,file="../river/river_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + !open(91,file="../river/stream_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + !write(88,*)wriver_global(i) + !write(89,*)wstream_global(i) + write(90,*)qoutflow_global(i) + !write(91,*)qsflow_global(i) + enddo + !close(88) + !close(89) + close(90) + !close(91) + !print *, "output river storage is: ",sum(wriver_global)/1.e9 + !print *, "output stream storage is: ",sum(wstream_global)/1.e9 + endif - ! Here we aggreagate GEOS_Catch/GEOS_CatchCN produced RUNOFF from TILES to CATCHMENTS - ! Everything is local to the parallel block. Units: RUNOFF [kg m-2 s-1], - ! RUNOFF_CATCH [m3 s-1] - ! ----------------------------------------------------------------------------------- - - ! Unit conversion - - mm2m3 = MAPL_RADIUS * MAPL_RADIUS / 1000. - - ALLOCATE (RUNOFF_CATCH(1:N_CatG)) - - RUNOFF_CATCH = 0. - - DO N = 1, NTILES - RUNOFF_CATCH (pfaf_code(n)) = RUNOFF_CATCH (pfaf_code(n)) + mm2m3 * RUNOFF_SAVE (N) * TILE_AREA (N) - END DO - - ! Inter-processor communication 1 - ! For catchment-tiles that contribute to the main catchment in some other processor, - ! send runoff to the corresponding srcProcsID(N) - ! ----------------------------------------------------------------------------------- - - do N = Local_Min, Local_Max - - if ((AllActive (N,MYPE+1) > 0).and.(srcProcsID(N) /= MYPE)) then - - rbuff = RUNOFF_CATCH (N) - - call MPI_ISend(rbuff,1,MPI_real,srcProcsID(N),999,MPI_COMM_WORLD,req,status) - call MPI_WAIT (req ,MPI_STATUS_IGNORE,status) - - RUNOFF_CATCH (N) = 0. - - else - - if(srcProcsID(N) == MYPE) then - - do i = 1,nDEs - if((i-1 /= MYPE).and.(AllActive (N,i) > 0)) then - - call MPI_RECV(rbuff,1,MPI_real,i-1,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,status) - RUNOFF_CATCH (N) = RUNOFF_CATCH (N) + rbuff - - endif - end do + if(use_res .eqv. .True.)then + allocate(qres_global(n_catg)) + call MPI_allgatherv ( & + res%qres_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + qres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(92,file="../river/res_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(92,*)qres_global(i) + enddo + close(92) endif + deallocate(qres_global) endif - end do - - ! Now compress and create subsets of arrays that only contain active catchments - ! in the local processor - ! ----------------------------------------------------------------------------- - - if(allocated (LENGSC_ACT ) .eqv. .false.) allocate (LENGSC_ACT (1:N_Active)) - if(allocated (AREACAT_ACT ) .eqv. .false.) allocate (AREACAT_ACT (1:N_Active)) - if(allocated (WSTREAM_ACT ) .eqv. .false.) allocate (WSTREAM_ACT (1:N_Active)) - if(allocated (WRIVER_ACT ) .eqv. .false.) allocate (WRIVER_ACT (1:N_Active)) - if(allocated (QSFLOW_ACT ) .eqv. .false.) allocate (QSFLOW_ACT (1:N_Active)) - if(allocated (QOUTFLOW_ACT) .eqv. .false.) allocate (QOUTFLOW_ACT(1:N_Active)) - if(allocated (RUNOFF_ACT ) .eqv. .false.) allocate (RUNOFF_ACT (1:N_Active)) - - DO N = 1, size (GlbActive) - - I = GlbActive (N) - RUNOFF_ACT (N) = RUNOFF_CATCH (I) - - I = GlbActive (N) - Local_Min + 1 - WSTREAM_ACT (N) = WSTREAM (I) - WRIVER_ACT (N) = WRIVER (I) - LENGSC_ACT (N) = LENGSC (I) - AREACAT_ACT (N) = AREACAT (I) - - END DO - - QSFLOW_ACT = 0. - QOUTFLOW_ACT = 0. - QSFLOW = 0. - QOUTFLOW = 0. - QINFLOW = 0. - - ! Call river_routing_model - ! ------------------------ - - CALL RIVER_ROUTING (N_Active, RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT, & - WSTREAM_ACT,WRIVER_ACT, QSFLOW_ACT,QOUTFLOW_ACT) - - DO N = 1, size (GlbActive) - - I = GlbActive (N) - Local_Min + 1 - - WSTREAM (I) = WSTREAM_ACT (N) - WRIVER (I) = WRIVER_ACT (N) - QSFLOW (I) = QSFLOW_ACT (N) - QOUTFLOW(I) = QOUTFLOW_ACT(N) - - if (LocDstCatchID (GlbActive (N)) == GlbActive (N)) then - ! This catchment drains to the ocean, lake or a sink - ! if(ORIVERMOUTH(... ) > 0) send QOUTFLOW(I) [m3/s] to ORIVERMOUTH(N) th ocean tile - ! if(LRIVERMOUTH(... ) > 0) send QOUTFLOW(I) [m3/s] to LRIVERMOUTH(N) th lake tile - - endif - END DO - - ! Inter-processor communication-2 - ! Update down stream catchments - ! ------------------------------- + deallocate(wriver_global,wstream_global,qoutflow_global,qsflow_global) + route%wriver_acc = 0. + route%wstream_acc = 0. + route%qoutflow_acc = 0. + route%qsflow_acc = 0. + res%qres_acc = 0. + endif - do N = 1,N_CatG - - if ((srcProcsID (N) == MYPE).and.(srcProcsID (LocDstCatchID (N)) == MYPE)) then ! destination is local - - I = LocDstCatchID (N) - Local_Min + 1 ! Downstream index in the local processor - K = N - Local_Min + 1 ! Source index in the local processor - - if(LocDstCatchID (N) /= N) then ! ensure not to refill the reservoir by itself - - QINFLOW(I) = QINFLOW(I) + QOUTFLOW (K) - WRIVER (I) = WRIVER (I) + QOUTFLOW (K) * real(route_dt) + !write restart + if(MM_next/=MM)then + allocate(wriver_global(n_catg),wstream_global(n_catg)) + call MPI_allgatherv ( & + route%wstream, route%scounts_cat(mype+1) ,MPI_REAL, & + wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + route%wriver, route%scounts_cat(mype+1) ,MPI_REAL, & + wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + write(yr_s,'(I4.4)')YY_next + write(mon_s,'(I2.2)')MM_next + write(day_s,'(I2.2)')DD_next + open(88,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(89,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(88,*)wriver_global(i) + write(89,*)wstream_global(i) + enddo + close(88);close(89) + print *, "saved river storage is: ",sum(wriver_global)/1.e9 + print *, "saved stream storage is: ",sum(wstream_global)/1.e9 + endif + if(use_res .eqv. .True.)then + allocate(wres_global(n_catg)) + call MPI_allgatherv ( & + res%Wr_res, route%scounts_cat(mype+1) ,MPI_REAL, & + wres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(90,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(90,*)wres_global(i) + enddo + close(90) + print *, "saved reservoir storage is: ",sum(wres_global)/1.e9 endif - - elseif ((srcProcsID (N) == MYPE).and.(srcProcsID (LocDstCatchID (N)) /= MYPE)) then - - if(srcProcsID (LocDstCatchID (N)) >= 0) then - - ! Send to downstream processor - - K = N - Local_Min + 1 ! Source index in the local processor - - call MPI_ISend(QOUTFLOW(K),1,MPI_real,srcProcsID (LocDstCatchID (N)),999,MPI_COMM_WORLD,req,status) - call MPI_WAIT(req,MPI_STATUS_IGNORE,status) - - endif - - elseif ((srcProcsID (N) /= MYPE).and.(srcProcsID (N) >= 0)) then - - K = srcProcsID (dstCatchID(N,srcProcsID (N)+1)) - - if (k == MYPE) then - - do i = 1,nDEs - - if(MYPE /= i-1) then - - if((srcProcsID (n) == i-1).and.(srcProcsID (dstCatchID(N, i)) == MYPE))then - call MPI_RECV(rbuff,1,MPI_real, srcProcsID (N),999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,status) - K = dstCatchID(N,i) - Local_Min + 1 - QINFLOW (K) = QINFLOW (K) + rbuff - WRIVER (K) = WRIVER (K) + rbuff * real(route_dt) - - endif - endif - end do - endif - + deallocate(wres_global) endif - - end do - - ! initialize the cycle counter and sum (runoff_tile) - runoff_save = 0. - ThisCycle = 1 + deallocate(wriver_global,wstream_global) + endif + if(FirstTime) FirstTime=.False. else - - runoff_save = runoff_save + runoff/real (N_CYC) - + + runoff_save = runoff_save + RUNOFF_SRC0/real (N_CYC) + ThisCycle = ThisCycle + 1 - - endif RUN_MODEL - call MAPL_TimerOff ( MAPL, "-RRM" ) + endif RUN_MODEL + + runoff_save => NULL() ! All done ! -------- + call MAPL_TimerOff ( MAPL, "-RRM" ) + call MAPL_TimerOff(MAPL,"RUN2") + !call MPI_Barrier(MPI_COMM_WORLD, mpierr) - call MAPL_TimerOff(MAPL,"RUN") RETURN_(ESMF_SUCCESS) + end subroutine RUN2 + + ! ------------------------------------------------------------------------------------------------------- - end subroutine RUN - -! --------------------------------------------------------------------------- - - subroutine InitializeRiverRouting(MYPE, numprocs, root_proc, & - pfaf_code, AllActive, AlldstCatchID, srcProcsID, LocDstCatchID, rc) - - implicit none - INTEGER, INTENT (IN) :: MYPE, numprocs - LOGICAL, INTENT (IN) :: root_proc - INTEGER, DIMENSION (:), INTENT (IN) :: pfaf_code - INTEGER, DIMENSION (N_CatG), INTENT (INOUT) :: srcProcsID, LocDstCatchID - INTEGER, DIMENSION (N_CatG,numprocs), INTENT (INOUT) :: Allactive, AlldstCatchID - - INTEGER, DIMENSION(:) ,ALLOCATABLE :: global_buff, scounts, rdispls, rcounts, LocalActive - INTEGER :: N_active, I,J,K,N,i1,i2,NProcs, Local_Min, Local_Max - - integer, optional, intent(OUT):: rc - - integer :: mpierr - character(len=ESMF_MAXSTR), parameter :: Iam='InitializeRiverRouting' - - ! STEP 1: Identify active catchments within the local processor. If the catchment is active in - ! more than 1 processor, choose an owner. - ! -------------------------------------------------------------------------------------------- - - allocate (LocalActive (1:N_CatG)) - LocalActive = -9999 - - Local_Min = minval (pfaf_code) - Local_Max = maxval (pfaf_code) - - do N = 1, size (pfaf_code) - LocalActive(pfaf_code(n)) = pfaf_code(n) - end do - - allocate (global_buff (N_CatG * numprocs)) - allocate (scounts(numprocs),rdispls(numprocs),rcounts(numprocs)) - - scounts = N_CatG - rcounts = N_CatG + subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUTFLOW_ACT,FirstTime,yr_s,mon_s) - rdispls(1) = 0 - global_buff= 0 + type(T_RROUTE_STATE), intent(in) :: route + integer, intent(in) :: ntiles,nt_local + real, intent(in) :: runoff_save(nt_local),WRIVER_ACT(ntiles),WSTREAM_ACT(ntiles),WTOT_BEFORE(ntiles),RUNOFF_ACT(ntiles) + real, intent(in) :: QINFLOW_LOCAL(ntiles),QOUTFLOW_ACT(ntiles) + logical, intent(in) :: FirstTime + character(len=*), intent(in) :: yr_s,mon_s + + ! --------------------------------------------- - do i=2,numprocs - rdispls(i)=rdispls(i-1)+rcounts(i-1) + real,allocatable :: runoff_cat_global(:) + real,allocatable :: runoff_save_m3(:),runoff_global_m3(:) + real,allocatable :: WTOT_AFTER(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) + real,allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) + + integer :: i, nt_global,mype,cid,temp(1),tid,mpierr + real :: wr_error, wr_tot, runf_tot + + nt_global = route%nt_global + mype = route%mype + + allocate(WTOT_AFTER(ntiles),UNBALANCE(ntiles),UNBALANCE_GLOBAL(n_catg),runoff_cat_global(n_catg)) + allocate(QFLOW_SINK(ntiles),QFLOW_SINK_GLOBAL(n_catg),WTOT_BEFORE_GLOBAL(n_catg),WTOT_AFTER_GLOBAL(n_catg)) + allocate(runoff_save_m3(nt_local),runoff_global_m3(nt_global),ERROR(ntiles),ERROR_GLOBAL(n_catg)) + + WTOT_AFTER=WRIVER_ACT+WSTREAM_ACT+route%reservoir%Wr_res + ERROR = WTOT_AFTER - (WTOT_BEFORE + RUNOFF_ACT*route_dt + QINFLOW_LOCAL*route_dt - QOUTFLOW_ACT*route_dt) + !UNBALANCE = abs(ERROR) + !call MPI_allgatherv ( & + ! UNBALANCE, route%scounts_cat(mype+1) ,MPI_REAL, & + ! UNBALANCE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + QFLOW_SINK=0. + do i=1,ntiles + if(route%downid(i)==-1)then + QFLOW_SINK(i) = QOUTFLOW_ACT(i) + endif enddo - call MPI_allgatherv ( & - LocalActive, scounts ,MPI_INTEGER, & - global_buff, rcounts, rdispls,MPI_INTEGER, & + QFLOW_SINK, route%scounts_cat(mype+1) ,MPI_REAL, & + QFLOW_SINK_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & MPI_COMM_WORLD, mpierr) - - do i=1,numprocs - Allactive (:,i) = global_buff((i-1)*N_CatG+1:i*N_CatG) - enddo - - if (root_proc) then - - DO N = 1, N_CatG - NPROCS = count(Allactive(N,:) >= 1) - if(NPROCS > 0)then - if (NPROCS == 1) then - srcProcsID (N) = maxloc(Allactive(N,:),dim=1) - 1 - else - i1 = MAX(N - 5,1) - i2 = MIN(N + 5, N_CatG) - N_active = 0 - do I = 1,numprocs - if(Allactive (N,I) >= 1) then - if(count (Allactive(I1:I2,I) > 0) > N_active) then - N_active = count (Allactive(I1:I2,I) > 0) - J = I - endif - endif - end do - srcProcsID (N) = J - 1 - endif - endif - END DO + call MPI_allgatherv ( & + WTOT_BEFORE, route%scounts_cat(mype+1) ,MPI_REAL, & + WTOT_BEFORE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + WTOT_AFTER, route%scounts_cat(mype+1) ,MPI_REAL, & + WTOT_AFTER_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + runoff_save_m3=runoff_save*route%tile_area/1000. + call MPI_allgatherv ( & + runoff_save_m3, route%scounts_global(mype+1) ,MPI_REAL, & + runoff_global_m3, route%scounts_global, route%rdispls_global,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + RUNOFF_ACT, route%scounts_cat(mype+1) ,MPI_REAL, & + runoff_cat_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(88,file="../runoff_tile_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(runoff_global_m3) + close(88) + open(88,file="../runoff_cat_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(runoff_cat_global) + close(88) + !print *,"sum(runoff_global_m3)=",sum(runoff_global_m3) + !print *,"sum(runoff_cat_global)=",sum(runoff_cat_global) + endif + if(mapl_am_I_root())then + open(88,file="../WTOT_AFTER_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(WTOT_AFTER_GLOBAL) + close(88) + open(88,file="../WTOT_BEFORE_RUNOFF_QSINK_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt + close(88) + wr_error=sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt) + runf_tot=sum(runoff_global_m3)*route_dt + wr_tot=sum(WTOT_AFTER_GLOBAL) + open(88,file="../WTOT_ERROR_2_RUNOFF_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) wr_error/runf_tot + close(88) + open(88,file="../WTOT_ERROR_2_WTOT_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) wr_error/wr_tot + close(88) + !print *,"WTOT_ERROR_2_RUNOFF:",(sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt))/(sum(runoff_global_m3)*route_dt) + endif + call MPI_allgatherv ( & + ERROR, route%scounts_cat(mype+1) ,MPI_REAL, & + ERROR_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + temp = maxloc(abs(ERROR_GLOBAL)) + cid = temp(1) + if(cid>=route%minCatch.and.cid<=route%maxCatch)then + tid=cid-route%minCatch+1 + print *,"my PE is:",mype,", max abs value of ERROR=", ERROR(tid)," at pfafid: ",route%minCatch+tid-1,", W_BEFORE=",WTOT_BEFORE(tid),", RUNOFF=",RUNOFF_ACT(tid)*route_dt,", QINFLOW=",QINFLOW_LOCAL(tid)*route_dt,", QOUTFLOW=",QOUTFLOW_ACT(tid)*route_dt,", W_AFTER=",WTOT_AFTER(tid) endif + !if(FirstTime)then + ! if(mapl_am_I_root())then + ! open(88,file="ERROR_TOTAL.txt",action="write") + ! do i=1,n_catg + ! write(88,*)ERROR_GLOBAL(i) + ! enddo + ! endif + !endif - call MPI_BCAST (srcProcsID, N_CatG, MPI_INTEGER, 0,MPI_COMM_WORLD,mpierr) + deallocate(WTOT_AFTER,UNBALANCE,UNBALANCE_GLOBAL,ERROR,QFLOW_SINK,QFLOW_SINK_GLOBAL,WTOT_BEFORE_GLOBAL,WTOT_AFTER_GLOBAL) + deallocate(runoff_save_m3,runoff_global_m3,ERROR_GLOBAL,runoff_cat_global) - ! STEP 2: reset downstream catchment indeces (from -1 OR 1:291284) of catchments that are - ! in the local processor to full domain indeces. - ! ------------------------------------------------------------------------------------------ - do N = Local_Min, Local_Max - - if(LocalActive (N) >=1) then - - if (LocDstCatchID (N) == -1) then - ! (a) DNST Catch is a sink hole, ocean or lake so water drains to self - LocDstCatchID (N) = N - - endif - - else - - LocDstCatchID (N) = -9999 ! is inactive - - endif - end do + end subroutine check_balance - global_buff= 0 - - call MPI_allgatherv ( & - LocDstCatchID, scounts ,MPI_INTEGER, & - global_buff, rcounts, rdispls,MPI_INTEGER, & - MPI_COMM_WORLD, mpierr) - - do i=1,numprocs - AlldstCatchID (:,i) = global_buff((i-1)*N_CatG+1:i*N_CatG) - enddo - - deallocate (global_buff, scounts, rdispls, rcounts, LocalActive) - RETURN_(ESMF_SUCCESS) - end subroutine InitializeRiverRouting end module GEOS_RouteGridCompMod + +! ======================= EOF ========================================================= + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 new file mode 100644 index 000000000..b1cd63d88 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 @@ -0,0 +1,157 @@ +module interp + +use omp_lib ! Use OpenMP library for parallel processing +use river_read ! Use custom module for reading NetCDF files +implicit none + +private +public :: M36_to_cat ! Make the M36_to_cat function public +public :: M09_to_cat ! Make the M09_to_cat function public + +contains + +!------------------------------------------------------------------------------ +! This function maps runoff data from M36 resolution to catchments (cat) +function M36_to_cat(runoff,nlon,nlat,ncat,inputdir) result(Qrunf) + + integer,intent(in) :: nlon,nlat,ncat ! Input: number of longitude, latitude, and catchments + real*8,intent(in) :: runoff(nlon,nlat) ! Input: runoff array of size (nlon, nlat) + character(len=500),intent(in) :: inputdir ! Input: directory path for input files + real*8 :: Qrunf(ncat) ! Output: runoff mapped to catchments + + real*8,parameter :: small=1.D-12 ! Small value to avoid division by zero + + integer,parameter :: nmax=150 ! Maximum number of sub-areas per catchment + integer,parameter :: nc=291284 ! Total number of catchments + + real*8,allocatable,dimension(:,:) :: subarea,frac ! Arrays for sub-area and fractions + integer,allocatable,dimension(:,:) :: subx,suby ! Arrays for x and y coordinates of sub-areas + real*8,allocatable,dimension(:) :: tot,runfC,fracA ! Arrays for total area, calculated runoff, and fraction + integer,allocatable,dimension(:) :: nsub ! Array for number of sub-areas per catchment + + integer :: i,j,sx,sy ! Loop variables and coordinates for sub-areas + + ! Allocate memory for arrays + allocate(nsub(nc),subarea(nmax,nc),subx(nmax,nc),suby(nmax,nc),tot(nc)) + + ! Read sub-area data from text files + open(77,file=trim(inputdir)//"/Pfaf_nsub_M36.txt"); read(77,*)nsub + open(77,file=trim(inputdir)//"/Pfaf_asub_M36.txt"); read(77,*)subarea + open(77,file=trim(inputdir)//"/Pfaf_xsub_M36.txt"); read(77,*)subx + open(77,file=trim(inputdir)//"/Pfaf_ysub_M36.txt"); read(77,*)suby + open(77,file=trim(inputdir)//"/Pfaf_area.txt"); read(77,*)tot + + ! Allocate memory for fraction array + allocate(frac(nmax,nc)) + + ! Compute fraction of each sub-area relative to the total catchment area + do i=1,nc + frac(:,i)=subarea(:,i)/tot(i) + enddo + + ! Allocate memory for runoff and fraction arrays + allocate(runfC(nc),fracA(nc)) + runfC=0.D0 ! Initialize runoff array to zero + fracA=0.D0 ! Initialize fraction array to zero + + !$OMP PARALLEL default(shared) private(i,j,sx,sy) ! Start OpenMP parallel region + !$OMP DO + ! Loop over all catchments and sub-areas + do i=1,nc + if(nsub(i)>=1)then + do j=1,nsub(i) + sy=suby(j,i) ! Get y-coordinate of the sub-area + sx=subx(j,i) ! Get x-coordinate of the sub-area + ! Check for valid fraction and runoff values + if(frac(j,i)>0.D0.and.runoff(sx,sy)<1.D14)then + runfC(i)=runfC(i)+frac(j,i)*runoff(sx,sy) ! Accumulate runoff for the catchment + fracA(i)=fracA(i)+frac(j,i) ! Accumulate fraction + endif + enddo + endif + enddo + !$OMP END DO + !$OMP END PARALLEL ! End OpenMP parallel region + + ! Convert to kg/s by multiplying by area (in m²) and dividing by time (in seconds) + Qrunf=runfC*(tot*1.D6)/86400.D0 + + ! Deallocate arrays to free memory + deallocate(subarea,subx,suby,tot,frac,& + runfC,fracA,nsub) + +end function M36_to_cat +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! This function maps runoff data from M09 resolution to catchments (cat) +function M09_to_cat(runoff,nlon,nlat,ncat,inputdir) result(Qrunf) + + integer,intent(in) :: nlon,nlat,ncat ! Input: number of longitude, latitude, and catchments + real*8,intent(in) :: runoff(nlon,nlat) ! Input: runoff array of size (nlon, nlat) + character(len=500),intent(in) :: inputdir ! Input: directory path for input files + real*8 :: Qrunf(ncat) ! Output: runoff mapped to catchments + + real*8,parameter :: small=1.D-12 ! Small value to avoid division by zero + + integer,parameter :: nmax=458 ! Maximum number of sub-areas per catchment + integer,parameter :: nc=291284 ! Total number of catchments + + real*8,allocatable,dimension(:,:) :: subarea,frac ! Arrays for sub-area and fractions + integer,allocatable,dimension(:,:) :: subx,suby ! Arrays for x and y coordinates of sub-areas + real*8,allocatable,dimension(:) :: tot,runfC,fracA ! Arrays for total area, calculated runoff, and fraction + integer,allocatable,dimension(:) :: nsub ! Array for number of sub-areas per catchment + + integer :: i,j,sx,sy ! Loop variables and coordinates for sub-areas + + ! Allocate memory for arrays + allocate(nsub(nc),subarea(nmax,nc),subx(nmax,nc),suby(nmax,nc),tot(nc)) + + ! Read sub-area data from text files + open(77,file=trim(inputdir)//"/Pfaf_nsub_M09.txt"); read(77,*)nsub + open(77,file=trim(inputdir)//"/Pfaf_asub_M09.txt"); read(77,*)subarea + open(77,file=trim(inputdir)//"/Pfaf_xsub_M09.txt"); read(77,*)subx + open(77,file=trim(inputdir)//"/Pfaf_ysub_M09.txt"); read(77,*)suby + open(77,file=trim(inputdir)//"/Pfaf_area.txt"); read(77,*)tot + + ! Allocate memory for fraction array + allocate(frac(nmax,nc)) + + ! Compute fraction of each sub-area relative to the total catchment area + do i=1,nc + frac(:,i)=subarea(:,i)/tot(i) + enddo + + ! Allocate memory for runoff and fraction arrays + allocate(runfC(nc),fracA(nc)) + runfC=0.D0 ! Initialize runoff array to zero + fracA=0.D0 ! Initialize fraction array to zero + + !$OMP PARALLEL default(shared) private(i,j,sx,sy) ! Start OpenMP parallel region + !$OMP DO + ! Loop over all catchments and sub-areas + do i=1,nc + do j=1,nsub(i) + sy=suby(j,i) ! Get y-coordinate of the sub-area + sx=subx(j,i) ! Get x-coordinate of the sub-area + ! Check for valid fraction and runoff values + if(frac(j,i)>0.D0.and.runoff(sx,sy)<1.D14.and.runoff(sx,sy)>=0.D0)then + runfC(i)=runfC(i)+frac(j,i)*runoff(sx,sy) ! Accumulate runoff for the catchment + fracA(i)=fracA(i)+frac(j,i) ! Accumulate fraction + endif + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL ! End OpenMP parallel region + + ! Convert to kg/s by multiplying by area (in m²) and dividing by time (in seconds) + Qrunf=runfC*(tot*1.D6)/86400.D0 + + ! Deallocate arrays to free memory + deallocate(subarea,subx,suby,tot,frac,& + runfC,fracA,nsub) + +end function M09_to_cat +!------------------------------------------------------------------------------ + +end module interp \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 new file mode 100644 index 000000000..176757772 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 @@ -0,0 +1,109 @@ +module lake + + +implicit none +private +public :: lake_init, lake_cal + +! Define parameters for small and large lakes +real*8, parameter :: fac_a_slake = 0.003D0 ! Factor for small lakes +real*8, parameter :: fac_b_slake = 0.40D0 ! Exponent for small lakes +real*8, parameter :: fac_a_llake = 0.01D0 ! Factor for large lakes +real*8, parameter :: fac_b_llake = 0.60D0 ! Exponent for large lakes +real*8, parameter :: thr_area_lake = 1D4 ! Threshold lake area (in km^2) + +! Define constants +real*8, parameter :: dt = 86400.D0 ! Time step in seconds (1 day) +real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 + +contains + +!------------------------------ +! Initialization subroutine for lakes +subroutine lake_init(input_dir, use_lake, nc, nlake, nres, active_res, active_lake, area_lake, Wr_lake, Q_lake) + character(len=500),intent(in) :: input_dir + logical, intent(in) :: use_lake ! Flag to use lake module + integer, intent(in) :: nc, nlake, nres ! Number of catchments, lakes, reservoirs + integer, intent(in) :: active_res(nres) ! Active reservoirs + integer, allocatable, intent(inout) :: active_lake(:) ! Active lakes (output) + real*8, allocatable, intent(inout) :: area_lake(:), Wr_lake(:), Q_lake(:) ! Lake areas, water storage, outflow + + integer, allocatable :: flag_valid_laked(:), catid_laked(:) + real*8, allocatable :: area_laked(:) + + integer :: i, cid + + ! Allocate arrays for lake attributes + allocate(flag_valid_laked(nlake), catid_laked(nlake), area_laked(nlake)) + allocate(active_lake(nc), area_lake(nc)) + allocate(Wr_lake(nc), Q_lake(nc)) + + ! Read lake outlet and area data from external files + open(77, file = trim(input_dir)//"/lake_outlet_flag_valid_2097.txt") + read(77, *) flag_valid_laked + open(77, file = trim(input_dir)//"/lake_outlet_catid.txt") + read(77, *) catid_laked + open(77, file = trim(input_dir)//"/lake_outlet_lakearea.txt") + read(77, *) area_laked ! km^2 + + ! Initialize lake attributes to zero + area_lake = 0.D0 + active_lake = 0 + + ! Assign active lakes and their areas based on data + do i = 1, nlake + if (flag_valid_laked(i) == 1) then + cid = catid_laked(i) + active_lake(cid) = 1 + area_lake(cid) = area_laked(i) + endif + enddo + + ! Deactivate lakes where reservoirs are active + where (active_res == 1) active_lake = 0 + + ! If lakes are not being used, set active lakes to zero + if (use_lake .eqv. .False.) active_lake = 0 + +end subroutine lake_init + +!------------------------------ +! Calculation subroutine for lakes +subroutine lake_cal(active_lake, area_lake, Q_lake, Wr_lake, Qout, B1, B2) + integer, intent(in) :: active_lake ! Flag indicating if lake is active + real*8, intent(in) :: area_lake, Qout ! Lake area, outlet flow rate + real*8, intent(inout) :: Q_lake, Wr_lake ! Lake inflow, water storage + real*8, intent(inout) :: B1, B2 ! Output variables (Q_lake, some other parameter) + + real*8 :: alp_lake ! Alpha parameter for lake flow calculation + + ! Process only active lakes + if (active_lake == 1) then + + ! Determine lake type based on area and calculate alpha + if (area_lake >= thr_area_lake) then + alp_lake = fac_a_llake * ( (1.D0 / sqrt(area_lake)) ** fac_b_llake ) / 3600.D0 + else + alp_lake = fac_a_slake * ( (1.D0 / sqrt(area_lake)) ** fac_b_slake ) / 3600.D0 + endif + + ! Compute lake outflow based on alpha and water storage + Q_lake = alp_lake * Wr_lake + + ! Ensure that outflow is non-negative and does not exceed available water + Q_lake = max(0.D0, Q_lake) + Q_lake = min(Q_lake, Wr_lake / dt + Qout) + + ! Update water storage in lake + Wr_lake = Wr_lake + dt * (Qout - Q_lake) + Wr_lake = max(0.D0, Wr_lake) + + ! Assign output values + B1 = Q_lake + B2 = 0.D0 + + endif + +end subroutine lake_cal + +end module lake \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/readme.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/readme.txt new file mode 100644 index 000000000..51eba9619 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/readme.txt @@ -0,0 +1,49 @@ +README - River Routing Model Offline Version +Last Updated: 10/28/2024 +Contact: yujin.zeng@nasa.gov +Overview + +This directory contains the code required to run the offline version of the river routing model. Note that not all files in this directory pertain to the offline model. Key files include: + + run: Script for building and running the model. + ncdioMod.f90: Local NetCDF library. + rwncMod.f90: Local NetCDF I/O library. + interp_M36toPfaf.f90: Interpolation module. + river_io_mod.f90: I/O module. + res_mod.f90: Reservoir module. + lake_mod.f90: Lake module. + river_routing.f90: Main program. + +Running the Offline Model + + Set Directory Paths + In river_io_mod.f90, set: + input_dir: Path for input data, e.g., /discover/nobackup/yzeng3/work/river_routing_model_offline/input/ + runoff_dir: Path for runoff data (e.g., Catchment model 2D output in M36 or M09 resolutions). + Example for M36 resolution: /discover/nobackup/yzeng3/GEOldas_output + output_dir: Path for output data. + + Define Start and End Dates + In river_routing.f90, set step_start (start date) and step_end (end date) as days since January 1, 1990 (Day 1). Ensure these dates align with the runoff forcing period. + + Build and Run + Compile and run the model using: + ./run river_routing.f90 + +Output Format + +The output files are in .txt format, generated daily with date information in each filename. The output variables are as follows: + + Main river discharge (Pfaf_Qr_Kv_*.txt) [m³/s] + Main river storage (Pfaf_Wr_Kv_*.txt) [kg] + Local stream storage (Pfaf_Ws_Kv_*.txt) [kg] + Reservoir outflow (Pfaf_Q_res_Kv_*.txt) [m³/s] (0 for catchments without reservoirs) + Reservoir water storage (Pfaf_Wr_res_Kv_*.txt) [kg] (0 for catchments without reservoirs) + Lake outflow (Pfaf_Q_lake_Kv_*.txt) [m³/s] (0 for catchments without lakes) + Lake water storage (Pfaf_Wr_lake_Kv_*.txt) [kg] (0 for catchments without lakes) + +Each .txt file contains a list of 291,284 values corresponding to catchments indexed from 1 to 291,284. To convert these lists into spatial maps, use the catchment distribution map at 1-minute resolution in CatchIndex from SRTM_PfafData.nc: + + Path: /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/topo/v1/SRTM-TopoData/SRTM_PfafData.nc + +For further assistance, please contact yujin.zeng@nasa.gov. \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 new file mode 100644 index 000000000..77d066bbd --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 @@ -0,0 +1,316 @@ +module reservoir + +use river_read + +implicit none +private +public :: res_init, res_cal + +!----Reservoir module constants---------- + +real*8, parameter :: fac_elec_a = 0.30D0 ! Coefficient for hydropower calculation +real*8, parameter :: fac_elec_b = 2.00D0 ! Exponent for hydropower calculation +real*8, parameter :: fac_irr_a = 0.01D0 ! Coefficient for irrigation calculation (arid areas) +real*8, parameter :: fac_irr_b = 3.00D0 ! Scaling factor for irrigation (arid areas) +real*8, parameter :: fac_sup_a = 0.03D0 ! Coefficient for water supply calculation +real*8, parameter :: fac_sup_b = 2.00D0 ! Exponent for water supply calculation +real*8, parameter :: fac_other_a = 0.20D0 ! Coefficient for other reservoir types +real*8, parameter :: fac_other_b = 2.00D0 ! Exponent for other reservoir types +integer, parameter :: fac_fld = 1 ! Flood control parameter + +real*8, parameter :: dt = 86400.D0 ! Time step in seconds (1 day) + +real*8, parameter :: ai_thres = 0.5D0 ! Aridity index threshold for irrigation reservoirs +real*8, parameter :: rho = 1.D3 ! Water density (kg/m^3) + +!----------------------------------------- + +contains + +!------------------------------------------ +! Initialization subroutine for reservoirs +subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,cap_res,Qavg_res,ai_res,fld_res,Qfld_thres,irr_sea_frac,cat2res,wid_res) + character(len=500),intent(in) :: input_dir + ! Define the number of reservoirs (nres) and the number of catchments (nc) + integer,intent(in) :: nres,nc + ! Logical variable to check if reservoirs are used + logical,intent(in) :: use_res + ! Input/output arrays for reservoir attributes: active reservoirs, types, capacities, etc. + integer,intent(inout),allocatable :: active_res(:),type_res(:),fld_res(:),cat2res(:) + real*8,intent(inout),allocatable :: Wr_res(:),Q_res(:),cap_res(:),Qavg_res(:),ai_res(:),Qfld_thres(:),irr_sea_frac(:,:) + real*8,intent(inout),allocatable :: wid_res(:) + + ! Internal arrays for various reservoir-related data + integer,allocatable,dimension(:) :: flag_grand,catid_grand,elec_grand,irrsup_grand,fld_grand,supply_grand,irr_grand,realuse_grand + integer,allocatable,dimension(:) :: nav_grand,rec_grand,other_grand + real*8,allocatable,dimension(:) :: cap_grand,area_max_res,Qavg_grand,ai_grand,area_grand,power_grand,area_res + real*8,allocatable,dimension(:,:) :: Wres_tar + + ! Define the flood threshold variable and a counter variable + character(len=2) :: fld_thres + integer :: i,cid,rid + +!----------reservoir module-------------- + ! Allocate memory for each array + allocate(flag_grand(nres),catid_grand(nres),active_res(nc)) + allocate(Wr_res(nc),Q_res(nc)) + allocate(elec_grand(nres),type_res(nc),cap_grand(nres),cap_res(nc),area_grand(nres)) + allocate(area_res(nc),area_max_res(nc)) + !allocate(irrsup_grand(nres)) + allocate(fld_grand(nres),fld_res(nc),Qfld_thres(nc),supply_grand(nres)) + allocate(irr_grand(nres)) + allocate(cat2res(nc)) + allocate(nav_grand(nres),rec_grand(nres)) + allocate(other_grand(nres)) + allocate(wid_res(nc)) + allocate(realuse_grand(nres)) + + ! Open reservoir-related data files and read the corresponding arrays + open(77,file=trim(input_dir)//"/catid_dam_corr_aca_grand5000.txt") + read(77,*)catid_grand + open(77,file=trim(input_dir)//"/flag_all_res.txt") + read(77,*)flag_grand + open(77,file=trim(input_dir)//"/cap_max_grand.txt") + read(77,*)cap_grand + cap_grand=cap_grand*1.D6*rho ! Convert capacity from million cubic meters (MCM) to kilograms (kg) + open(77,file=trim(input_dir)//"/hydroelec_grand.txt") + read(77,*)elec_grand + !open(77,file=trim(input_dir)//"/Qavg_res_2016_2020_OL7000.txt") + !read(77,*)Qavg_grand + !Qavg_grand=Qavg_grand*rho ! Convert flow rate from cubic meters per second (m3/s) to kilograms per second (kg/s) + !open(77,file=trim(input_dir)//"/ai_grand.txt") + !read(77,*)ai_grand + !open(77,file=trim(input_dir)//"/irrmainsec_noelec_grand.txt") + !read(77,*)irrsup_grand + open(77,file=trim(input_dir)//"/fldmainsec_grand.txt") + read(77,*)fld_grand + write(fld_thres,'(I2.2)')fac_fld + !open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt") + !read(77,*)Qfld_thres ! Read flood thresholds in cubic meters per second (m3/s) + Qfld_thres=0.D0!Qfld_thres*rho ! Convert threshold from cubic meters per second to kilograms per second (kg/s) + open(77,file=trim(input_dir)//"/watersupply_grand.txt") + read(77,*)supply_grand + open(77,file=trim(input_dir)//"/irr_grand.txt") + read(77,*)irr_grand + open(77,file=trim(input_dir)//"/nav_grand.txt") + read(77,*)nav_grand + open(77,file=trim(input_dir)//"/rec_grand.txt") + read(77,*)rec_grand + open(77,file=trim(input_dir)//"/other_grand.txt") + read(77,*)other_grand + open(77,file=trim(input_dir)//"/area_skm_grand.txt") + read(77,*)area_grand + area_grand=area_grand*1.D6 ! Convert area from square kilometers (km2) to square meters (m2) + !open(77,file=trim(input_dir)//"/power_grand.txt") + !read(77,*)power_grand + + ! Set initial reservoir ID mapping + cat2res=0 + do i=1,nres + if(flag_grand(i)==1)then + cid=catid_grand(i) + cat2res(cid)=i ! Link reservoirs with catchments: multiple reservoirs in a catchment share attributes that can be accessed via cat2res + endif + enddo + + ! Initialize reservoir properties + cap_res = 0.D0 ! Set reservoir capacity to zero + area_res = 0.D0 ! Set reservoir area to zero + area_max_res = 0.D0 ! Set max reservoir area to zero + type_res = 0 ! Set reservoir type to zero + !Qavg_res = 0.D0 ! Set average reservoir flow rate to zero + !ai_res = 0.D0 ! Set irrigation index to zero + fld_res = 0 ! Set flood status to zero + active_res = 0 ! Set active reservoirs to zero + realuse_grand = 0 ! Initialize real use for each reservoir to zero + + ! Loop over all reservoirs + do i = 1, nres + if(flag_grand(i) == 1) then ! If the reservoir is flagged as active + cid = catid_grand(i) ! Get the catchment ID for the reservoir + cap_res(cid) = cap_res(cid) + cap_grand(i) ! Sum up the capacities for reservoirs in the same catchment + area_res(cid) = area_res(cid) + area_grand(i) ! Sum up the areas for reservoirs in the same catchment + !Qavg_res(cid) = Qavg_grand(i) ! Assign average flow rate to the catchment + if(fld_grand(i) == 1) fld_res(cid) = 1 ! Mark the catchment if it has flood control + endif + enddo + + ! Compute reservoir width from area (square root of the area) + wid_res = sqrt(area_res) + + ! Assign reservoir type 6 (Other use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(other_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 6 ! Type 7 for other uses + cat2res(cid) = i ! Map the catchment to the reservoir + area_max_res(cid) = area_grand(i) ! Update the maximum area for the catchment + endif + endif + enddo + + ! Assign reservoir type 5 (Recreational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(rec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 5 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 4 (Navigational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(nav_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 4 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 3 (Water supply) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(supply_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 3 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 2 (Electricity generation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(elec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 2 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + + ! Assign reservoir type 1 (Irrigation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(irr_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 1 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Mark active reservoirs based on type or flood control status + do i = 1, nc + if(type_res(i) /= 0 .or. fld_res(i) == 1) then + active_res(i) = 1 + endif + enddo + + ! Assign real reservoir usage based on type, with error checking + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + rid = cat2res(cid) + if(rid > 0) then + if(type_res(cid) == 0 .and. fld_res(cid) == 0) then + print *, "type_res(cid) == 0" + stop + endif + if(type_res(cid) == 0) then + realuse_grand(i) = -1 ! Invalid reservoir use type + else + realuse_grand(i) = type_res(cid) ! Assign the actual use type + endif + else + print *, "rid == 0" + stop + endif + endif + enddo + + ! Read irrigation and reservoir target data from NetCDF files + ! call read_ncfile_double2d(trim(input_dir)//"/irr_grand_frac.nc", "data", irr_sea_frac, nres, 12) + ! call read_ncfile_double2d(trim(input_dir)//"/Wr_tar_Dang.nc", "data", Wres_tar, 365, nres) + + ! Wres_tar = Wres_tar * 1.D6 * rho ! Convert from million cubic meters (MCM) to kilograms (kg) + + ! Deactivate reservoirs if the use_res flag is set to False + if(use_res .eqv. .False.) active_res = 0 + +end subroutine res_init + +!----------------------- +! Reservoir calculation subroutine +subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,cat2res,Q_res,wid_res,fld_res,Wr_res,Qfld_thres,cap_res,B1,B2) + integer, intent(in) :: active_res, type_res, active_lake, cat2res, fld_res + real*8, intent(in) :: Qout, Q_lake, wid_res, Qfld_thres, cap_res + real*8, intent(inout) :: Q_res, Wr_res, B1, B2 + + integer :: rid ! Reservoir ID + real*8 :: Qin_res, coe, irrfac, alp_res ! Variables for inflow, coefficients, and factors + + ! If the reservoir is active + if (active_res == 1) then + + ! Determine the inflow to the reservoir (from river or lake) + if (active_lake == 0) then + Qin_res = Qout ! Inflow from river + else + Qin_res = Q_lake ! Inflow from lake + endif + + ! Irrigation reservoir + if (type_res == 1) then + alp_res = fac_irr_a * ((1.D0 / (wid_res / 1.D3)) ** fac_irr_b) / 3600.D0 ! irrigation coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage + + ! Hydropower reservoir + else if (type_res == 2) then + alp_res = fac_elec_a * ((1.D0 / (wid_res / 1.D3)) ** fac_elec_b) / 3600.D0 ! Hydropower coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage + + ! Water supply reservoir + else if (type_res == 3) then + alp_res = fac_sup_a * ((1.D0 / (wid_res / 1.D3)) ** fac_sup_b) / 3600.D0 ! Supply coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage + + ! Other reservoir types + else if (type_res == 4 .or. type_res == 5 .or. type_res == 6 .or. type_res == 0) then + alp_res = fac_other_a * ((1.D0 / (wid_res / 1.D3)) ** fac_other_b) / 3600.D0 ! Generic reservoir coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage + endif + + ! Ensure outflow is within reasonable bounds + Q_res = max(0.D0, Q_res) ! Ensure non-negative outflow + Q_res = min(Q_res, Wr_res / dt + Qin_res) ! Limit outflow to prevent exceeding inflow and storage + !if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control + Wr_res = Wr_res + dt * (Qin_res - Q_res) ! Update water storage in the reservoir + Wr_res = max(0.D0, Wr_res) ! Ensure non-negative storage + + ! If the storage exceeds capacity, adjust outflow and storage + if (Wr_res > cap_res) then + Q_res = Q_res + (Wr_res - cap_res) / dt ! Adjust outflow for overflow + Wr_res = cap_res ! Limit storage to reservoir capacity + endif + + ! Output the calculated outflow and zero out the second output variable (B2) + B1 = Q_res + B2 = 0.D0 + + endif + +end subroutine res_cal + +end module reservoir diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 new file mode 100644 index 000000000..ef83a668d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 @@ -0,0 +1,320 @@ +module river_io + +use interp +use river_read + +implicit none +private + +public :: read_input,read_restart,read_runoff,write_output + +real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 +character(len=500) :: input_dir="/discover/nobackup/yzeng3/data/river_input/" ! Directory for input files +character(len=500) :: restart_dir="/discover/nobackup/yzeng3/data/river_restart/" +character(len=500) :: output_dir="/discover/nobackup/yzeng3/river_output/" ! Directory for output files +character(len=500) :: runoff_dir="/discover/nobackup/yzeng3/GEOldas_output/" ! Directory for runoff files + +integer :: nlon=964 !for M36, change to 3856 for M09 +integer :: nlat=406 !for M36, change to 1624 for M09 + +contains + +!------------------------------ +subroutine read_input(nc,ny,upmax,days_in_year,fac_kstr,qstr_clmt,qri_clmt,nts,upID,nup,llc_ori,lstr,qin_clmt,K,Kstr,days_acc_year,days_acc_noleap,days_acc_leap,inputdir) + ! Input parameters: + integer,intent(in) :: nc, ny, upmax ! nc: number of catchments, ny: number of years, upmax: max number of upstream catchments + integer,intent(in) :: days_in_year(ny) ! Array of days in each year + real*8,intent(in) :: fac_kstr ! Scaling factor for streamflow + real*8,intent(out) :: qstr_clmt(nc), qri_clmt(nc) ! Climate streamflow (qstr_clmt) and routing inflow (qri_clmt) in kg/s + integer,intent(out) :: nts(nc), upID(upmax,nc), nup(nc) ! Number of time steps, upstream IDs, and number of upstream catchments + real*8,intent(out) :: llc_ori(nc), lstr(nc), qin_clmt(nc), K(nc), Kstr(nc) ! Original stream length (llc_ori), stream length (lstr), climate inflow (qin_clmt), and hydraulic parameters (K, Kstr) + integer,intent(out) :: days_acc_year(ny), days_acc_noleap(12), days_acc_leap(12) ! Accumulated days in regular and leap years + character(len=500),intent(out) :: inputdir + + ! Days in each month for no-leap and leap years + integer,dimension(12) :: days_in_mon_noleap=(/31,28,31,30,31,30,31,31,30,31,30,31/) + integer,dimension(12) :: days_in_mon_leap=(/31,29,31,30,31,30,31,31,30,31,30,31/) + integer :: i + + inputdir=input_dir + ! Read input data from files + open(77,file=trim(input_dir)//"/Pfaf_qstr.txt") + read(77,*)qstr_clmt ! Read streamflow climatology (m3/s) + qstr_clmt=qstr_clmt*rho ! Convert to kg/s + + open(77,file=trim(input_dir)//"/Pfaf_qri.txt") + read(77,*)qri_clmt ! Read routing inflow (m3/s) + qri_clmt=qri_clmt*rho ! Convert to kg/s + + open(77,file=trim(input_dir)//"/Pfaf_qin.txt") + read(77,*)qin_clmt ! Read climate inflow (m3/s) + qin_clmt=qin_clmt*rho ! Convert to kg/s + + open(77,file=trim(input_dir)//"/Pfaf_tosink.txt") + read(77,*)nts ! Read number of steps to endpoint + + open(77,file=trim(input_dir)//"/upstream_1D.txt") + read(77,*)upID ! Read upstream IDs + + open(77,file=trim(input_dir)//"/Pfaf_upnum.txt") + read(77,*)nup ! Read number of upstream catchments + + open(77,file=trim(input_dir)//"/Pfaf_lriv_PR.txt") + read(77,*)llc_ori ! Read original stream length (km) + llc_ori=llc_ori*1.D3 ! Convert km to meters + + open(77,file=trim(input_dir)//"/Pfaf_lstr_PR.txt") + read(77,*)lstr ! Read stream length (km) + lstr=lstr*1.D3 ! Convert km to meters + + open(77,file=trim(input_dir)//"Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt") + read(77,*)K ! Read hydraulic parameter K + + open(77,file=trim(input_dir)//"Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt") + read(77,*)Kstr ! Read hydraulic parameter Kstr + Kstr=fac_kstr*Kstr ! Apply scaling factor to Kstr + + ! Calculate accumulated days for regular years + days_acc_year(1)=0 + do i=2,ny + days_acc_year(i)=days_acc_year(i-1)+days_in_year(i-1) + end do + + ! Calculate accumulated days for no-leap and leap years + days_acc_noleap(1)=0 + days_acc_leap(1)=0 + do i=2,12 + days_acc_noleap(i)=days_acc_noleap(i-1)+days_in_mon_noleap(i-1) + days_acc_leap(i)=days_acc_leap(i-1)+days_in_mon_leap(i-1) + end do + +end subroutine read_input +!------------------------------ +subroutine read_restart(iter,is_coldstart,ny,nc,days_acc_year,days_acc_noleap,days_acc_leap,Ws,Wr,Wr_res,Wr_lake) + ! Input parameters: + integer,intent(in) :: iter ! Current iteration + logical,intent(inout) :: is_coldstart ! Flag for cold start condition + integer,intent(in) :: ny, nc ! ny: number of years, nc: number of catchments + integer,intent(in) :: days_acc_year(ny), days_acc_noleap(12), days_acc_leap(12) ! Accumulated days for each year and for no-leap/leap years + real*8,intent(inout) :: Ws(nc), Wr(nc), Wr_res(nc), Wr_lake(nc) ! Water storage in soil (Ws), routing (Wr), reservoir (Wr_res), and lake (Wr_lake) + + ! Local variables: + character(len=50) :: iter_s, yr_s, mon_s, day_s ! Strings for iteration, year, month, and day + integer :: step_prev, i, yr_cur, mon_cur, day_cur, d_res ! Step count, loop index, current year, month, day, and day residual + integer :: days_acc_mon(12) ! Accumulated days per month + + ! Convert iteration number to string format + write(iter_s,'(I5.5)')iter + print *,trim(iter_s) + + ! If first iteration or cold start, read initial data + if(iter==1.or.is_coldstart)then + ! Read initial water storage data from files for cold start + open(77,file=trim(restart_dir)//"/Pfaf_Ws_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Ws ! Read soil water storage (Ws) + + open(77,file=trim(restart_dir)//"/Pfaf_Wr_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Wr ! Read routing water storage (Wr) + + !----reservoir module------- + open(77,file=trim(restart_dir)//"/Pfaf_Wr_res_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Wr_res ! Read reservoir water storage (Wr_res) + + !----lake module------------ + open(77,file=trim(restart_dir)//"/Pfaf_Wr_lake_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Wr_lake ! Read lake water storage (Wr_lake) + + ! Set cold start flag to False after initialization + is_coldstart=.False. + + else + ! For non-cold start, calculate the current year and day from the previous iteration + step_prev = iter - 1 + do i = ny, 1, -1 + if(step_prev > days_acc_year(i))then + yr_cur = 1989 + i ! Calculate the current year + d_res = step_prev - days_acc_year(i) ! Calculate residual days + exit + endif + enddo + + ! Determine whether the current year is a leap year + if(mod(yr_cur,4) == 0)then + days_acc_mon = days_acc_leap ! Use leap year days if it is a leap year + else + days_acc_mon = days_acc_noleap ! Use no-leap year days if it is not a leap year + endif + + ! Determine the current month and day from the residual days + do i = 12, 1, -1 + if(d_res > days_acc_mon(i))then + mon_cur = i ! Current month + day_cur = d_res - days_acc_mon(i) ! Current day + exit + endif + enddo + + ! Convert year, month, and day to string format + write(yr_s,'(I4)')yr_cur + write(mon_s,'(I2.2)')mon_cur + write(day_s,'(I2.2)')day_cur + + ! Read water storage data for the specific date (year, month, day) + open(77,file=trim(output_dir)//"/Pfaf_Ws_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Ws ! Read soil water storage (Ws) + + open(77,file=trim(output_dir)//"/Pfaf_Wr_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Wr ! Read routing water storage (Wr) + + !----reservoir module------- + open(77,file=trim(output_dir)//"Pfaf_Wr_res_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Wr_res ! Read reservoir water storage (Wr_res) + + !----lake module------------ + open(77,file=trim(output_dir)//"Pfaf_Wr_lake_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Wr_lake ! Read lake water storage (Wr_lake) + + ! Optionally scale the water storage values (commented out) + ! Ws = Ws * 1.D9 + ! Wr = Wr * 1.D9 + endif + +end subroutine read_restart +!------------------------------ +subroutine read_runoff(nc,ny,iter,days_acc_year,days_acc_noleap,days_acc_leap,Qrunf,yr_s,mon_s,day_s,d_res,mon_cur) + integer,intent(in) :: nc,ny,iter + integer,intent(in) :: days_acc_year(ny),days_acc_noleap(12),days_acc_leap(12) + real*8,intent(inout) :: Qrunf(nc) + character(len=50),intent(inout) :: yr_s,mon_s,day_s + integer,intent(out) :: d_res,mon_cur + + real*8,allocatable,dimension(:,:,:) :: runoff,runoffr,baseflow ! Declare 3D arrays for runoff and baseflow + + integer :: i,yr_cur,day_cur + integer :: days_acc_mon(12) ! Array to store accumulated days for current month + + + ! Determine current year based on iteration days + do i=ny,1,-1 + if(iter>days_acc_year(i))then + yr_cur=1989+i ! Set current year + d_res=iter-days_acc_year(i) ! Calculate residual days + exit + endif + enddo + + ! Set days_acc_mon based on whether the current year is a leap year + if(mod(yr_cur,4)==0)then + days_acc_mon=days_acc_leap ! Use leap year days + else + days_acc_mon=days_acc_noleap ! Use non-leap year days + endif + + ! Determine current month and day based on residual days + do i=12,1,-1 + if(d_res>days_acc_mon(i))then + mon_cur=i ! Set current month + day_cur=d_res-days_acc_mon(i) ! Set current day + exit + endif + enddo + + ! Write current year, month, and day as strings + write(yr_s,'(I4)')yr_cur + write(mon_s,'(I2.2)')mon_cur + write(day_s,'(I2.2)')day_cur + print *,trim(yr_s)," ",trim(mon_s)," ",trim(day_s) + + ! Allocate memory for runoff, runoffr, and baseflow arrays + allocate(runoff(nlon,nlat,1),runoffr(nlon,nlat,1),baseflow(nlon,nlat,1)) + + ! Read runoff and baseflow data from NetCDF files + call read_ncfile_double3d(trim(runoff_dir)//"/Y"//trim(yr_s)//"/M"//trim(mon_s)//"/SMAP_Nature_v10.0_M36.tavg24_2d_lnd_Nx."//trim(yr_s)//trim(mon_s)//trim(day_s)//"_1200z.nc4","RUNOFF",runoff,nlon,nlat,1) + call read_ncfile_double3d(trim(runoff_dir)//"/Y"//trim(yr_s)//"/M"//trim(mon_s)//"/SMAP_Nature_v10.0_M36.tavg24_2d_lnd_Nx."//trim(yr_s)//trim(mon_s)//trim(day_s)//"_1200z.nc4","BASEFLOW",baseflow,nlon,nlat,1) + + ! Combine runoff and baseflow, and convert to daily values + runoff=runoff+baseflow + runoff=runoff*86400.D0 ! Convert to mm/day + + ! Reverse the y-direction of the runoff array + do i=1,406 + runoffr(:,i,:)=runoff(:,407-i,:) + enddo + runoff=runoffr + + ! Convert from mm/day to kg/s and store in Qrunf + Qrunf=M36_to_cat(runoff(:,:,1),nlon,nlat,nc,input_dir) + + ! Deallocate the arrays to free memory + deallocate(runoff,runoffr,baseflow) + + ! The following lines are commented out, but they suggest reading runoff from a text file instead of NetCDF + !open(77,file="/Users/zsp/Desktop/work/river/OL7000_Pfaf/runoff_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt") + !read(77,*)Qrunf + !Qrunf=Qrunf*rho !m3/s -> kg/s + +end subroutine read_runoff +!------------------------------ +subroutine write_output(nc,yr_s,mon_s,day_s,Qout,Ws,Wr,Q_res,Wr_res,Q_lake,Wr_lake) + integer,intent(in) :: nc + character(len=50),intent(in) :: yr_s,mon_s,day_s + real*8,intent(in) :: Qout(nc),Ws(nc),Wr(nc),Q_res(nc),Wr_res(nc),Q_lake(nc),Wr_lake(nc) + + integer :: i + + ! Open file to write Qout (discharge) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Qr_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Qout(i)/1.D3 ! Convert from m^3/s to km^3/s + enddo + + ! Open file to write Ws (soil water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Ws_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Ws(i) ! Write Ws values, unit in kg + enddo + + ! Open file to write Wr (river water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Wr_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Wr(i) ! Write Wr values, unit in kg + enddo + + !-----------reservoir module---------------- + ! Open file to write Q_res (reservoir discharge) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Q_res_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Q_res(i)/1.D3 ! Convert from m^3/s to km^3/s + enddo + + ! Open file to write Wr_res (reservoir water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Wr_res_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Wr_res(i) ! Write Wr_res values, unit in kg + enddo + !------------------------------------------- + + !-----------lake module--------------------- + ! Open file to write Q_lake (lake discharge) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Q_lake_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Q_lake(i)/1.D3 ! Convert from m^3/s to km^3/s + enddo + + ! Open file to write Wr_lake (lake water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Wr_lake_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Wr_lake(i) ! Write Wr_lake values, unit in kg + enddo + !------------------------------------------- + + ! Print out the sum of Wr (river water storage) in petagrams (10^12 kg) + print *,"sum of Wr is ", sum(Wr)/1.D12 + ! Print out the sum of Wr_lake (lake water storage) in petagrams (10^12 kg) + print *,"sum of Wr_lake is ", sum(Wr_lake)/1.D12 + ! Print out the sum of Wr_res (reservoir water storage) in petagrams (10^12 kg) + print *,"sum of Wr_res is ", sum(Wr_res)/1.D12 + +end subroutine write_output + +end module river_io diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_read.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_read.f90 new file mode 100755 index 000000000..c8774b93a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_read.f90 @@ -0,0 +1,219 @@ +module river_read + + implicit none + include 'netcdf.inc' + + public :: read_ncfile_int1d + public :: read_ncfile_real1d + public :: read_ncfile_double1d + + public :: read_ncfile_int2d + public :: read_ncfile_int3d + public :: read_ncfile_real2d + public :: read_ncfile_real3d + public :: read_ncfile_double2d + public :: read_ncfile_double3d + + contains +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + integer, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real*8, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + integer, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double2d + + + subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real*8, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double3d +!------------------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: check_ret +! +! !INTERFACE: + subroutine check_ret(ret, calling) +! !DESCRIPTION: +! Check return status from netcdf call +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: ret + character(len=*) :: calling +! +! !REVISION HISTORY: +! +!EOP +!----------------------------------------------------------------------- + + if (ret /= NF_NOERR) then + write(6,*)'netcdf error from ',trim(calling) + call endrun(nf_strerror(ret)) + end if + + end subroutine check_ret +!----------------------------------------------------------------------- +!BOP +! !IROUTINE: endrun +! +! !INTERFACE: +subroutine endrun(msg,subname) +! +! !DESCRIPTION: +! Abort the model for abnormal termination + implicit none +! !ARGUMENTS: + character(len=*), intent(in), optional :: msg ! string to be printed + character(len=*), intent(in), optional :: subname ! subname + + if (present (subname)) then + write(6,*) 'ERROR in subroutine :', trim(subname) + end if + + if (present (msg)) then + write(6,*)'ENDRUN:', msg + else + write(6,*) 'ENDRUN: called without a message string' + end if + + stop +end subroutine endrun + +!----------------------------------------------------------------------- + +end module river_read + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_routing.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_routing.f90 new file mode 100644 index 000000000..f17167930 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_routing.f90 @@ -0,0 +1,248 @@ +program main + +use omp_lib ! OpenMP library for parallel computing +use reservoir ! Module for reservoir operations +use lake ! Module for lake operations +use river_io ! Module for river input/output + +implicit none + +! Define parameters and constants +real*8, parameter :: small = 1.D-48 ! A small value threshold for numerical comparisons +integer, parameter :: step_start = 9221 ! Start timestep (represents 1990-01-01) +integer, parameter :: step_end = 9226 ! End timestep (adjusted for different ranges) +logical :: is_coldstart = .True. ! Logical flag for cold start +integer, parameter :: ny = 33 ! Number of years (33 years) + +real*8, parameter :: fac_kstr = 0.01D0 ! Factor for local stream scaling +real*8, parameter :: M = 0.45D0 ! Parameter in hydraulic geometry formula +real*8, parameter :: mm = 0.35D0 ! Parameter in hydraulic geometry formula + +real*8, parameter :: dt = 86400.D0 ! Time step in seconds (1 day) + +integer, parameter :: nmax = 373 ! Maximum number of catchments in a river +integer, parameter :: upmax = 34 ! Maximum number of upstream basins +integer, parameter :: nc = 291284 ! Total number of river cells +real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 + +! Declare variables +integer :: i, j, n, iter ! Loop indices and iteration variable + +! Allocate dynamic arrays for variables +integer, allocatable, dimension(:) :: nts ! Array for timestep indices +real*8, allocatable, dimension(:) :: qstr_clmt, qri_clmt, qin_clmt, & + llc_ori, llc, lstr, & + Qrunf, nume, deno, & + alp_s, alp_r, K, Kstr +real*8, allocatable, dimension(:) :: Ws, Wr ! Water storage arrays for stream and river +real*8, allocatable, dimension(:) :: Qs0, ks, Ws_last, Qs, & + Qr0, kr, Cl, Al +real*8, allocatable, dimension(:) :: C1, C2, Qout, Qin, A1, P, B1, B2 +integer, allocatable, dimension(:) :: nup ! Number of upstream nodes +integer, allocatable, dimension(:,:) :: upID ! IDs of upstream cells +real*8 :: co1, co2, co3 ! Coefficients used in calculations +integer :: ui ! Temporary upstream index variable + +real*8, allocatable, dimension(:) :: lon, lat ! Longitude and latitude arrays + +! Reservoir module variables +logical, parameter :: use_res = .True. ! Flag to enable reservoir module +integer, parameter :: nres = 7250 ! Number of reservoirs +integer, allocatable, dimension(:) :: active_res, fld_res, cat2res ! Reservoir attributes +real*8, allocatable, dimension(:) :: Wr_res, Q_res, cap_res, Qavg_res, ai_res, Qfld_thres, wid_res +integer, allocatable, dimension(:) :: type_res ! Type of reservoir (0=inactive, 1-7=different functions) +real*8, allocatable, dimension(:,:) :: irr_sea_frac ! Irrigation and sea fraction for reservoirs + +! Lake module variables +logical, parameter :: use_lake = .True. ! Flag to enable lake module +integer, parameter :: nlake = 3917 ! Number of lakes +integer, allocatable, dimension(:) :: active_lake ! Active lake flag +real*8, allocatable, dimension(:) :: area_lake, Wr_lake, Q_lake ! Lake attributes + +! Time-related variables +integer,dimension(ny) :: days_in_year=(/365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,365/) ! Number of days per year from 1990 to 2020 +integer :: days_acc_year(ny), days_acc_noleap(12), days_acc_leap(12) ! Accumulated days for leap and non-leap years +integer :: yr_cur, mon_cur, day_cur, d_res, step_prev ! Current date variables and previous step +character(len=50) :: yr_s, mon_s, day_s ! Year, month, day strings +character(len=500) :: inputdir ! Input directory path + +! Allocate memory for variables +allocate(nts(nc)) +allocate(qstr_clmt(nc), qri_clmt(nc), qin_clmt(nc)) +allocate(llc_ori(nc), llc(nc), lstr(nc)) +allocate(Qrunf(nc), nume(nc), deno(nc), alp_s(nc), alp_r(nc)) +allocate(Ws(nc), Wr(nc)) +allocate(Qs0(nc), ks(nc), Ws_last(nc), Qs(nc)) +allocate(Qr0(nc), kr(nc), Cl(nc), Al(nc)) +allocate(C1(nc), C2(nc), Qout(nc), Qin(nc), A1(nc), P(nc), B1(nc), B2(nc)) +allocate(nup(nc)) +allocate(upID(upmax,nc)) +allocate(K(nc), Kstr(nc)) + +! Read input data +call read_input(nc, ny, upmax, days_in_year, fac_kstr, qstr_clmt, qri_clmt, nts, upID, nup, llc_ori, lstr, qin_clmt, K, Kstr, days_acc_year, days_acc_noleap, days_acc_leap, inputdir) + +! Initialize reservoir module +call res_init(inputdir, nres, nc, use_res, active_res, Wr_res, Q_res, type_res, cap_res, Qavg_res, ai_res, fld_res, Qfld_thres, irr_sea_frac, cat2res, wid_res) + +! Initialize lake module +call lake_init(inputdir, use_lake, nc, nlake, nres, active_res, active_lake, area_lake, Wr_lake, Q_lake) + +! Calculate llc (length of river channel) +nume = qri_clmt**(2.D0-M) - qin_clmt**(2.D0-M) ! Numerator for the llc calculation +deno = (2.D0-M) * (qri_clmt - qin_clmt) * (qri_clmt**(1.D0-M)) ! Denominator for the llc calculation +where(abs(deno) > small) llc = llc_ori * (nume / deno) ! Compute llc where denominator is not too small +where(abs(deno) <= small) llc = llc_ori * 0.5D0 ! Set llc to half of original value if denominator is small + +! Calculate alp_s (slope coefficient) and alp_r (river coefficient) +where(qstr_clmt > small) alp_s = (rho**(-M) * qstr_clmt**(M-mm) * Kstr * (0.5D0*lstr)**(-1.D0))**(1.D0/(1.D0-mm)) ! For non-zero streamflow +where(qstr_clmt <= small) alp_s = 0.D0 ! If streamflow is too small, set alp_s to 0 + +where(qri_clmt > small) alp_r = (rho**(-M) * qri_clmt**(M-mm) * K * llc**(-1.D0))**(1.D0/(1.D0-mm)) ! For non-zero river input +where(qri_clmt <= small) alp_r = 0.D0 ! If river input is too small, set alp_r to 0 + +!temporal loop +DO iter=step_start,step_end + + ! Read the state of the system from a restart file for the current iteration + call read_restart(iter,is_coldstart,ny,nc,days_acc_year,days_acc_noleap,days_acc_leap,Ws,Wr,Wr_res,Wr_lake) + + ! Read runoff data for the current time step + call read_runoff(nc,ny,iter,days_acc_year,days_acc_noleap,days_acc_leap,Qrunf,yr_s,mon_s,day_s,d_res,mon_cur) + + !$omp parallel default(shared) + !$omp workshare + + ! Update state variables: ks, Ws, and Qs + where(Qrunf<=small)Qrunf=0.D0 ! Set runoff to zero if it's too small + Qs0=max(0.D0,alp_s * Ws**(1.D0/(1.D0-mm))) ! Initial flow from stream storage (kg/s) + ks=max(0.D0,(alp_s/(1.D0-mm)) * Ws**(mm/(1.D0-mm))) ! Flow coefficient (s^-1) + Ws_last=Ws ! Store the current water storage + where(ks>small) Ws=Ws + (Qrunf-Qs0)/ks*(1.D0-exp(-ks*dt)) ! Update storage (kg) + where(ks<=small) Ws=Ws + (Qrunf-Qs0)*dt ! Simplified update if ks is small + Ws=max(0.D0,Ws) ! Ensure storage is non-negative + Qs=max(0.D0,Qrunf-(Ws-Ws_last)/dt) ! Calculate the stream flow (kg/s) + + ! Calculate variables related to river routing: Qr0, kr + Qr0=max(0.D0,alp_r * Wr**(1.D0/(1.D0-mm))) ! River flow based on water storage (kg/s) + kr=max(0.D0,(alp_r/(1.D0-mm)) * Wr**(mm/(1.D0-mm))) ! Flow coefficient for river (s^-1) + + ! Update Cl and Al + where(kr>small.and.abs(kr-ks)>small) Cl=Wr + (Qrunf-Qr0)/kr*(1.D0-exp(-kr*dt)) + (Qrunf-Qs0)/(kr-ks)*(exp(-kr*dt)-exp(-ks*dt)) + where(kr>small.and.abs(kr-ks)<=small) Cl=Wr + (Qrunf-Qr0)/kr*(1.D0-exp(-kr*dt)) - (Qrunf-Qs0)*dt*exp(-kr*dt) + where(kr<=small.and.ks>small) Cl=Wr + (Qrunf-Qr0)*dt - (Qrunf-Qs0)/ks*(1.D0-exp(-ks*dt)) + where(kr<=small.and.ks<=small) Cl=Wr + (Qs0-Qr0)*dt + Al=Qs+Wr/dt-Cl/dt ! Update flow variables + + ! Initialize variables for river routing process + C1=0.D0 + C2=0.D0 + Qin=0.D0 + Qout=0.D0 + A1=0.D0 + P=0.D0 + B1=0.D0 + B2=0.D0 + + !$omp end workshare + !$omp end parallel + + ! Reservoir module: reset reservoir flow + Q_res=0.D0 + if(d_res==366)d_res=365 ! Handle leap year day adjustment + + ! Lake module: reset lake flow + Q_lake=0.D0 + + ! Process river routing by going through each node from upstream to downstream + do n=nmax,0,-1 + + !$OMP PARALLEL default(shared) private(i,j,ui,co1,co2,co3) + !$OMP DO + + ! Loop over each catchment to update the water storage and flow + do i=1,nc + if(nts(i)==n)then ! If the current node matches the iteration step + + ! Process upstream dependencies if any exist + if(nup(i)>=1)then + do j=1,nup(i) + ui=upID(j,i) + if(ui==-1)exit ! Exit loop if no more upstream IDs + + ! Calculate flow coefficients based on flow conditions + if(kr(i)>small)then + co1=max(0.D0,(1.D0-exp(-kr(i)*dt))/kr(i)) + else + co1=dt + endif + C1(i)=C1(i)+co1*B1(ui) + + if(abs(kr(i)-kr(ui))>small)then + co2=-(exp(-kr(i)*dt)-exp(-kr(ui)*dt))/(kr(i)-kr(ui)) + else + co2=dt*exp(-kr(i)*dt) + endif + C2(i)=C2(i)+co2*B2(ui) + + ! Process reservoir and lake flows, if active + if(active_res(ui)==1.and.active_lake(ui)==0)then + Qin(i)=Qin(i)+Q_res(ui) + else if(active_res(ui)==0.and.active_lake(ui)==1)then + Qin(i)=Qin(i)+Q_lake(ui) + else if(active_res(ui)==1.and.active_lake(ui)==1)then + Qin(i)=Qin(i)+Q_res(ui) + else + Qin(i)=Qin(i)+Qout(ui) + endif + enddo + endif + + ! Update water storage in the current node + Wr(i)=max(0.D0,Cl(i)+C1(i)+C2(i)) + A1(i)=Qin(i)-C1(i)/dt-C2(i)/dt + Qout(i)=max(0.D0,Al(i)+A1(i)) + + ! Calculate flow parameters based on river flow characteristics + if(kr(i)>small.and.Qin(i)+Qrunf(i)>small)then + co3=max(0.D0,(1.D0-exp(-kr(i)*dt))/kr(i)) + P(i)=(dt*Qout(i)-co3*Qr0(i))/((Qin(i)+Qrunf(i))*(dt-co3)) + if(P(i)>0.5D0.and.P(i)<1.5D0)then + B1(i)=P(i)*(Qin(i)+Qrunf(i)) + B2(i)=-P(i)*(Qin(i)+Qrunf(i))+Qr0(i) + else + B1(i)=Qout(i) + B2(i)=0.D0 + endif + else + B1(i)=Qout(i) + B2(i)=0.D0 + P(i)=-9999. + endif + + ! Call lake and reservoir calculation subroutines + call lake_cal(active_lake(i),area_lake(i),Q_lake(i),Wr_lake(i),Qout(i),B1(i),B2(i)) + call res_cal(active_res(i),active_lake(i),Qout(i),Q_lake(i),type_res(i),cat2res(i),& + Q_res(i),wid_res(i),fld_res(i),Wr_res(i),Qfld_thres(i),cap_res(i),B1(i),B2(i)) + + endif + enddo + + !$OMP END DO + !$OMP END PARALLEL + + enddo + + ! Write the output for the current time step + call write_output(nc,yr_s,mon_s,day_s,Qout,Ws,Wr,Q_res,Wr_res,Q_lake,Wr_lake) + +ENDDO + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/run b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/run new file mode 100755 index 000000000..d8ec1089f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/run @@ -0,0 +1,22 @@ +#!/bin/bash + +module load comp/intel/2021.3.0 + +if [ $# -lt 1 ]; then + echo "no f90 specified" + exit +fi + +string=$1 +array=(${string//./ }) + +FILENAME=${array[0]} + +NETCDF_PATH=/discover/nobackup/yzeng3/apps/netcdf-4.2.1.1 +LD_LIBRARY_PATH=$NETCDF_PATH/lib:$LD_LIBRARY_PATH + +#ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -L/usr/local/intel/oneapi/2021/compiler/2021.4.0/linux/lib -lnetcdf -lnetcdff -o ${FILENAME}.out + +ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out + +./${FILENAME}.out diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 new file mode 100644 index 000000000..a01fd8e24 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 @@ -0,0 +1,330 @@ +module reservoir + + +implicit none +private +public :: res_init, res_cal + +!----Reservoir module constants---------- +integer,parameter :: nres=7250 +integer,parameter :: nlake=3917 + +real, parameter :: fac_elec_a = 0.30 ! Coefficient for hydropower calculation +real, parameter :: fac_elec_b = 2.00 ! Exponent for hydropower calculation +real, parameter :: fac_irr_a = 0.01 ! Coefficient for irrigation calculation (arid areas) +real, parameter :: fac_irr_b = 3.00 ! Scaling factor for irrigation (arid areas) +real, parameter :: fac_sup_a = 0.03 ! Coefficient for water supply calculation +real, parameter :: fac_sup_b = 2.00 ! Exponent for water supply calculation +real, parameter :: fac_other_a = 0.20 ! Coefficient for other reservoir types +real, parameter :: fac_other_b = 2.00 ! Exponent for other reservoir types +integer, parameter :: fac_fld = 1 ! Flood control parameter + +real, parameter :: fac_a_slake = 0.003 ! Factor for small lakes +real, parameter :: fac_b_slake = 0.40 ! Exponent for small lakes +real, parameter :: fac_a_llake = 0.01 ! Factor for large lakes +real, parameter :: fac_b_llake = 0.60 ! Exponent for large lakes +real, parameter :: thr_wid_lake = 1.e5 ! Threshold lake width (in m) + +real, parameter :: rho = 1.e3 ! Water density (kg/m^3) + +!----------------------------------------- + +contains + +!------------------------------------------ +! Initialization subroutine for reservoirs +subroutine res_init(input_dir,nall,nc,minCatch,maxCatch,use_res,active_res,type_res,cap_res,fld_res,Qfld_thres,cat2res,wid_res) + character(len=*),intent(in) :: input_dir + ! Define the number of reservoirs (nres) and the number of catchments (nc) + integer,intent(in) :: nall,nc,minCatch,maxCatch + ! Logical variable to check if reservoirs are used + logical,intent(in) :: use_res + ! Input/output arrays for reservoir attributes: active reservoirs, types, capacities, etc. + integer,intent(inout),pointer :: active_res(:),type_res(:),fld_res(:),cat2res(:) + real,intent(inout),pointer :: cap_res(:),Qfld_thres(:) + real,intent(inout),pointer :: wid_res(:) + + ! Internal arrays for various reservoir-related data + integer,allocatable,dimension(:) :: flag_grand,catid_grand,elec_grand,fld_grand,supply_grand,irr_grand,realuse_grand + integer,allocatable,dimension(:) :: nav_grand,rec_grand,other_grand + integer,allocatable,dimension(:) :: type_res_all,cat2res_all + real,allocatable,dimension(:) :: cap_grand,area_max_res,Qavg_grand,ai_grand,area_grand,power_grand,area_res + real,allocatable,dimension(:,:) :: Wres_tar + real,pointer :: buff_global(:)=>NULL(),area_all(:)=>NULL() + integer,pointer :: fld_all(:)=>NULL() !buff_global_int(:)=>NULL() + real :: value_max + + integer,allocatable,dimension(:) :: flag_lake,catid_lake + real,allocatable,dimension(:) :: area_lake + + ! Define the flood threshold variable and a counter variable + character(len=2) :: fld_thres + integer :: i,cid,rid + +!----------reservoir module-------------- + ! Allocate memory for each array + allocate(flag_grand(nres),catid_grand(nres),active_res(nc),Qfld_thres(nc)) + allocate(elec_grand(nres),type_res(nc),type_res_all(nall),cap_grand(nres),cap_res(nc),area_grand(nres)) + allocate(area_res(nc),area_max_res(nall)) + allocate(fld_grand(nres),fld_res(nc),supply_grand(nres)) + allocate(irr_grand(nres)) + allocate(cat2res(nc),cat2res_all(nall)) + allocate(nav_grand(nres),rec_grand(nres)) + allocate(other_grand(nres)) + allocate(wid_res(nc)) + allocate(realuse_grand(nres)) + + allocate(flag_lake(nlake),catid_lake(nlake),area_lake(nlake)) + + ! Open reservoir-related data files and read the corresponding arrays + open(77,file=trim(input_dir)//"/catid_dam_corr_aca_grand5000.txt",status="old",action="read") + read(77,*)catid_grand;close(77) + open(77,file=trim(input_dir)//"/flag_all_res.txt",status="old",action="read") + read(77,*)flag_grand;close(77) + open(77,file=trim(input_dir)//"/cap_max_grand.txt",status="old",action="read") + read(77,*)cap_grand;close(77) + cap_grand=cap_grand*1.e6! Convert capacity from million cubic meters (MCM) to m3 + open(77,file=trim(input_dir)//"/hydroelec_grand.txt",status="old",action="read") + read(77,*)elec_grand;close(77) + open(77,file=trim(input_dir)//"/fldmainsec_grand.txt",status="old",action="read") + read(77,*)fld_grand;close(77) + write(fld_thres,'(I2.2)')fac_fld + + open(77,file=trim(input_dir)//"/watersupply_grand.txt",status="old",action="read") + read(77,*)supply_grand;close(77) + open(77,file=trim(input_dir)//"/irr_grand.txt",status="old",action="read") + read(77,*)irr_grand;close(77) + open(77,file=trim(input_dir)//"/nav_grand.txt",status="old",action="read") + read(77,*)nav_grand;close(77) + open(77,file=trim(input_dir)//"/rec_grand.txt",status="old",action="read") + read(77,*)rec_grand;close(77) + open(77,file=trim(input_dir)//"/other_grand.txt",status="old",action="read") + read(77,*)other_grand;close(77) + open(77,file=trim(input_dir)//"/area_skm_grand.txt",status="old",action="read") + read(77,*)area_grand;close(77) + area_grand=area_grand*1.e6 ! Convert area from square kilometers (km2) to square meters (m2) + + allocate(buff_global(nall)) + !open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt");read(77,*)buff_global;close(77) + Qfld_thres=0.!buff_global(minCatch:maxCatch) + deallocate(buff_global) + + !lake input + open(77, file = trim(input_dir)//"/lake_outlet_flag_valid_2097.txt") + read(77, *) flag_lake;close(77) + open(77, file = trim(input_dir)//"/lake_outlet_catid.txt") + read(77, *) catid_lake;close(77) + open(77, file = trim(input_dir)//"/lake_outlet_lakearea.txt") + read(77, *) area_lake;close(77) ! km^2 + area_lake=area_lake*1.e6 + + ! Set initial reservoir ID mapping + cat2res_all=0 + do i=1,nres + if(flag_grand(i)==1)then + cid=catid_grand(i) + cat2res_all(cid)=i ! Link reservoirs with catchments: multiple reservoirs in a catchment share attributes that can be accessed via cat2res + endif + enddo + + ! Initialize reservoir properties + cap_res = 0.0 ! Set reservoir capacity to zero + area_res = 0.0 ! Set reservoir area to zero + area_max_res = 0.0 ! Set max reservoir area to zero + type_res_all = 0 ! Set reservoir type to zero + fld_res = 0 ! Set flood status to zero + active_res = 0 ! Set active reservoirs to zero + realuse_grand = 0 ! Initialize real use for each reservoir to zero + + ! Loop over all reservoirs + allocate(buff_global(nall),fld_all(nall),area_all(nall)) + buff_global=0. + area_all=0. + fld_all=0 + do i = 1, nres + if(flag_grand(i) == 1) then ! If the reservoir is flagged as active + cid = catid_grand(i) ! Get the catchment ID for the reservoir + buff_global(cid) = buff_global(cid) + cap_grand(i) ! Sum up the capacities for reservoirs in the same catchment + area_all(cid) = area_all(cid) + area_grand(i) ! Sum up the areas for reservoirs in the same catchment + !Qavg_res(cid) = Qavg_grand(i) ! Assign average flow rate to the catchment + if(fld_grand(i) == 1) fld_all(cid) = 1 ! Mark the catchment if it has flood control + endif + enddo + cap_res=buff_global(minCatch:maxCatch) + value_max=huge(value_max) + where(cap_res==0.) cap_res=value_max + !area_res=buff_global2(minCatch:maxCatch) + fld_res=fld_all(minCatch:maxCatch) + deallocate(buff_global) + + ! Assign reservoir type 6 (Other use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(other_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 6 + cat2res_all(cid) = i ! Map the catchment to the reservoir + area_max_res(cid) = area_grand(i) ! Update the maximum area for the catchment + endif + endif + enddo + + ! Assign reservoir type 5 (Recreational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(rec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 5 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 4 (Navigational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(nav_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 4 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 3 (Water supply) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(supply_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 3 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 2 (Electricity generation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(elec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 2 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 1 (Irrigation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(irr_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 1 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Set up natural lakes + do i = 1, nlake + if(flag_lake(i) == 1 .and. catid_lake(i) > 0) then + cid = catid_lake(i) + if(type_res_all(cid)==0.and.fld_all(cid)==0)then + type_res_all(cid) = -1 !for lake + cat2res_all(cid) = i + area_all(cid) = area_lake(i) + endif + endif + enddo + + type_res=type_res_all(minCatch:maxCatch) + cat2res=cat2res_all(minCatch:maxCatch) + area_res=area_all(minCatch:maxCatch) + ! Compute reservoir width from area (square root of the area) + wid_res = sqrt(area_res)!m + + ! Mark active reservoirs based on type or flood control status + do i = 1, nc + if(type_res(i) /= 0 .or. fld_res(i) == 1) then + active_res(i) = 1 + endif + enddo + + ! Deactivate reservoirs if the use_res flag is set to False + if(use_res .eqv. .False.) active_res = 0 + + deallocate(flag_grand,catid_grand,elec_grand,type_res_all,cap_grand,area_grand) + deallocate(area_res,area_max_res,fld_grand,supply_grand,irr_grand) + deallocate(cat2res_all,nav_grand,rec_grand,other_grand,realuse_grand) + deallocate(flag_lake,catid_lake,area_lake,area_all,fld_all) + +end subroutine res_init + +!----------------------- +! Reservoir calculation subroutine +subroutine res_cal(active_res,Qout,type_res,cat2res,Q_res,wid_res,fld_res,Wr_res,Qfld_thres,cap_res,dt) + integer, intent(in) :: active_res, type_res, cat2res, fld_res + real, intent(in) :: Qout, wid_res, Qfld_thres, cap_res + real, intent(inout) :: Q_res, Wr_res + real, intent(in) :: dt + + integer :: rid ! Reservoir ID + real :: Qin_res, coe, irrfac, alp_res ! Variables for inflow, coefficients, and factors + + ! If the reservoir is active + if (active_res == 1) then + + ! Determine the inflow to the reservoir + Qin_res = Qout ! Inflow from river + + ! Irrigation reservoir + if (type_res == 1) then + alp_res = fac_irr_a * ((1.0 / (wid_res / 1.e3)) ** fac_irr_b) / 3600.0 ! irrigation coefficient + + ! Hydropower reservoir + else if (type_res == 2) then + alp_res = fac_elec_a * ((1.0 / (wid_res / 1.e3)) ** fac_elec_b) / 3600.0 ! Hydropower coefficient + + ! Water supply reservoir + else if (type_res == 3) then + alp_res = fac_sup_a * ((1.0 / (wid_res / 1.e3)) ** fac_sup_b) / 3600.0 ! Supply coefficient + + ! Other reservoir types + else if (type_res == 4 .or. type_res == 5 .or. type_res == 6 .or. type_res == 0) then + alp_res = fac_other_a * ((1.0 / (wid_res / 1.e3)) ** fac_other_b) / 3600.0 ! Generic reservoir coefficient + + ! Natural lake + else if (type_res == -1) then + ! Determine lake type based on area and calculate alpha + if (wid_res >= thr_wid_lake) then + alp_res = fac_a_llake * ( (1. / (wid_res / 1.e3)) ** fac_b_llake ) / 3600. + else + alp_res = fac_a_slake * ( (1./ (wid_res / 1.e3)) ** fac_b_slake ) / 3600. + endif + + endif + + Q_res = alp_res * Wr_res + + ! Ensure outflow is within reasonable bounds + Q_res = max(0.0, Q_res) ! Ensure non-negative outflow + Q_res = min(Q_res, Wr_res / dt + Qin_res) ! Limit outflow to prevent exceeding inflow and storage + !if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control + Wr_res = Wr_res + dt * (Qin_res - Q_res) ! Update water storage in the reservoir + Wr_res = max(0.0, Wr_res) ! Ensure non-negative storage + + ! If the storage exceeds capacity, adjust outflow and storage + if (Wr_res > cap_res) then + Q_res = Q_res + (Wr_res - cap_res) / dt ! Adjust outflow for overflow + Wr_res = cap_res ! Limit storage to reservoir capacity + endif + + endif + +end subroutine res_cal + +end module reservoir \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 index 4d0f6a2da..d89164d30 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 @@ -3,15 +3,31 @@ MODULE routing_model IMPLICIT NONE private - public :: river_routing, SEARCH_DNST, ROUTE_DT + public :: river_routing_lin, river_routing_hyd, SEARCH_DNST, ROUTE_DT integer , parameter :: ROUTE_DT = 3600 CONTAINS - ! ------------------------------------------------------------------------ + ! Routing Model Input Parameters + ! ------------------------------ + !**** NCAT = NUMBER OF CATCHMENTS IN THE STUDY DOMAIN + !**** RUNCATCH = RUNOFF PRODUCED BY LAND SURFACE MODEL IN THE CATCHMENT [m^3/s] + !**** AREACAT = AREA OF CATCHMENT [km^2] + !**** LENGSC = LENGTHSCALE OF CATCHMENT FOR RIVER CALCULATION [km] + ! Note: We assume LENGSC for stream to river calculation as AREACAT/LENGSC + + ! Routing Model Prognostics + ! ------------------------- + !**** WSTREAM = AMOUNT OF WATER IN "LOCAL STREAM" [m^3] + !**** WRIVER = AMOUNT OF WATER IN RIVER [m^3] + + ! Routing Model Diagnostics + ! ------------------------- + !**** QSFLOW = TRANSFER OF MOISTURE FROM STREAM VARIABLE TO RIVER VARIABLE [m^3/s] + !**** QOUTFLOW = TRANSFER OF RIVER WATER TO THE DOWNSTREAM CATCHMENT [m^3/s] - SUBROUTINE RIVER_ROUTING ( & + SUBROUTINE RIVER_ROUTING_LIN ( & NCAT, & RUNCATCH,AREACAT,LENGSC, & WSTREAM,WRIVER, & @@ -24,32 +40,13 @@ SUBROUTINE RIVER_ROUTING ( & REAL, INTENT(OUT), DIMENSION (NCAT) :: QSFLOW,QOUTFLOW REAL, PARAMETER :: K_SIMPLE = 0.111902, K_RES_MAX = 0.8 ! m1_r2com_c1 + REAL, PARAMETER :: CUR_AVG = 1.4 REAL, PARAMETER :: P1 = 0.010611, P2 = 0.188556, P3 = 0.096864, & - P4 = 0.691310, P5 = 0.365747, P6 = 0.009831 ! m5_calib_240 + P4 = 0.691310, P5 = 0.1, P6 = 0.009831 ! m5_calib_240, ori P5 = 0.365747, INTEGER :: N,I,J REAL :: COEFF, LS, COEFF1, COEFF2,ROFF - ! Routing Model Input Parameters - ! ------------------------------ - !**** NCAT = NUMBER OF CATCHMENTS IN THE STUDY DOMAIN - !**** RUNCATCH = RUNOFF PRODUCED BY LAND SURFACE MODEL IN THE CATCHMENT [m3/s] - !**** AREACAT = AREA OF CATCHMENT [km^2] - !**** LENGSC = LENGTHSCALE OF CATCHMENT FOR RIVER CALCULATION [km] - ! Note: We assume LENGSC for stream to river calculation as AREACAT/LENGSC - - ! Routing Model Prognostics - ! ------------------------- - !**** WSTREAM = AMOUNT OF WATER IN "LOCAL STREAM" [m^3] - !**** WRIVER = AMOUNT OF WATER IN RIVER [m^3] - - ! Routing Model Diagnostics - ! ------------------------- - !**** QSFLOW = TRANSFER OF MOISTURE FROM STREAM VARIABLE TO RIVER VARIABLE [m^3/s] - !**** QINFLOW = TRANSFER OF RIVER WATER FROM UPSTREAM CATCHMENTS [m^3/s] - i.e. sum of - ! QOUTFLOWs from all upstream catchments. This is computed outside this subroutine - !**** QOUTFLOW = TRANSFER OF RIVER WATER TO THE DOWNSTREAM CATCHMENT [m^3/s] - QSFLOW = 0. QOUTFLOW = 0. @@ -58,7 +55,7 @@ SUBROUTINE RIVER_ROUTING ( & ! Updating WSTREAM WSTREAM(N) = WSTREAM(N) + RUNCATCH(N) * REAL (ROUTE_DT) - LS = AREACAT(N) / (AMAX1(1.,LENGSC (N))) + LS = AREACAT(N) / (AMAX1(1.,LENGSC (N))) /4. * CUR_AVG ROFF = RUNCATCH(N) * AREACAT(N) IF(ROFF < 2. ) THEN COEFF = RESCONST (LS, P1, P2) @@ -84,6 +81,7 @@ SUBROUTINE RIVER_ROUTING ( & IF(COEFF > K_RES_MAX) COEFF = K_SIMPLE QOUTFLOW(N) = COEFF * WRIVER(N) + QOUTFLOW(N) = MIN(QOUTFLOW(N), WRIVER(N)) !make WRIVER(N) >=0. WRIVER(N) = WRIVER(N) - QOUTFLOW(N) QOUTFLOW(N) = QOUTFLOW(N) / REAL (ROUTE_DT) @@ -91,7 +89,7 @@ SUBROUTINE RIVER_ROUTING ( & RETURN - END SUBROUTINE RIVER_ROUTING + END SUBROUTINE RIVER_ROUTING_LIN ! ------------------------------------------------------------------------------------------------------- @@ -135,5 +133,114 @@ RECURSIVE SUBROUTINE SEARCH_DNST (K, NCAT_G, DNST, Pfaf_all, DNST_OUT) END SUBROUTINE SEARCH_DNST ! ------------------------------------------------------------------------------------------------------- + ! Routing Model Input Parameters + ! ------------------------------ + !**** NCAT = NUMBER OF CATCHMENTS IN THE STUDY DOMAIN + !**** Qrunf0 = RUNOFF PRODUCED BY LAND SURFACE MODEL IN THE CATCHMENT [m^3/s] + !**** llc_ori = MAIN RIVER LENGTH SCALE [m] + !**** lstr = LOCAL STREAMS LENGTH SCALE [m] + !**** qstr_clmt0= CLIMATOLOGY RUNOFF [m^3/s] + !**** qri_clmt0 = CLIMATOLOGY DISCHAR [m^3/s] + !**** qin_clmt0 = CLIMATOLOGY INFLOW [m^3/s] + !**** K = K PARAMETER FOR MAIN RIVER + !**** Kstr0 = K PARAMETER FOR LOCAL STREAM [m^3/s] + + ! Routing Model Prognostics + ! ------------------------- + !**** Ws0 = AMOUNT OF WATER IN "LOCAL STREAM" [m^3] + !**** Wr0 = AMOUNT OF WATER IN RIVER [m^3] + + ! Routing Model Diagnostics + ! ------------------------- + !**** QS = TRANSFER OF MOISTURE FROM STREAM VARIABLE TO RIVER VARIABLE [m^3/s] + !**** QOUT = TRANSFER OF RIVER WATER TO THE DOWNSTREAM CATCHMENT [m^3/s] + + SUBROUTINE RIVER_ROUTING_HYD ( & + NCAT, & + Qrunf0,llc_ori,lstr, & + qstr_clmt0, qri_clmt0, qin_clmt0, & + K, Kstr0, & + Ws0,Wr0, & + Qs,Qout) + + IMPLICIT NONE + INTEGER, INTENT(IN) :: NCAT + REAL, INTENT(IN), DIMENSION (NCAT) :: Qrunf0,llc_ori,lstr + REAL, INTENT(IN), DIMENSION (NCAT) :: qstr_clmt0,qri_clmt0,qin_clmt0 + REAL, INTENT(IN), DIMENSION (NCAT) :: K, Kstr0 + REAL, INTENT(INOUT),DIMENSION (NCAT) :: Ws0,Wr0 + REAL, INTENT(OUT), DIMENSION (NCAT) :: Qs,Qout + + + + real, parameter :: small = 1.e-20 + real, parameter :: fac_kstr = 0.01 ! Factor for local stream scaling + real, parameter :: M = 0.45 ! Parameter in hydraulic geometry formula + real, parameter :: mm = 0.35 ! Parameter in hydraulic geometry formula + real, parameter :: rho = 1000. + real, parameter :: cur_avg = 1.4 + + real,dimension(NCAT) :: Qrunf,qstr_clmt,qri_clmt,qin_clmt,Ws,Wr,Kstr + real,dimension(NCAT) :: nume,deno,llc,alp_s,alp_r,Qs0,ks,Ws_last + real :: dt + + integer :: i,j + + + Qrunf = Qrunf0 * rho !m3/s -> kg/s + !llc_ori = llc_ori0 * 1.e3 !km -> m + !lstr = lstr0 * 1.e3 !km -> m + qstr_clmt = qstr_clmt0 * rho !m3/s -> kg/s + qri_clmt = qri_clmt0 * rho !m3/s -> kg/s + qin_clmt = qin_clmt0 * rho !m3/s -> kg/s + Ws = Ws0 * rho !m3 -> kg + Wr = Wr0 * rho !m3 -> kg + Kstr = fac_kstr * Kstr0 + dt = ROUTE_DT + + ! Adjust llc (length of river channel) + nume = qri_clmt**(2.-M) - qin_clmt**(2.-M) ! Numerator for the llc calculation + deno = (2.-M) * (qri_clmt - qin_clmt) * (qri_clmt**(1.-M)) ! Denominator for the llc calculation + where(abs(deno) > small) llc = llc_ori * (nume / deno) ! Compute llc where denominator is not too small + where(abs(deno) <= small) llc = llc_ori * 0.5 ! Set llc to half of original value if denominator is small + + ! Calculate alp_s (stream coefficient) and alp_r (river coefficient) + where(qstr_clmt > small) alp_s = (rho**(-M) * qstr_clmt**(M-mm) * Kstr * (0.5*lstr)**(-1.))**(1./(1.-mm)) ! For non-zero streamflow + where(qstr_clmt <= small) alp_s = 0. ! If streamflow is too small, set alp_s to 0 + where(qri_clmt > small) alp_r = (rho**(-M) * qri_clmt**(M-mm) * K * llc**(-1.))**(1./(1.-mm)) ! For non-zero river input + where(qri_clmt <= small) alp_r = 0. ! If river input is too small, set alp_r to 0 + + ! Update state variables: ks, Ws, and Qs + where(Qrunf<=small)Qrunf=0. ! Set runoff to zero if it's too small + Qs0=max(0.,alp_s * Ws**(1./(1.-mm))) ! Initial flow from stream storage (kg/s) + ks=max(0.,(alp_s/(1.-mm)) * Ws**(mm/(1.D0-mm))) ! Flow coefficient (s^-1) + Ws_last=Ws ! Store the current water storage + where(ks>small) Ws=Ws + (Qrunf-Qs0)/ks*(1.-exp(-ks*dt)) ! Update storage (kg) + where(ks<=small) Ws=Ws + (Qrunf-Qs0)*dt ! Simplified update if ks is small + Ws=max(0.,Ws) ! Ensure storage is non-negative + Qs=max(0.,Qrunf-(Ws-Ws_last)/dt) ! Calculate the stream flow (kg/s) + + ! Calculate variables related to river routing: Qr0, kr + Wr=Wr+Qs*dt + Qout=max(0.,alp_r * Wr**(1./(1.-mm))) ! River flow based on water storage (kg/s) + Qout=min(Qout,Wr/dt) + Wr=max(0.,Wr-Qout*dt) + + Ws0 = Ws/rho !kg -> m3 + Wr0 = Wr/rho !kg -> m3 + Qs = Qs/rho !kg/s -> m3/s + Qout = Qout/rho !kg/s -> m3/s + + + RETURN + + END SUBROUTINE RIVER_ROUTING_HYD + + + + +! ------------------------------------------------------------------------------------------------------- + + END MODULE routing_model diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py index b5e651deb..d1dc3b77d 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py @@ -172,6 +172,14 @@ def get_script_mv(grid_type): echo "Successfully copied CO2_MonthlyMean_DiurnalCycle.nc4 to bcs dir." endif +if(-d land/shared/river_input) then + echo "river_input already present in bcs dir." +else + /bin/cp -rp /discover/nobackup/yzeng3/data/river_input land/shared/river_input + echo "Successfully copied river_input to bcs dir." +endif + + # adjust permissions chmod +rX -R geometry land logs diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build new file mode 100755 index 000000000..b411a5dfa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build @@ -0,0 +1,18 @@ +#!/bin/bash + +if [ $# -lt 1 ]; then + echo "no f90 specified" + exit +fi + +string=$1 +array=(${string//./ }) + +FILENAME=${array[0]} + +NETCDF_PATH=/usr/local/other/GEOSpyD/23.5.2-0_py3.11/2023-11-02 +LD_LIBRARY_PATH=${NETCDF_PATH}/lib:$LD_LIBRARY_PATH + +ifort -diag-disable=10448 -qopenmp constant.f90 river_read.f90 k_module_cali.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/constant.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/constant.f90 new file mode 100644 index 000000000..f46edc201 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/constant.f90 @@ -0,0 +1,39 @@ +module constant +!module for constants used in the river routing pre-processing package + + implicit none + public + + ! Define constant parameters + integer,parameter :: nmax09=458 ! Maximum number of sub-catchments per catchment for M09 + integer,parameter :: nmax36=150 ! Maximum number of sub-catchments per catchment for M36 + integer,parameter :: nc=291284 ! Total number of catchments + integer,parameter :: nlon=21600 ! Number of longitude grid points in the original grid + integer,parameter :: nlat=10800 ! Number of latitude grid points in the original grid + integer,parameter :: nlat09=1624, nlon09=3856 ! Dimensions for the M09 grid + integer,parameter :: nlat36=406, nlon36=964 ! Dimensions for the aggregated M36 grid + integer,parameter :: nt_global09=1684725 ! Total number of global tiles for area mapping for M09 + integer,parameter :: nt_global36=112573 ! Total number of global tiles for area mapping for M36 + ! Define grid dimensions for 15-second resolution data (HydroSHEDS high-res grid) + integer,parameter :: nlonh = 86400 + integer,parameter :: nlath = 33600 + + integer,parameter :: nl_USGS = 3352492 ! Total number of USGS data records + integer,parameter :: nt09=1684725, nt36=112573 !Total number of catchment gridcell in M09 and M36 + integer,parameter :: nupmax = 34 ! Maximum number of upstream catchments to record + + !river curve parameters + real,parameter :: cur_avg = 1.4 + real,parameter :: cur_min = 0.5 + real,parameter :: cur_max = 5.0 + + integer,parameter :: nga = 9067 ! Number of GAGE-II records + + !lake input parameters: + integer,parameter :: no = 1459201 ! Total number of outlet records in the outlet files + integer,parameter :: nvl = 3409 ! Number of lakes that pass the filtering criteria (area >= 50) + integer,parameter :: nvo = 3917 ! Number of outlet records after matching with lakes + integer,parameter :: nl_lake = 1426967 ! Total number of lake records in the input files + + +end module constant \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 new file mode 100755 index 000000000..6570fc17c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 @@ -0,0 +1,124 @@ +program main +!Main purpose: Calculates the K parameter used in the river routing model. + + use k_module ! Import custom module "k_module" which contains necessary subroutines and functions + use constant, only: nl=>nl_USGS,nlat,nlon,nc + implicit none + + ! Declare variables and allocatable arrays + integer, allocatable :: lati(:), loni(:) ! Arrays to store grid indices (latitude and longitude) for stations + real, allocatable :: data(:, :) ! 2D data array to store USGS data + integer, allocatable :: catid_full(:), catid(:) ! Arrays to store full and filtered catchment ids for stations + real, allocatable, dimension(:) :: vel, dis ! Arrays to store velocity and distance data from the USGS dataset + integer, allocatable :: nv(:), flag_gageii(:) ! Arrays for number of values per station and GAGE-II validation flags + real, allocatable :: Qclmt_full(:), slp_full(:), KKobs_full(:), KImodel_full(:) + ! climatology discharge (Qclmt), slope (slp), observed K factor (KKobs), and initial appromaxtion of modeled K factor (KImodel) + real, allocatable :: Qclmt(:), slp(:), KKobs(:), KImodel(:) + ! Arrays for filtered parameters after station selection + real, allocatable :: KImodel_all(:) ! Array to store all modeled K values from the dataset + real, allocatable :: lats_full(:), lons_full(:) ! Arrays to store the full latitude and longitude values for the grid + real*8, allocatable :: MU_axis(:), slp_axis(:), clmt_axis(:), p_axis(:) + ! Arrays for parameter axes: M factor (MU), slope exponent (slp_axis), runoff exponent (clmt_axis), and an additional parameter axis (p_axis) + + ! Set model parameters and scaling factors + real :: mm = 0.35, MU = 0.45, exp_slp = 0.2, exp_clmt = -0.2 ! Base model parameters (mm, MU, and exponents for slope and climatology discharge) + !real :: mm=0.4, MU=0.1, exp_slp=0.5, exp_clmt=0.2 ! Alternative parameter set (commented out) + real :: fac_str = 1. ! Scaling factor for stream K + + ! Declare additional integer and real variables for looping and statistical calculations + integer :: nt, ns, np, i, j, k, p, count + real :: ccr(10,10,10), rms(10,10,10) ! 3D arrays to hold correlation coefficients and RMS errors over a parameter space + !real :: ccr(20,10), rms(20,10) ! Alternative array dimensions (commented out) + real :: ccrp, rmsp ! Variables to store computed correlation coefficient and RMS error for a given parameter set + + character(len=900) :: file_vel + character(len=900) :: file_dis + character(len=900) :: file_usid + character(len=900) :: file_lats + character(len=900) :: file_lons + character(len=900) :: file_lat1m + character(len=900) :: file_lon1m + character(len=900) :: file_pfafmap + character(len=900) :: file_gage_id + character(len=900) :: file_gage_acar + + if (command_argument_count() /= 10) then + print *, "no appropriate files found" + stop + endif + call get_command_argument(1, file_vel) + call get_command_argument(2, file_dis) + call get_command_argument(3, file_usid) + call get_command_argument(4, file_lats) + call get_command_argument(5, file_lons) + call get_command_argument(6, file_lat1m) + call get_command_argument(7, file_lon1m) + call get_command_argument(8, file_pfafmap) + call get_command_argument(9, file_gage_id) + call get_command_argument(10, file_gage_acar) + + ! Read USGS data and process it + call read_usgs_data(file_vel, file_dis, nl, data) ! Read USGS data (nl records) into the 2D array "data" + call process_usgs_data(file_usid, nl, ns, data, nv, nt, vel, dis) + ! Process the USGS data to extract the number of stations (ns), velocity, distance + + ! Determine the nearest grid coordinates for each station based on the full grid latitude and longitude arrays + call find_nearest_coords(file_lats, file_lons, file_lat1m, file_lon1m, ns, nlat, nlon, lats_full, lons_full, lati, loni) + + ! Allocate arrays for parameter axes (each with 10 discrete values) + allocate(MU_axis(10), slp_axis(10), clmt_axis(10)) + ! Initialize the correlation and RMS error arrays with a default invalid value + ccr = -9999. + rms = -9999. + count = 0 + ! Set up the parameter axis for MU (M factor): values from 0 to 0.45 in increments of 0.05 + do k = 1, 10 + MU_axis(k) = (k - 1) * 0.05 + enddo + ! Set up the parameter axis for slope exponent: values from 0 to 0.9 in increments of 0.1 + do i = 1, 10 + slp_axis(i) = (i - 1) * 0.1 + enddo + ! Set up the parameter axis for climate exponent: values from -0.8 to 1.2 in increments of 0.2 + do j = 1, 10 + clmt_axis(j) = (j - 1) * 0.2 - 0.8 + enddo + + !do k=1,10 + !do i=1,10 + !do j=1,10 + + ! count = count + 1 ! Increment the count of parameter combinations (currently only one iteration) + + !MU = MU_axis(k) + !exp_slp = slp_axis(i) + !exp_clmt = clmt_axis(j) + +! print *, "count=", count + print *, "M=", MU, ", exp_slp=", exp_slp, ", exp_clmt=", exp_clmt + + ! Retrieve station information and associated parameter data based on grid indices and model parameters + call get_station_inf(file_pfafmap, ns, nc, nlat, nlon, lati, loni, catid_full, Qclmt_full, slp_full, KImodel_all, exp_slp, exp_clmt, fac_str) + ! filtering stations using the GAGE-II dataset criteria + call get_valide_stations_gageii(file_gage_id, file_gage_acar, ns, nc, catid_full, flag_gageii) + ! Perform regression analysis using the USGS data + call regression(nt, vel, dis, nv, ns, Qclmt_full, slp_full, KKobs_full, KImodel_full, exp_slp, exp_clmt, mm, MU) + ! Filter stations based on predefined criteria + call filter_station(nc, ns, np, lats_full, lons_full, Qclmt_full, slp_full, catid_full, KKobs_full, KImodel_full, Qclmt, slp, catid, KKobs, KImodel, flag_gageii) + ! Calculate the modeled K parameter for each station + !call cal_Kmodel(ns, np, nc, MU, exp_slp, exp_clmt, Qclmt, slp, KKobs, KImodel, KImodel_all, catid, catid_full, ccr(k,i,j), rms(k,i,j)) + call cal_Kmodel(ns, np, nc, MU, exp_slp, exp_clmt, Qclmt, slp, KKobs, KImodel, KImodel_all, catid, catid_full, ccrp, rmsp) + + ! Print the computed correlation coefficient and RMS error + print *, "ccr=", ccrp + print *, "rms=", rmsp + + !enddo + !enddo + !enddo + + ! The following calls would write the 3D parameter space results to NetCDF files (currently commented out) + !call create_ncfile_real3d("ccr_clmtxslpxMU_10x10x10_mm0p35.nc", "data", ccr, MU_axis, slp_axis, clmt_axis, 10, 10, 10) + !call create_ncfile_real3d("rms_clmtxslpxMU_10x10x10_mm0p35.nc", "data", rms, MU_axis, slp_axis, clmt_axis, 10, 10, 10) + +end program main \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 new file mode 100644 index 000000000..69200c82b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 @@ -0,0 +1,206 @@ +program main +!main purpose: Reads the Pfafstetter code dataset and generates files for the connectivity of catchments in the routing network. + + use constant, only: nc, nupmax + + implicit none + + ! Declare allocatable arrays for routing and Pfafstetter information: + integer, allocatable, dimension(:) :: downid, finalid + real*8, allocatable, dimension(:) :: pfaf ! Pfafstetter number for each catchment + integer, allocatable, dimension(:,:) :: pfaf_digit, upstream + integer*8, allocatable, dimension(:) :: res ! Temporary storage for digit extraction + integer, allocatable, dimension(:) :: pfaf_last, pfaf_msk, code, behind + integer, allocatable, dimension(:) :: first, last, nup, nts, nts_old + real, allocatable, dimension(:) :: pfaf_area, pfaf_acar, pfaf_acar_old + + ! Declare loop and temporary variables: + integer :: i, j, jj, k, p, down, cur, idx, num, ok, samed, did, nmax + integer :: fulli(12), fullj(12) + real :: val(5) + + ! Define file path for input routing data: + character(len=900) :: file_path !"input/Pfafcatch-routing.dat" + + if (command_argument_count() /= 1) then + print *, "no found" + stop + endif + call get_command_argument(1, file_path) + + !--------------------------------------------------------------------------- + ! Read routing data from the input file: + open(77, file=trim(file_path), form="formatted", status="old") + read(77, *) num + + ! Allocate arrays based on the total number of catchments (nc): + allocate(downid(nc), finalid(nc), pfaf(nc), pfaf_digit(nc,12), res(nc), & + pfaf_last(nc), pfaf_msk(nc), pfaf_area(nc)) + allocate(first(nc), last(nc)) + + do i = 1, nc + read(77, *) idx, pfaf(i), val(1:5), pfaf_area(i) + end do + + !--------------------------------------------------------------------------- + ! Separate the Pfafstetter number into its 12 individual digits. + res = int8(pfaf) ! Convert Pfafstetter numbers to 64-bit integers + pfaf_digit(:,1) = res / (int8(10) ** int8(11)) + do i = 2, 12 + res = res - int8(10) ** int8(13-i) * int8(pfaf_digit(:, i-1)) + pfaf_digit(:, i) = res / (int8(10) ** int8(12-i)) + end do + + !--------------------------------------------------------------------------- + ! Determine the positions of the last nonzero digit (pfaf_last) + ! and the position of the last digit that is not 1 (stored in 'last'). + first = 2 ! Initialize 'first' to 2 by default + last = 2 ! Initialize 'last' to 2 by default + do i = 1, nc + do j = 12, 1, -1 + if (pfaf_digit(i, j) /= 0) then + pfaf_last(i) = j + do k = 0, j-1 + if (pfaf_digit(i, j-k) /= 1) then + last(i) = j - k + exit + endif + end do + exit + endif + end do + end do + do i = 1, nc + if (last(i) <= 1) last(i) = 2 + end do + + !--------------------------------------------------------------------------- + ! Determine the position of the final zero that has nonzero digits after it. + do i = 1, nc + do j = last(i), 2, -1 + if (pfaf_digit(i, j) == 0) then + first(i) = j + exit + endif + end do + end do + + !--------------------------------------------------------------------------- + ! Determine the immediate downstream catchment for each catchment. + do i = 1, nc + + if (first(i) > last(i) - 1) then + ! No valid downstream digit exists; mark as terminal (sink) + downid(i) = -1 + else + + allocate(code(1 : last(i) - first(i))) + code = pfaf_digit(i, first(i) : last(i)-1) + if (any(code == 2) .or. any(code == 4) .or. any(code == 6) .or. any(code == 8)) then + ! If any digit in the extracted part is even, then the catchment is non-coastal. + fulli = pfaf_digit(i, :) + do j = i-1, 1, -1 ! Loop backward to find a catchment just downstream of catchment i + ok = 1 + fullj = pfaf_digit(j, :) + samed = 0 + do k = 1, min(pfaf_last(i), pfaf_last(j)) + if (fulli(k) == fullj(k)) then + samed = samed + 1 + else + exit + endif + end do ! End of k loop: number of matching leading digits stored in 'samed' + if (samed + 1 <= pfaf_last(j)) then + ! Check that none of catchment j's remaining digits (after the common part) + ! are even, which would indicate a branching downstream. + allocate(behind(1 : pfaf_last(j) - samed)) + behind = fullj(samed+1 : pfaf_last(j)) + if (any(mod(behind, 2) == 0)) ok = 0 + deallocate(behind) + else + ok = 0 + endif + if (ok == 1) then + downid(i) = j ! Found the immediate downstream catchment for catchment i + exit + endif + end do ! End of j loop + else + downid(i) = -1 ! If extracted digits are not even, mark as sink (or coastal) + endif + deallocate(code) + + endif ! End if for determining downstream catchment for catchment i + + end do + + !--------------------------------------------------------------------------- + ! Write the downstream catchment IDs to an output file: + open(88, file="output/downstream_1D_new_noadj.txt") + do i = 1, nc + write(88, *) downid(i) + end do + + ! Write catchment areas to an output file: + open(88, file="output/Pfaf_area.txt") + do i = 1, nc + write(88, *) pfaf_area(i) + end do + + !--------------------------------------------------------------------------- + ! Build an upstream connectivity matrix: + allocate(upstream(nupmax, nc), nup(nc)) + nup = 0 + upstream = -1 + do i = 1, nc + did = downid(i) + if (did >= 1) then + nup(did) = nup(did) + 1 + upstream(nup(did), did) = i + end if + end do + open(88, file="output/upstream_1D.txt") + do i = 1, nc + write(88, '(34(I8))') upstream(:, i) + end do + open(88, file="output/Pfaf_upnum.txt") + do i = 1, nc + write(88, *) nup(i) + end do + + !--------------------------------------------------------------------------- + ! Calculate the number of steps (nts) from each catchment to the sink: + allocate(nts(nc), pfaf_acar(nc)) + nts = -9999 + do i = 1, nc + k = 0 + cur = i + do while (downid(cur) /= -1) + k = k + 1 + cur = downid(cur) + end do + nts(i) = k + end do + open(88, file="output/Pfaf_tosink.txt") + do i = 1, nc + write(88, *) nts(i) + end do + + !--------------------------------------------------------------------------- + ! Aggregate catchment areas along the flow network: + nmax = maxval(nts) + pfaf_acar = pfaf_area + do j = nmax, 1, -1 + do i = 1, nc + if (nts(i) == j) then + did = downid(i) + pfaf_acar(did) = pfaf_acar(did) + pfaf_acar(i) + endif + end do + end do + open(88, file="temp/Pfaf_acar.txt") + do i = 1, nc + write(88, *) pfaf_acar(i) + end do + +end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 new file mode 100644 index 000000000..853429c74 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 @@ -0,0 +1,184 @@ +program main +!Main purpose: Reads SMAP L4 runoff data (2016–2023) from a NetCDF file and computes the climatological mean discharge for each catchment. + + use omp_lib + use river_read + use constant, only : nlat=>nlat09, nlon=>nlon09, nc, nupmax + + implicit none + + ! Define variables: + real, allocatable :: runoff(:,:), qrunf(:), temp(:,:), qri(:), qin(:) + integer, allocatable :: nts(:), downid(:), upstream(:,:) + integer :: i, j, nmax, did + + character(len=900) :: file_path !"input/SMAPL4_OL7000_runoff_mean_2016_2023.nc" + + if (command_argument_count() /= 1) then + print *, "no found" + stop + endif + call get_command_argument(1, file_path) + + ! Allocate arrays for runoff (grid), catchment runoff, and a temporary grid array: + allocate(runoff(nlon, nlat), qrunf(nc), temp(nlon, nlat)) + + ! Read the "mean_runoff_flux" variable from the NetCDF file: + call read_ncfile_real2d(trim(file_path), "mean_runoff_flux", runoff, nlon, nlat) + ! Replace missing values (-9999) with 0: + where(runoff == -9999.) runoff = 0. + + ! Flip the grid vertically (reverse the latitude order) and assign back to runoff: + temp = runoff(:, nlat:1:-1) + runoff = temp + + ! Convert runoff from [mm/s] to [mm/d] + runoff = runoff * 86400. + + ! Map runoff from the M09 grid to catchments using the function M09_to_cat. + ! The result is in kg/s; then convert to m^3/s by dividing by 1.e3. + qrunf = M09_to_cat(runoff, nlon, nlat, nc) ! kg/s + qrunf = qrunf / 1.e3 ! m^3/s + + ! Write catchment runoff (qrunf): + open(88, file="output/Pfaf_qstr.txt") + do i = 1, nc + write(88, *) qrunf(i) + end do + + ! Allocate arrays for "steps to sink" (nts), downstream id (downid) and aggregated runoff (qri): + allocate(nts(nc), downid(nc), qri(nc)) + ! Read the number of steps to sink for each catchment from file: + open(77, file="output/Pfaf_tosink.txt") + read(77, *) nts + ! Read the downstream connectivity (immediate downstream catchment id) from file: + open(77, file="output/downstream_1D_new_noadj.txt") + read(77, *) downid + + ! Get the maximum number of steps among all catchments: + nmax = maxval(nts) + ! Initialize qri with the catchment runoff values: + qri = qrunf + ! Aggregate runoff upstream: For each catchment with a given number of steps j, + ! add its runoff to its downstream catchment. + do j = nmax, 1, -1 + do i = 1, nc + if (nts(i) == j) then + did = downid(i) + qri(did) = qri(did) + qri(i) + endif + end do + end do + + ! Write the aggregated runoff (qri) to file "Pfaf_qri.txt": + open(88, file="output/Pfaf_qri.txt") + do i = 1, nc + write(88, *) qri(i) + end do + + ! Allocate arrays for upstream connectivity and inlet discharge (qin): + allocate(upstream(nupmax, nc), qin(nc)) + ! Read upstream connectivity information from file "upstream_1D.txt": + open(77, file="output/upstream_1D.txt") + read(77, *) upstream + ! Initialize qin to -9999: + qin = -9999. + ! For catchments that have upstream connectivity (upstream(1,:) /= -1), + ! set qin as the difference between outlet discharge (qri) and runoff (qrunf); + ! for catchments with no upstream (upstream(1,:) == -1), set qin to half of direct runoff. + where(upstream(1,:) /= -1) qin = qri - qrunf + where(upstream(1,:) == -1) qin = qrunf / 2. + + ! Write the inlet discharge (qin): + open(88, file="output/Pfaf_qin.txt") + do i = 1, nc + write(88, *) qin(i) + end do + +contains + !------------------------------------------------------------------------------ + ! Function: M09_to_cat + ! Purpose : Maps runoff data from the M09 grid resolution to catchments using + ! sub-area information. It aggregates runoff from sub-areas weighted by + ! their area fractions. + ! + ! Input: + ! runoff - Runoff array of size (nlon, nlat) [in mm/d] + ! nlon - Number of longitude grid cells. + ! nlat - Number of latitude grid cells. + ! ncat - Number of catchments. + ! + ! Output: + ! Qrunf - Runoff mapped to catchments (in kg/s, then converted to m^3/s). + !------------------------------------------------------------------------------ + function M09_to_cat(runoff, nlon, nlat, ncat) result(Qrunf) + integer, intent(in) :: nlon, nlat, ncat ! Grid dimensions and number of catchments + real, intent(in) :: runoff(nlon, nlat) ! Input runoff array at grid resolution + real :: Qrunf(ncat) ! Output catchment runoff array + + real, parameter :: small = 1.e-12 + + ! Define sub-area parameters (same as in the M09 dataset) + integer, parameter :: nmax = 458 ! Maximum number of sub-areas per catchment + integer, parameter :: nc = 291284 ! Total number of catchments + + ! Declare allocatable arrays to hold sub-area data: + real, allocatable, dimension(:,:) :: subarea, frac ! subarea: area of each sub-area, frac: fraction of total + integer, allocatable, dimension(:,:) :: subx, suby ! Coordinates of sub-areas in the grid + real, allocatable, dimension(:) :: tot, runfC, fracA ! tot: total catchment area; runfC: aggregated runoff; fracA: fraction sum + integer, allocatable, dimension(:) :: nsub ! nsub: number of sub-areas per catchment + + integer :: i, j, sx, sy ! Loop counters and sub-area grid coordinates + + ! Allocate arrays for sub-area information and total area: + allocate(nsub(nc), subarea(nmax, nc), subx(nmax, nc), suby(nmax, nc), tot(nc)) + + ! Read sub-area data from text files: + open(77, file="output/Pfaf_nsub_M09.txt"); read(77, *) nsub + open(77, file="output/Pfaf_asub_M09.txt"); read(77, *) subarea + open(77, file="output/Pfaf_xsub_M09.txt"); read(77, *) subx + open(77, file="output/Pfaf_ysub_M09.txt"); read(77, *) suby + open(77, file="output/Pfaf_area.txt"); read(77, *) tot + + ! Allocate fraction array (fraction of sub-area relative to total catchment area) + allocate(frac(nmax, nc)) + + ! Compute the fraction for each sub-area: + do i = 1, nc + frac(:, i) = subarea(:, i) / tot(i) + end do + + ! Allocate arrays to accumulate runoff and fraction sums per catchment: + allocate(runfC(nc), fracA(nc)) + runfC = 0. ! Initialize aggregated runoff for each catchment to zero + fracA = 0. ! Initialize fraction accumulation to zero + + !$OMP PARALLEL default(shared) private(i,j,sx,sy) + !$OMP DO + ! Loop over all catchments and their sub-areas: + do i = 1, nc + do j = 1, nsub(i) + sy = suby(j, i) ! Get y-coordinate of the sub-area + sx = subx(j, i) ! Get x-coordinate of the sub-area + ! Only consider valid sub-areas (non-zero fraction and valid runoff values) + if (frac(j, i) > 0. .and. runoff(sx, sy) < 1.e14 .and. runoff(sx, sy) >= 0.) then + runfC(i) = runfC(i) + frac(j, i) * runoff(sx, sy) + fracA(i) = fracA(i) + frac(j, i) + endif + end do + end do + !$OMP END DO + !$OMP END PARALLEL + + ! Convert aggregated runoff to kg/s by multiplying by total catchment area (in m²) + ! and dividing by the number of seconds per day (86400): + Qrunf = runfC * (tot * 1.e6) / 86400. + + ! Deallocate allocated arrays to free memory: + deallocate(subarea, subx, suby, tot, frac, & + runfC, fracA, nsub) + + end function M09_to_cat + !------------------------------------------------------------------------------ + +end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 new file mode 100755 index 000000000..38f055179 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 @@ -0,0 +1,103 @@ +program main +!Main purpose: Gets the area for each catchment-tile for M09 grid. + +use river_read +use constant, only: nmax=>nmax09,nc,nlon,nlat,nlat09,nlon09,nt_global=>nt_global09 + +implicit none +! Require explicit declaration of all variables + +! Declare variables for indices, flags, and temporary storage +integer :: id, xi, yi, i, j, flag, subi, x_m09, y_m09, it +! Allocatable arrays to hold sub-catchment coordinate indices and global sub-catchment information +integer,allocatable :: xsub(:,:), ysub(:,:), subi_global(:,:) + +! Allocatable array to store sub-catchment area data +real,allocatable :: asub(:,:) + +! Allocatable double precision arrays for storing longitude and latitude values from file +real*8,allocatable :: lon(:), lat(:) +! Allocatable integer arrays for mapping longitude and latitude indices +integer,allocatable :: loni(:), lati(:) +! 2D arrays: catchind holds catchment index for each grid cell; map_tile maps M09 grid cells to global indices +integer,allocatable :: catchind(:,:), map_tile(:,:) +! Arrays for cell areas from the original grid, aggregated area on the M grid, and area per global tile +real,allocatable :: cellarea(:,:), area_m09(:,:), area_tile(:) + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays for sub-catchment data +! Allocate 2D arrays with dimensions (nmax, nc) for sub-catchment coordinate indices and areas +allocate(xsub(nmax,nc), ysub(nmax,nc), asub(nmax,nc)) + +! Allocate arrays for the catchment index grid and cell area data +allocate(catchind(nlon,nlat), cellarea(nlon,nlat)) +! Allocate 1D arrays for longitude and latitude values +allocate(lon(nlon), lat(nlat)) +! Allocate arrays for integer mappings of longitude and latitude indices +allocate(loni(nlon), lati(nlat)) + +! Read longitude and latitude data from the NetCDF file +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +! Read 2D catchment index data from the same file +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +! Read cell area data +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +! Scale cell area values (from m^2 to km^2) +cellarea = cellarea/1.e6 + +! Read mapping indices from text files for the M09 grid conversion +! Read integer latitude indices mapping for each original grid +open(10, file="temp/lati_1m_M09.txt") +read(10, *) lati +! Read integer longitude indices mapping for each original grid +open(11, file="temp/loni_1m_M09.txt") +read(11, *) loni + +! Allocate and initialize the aggregated area array for the M09 grid +allocate(area_m09(nlon09, nlat09)) +area_m09 = 0. +! Loop over the original grid and accumulate cell areas into the M09 grid using mapping indices +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi,yi) >= 1) then + x_m09 = loni(xi) + y_m09 = lati(yi) + ! For grid cells with a valid catchment index, add their cell area to the corresponding M09 grid cell + area_m09(x_m09, y_m09) = area_m09(x_m09, y_m09) + cellarea(xi,yi) + endif + enddo +enddo + +! Allocate the map_tile array and read its data from a NetCDF file +allocate(map_tile(nlon09, nlat09)) +call read_ncfile_int2d("temp/map_tile_M09.nc", "data", map_tile, nlon09, nlat09) +! Allocate the global area array to hold area data for each tile +allocate(area_tile(nt_global)) +area_tile = -9999. + +! Map the aggregated M09 grid areas to the global tile indices using the map_tile array +do i = 1, nlon09 + do j = 1, nlat09 + it = map_tile(i, j) + if (it > 0) then + area_tile(it) = area_m09(i, j) + endif + enddo +enddo + +! Write the global tile area data to an output text file +open(88, file="output/area_M09_1d.txt") +do i = 1, nt_global + write(88, *) area_tile(i) +enddo + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 new file mode 100755 index 000000000..3b0394e50 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 @@ -0,0 +1,104 @@ +program main +!Main purpose: Gets the area for each catchment-tile for M36 grid. + +use river_read ! Use the module "river_read" to access functions for reading NetCDF files +use constant, only: nmax=>nmax36,nc,nlon,nlat,nlat36,nlon36,nt_global=>nt_global36 + +implicit none +! Require explicit declaration of all variables + +! Declare variables for indices and temporary storage +integer :: id, xi, yi, i, j, flag, subi, x_m36, y_m36, it + +! Declare allocatable arrays for sub-catchment information +integer,allocatable :: xsub(:,:), ysub(:,:), subi_global(:,:) +! Arrays for storing sub-catchment coordinate indices and sub-catchment areas +real,allocatable :: asub(:,:) + +! Declare arrays for grid and mapping information +! Arrays for longitude and latitude values from the NetCDF file +real*8,allocatable :: lon(:), lat(:) +! Arrays for integer mappings of longitude and latitude indices +integer,allocatable :: loni(:), lati(:) +! 2D arrays: "catchind" holds catchment index for each original grid cell; "map_tile" maps aggregated grid cells to global indices +integer,allocatable :: catchind(:,:), map_tile(:,:) +! "cellarea" holds the area of each grid cell; "area_m36" is the aggregated area on the M36 grid; +! "area_tile" will store the area for each global tile based on the aggregated grid +real,allocatable :: cellarea(:,:), area_m36(:,:), area_tile(:) + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays for sub-catchment information with dimensions (nmax, nc) +allocate(xsub(nmax,nc), ysub(nmax,nc), asub(nmax,nc)) +! Allocate arrays for the original grid: catchment indices and cell areas +allocate(catchind(nlon,nlat), cellarea(nlon,nlat)) +! Allocate arrays for longitude and latitude values +allocate(lon(nlon), lat(nlat)) +! Allocate arrays for the mapping of longitude and latitude indices +allocate(loni(nlon), lati(nlat)) + +! Read longitude and latitude data from the NetCDF file +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +! Read the 2D catchment index data +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +! Read the cell area data +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +! Convert cell areas (from m^2 to km^2) by scaling with 1.e6 +cellarea = cellarea / 1.e6 + +! Open text files to read the mapping indices for the aggregated grid (M36) +! Read the latitude mapping: converts original latitude indices to M36 grid indices +open(10, file="temp/lati_1m_M36.txt") +read(10, *) lati +! Read the longitude mapping: converts original longitude indices to M36 grid indices +open(11, file="temp/loni_1m_M36.txt") +read(11, *) loni + +! Allocate and initialize the aggregated area array for the M36 grid +allocate(area_m36(nlon36, nlat36)) +area_m36 = 0. +! Loop over each grid cell in the original grid +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi,yi) >= 1) then + ! For cells that belong to a catchment (valid catchment index) + x_m36 = loni(xi) + y_m36 = lati(yi) + ! Accumulate the cell area into the corresponding aggregated grid cell + area_m36(x_m36, y_m36) = area_m36(x_m36, y_m36) + cellarea(xi,yi) + endif + enddo +enddo + +! Allocate the map_tile array and read its data from a NetCDF file +allocate(map_tile(nlon36, nlat36)) +call read_ncfile_int2d("temp/map_tile_M36.nc", "data", map_tile, nlon36, nlat36) +! Allocate the global area array to hold the area for each global tile +allocate(area_tile(nt_global)) +area_tile = -9999. + +! Map the aggregated grid areas to the global tile indices using the map_tile mapping +do i = 1, nlon36 + do j = 1, nlat36 + it = map_tile(i, j) + if (it > 0) then + area_tile(it) = area_m36(i, j) + endif + enddo +enddo + +! Write the global tile area data to an output text file +open(88, file="output/area_M36_1d.txt") +do i = 1, nt_global + write(88, *) area_tile(i) +enddo + +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py new file mode 100755 index 000000000..d89a3cc8c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py @@ -0,0 +1,235 @@ +import sys +import numpy as np +from netCDF4 import Dataset +import os +import glob + +#Main purpose: Processes reservoir (dam) data: reads dam locations and usage information from GRanD database. + +# Function to find the nearest index in a coordinate array +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +if __name__ == '__main__': + + file_latdam, file_londam, file_lat1m, file_lon1m, file_catmap, file_acadam, file_damcat_manfix, file_dam_manflag, file_dam_use, file_flood = sys.argv[1:11] + # Parameter settings + ns = 7250 #nr + nlat = 10800 + nlon = 21600 + nc = 291284 + thres = 5000.0 + +#----get dam lat lon ind---- + + # Read data from ASCII files + lats = np.loadtxt(file_latdam, dtype=np.float64, max_rows=ns) + lons = np.loadtxt(file_londam, dtype=np.float64, max_rows=ns) + lat1m = np.loadtxt(file_lat1m, dtype=np.float64, max_rows=nlat) + lon1m = np.loadtxt(file_lon1m, dtype=np.float64, max_rows=nlon) + + # For each target coordinate, find the nearest index in the reference array. + lati = ind_nearest_coord(lats, lat1m) + loni = ind_nearest_coord(lons, lon1m) + +#----get dam catchemnt indices---- + # Read the catchment indices file + nc_file = file_catmap + with Dataset(nc_file, 'r') as ncf: + catchind = ncf.variables["CatchIndex"][:] + if np.ma.is_masked(catchind): + catchind = catchind.filled(-9999) + + # Initialize the array to store the output catchment ID values + catid = np.empty(ns, dtype=int) + + # Loop over each index + for i in range(ns): + # For each index, retrieve the value from catchind. + catid[i] = catchind[ lati[i], loni[i] ] + +#----get dam drainage area-- + # Read full dataset for acar(drainage area) and catchment area from ASCII files + acar_all = np.loadtxt("temp/Pfaf_acar.txt", dtype=float, max_rows=nc) + area_all = np.loadtxt("output/Pfaf_area.txt", dtype=float, max_rows=nc) + + # Initialize arrays to store the selected values for each catchment + acar = np.empty(ns, dtype=float) + area = np.empty(ns, dtype=float) + + # Loop over each catchment index and assign values based on catid + for i in range(ns): + cid = catid[i] + if cid != -9999: + # Subtract 1 from cid to convert 1-based index to 0-based index for Python + acar[i] = acar_all[cid - 1] + area[i] = area_all[cid - 1] + else: + acar[i] = -9999.0 + area[i] = -9999.0 + +#----look for station: model drainage area is too small------ + # Read drainage area from GRAND database + grand = np.loadtxt(file_acadam, dtype=float, max_rows=ns) + + # Initialize lists to store error information + id_error = [] + + # Loop over each catchment index + for i in range(ns): + # At here only care about large-scale dams + if grand[i] > thres: + if acar[i] < 0.8 * grand[i]: + # Append error information; add 1 to i for 1-based indexing + id_error.append(i + 1) + + # Get the number of errors found + ne = len(id_error) + +#----get corrected catid for above station-------------------- + # Read manually corrected catid array from ASCII files. + catid_error = np.loadtxt(file_damcat_manfix, dtype=int, max_rows=ne) + + # Loop over each error index and update catid. + # Note: We subtract 1 from resid_error values to convert from 1-based to 0-based indexing. + for i in range(ne): + rid = id_error[i] + catid[rid - 1] = catid_error[i] + +#----get dam drainage area with corrected catid-------------------- + # Initialize arrays to store the selected acar and area values for each catchment + acar = np.empty(ns, dtype=float) + area = np.empty(ns, dtype=float) + + # Loop over each catchment index + for i in range(ns): + cid = catid[i] + if cid != -9999: + # Adjust for 1-based indexing: subtract 1 when accessing the full dataset arrays + acar[i] = acar_all[cid - 1] + area[i] = area_all[cid - 1] + else: + acar[i] = -9999.0 + area[i] = -9999.0 + +#----look for station: model drainage area is too large------ + model = acar + # we use a list to collect error indices. + id_error = [] + + # Loop over each catchment index + for i in range(ns): + # Check if the model value is greater than the threshold and grand is less than 80% of model + if model[i] > thres: + if grand[i] < 0.8 * model[i]: + # Append 1-based index (i+1) to the error list + id_error.append(i + 1) + + ne = len(id_error) + +#----create flag for all dams------ + + # Three more manual adjustment dams + resid_man = np.array([5179, 289, 7070], dtype=int) + catid_man = np.array([46616, 142851, 199281], dtype=int) + nman = resid_man.size + + # Update specific indices in catid_all with manual adjustments. + for i in range(nman): + catid[resid_man[i] - 1] = catid_man[i] + + # Write the updated catid_all to an ASCII file + np.savetxt("output/catid_dam_corr_aca_grand5000.txt", catid, fmt='%d') + + # Read dams flag (whether we still need it in the model) for the above uncorrect dams from a manually checked flag file + flag_error = np.loadtxt(file_dam_manflag, dtype=int, max_rows=ne) + + # Initialize flag_all array with ones (default flag value) + flag_all = np.ones(ns, dtype=int) + + # For each error entry, update flag_all at the specified index. + # Adjust id from 1-based to 0-based indexing. + for i in range(ne): + id_val = id_error[i] + flag_all[id_val - 1] = flag_error[i] + + # If drainage area in GRAND is small and also less than 0.5 times model drainage area, we do not need the dam. + for i in range(ns): + if grand[i] < 1.e3: + if grand[i] < 0.5 * acar[i]: + flag_all[i] = 0 + + # If model drainage area is negative, set flag_all to 0 for that dam. + for i in range(ns): + if acar[i] < 0.: + flag_all[i] = 0 + + # Write the final flag_all array to an ASCII file. + np.savetxt("output/flag_all_res.txt", flag_all, fmt='%d') + +#----get dam main use--------------- + # Define category strings and corresponding output tags + use_string = ["Irrigation", "Hydroelectricity", "Water supply", "Navigation", "Recreation"] + use_out = ["irr", "hydroelec", "watersupply", "nav", "rec"] + nu = len(use_string) + + # Read the main use data as strings from the GRAND file + with open(file_dam_use, "r") as f: + use = [line.strip() for line in f] + if len(use) != ns: + print(f"Warning: expected {ns} lines, but got {len(use)} lines.") + + # For each category in use_string, create a flag array and output the result + for j in range(nu): + flag = np.zeros(ns, dtype=int) + # Set flag to 1 where the use value matches the current category + for i in range(ns): + if use[i] == use_string[j]: + flag[i] = 1 + + # Write the flag array + out_filename = os.path.join("output", use_out[j] + "_grand.txt") + np.savetxt(out_filename, flag, fmt='%d') +#----flood use-------------------- + # Read the use_irr strings from the GRAND file + with open(file_flood, "r") as f: + use_irr = [line.strip() for line in f] + + # Initialize the flag array with zeros + flag = np.zeros(ns, dtype=int) + + # Loop over each entry and set flag to 1 if the entry is not "NA" + for i in range(ns): + if use_irr[i] != "NA": + flag[i] = 1 + + # Write the flag array + np.savetxt("output/fldmainsec_grand.txt", flag, fmt='%d') + +#----other use-------------------- + use_out = "other" + + # Read the main use data from the GRAND file + with open(file_dam_use, "r") as f: + use = [line.strip() for line in f] + if len(use) != ns: + print(f"Warning: expected {ns} entries, but got {len(use)} entries.") + + # Initialize the flag array with zeros + flag = np.zeros(ns, dtype=int) + + # Loop over each entry and set flag to 1 if the entry matches the specified categories + for i in range(ns): + if use[i] == "Fisheries" or use[i] == "NA" or use[i] == "Other": + flag[i] = 1 + + # Write the flag array + np.savetxt("output/" + use_out + "_grand.txt", flag, fmt='%d') + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 new file mode 100755 index 000000000..d82c6b791 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 @@ -0,0 +1,55 @@ +program main +!Main purpose: Assigns a catchment‐tile index from maptile files to each sub-catchment for M09 grid. + +use river_read ! Use custom module for reading NetCDF files +use constant, only: nlat=>nlat09, nlon=>nlon09, nmax=>nmax09, nc +implicit none + +! Declare allocatable arrays for grid mapping and sub-catchment indices +integer,allocatable :: map_tile(:,:), subx(:,:), suby(:,:), subi(:,:) + +! Declare integer variables for looping and temporary storage +integer :: i, x, y, j, it + +! Allocate the map_tile array for the aggregated grid (M09) with dimensions (nlon, nlat) +allocate(map_tile(nlon,nlat)) +! Read the mapping data from a NetCDF file into the map_tile array +call read_ncfile_int2d("temp/map_tile_M09.nc", "data", map_tile, nlon, nlat) + +! Allocate subx, suby, and subi arrays to store sub-catchment coordinate data and indices +allocate(subx(nmax,nc), suby(nmax,nc), subi(nmax,nc)) + +! Open and read the x-coordinates of sub-catchments from a text file into subx +open(77, file="output/Pfaf_xsub_M09.txt") +read(77, *) subx + +! Open and read the y-coordinates of sub-catchments from a text file into suby +open(77, file="output/Pfaf_ysub_M09.txt") +read(77, *) suby + +! Initialize the subi array to zero +subi = 0 + +! Loop over each catchment +do i = 1, nc + ! Loop over each possible sub-area within a catchment + do j = 1, nmax + x = subx(j, i) + y = suby(j, i) + ! If the x-coordinate is non-zero, then the sub-area exists + if (x /= 0) then + ! If x exists but y is zero, then there is an error and the program stops + if (y == 0) stop + ! Map the sub-area indices from the aggregated grid using the map_tile array + subi(j, i) = map_tile(x, y) + endif + enddo +enddo + +! Open an output file to write the computed sub-catchment tile indices +open(88, file="output/Pfaf_isub_M09.txt") +do i = 1, nc + write(88, '(150(i8))') subi(:, i) +enddo + +end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 new file mode 100755 index 000000000..637f116e7 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 @@ -0,0 +1,53 @@ +program main +!Main purpose: Assigns a catchment‐tile index from maptile files to each sub-catchment for M36 grid. + +use river_read ! Use custom module for reading NetCDF files +use constant, only: nlat=>nlat36, nlon=>nlon36, nmax=>nmax36, nc +implicit none + +! Declare allocatable arrays for grid mapping and sub-catchment indices +integer,allocatable :: map_tile(:,:), subx(:,:), suby(:,:), subi(:,:) + +! Declare integer variables for loop indices and temporary storage +integer :: i, x, y, j, it + +! Allocate the mapping array for the aggregated grid with dimensions (nlon, nlat) +allocate(map_tile(nlon, nlat)) +! Read mapping data from the NetCDF file into the map_tile array +call read_ncfile_int2d("temp/map_tile_M36.nc", "data", map_tile, nlon, nlat) + +! Allocate arrays to store sub-catchment x and y coordinates and their mapped indices +allocate(subx(nmax, nc), suby(nmax, nc), subi(nmax, nc)) + +! Open and read the sub-catchment x-coordinates from a text file into the subx array +open(77, file="output/Pfaf_xsub_M36.txt") +read(77, *) subx + +! Open and read the sub-catchment y-coordinates from a text file into the suby array +open(77, file="output/Pfaf_ysub_M36.txt") +read(77, *) suby + +! Initialize the sub-area index array to zero +subi = 0 + +! Loop over each catchment +do i = 1, nc + ! Loop over each potential sub-area within the current catchment + do j = 1, nmax + x = subx(j, i) ! Retrieve the x-coordinate for the sub-area + y = suby(j, i) ! Retrieve the y-coordinate for the sub-area + if (x /= 0) then ! Check if a valid sub-area exists (non-zero x-coordinate) + if (y == 0) stop ! If x is valid but y is zero, there is an error, so stop the program + subi(j, i) = map_tile(x, y) ! Map the sub-area coordinates to a global tile index using map_tile + endif + enddo +enddo + +! Open an output file to write the computed sub-catchment tile indices +open(88, file="output/Pfaf_isub_M36.txt") +do i = 1, nc + write(88, '(150(i7))') subi(:, i) +enddo + +end program main + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py new file mode 100755 index 000000000..790e12a8d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py @@ -0,0 +1,139 @@ +import sys +import numpy as np +import os +from netCDF4 import Dataset + +#Main purpose: Computes grid-cell index arrays and per-cell areas for 1-m high-res grid. + +lat36_file, lon36_file, lat09_file, lon09_file, lat1m_file, lon1m_file = sys.argv[1:7] + +lati36_output_file = "temp/lati_1m_M36.txt" +loni36_output_file = "temp/loni_1m_M36.txt" +lati09_output_file = "temp/lati_1m_M09.txt" +loni09_output_file = "temp/loni_1m_M09.txt" +cellarea_output_file = "temp/cellarea.nc" + +# Grid dimensions +nlat36, nlon36 = 406, 964 +nlat1m, nlon1m = 10800, 21600 +nlat09, nlon09 = 1624, 3856 + +# Read data +lat36 = np.loadtxt(lat36_file, dtype=float, max_rows=nlat36) +lon36 = np.loadtxt(lon36_file, dtype=float, max_rows=nlon36) +lat1m = np.loadtxt(lat1m_file, dtype=float, max_rows=nlat1m) +lon1m = np.loadtxt(lon1m_file, dtype=float, max_rows=nlon1m) +lat09 = np.loadtxt(lat09_file, dtype=float, max_rows=nlat09) +lon09 = np.loadtxt(lon09_file, dtype=float, max_rows=nlon09) + +# Define nearest coordinate function +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +# Find nearest coordinates +lati36 = ind_nearest_coord(lat1m, lat36) +loni36 = ind_nearest_coord(lon1m, lon36) +lati09 = ind_nearest_coord(lat1m, lat09) +loni09 = ind_nearest_coord(lon1m, lon09) + +# Save indices to files (1-based index) +np.savetxt(lati36_output_file, lati36 + 1, fmt='%d') +np.savetxt(loni36_output_file, loni36 + 1, fmt='%d') +np.savetxt(lati09_output_file, lati09 + 1, fmt='%d') +np.savetxt(loni09_output_file, loni09 + 1, fmt='%d') + +# Compute global grid cell area +def area_global_rectilinear_grid(lat, lon, rearth=6371.22): + """ + Calculate the approximate area of each grid cell on a global rectilinear grid. + + Parameters: + lat : numpy.ndarray + Array of latitude values (degrees). + lon : numpy.ndarray + Array of longitude values (degrees). + rearth : float + Earth radius in kilometers. Default is 6371.22 km. + + Returns: + area_grid : numpy.ndarray + 2D array representing the area of each grid cell (km^2). + """ + # Convert degrees to radians + rad = np.pi / 180.0 + rr = rearth * rad + + # Longitude spacing (constant across latitudes) + dlon = rr * (lon[1] - lon[0]) # Assuming uniform spacing in longitude + + # Compute longitude spacing at each latitude (dx) + dx = dlon * np.cos(lat * rad) + + # Handle rounding issues at poles + dx[0] = 0.0 if lat[0] < -89.9999 else dx[0] + dx[-1] = 0.0 if lat[-1] > 89.9999 else dx[-1] + + # Latitude spacing (dy), can be variable + dy = np.zeros_like(lat) + dy[0] = (lat[1] - lat[0]) * rr + dy[1:-1] = (lat[2:] - lat[:-2]) * rr / 2.0 + dy[-1] = (lat[-1] - lat[-2]) * rr + + # Area per latitude band + area_lat = dx * dy + + # Extend latitude areas to all longitudes + area_grid = np.outer(area_lat, np.ones(len(lon))) + + # Total area of all grid cells + area_total = np.sum(area_grid) + + # Total surface area of the sphere + area_sphere = 4.0 * np.pi * (rearth ** 2) + + # Add metadata as a dictionary + metadata = { + "long_name": "area of each grid cell", + "units": "km^2", + "area_total": area_total, + "area_lat": area_lat, + "rearth": rearth, + "area_sphere": area_sphere, + "area_ratio": area_total / area_sphere + } + + return area_grid, metadata + +# Calculate and save cell area +area, metadata = area_global_rectilinear_grid(lat1m, lon1m) +area *= 1.e6 # Convert to m² + +# Remove existing file and write new cell area to NetCDF +if os.path.exists(cellarea_output_file): + os.remove(cellarea_output_file) + +with Dataset(cellarea_output_file, "w", format="NETCDF4") as fout: + # Create dimensions + fout.createDimension("lat", nlat1m) + fout.createDimension("lon", nlon1m) + + # Create variables for lat and lon + lat_var = fout.createVariable("lat", "f4", ("lat",)) + lon_var = fout.createVariable("lon", "f4", ("lon",)) + lat_var[:] = lat1m + lon_var[:] = lon1m + # Assign units attribute to lat and lon + lat_var.units = "degrees_north" + lon_var.units = "degrees_east" + + # Create the area variable + area_var = fout.createVariable("data", "f8", ("lat", "lon")) + area_var[:] = area + area_var.units = "m2" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 new file mode 100755 index 000000000..bb0dc5c74 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 @@ -0,0 +1,62 @@ +program main +!Main purpose: Extracts the latitude/longitude boundaries of each catchment-tile from catchment definition files for M09 grid. + +use constant, only : nt=>nt09 + +implicit none + +! Declare allocatable arrays for catchment ID, parent catchment ID, +! and geographical boundaries (longitude and latitude extents) +integer, allocatable, dimension(:) :: id, catid +real, allocatable, dimension(:) :: lon_left, lon_right, lat_bottom, lat_top + +integer :: i, ntot ! Loop counter and total number of catchments read from file + +! Define file path for input routing data: +character(len=900) :: file_path !"input/catchment_M09.def" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays with size nt +allocate(id(nt), catid(nt), lon_left(nt), lon_right(nt), lat_bottom(nt), lat_top(nt)) + +! Open input file that contains catchment definitions +open(77, file=trim(file_path)) +! Read total number of catchments (ntot) from the file header +read(77, *) ntot + +! Loop over each catchment and read the definitions: +! id, catchment id, left and right longitudes, bottom and top latitudes +do i = 1, nt + read(77, *) id(i), catid(i), lon_left(i), lon_right(i), lat_bottom(i), lat_top(i) +end do + +! Write the left longitude values to a temporary output file +open(88, file="temp/lon_left_M09.txt") +do i = 1, nt + write(88, *) lon_left(i) +end do + +! Write the right longitude values to a temporary output file +open(88, file="temp/lon_right_M09.txt") +do i = 1, nt + write(88, *) lon_right(i) +end do + +! Write the bottom latitude values to a temporary output file +open(88, file="temp/lat_bottom_M09.txt") +do i = 1, nt + write(88, *) lat_bottom(i) +end do + +! Write the upper (top) latitude values to a temporary output file +open(88, file="temp/lat_upper_M09.txt") +do i = 1, nt + write(88, *) lat_top(i) +end do + +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 new file mode 100755 index 000000000..a033bd133 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 @@ -0,0 +1,59 @@ +program main +!Main purpose: Extracts the latitude/longitude boundaries of each catchment-tile from catchment definition files for M36 grid. + +use constant, only : nt=>nt36 + +implicit none + +! Declare allocatable arrays for catchment ID, parent catchment ID, and boundary coordinates +integer, allocatable, dimension(:) :: id, catid +real, allocatable, dimension(:) :: lon_left, lon_right, lat_bottom, lat_top + +integer :: i, ntot ! 'i' is the loop counter; 'ntot' holds the total number of catchments read from the file + +! Define file path for input routing data: +character(len=900) :: file_path !"input/catchment_M36.def" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays with size nt +allocate(id(nt), catid(nt), lon_left(nt), lon_right(nt), lat_bottom(nt), lat_top(nt)) + +! Open the catchment definition file for the M36 grid and read the total number of catchments (header) +open(77, file=trim(file_path)) +read(77, *) ntot + +! Loop over each catchment and read: id, catchment id, left/right longitudes, bottom/top latitudes +do i = 1, nt + read(77, *) id(i), catid(i), lon_left(i), lon_right(i), lat_bottom(i), lat_top(i) +end do + +! Write the left boundary longitudes to an output file +open(88, file="temp/lon_left_M36.txt") +do i = 1, nt + write(88, *) lon_left(i) +end do + +! Write the right boundary longitudes to an output file +open(88, file="temp/lon_right_M36.txt") +do i = 1, nt + write(88, *) lon_right(i) +end do + +! Write the bottom boundary latitudes to an output file +open(88, file="temp/lat_bottom_M36.txt") +do i = 1, nt + write(88, *) lat_bottom(i) +end do + +! Write the top boundary latitudes to an output file +open(88, file="temp/lat_upper_M36.txt") +do i = 1, nt + write(88, *) lat_top(i) +end do + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py new file mode 100755 index 000000000..9ecf8396d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py @@ -0,0 +1,70 @@ +import sys +import numpy as np +from netCDF4 import Dataset +import os +#Main purpose: Assigns a catchment‐tile index from catchment definition files to each model grid cell for M09 grid. + +# Load data +nt = 1684725 +nlat = 1624 +nlon = 3856 +nc = 291284 + +# Read input data from text files +lat_bot = np.loadtxt("temp/lat_bottom_M09.txt", dtype=float) +lat_up = np.loadtxt("temp/lat_upper_M09.txt", dtype=float) +lon_left = np.loadtxt("temp/lon_left_M09.txt", dtype=float) +lon_right = np.loadtxt("temp/lon_right_M09.txt", dtype=float) + +# Calculate the center latitudes and longitudes +latc = (lat_bot + lat_up) / 2.0 +lonc = (lon_left + lon_right) / 2.0 + +# Read latitudes and longitudes for the grid +lat09_file, lon09_file = sys.argv[1:3] + +lat09m = np.loadtxt(lat09_file, dtype=float) +lon09m = np.loadtxt(lon09_file, dtype=float) + +# Find the nearest coordinates +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +lati = ind_nearest_coord(latc, lat09m) +loni = ind_nearest_coord(lonc, lon09m) + +# Save the indices to files (1-based index) +np.savetxt("temp/lati_tile_M09.txt", lati + 1, fmt='%d') +np.savetxt("temp/loni_tile_M09.txt", loni + 1, fmt='%d') + +# Initialize the map_tile array +map_tile = np.full((nlat, nlon), -9999, dtype=int) + +# Fill the map_tile with data +for i in range(nt): + map_tile[lati[i], loni[i]] = i + 1 + +# Remove the existing file if it exists +if os.path.exists("temp/map_tile_M09.nc"): + os.remove("temp/map_tile_M09.nc") + +# Create a NetCDF file and write the data +with Dataset("temp/map_tile_M09.nc", "w", format="NETCDF4") as fout: + # Create dimensions + fout.createDimension("lat", nlat) + fout.createDimension("lon", nlon) + + # Create variable to store the map_tile data with fill_value set during creation + map_tile_var = fout.createVariable("data", "i4", ("lat", "lon"), fill_value=-9999) + map_tile_var[:] = map_tile + +# Print a sample of the map_tile data +#print(map_tile[62, 10]) # Corresponds to map_tile(63-1, 11-1) in NCL (1-based to 0-based) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py new file mode 100755 index 000000000..08b57572c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py @@ -0,0 +1,70 @@ +import sys +import numpy as np +from netCDF4 import Dataset +import os +#Main purpose: Assigns a catchment‐tile index from catchment definition files to each model grid cell for M36 grid. + +# Load data +nt = 112573 +nlat = 406 +nlon = 964 +nc = 291284 + +# Read input data from text files +lat_bot = np.loadtxt("temp/lat_bottom_M36.txt", dtype=float) +lat_up = np.loadtxt("temp/lat_upper_M36.txt", dtype=float) +lon_left = np.loadtxt("temp/lon_left_M36.txt", dtype=float) +lon_right = np.loadtxt("temp/lon_right_M36.txt", dtype=float) + +# Calculate the center latitudes and longitudes +latc = (lat_bot + lat_up) / 2.0 +lonc = (lon_left + lon_right) / 2.0 + +# Read latitudes and longitudes for the grid +lat36_file, lon36_file = sys.argv[1:3] + +lat36m = np.loadtxt(lat36_file, dtype=float) +lon36m = np.loadtxt(lon36_file, dtype=float) + +# Find the nearest coordinates +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +lati = ind_nearest_coord(latc, lat36m) +loni = ind_nearest_coord(lonc, lon36m) + +# Save the indices to files (1-based index) +np.savetxt("temp/lati_tile_M36.txt", lati + 1, fmt='%d') +np.savetxt("temp/loni_tile_M36.txt", loni + 1, fmt='%d') + +# Initialize the map_tile array +map_tile = np.full((nlat, nlon), -9999, dtype=int) + +# Fill the map_tile with data +for i in range(nt): + map_tile[lati[i], loni[i]] = i + 1 + +# Remove the existing file if it exists +if os.path.exists("temp/map_tile_M36.nc"): + os.remove("temp/map_tile_M36.nc") + +# Create a NetCDF file and write the data +with Dataset("temp/map_tile_M36.nc", "w", format="NETCDF4") as fout: + # Create dimensions + fout.createDimension("lat", nlat) + fout.createDimension("lon", nlon) + + # Create variable to store the map_tile data with fill_value set during creation + map_tile_var = fout.createVariable("data", "i4", ("lat", "lon"), fill_value=-9999) + map_tile_var[:] = map_tile + +# Print a sample of the map_tile data +#print(map_tile[62, 10]) # Corresponds to map_tile(63-1, 11-1) in NCL (1-based to 0-based) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 new file mode 100755 index 000000000..f1cc1be7c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 @@ -0,0 +1,113 @@ +program main +!Main purpose: Assigns a catchment‐tile index from catchment definition files to each model grid cell for M09 grid. + +use river_read +use constant, only : nmax=>nmax09, nc, nlon, nlat + +implicit none + +! Variable declarations: +integer :: id, xi, yi, i, flag, subi +integer :: nsub(nc) ! Array storing the number of sub-areas for each catchment + +! Allocatable arrays for sub-catchment information: +integer, allocatable :: xsub(:,:), ysub(:,:) +real, allocatable :: asub(:,:) ! Aggregated area for each sub-catchment + +! Arrays for grid data and mapping: +real*8, allocatable :: lon(:), lat(:) ! Longitude and latitude arrays from NetCDF file +integer, allocatable :: loni(:), lati(:) ! Mapped integer indices from 1-minute resolution files +integer, allocatable :: catchind(:,:) ! 2D array of catchment indices for each grid cell +real, allocatable :: cellarea(:,:) ! 2D array of cell areas + + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays based on the defined dimensions: +allocate(xsub(nmax, nc), ysub(nmax, nc), asub(nmax, nc)) +allocate(catchind(nlon, nlat), cellarea(nlon, nlat)) +allocate(lon(nlon), lat(nlat)) +allocate(loni(nlon), lati(nlat)) + +! Read grid longitude, latitude, catchment index, and cell area data from NetCDF files: +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +cellarea = cellarea / 1.e6 ! Convert cell area units (from m^2 to km^2) + +! Read mapped grid indices for 1-minute resolution from text files: +open(10, file="temp/lati_1m_M09.txt") +read(10, *) lati +open(11, file="temp/loni_1m_M09.txt") +read(11, *) loni + +! Initialize aggregation arrays: +nsub = 0 ! Set number of sub-areas per catchment to zero +xsub = 0 ! Initialize x-coordinate array for sub-catchments to zero +ysub = 0 ! Initialize y-coordinate array for sub-catchments to zero +asub = 0. ! Initialize aggregated area values to zero + +! Loop over each 1m grid cell to accumulate cell areas into sub-catchments: +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi, yi) >= 1) then + ! The cell belongs to a catchment: + id = catchind(xi, yi) ! Retrieve the catchment id for the current cell + flag = 0 ! Reset flag; will be set to 1 if a matching sub-area is found + + ! Check if this catchment already has at least one sub-area: + if (nsub(id) >= 1) then + do i = 1, nsub(id) + ! If the mapped indices of the current cell match an existing sub-area: + if (loni(xi) == xsub(i, id) .and. lati(yi) == ysub(i, id)) then + flag = 1 + ! Accumulate the cell area into the existing sub-area: + asub(i, id) = asub(i, id) + cellarea(xi, yi) + exit ! Exit the loop once the match is found + endif + end do + endif + + ! If no matching sub-area was found, create a new sub-area for this catchment: + if (flag == 0) then + nsub(id) = nsub(id) + 1 + xsub(nsub(id), id) = loni(xi) + ysub(nsub(id), id) = lati(yi) + asub(nsub(id), id) = cellarea(xi, yi) + endif + + endif + end do +end do + +! Open output files to write the aggregated sub-catchment information: +open(50, file="output/Pfaf_nsub_M09.txt") +open(51, file="output/Pfaf_xsub_M09.txt") +open(52, file="output/Pfaf_ysub_M09.txt") +open(53, file="output/Pfaf_asub_M09.txt") + +! For each catchment, write: +! - Number of sub-areas +! - X indices of sub-areas (formatted in groups of 458 integers) +! - Y indices of sub-areas (formatted similarly) +! - Aggregated area values of sub-areas (formatted as floating-point numbers) +do i = 1, nc + write(50, *) nsub(i) + write(51, '(458(1x,i4))') xsub(:, i) + write(52, '(458(1x,i4))') ysub(:, i) + write(53, '(458(1x,f10.4))') asub(:, i) +end do + +! Print the maximum number of sub-areas found for any catchment and its location: +print *, maxval(nsub) +print *, maxloc(nsub) + +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 new file mode 100755 index 000000000..8a5725800 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 @@ -0,0 +1,107 @@ +program main +!Main purpose: Assigns a catchment‐tile index from catchment definition files to each model grid cell for M36 grid. + +use river_read +use constant, only : nmax=>nmax36, nc, nlon, nlat + +implicit none + + +! Variable declarations: +integer :: id, xi, yi, i, flag, subi +integer :: nsub(nc) ! Array to store the number of sub-areas for each catchment +integer, allocatable :: xsub(:,:), ysub(:,:), subi_global(:,:) +! xsub and ysub: 2D arrays to store mapped x and y indices for sub-catchments (not using subi_global in this code) +real, allocatable :: asub(:,:) ! 2D array to store aggregated area for each sub-catchment + +real*8, allocatable :: lon(:), lat(:) ! Arrays to hold longitude and latitude values from the NetCDF file +integer, allocatable :: loni(:), lati(:) +! loni and lati: Arrays holding mapping indices from 1-minute resolution data files +integer, allocatable :: catchind(:,:) ! 2D array holding catchment indices for each grid cell +real, allocatable :: cellarea(:,:) ! 2D array containing the area of each grid cell + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays with the specified dimensions: +allocate(xsub(nmax, nc), ysub(nmax, nc), asub(nmax, nc)) +allocate(catchind(nlon, nlat), cellarea(nlon, nlat)) +allocate(lon(nlon), lat(nlat)) +allocate(loni(nlon), lati(nlat)) + +! Read grid information from the NetCDF file "CatchIndex.nc": +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +! Read cell area data from the NetCDF file "cellarea.nc": +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +cellarea = cellarea / 1.e6 ! Convert cell area (e.g., from m^2 to km^2) + +! Read mapping indices for the 1-minute resolution grid from text files: +open(10, file="temp/lati_1m_M36.txt") +read(10, *) lati +open(11, file="temp/loni_1m_M36.txt") +read(11, *) loni + +! Initialize aggregation arrays to zero: +nsub = 0 +xsub = 0 +ysub = 0 +asub = 0. + +! Loop over all grid cells to aggregate cell areas by catchment and sub-area: +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi, yi) >= 1) then + ! The grid cell belongs to a catchment + id = catchind(xi, yi) ! Get the catchment id for the current cell + flag = 0 ! Reset flag to indicate whether a matching sub-area is found + + ! If the catchment already has one or more sub-areas, check for a matching sub-area: + if (nsub(id) >= 1) then + do i = 1, nsub(id) + if (loni(xi) == xsub(i, id) .and. lati(yi) == ysub(i, id)) then + flag = 1 + ! If a match is found, accumulate the cell area into the existing sub-area: + asub(i, id) = asub(i, id) + cellarea(xi, yi) + exit ! Exit the inner loop since a matching sub-area has been found + endif + end do + endif + + ! If no matching sub-area was found, create a new sub-area: + if (flag == 0) then + nsub(id) = nsub(id) + 1 + xsub(nsub(id), id) = loni(xi) + ysub(nsub(id), id) = lati(yi) + asub(nsub(id), id) = cellarea(xi, yi) + endif + + endif + end do +end do + +! Open output files to write the aggregated sub-catchment information: +open(50, file="output/Pfaf_nsub_M36.txt") +open(51, file="output/Pfaf_xsub_M36.txt") +open(52, file="output/Pfaf_ysub_M36.txt") +open(53, file="output/Pfaf_asub_M36.txt") +! Loop over all catchments and write: +do i = 1, nc + write(50, *) nsub(i) ! Write the number of sub-areas for catchment i + write(51, '(150(1x,i3))') xsub(:, i) ! Write the x indices for all sub-areas (formatted as 3-digit integers) + write(52, '(150(1x,i3))') ysub(:, i) ! Write the y indices for all sub-areas (formatted as 3-digit integers) + write(53, '(150(1x,f10.4))') asub(:, i) ! Write the aggregated areas for all sub-areas (formatted as floating-point numbers) +end do + +! Print the maximum number of sub-areas found for any catchment and its location: +print *, maxval(nsub) +print *, maxloc(nsub) + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 new file mode 100755 index 000000000..86945ee83 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 @@ -0,0 +1,250 @@ +program main +!Main purpose: Determines main river channel lengths for each catchment by using HydroSHEDS data of distance to sink. + +use river_read +use constant, only : nc, nlon, nlat, nlonh, nlath, cur_avg, cur_min, cur_max + +implicit none + +real*8, allocatable :: lon(:), lat(:) +real, allocatable :: ldn1m(:,:), elev1m(:,:) +integer, allocatable :: catid(:,:), flag_slp(:) + +real*8, allocatable :: lonh(:), lath(:) +real, allocatable :: ldnh(:,:), elev_15s(:,:) + +! Declare arrays to hold routing and catchment characteristics: +real, allocatable, dimension(:) :: lon_dn, lat_dn, lon_up, lat_up, dist_ref, dist_ref2, ldn_min, ldn_max, riv_len, str_len, slp +real, allocatable, dimension(:) :: lon_min, lon_max, lat_min, lat_max, area, elevdiff_ref, elevdiff +integer, allocatable, dimension(:) :: xi_min, yi_min, xi_max, yi_max +integer, allocatable, dimension(:) :: downid + +! Loop indices and temporary variables +integer xi, yi +integer :: num, i, j, cid, did, k +integer :: data1, data12 +real*8 :: data2 +real :: data7, data9, data10 +real :: elev_temp + +character(len=100) :: file_pfafmap !input/SRTM_PfafData.nc +character(len=100) :: file_ldn !input/hyd_glo_ldn_15s.nc +character(len=100) :: file_hyelev !input/hyd_glo_dem_15s.nc +character(len=100) :: file_pfafrout !input/Pfafcatch-routing.dat + + if (command_argument_count() /= 4) then + print *, "no found" + stop + endif + call get_command_argument(1, file_pfafmap) + call get_command_argument(2, file_ldn) + call get_command_argument(3, file_hyelev) + call get_command_argument(4, file_pfafrout) + +!----------------------------------------------------------------------- +! Regrid LDN (length to sink) from HydroSHEDS data + +allocate(ldn1m(nlon, nlat), catid(nlon, nlat)) +allocate(lon(nlon), lat(nlat)) +! Read longitude, latitude, and catchment index data from SRTM Pfaf data +call read_ncfile_double1d(trim(file_pfafmap), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_pfafmap), "latitude", lat, nlat) +call read_ncfile_int2d(trim(file_pfafmap), "CatchIndex", catid, nlon, nlat) +ldn1m = -1. +where(catid == -9999) ldn1m = -9999. + +! Allocate high-resolution LDN array and read data from HydroSHEDS 15s file +allocate(ldnh(nlonh, nlath)) +call read_ncfile_real2d(trim(file_ldn), "Band1", ldnh, nlonh, nlath) +where(ldnh.lt.4.e9) ldnh = ldnh / 1.e3 ! Convert from meters to kilometers + +! Regrid: For each grid cell in the M09 grid, assign the minimum LDN value from the corresponding high-res block. +do xi = 1, nlon + do yi = 2041, 10440 + if (ldn1m(xi, yi) .ne. -9999.) then + ldn1m(xi, yi) = minval(ldnh(4*xi-3:4*xi, 4*yi-3-8160:4*yi-8160)) + if (ldn1m(xi, yi) .gt. 4.e9) ldn1m(xi, yi) = -1. + end if + end do +end do +print *, maxval(ldn1m) + +! Allocate arrays to store minimum and maximum LDN for each catchment and their corresponding grid indices +allocate(ldn_min(nc), ldn_max(nc), xi_min(nc), yi_min(nc), xi_max(nc), yi_max(nc)) +ldn_min = 1.e20 +ldn_max = -9999. +xi_min = -9999; yi_min = -9999; xi_max = -9999; yi_max = -9999 +do i = 1, nlon + do j = 1, nlat + if (catid(i, j) >= 1) then + cid = catid(i, j) + if (ldn1m(i, j) > 0. .and. ldn1m(i, j) < ldn_min(cid)) then + ldn_min(cid) = ldn1m(i, j) + xi_min(cid) = i + yi_min(cid) = j + endif + if (ldn1m(i, j) > 0. .and. ldn1m(i, j) > ldn_max(cid)) then + ldn_max(cid) = ldn1m(i, j) + xi_max(cid) = i + yi_max(cid) = j + endif + endif + end do +end do +where(ldn_min == 1.e20) ldn_min = -9999 + +!----------------------------------------------------------------------- +! Compute elevation at 1-minute resolution from high-resolution DEM (15s) +allocate(elev_15s(nlonh, nlath), elev1m(nlon, nlat)) +call read_ncfile_real2d(trim(file_hyelev), "Band1", elev_15s, nlonh, nlath) +where(elev_15s > 30000.) elev_15s = 0. +elev1m = 0. +do xi = 1, nlon + do yi = 2041, 10440 + elev1m(xi, yi) = sum(elev_15s(4*xi-3:4*xi, 4*yi-3-8160:4*yi-8160)) / 16. + end do +end do + + +deallocate(ldnh, elev_15s) +!----------------------------------------------------------------------- +! Get reference distances using routing data + +open(77, file=trim(file_pfafrout), form="formatted", status="old") +read(77, *) num +allocate(lon_dn(nc), lat_dn(nc), lon_up(nc), lat_up(nc), dist_ref(nc), dist_ref2(nc)) +allocate(lon_min(nc), lon_max(nc), lat_min(nc), lat_max(nc), area(nc), elevdiff_ref(nc), elevdiff(nc)) + +! Read routing and catchment geometry data from the Pfafcatch routing file +do i = 1, nc + read(77, *) data1, data2, lon_min(i), lon_max(i), lat_min(i), lat_max(i), data7, area(i), data9, data10, elevdiff_ref(i), data12, lon_dn(i), lat_dn(i), lon_up(i), lat_up(i) +end do + +! Compute spherical distances reference +do i = 1, nc + dist_ref(i) = spherical_distance(lon_dn(i), lat_dn(i), lon_up(i), lat_up(i)) + dist_ref2(i) = spherical_distance(lon_min(i), lat_min(i), lon_max(i), lat_max(i)) +end do +where(dist_ref > dist_ref2 .or. dist_ref == 0.) dist_ref = 0.5 * dist_ref2 + +!-------------------------------------------------------------------- +! Get initial guess of river length (riv_len) based on LDN differences and elevation differences + +allocate(riv_len(nc), downid(nc), flag_slp(nc)) +open(77, file="output/downstream_1D_new_noadj.txt") +read(77, *) downid + +flag_slp = 1 + +riv_len = -9999. +elevdiff = -9999. +do i = 1, nc + if (downid(i) >= 1) then + did = downid(i) + if (.not. (riv_len(did) >= cur_min * dist_ref(did) .and. riv_len(did) <= cur_max * dist_ref(did))) then + riv_len(did) = ldn_min(i) - ldn_min(did) + if (xi_min(i) > 0 .and. xi_min(did) > 0) then + elevdiff(did) = max(0., elev1m(xi_min(i), yi_min(i)) - elev1m(xi_min(did), yi_min(did))) + flag_slp(did) = 1 + else + elevdiff(did) = elevdiff_ref(did) + flag_slp(did) = 0 + endif + else if (flag_slp(did) == 0 .or. elevdiff(did) == 0.) then + riv_len(did) = ldn_min(i) - ldn_min(did) + if (xi_min(i) > 0 .and. xi_min(did) > 0) then + elevdiff(did) = max(0., elev1m(xi_min(i), yi_min(i)) - elev1m(xi_min(did), yi_min(did))) + flag_slp(did) = 1 + else + elevdiff(did) = elevdiff_ref(did) + flag_slp(did) = 0 + endif + endif + endif +end do + +do i = 1, nc + if (riv_len(i) == -9999.) then + riv_len(i) = (ldn_max(i) - ldn_min(i)) * 0.5 + if (xi_min(i) > 0) then + elevdiff(i) = max(0., 0.5 * elev1m(xi_max(i), yi_max(i)) - 0.5 * elev1m(xi_min(i), yi_min(i))) + else + elevdiff(i) = elevdiff_ref(i) + flag_slp(i) = 0 + endif + endif +end do + +k = 0 +do i = 1, nc + if (.not. (riv_len(i) >= cur_min * dist_ref(i) .and. riv_len(i) <= cur_max * dist_ref(i))) then + riv_len(i) = cur_avg * dist_ref(i) + elevdiff(i) = elevdiff_ref(i) + flag_slp(i) = 0 + k = k + 1 + endif +end do +open(88, file="output/Pfaf_lriv_PR.txt") +do i = 1, nc + write(88, *) riv_len(i) +end do + +!-------------------------------------------------------------------- +! Calculate the length scale of local streams based on catchment area and river length. +allocate(str_len(nc)) +str_len = area / riv_len / 4. * cur_avg +open(88, file="output/Pfaf_lstr_PR.txt") +do i = 1, nc + write(88, *) str_len(i) +end do +!-------------------------------------------------------------------- +! Calculate the catchment slope from elevation difference and river length. +allocate(slp(nc)) +slp = elevdiff * 1.e-3 / riv_len +where(slp.lt.1.e-5) flag_slp = 0 +where(slp.lt.1.e-5) slp = 1.e-5 +print *, sum(flag_slp) +open(88, file="temp/Pfaf_slope.txt") +do i = 1, nc + write(88, *) slp(i) +end do +print *, minval(slp) +open(88, file="temp/Pfaf_slope_flag.txt") +do i = 1, nc + write(88, *) flag_slp(i) +end do + +!-------------------------------------------------------------------- +contains + +function spherical_distance(lon_dn, lat_dn, lon_up, lat_up) result(distance) + implicit none + !------------------------------------------------------------ + ! Function: spherical_distance + ! Purpose : Calculates the great-circle distance between two geographic + ! points using the Haversine formula. + ! + ! Input: + ! lon_dn, lat_dn - Longitude and latitude of the first point (degrees) + ! lon_up, lat_up - Longitude and latitude of the second point (degrees) + ! + ! Output: + ! distance - Great-circle distance between the two points (kilometers) + !------------------------------------------------------------ + real, intent(in) :: lon_dn, lat_dn ! Coordinates of downstream point + real, intent(in) :: lon_up, lat_up ! Coordinates of upstream point + real :: distance ! Computed distance (km) + real :: R, dlon, dlat, a, c ! Intermediate variables + + R = 6371.0 ! Earth's radius in kilometers + dlon = (lon_up - lon_dn) * (acos(-1.0) / 180.0) ! Delta longitude (radians) + dlat = (lat_up - lat_dn) * (acos(-1.0) / 180.0) ! Delta latitude (radians) + + a = sin(dlat / 2.0)**2 + cos(lat_dn * (acos(-1.0) / 180.0)) * & + cos(lat_up * (acos(-1.0) / 180.0)) * sin(dlon / 2.0)**2 + c = 2.0 * atan2(sqrt(a), sqrt(1.0 - a)) + distance = R * c + +end function spherical_distance + +end program main \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 new file mode 100755 index 000000000..b8a178b30 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 @@ -0,0 +1,1033 @@ +module k_module +!module for K parameter calculations. + + use river_read + use constant, only: nga + + implicit none + private + public :: read_usgs_data, process_usgs_data, find_nearest_coords, get_station_inf, regression + public :: filter_station, cal_Kmodel, get_valide_stations_gageii + +contains +!------------------------------------------------------------ + subroutine read_usgs_data(file_vel, file_dis, nl, data) + !------------------------------------------------------------ + ! Subroutine: read_usgs_data + ! Purpose : Reads USGS velocity and discharge data from text files + ! and stores the data in a 2D array. + ! + ! Input: + ! nl - Total number of records (lines) to read. + ! + ! Output: + ! data - 2D array (nl x 2) where column 1 contains velocity and + ! column 2 contains discharge. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_vel, file_dis + integer, intent(in) :: nl + real, allocatable, intent(out) :: data(:,:) + + character(len=100) :: var(2) + character(len=900) :: filename + character(len=100) :: line + character(len=100) :: x(100) + + integer :: i, j, l, io, k + integer, allocatable :: nv(:) + + ! Define the variable names for the two data files + var = (/ "velocity", "discharge" /) + + ! Allocate the data array with nl rows and 2 columns + allocate(data(nl, 2)) + + ! Loop over both "velocity" and "discharge" files + do l = 1, 2 + ! Construct the file name + if(l==1)filename = file_vel + if(l==2)filename = file_dis + open(unit=77, file=trim(filename), status='old') + + ! Allocate a temporary array to count the number of valid tokens per line + allocate(nv(nl)) + + ! Read each line from the file + do k = 1, nl + read(77, '(A)', iostat=io) line + if (io /= 0) then + print *, "Error reading line ", k, " from file: ", trim(filename) + exit + endif + + ! Read tokens from the line and store them in array x + do i = 1, 100 + read(line, *, iostat=io) (x(j), j = 1, i) + if (io == -1) then + exit + endif + end do + + ! Record the number of valid tokens read from this line + nv(k) = i - 1 + + ! If valid data is found, extract the first value for the data array; + ! otherwise assign a missing value (-9999) + if (nv(k) >= 1) then + read(x(1), *, iostat=io) data(k, l) + else + data(k, l) = -9999 + end if + end do + + ! Deallocate the temporary token count array + deallocate(nv) + + ! Close the current file + close(77) + end do + end subroutine read_usgs_data + +!------------------------------------------------------------ + subroutine process_usgs_data(file_usid, nl, ns, data, nv, nt, vel, dis) + !------------------------------------------------------------ + ! Subroutine: process_usgs_data + ! Purpose : Processes the raw USGS data by reading unique station IDs, + ! counting valid records per station. + ! + ! Input: + ! nl - Total number of records. + ! data - 2D array with raw velocity and discharge data. + ! + ! Output: + ! ns - Number of unique stations. + ! nv - Array with the count of valid records per station. + ! nt - Total number of valid records. + ! vel - Array of velocity values. + ! dis - Array of discharge values. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_usid + integer, intent(in) :: nl + integer, intent(out) :: ns + real, intent(inout), allocatable :: data(:,:) + real, allocatable, intent(out) :: vel(:), dis(:) + integer, allocatable, intent(out) :: nv(:) + integer, intent(out) :: nt + + character(len=20), allocatable :: id(:) + integer, allocatable :: nu(:) + character(len=20), allocatable :: idu(:) + integer :: i, k, ii + + ! Allocate array to hold station IDs for each record + allocate(id(nl)) + + ! Read station IDs from file "input/USGSID.txt" + open(unit=11, file=trim(file_usid), status="old") + read(11, *) id + close(11) + + ! Initialize station count and count unique IDs + k = 1 + do i = 2, nl + if (.not.(trim(id(i)) == trim(id(i-1)))) then + k = k + 1 + end if + end do + ns = k + allocate(nu(ns), nv(ns)) + allocate(idu(ns)) + + nu(1) = 1 + idu(1) = id(1) + k = 1 + do i = 2, nl + if (trim(id(i)) == trim(id(i-1))) then + nu(k) = nu(k) + 1 + else + k = k + 1 + nu(k) = 1 + idu(k) = id(i) + end if + end do + + ! Write unique station IDs to files (with and without commas) + open(unit=13, file="temp/id_for_site.txt") + do i = 1, ns + write(13, '(A)') trim(idu(i)) // "," + end do + close(13) + open(unit=13, file="temp/id_for_site_nocomma.txt") + do i = 1, ns + write(13, '(A)') trim(idu(i)) + end do + close(13) + + ! Read record + nv = 0 + nv(1) = 1 + k = 1 + ii = 0 + k = k - 1 + do i = 2, nl + if (id(i) == id(i - 1)) then + k = k + 1 + if (data(i,1) <= 0.0) then + k = k - 1 + else if (data(i,2) <= 0.0) then + k = k - 1 + end if + else + nv(ii + 1) = k + k = 1 + ii = ii + 1 + if (data(i,1) <= 0.0) then + k = k - 1 + else if (data(i,2) <= 0.0) then + k = k - 1 + end if + end if + end do + nv(ii + 1) = k + nt = sum(nv) + allocate(vel(nt), dis(nt)) + k = 0 + do i = 1, nl + if (data(i,1) > 0.0 .and. data(i,2) > 0.0) then + k = k + 1 + vel(k) = data(i,1) + dis(k) = data(i,2) + endif + enddo + + ! Deallocate temporary arrays + deallocate(id) + deallocate(nu) + deallocate(idu) + deallocate(data) + + end subroutine process_usgs_data + +!------------------------------------------------------------ + subroutine find_nearest_coords(file_lats, file_lons, file_lat1m, file_lon1m, ns, nlat, nlon, lats, lons, lati, loni) + !------------------------------------------------------------ + ! Subroutine: find_nearest_coords + ! Purpose : For each station, finds the nearest grid point in a 1-minute + ! resolution grid and returns the corresponding indices. + ! + ! Input: + ! ns - Number of stations. + ! nlat - Number of latitude grid points in the high-resolution grid. + ! nlon - Number of longitude grid points in the high-resolution grid. + ! + ! In/Out: + ! lats, lons - Arrays to store the station latitude and longitude values. + ! + ! Output: + ! lati, loni - Arrays of indices corresponding to the nearest grid points. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_lats, file_lons, file_lat1m, file_lon1m + integer, intent(in) :: ns, nlat, nlon + real, allocatable, intent(inout) :: lats(:), lons(:) + integer, allocatable, intent(out) :: lati(:), loni(:) + real, allocatable :: lat1m(:), lon1m(:) + real :: min_dist_lat, min_dist_lon, dist + integer :: i, j, idx_min_lat, idx_min_lon + + ! Allocate output arrays for grid indices for each station + allocate(lati(ns), loni(ns)) + ! Allocate arrays for station coordinates + allocate(lats(ns), lons(ns)) + ! Allocate arrays for 1-minute grid coordinates + allocate(lat1m(nlat), lon1m(nlon)) + + ! Read station latitudes from file "input/lat_for_site_200.txt" + open(unit=10, file=trim(file_lats), status='old') + do i = 1, ns + read(10, *) lats(i) + end do + close(10) + + ! Read station longitudes from file "input/lon_for_site_200.txt" + open(unit=11, file=trim(file_lons), status='old') + do i = 1, ns + read(11, *) lons(i) + end do + close(11) + + ! Read high-resolution latitude grid from file "input/lat_1m.txt" + open(unit=12, file=trim(file_lat1m), status='old') + do i = 1, nlat + read(12, *) lat1m(i) + end do + close(12) + + ! Read high-resolution longitude grid from file "input/lon_1m.txt" + open(unit=13, file=trim(file_lon1m), status='old') + do i = 1, nlon + read(13, *) lon1m(i) + end do + close(13) + + ! For each station, determine the nearest latitude and longitude indices + do i = 1, ns + min_dist_lat = 1.0e20 + min_dist_lon = 1.0e20 + idx_min_lat = -1 + idx_min_lon = -1 + + ! Find nearest latitude index + do j = 1, nlat + dist = abs(lats(i) - lat1m(j)) + if (dist < min_dist_lat) then + min_dist_lat = dist + idx_min_lat = j + end if + end do + lati(i) = idx_min_lat + + ! Find nearest longitude index + do j = 1, nlon + dist = abs(lons(i) - lon1m(j)) + if (dist < min_dist_lon) then + min_dist_lon = dist + idx_min_lon = j + end if + end do + loni(i) = idx_min_lon + end do + + ! Deallocate high-resolution grid arrays + deallocate(lat1m) + deallocate(lon1m) + end subroutine find_nearest_coords +!------------------------------------------------------------ + subroutine get_station_inf(file_pfafmap, ns, nc, nlat, nlon, lati, loni, catid, Qclmt, slp, KImodel_all, exp_slp, exp_clmt, fac_str) + !------------------------------------------------------------ + ! Subroutine: get_station_inf + ! Purpose : Retrieves station catchment information from a NetCDF file, + ! assigns climate runoff (Qclmt) and slope values for each station, + ! and computes modeled K values for all catchments. + ! + ! Input: + ! ns - Number of stations. + ! nc - Total number of catchments. + ! nlat, nlon - Dimensions of the grid. + ! lati, loni - Grid indices for each station. + ! exp_slp, exp_clmt - Exponents for slope and climatology discharge. + ! fac_str - Scaling factor for stream. + ! + ! Output: + ! catid - Array of catchment IDs for each station. + ! Qclmt - Array of climatology discharge values for stations. + ! slp - Array of slope values for stations. + ! KImodel_all - Array of modeled K values for all catchments. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_pfafmap + integer, intent(in) :: ns, nc, nlat, nlon + integer, intent(in) :: lati(nlon), loni(nlon) + integer, allocatable, intent(out) :: catid(:) + real, allocatable, intent(out) :: Qclmt(:), slp(:) + real, allocatable, intent(out) :: KImodel_all(:) + real, intent(in) :: exp_slp, exp_clmt, fac_str + + integer, allocatable :: catchind(:,:) + real, allocatable, dimension(:) :: Qclmt_all, slp_all, Kstr_all, Qstr_all + integer :: i + + ! Allocate arrays for the catchment index and station outputs + allocate(catchind(nlon, nlat), catid(ns)) + allocate(Qclmt_all(nc), slp_all(nc)) + allocate(Qclmt(ns), slp(ns)) + allocate(KImodel_all(nc), Kstr_all(nc), Qstr_all(nc)) + + ! Read catchment index data from the NetCDF file "input/SRTM_PfafData.nc" + call read_ncfile_int2d(trim(file_pfafmap), "CatchIndex", catchind, nlon, nlat) + + ! For each station, assign the catchment ID based on its grid location + do i = 1, ns + catid(i) = catchind(loni(i), lati(i)) + end do + + ! Write station catchment IDs to a temporary file + open(88, file="temp/catid_for_site_200.txt") + do i = 1, ns + write(88, *) catid(i) + end do + close(88) + + ! Read climate runoff data from file "output/Pfaf_qri.txt" + open(77, file="output/Pfaf_qri.txt") + read(77, *) Qclmt_all + where(Qclmt_all < 1.e-8) Qclmt_all = 1.e-8 + ! Read slope data from file "temp/Pfaf_slope.txt" + open(77, file="temp/Pfaf_slope.txt") + read(77, *) slp_all + ! Read clmt discharge data from file "output/Pfaf_qstr.txt" + open(77, file="output/Pfaf_qstr.txt") + read(77, *) Qstr_all + where(Qstr_all < 1.e-8) Qstr_all = 1.e-8 + + ! For each station, assign Qclmt and slope using the catchment ID + do i = 1, ns + if (catid(i) /= -9999) then + Qclmt(i) = Qclmt_all(catid(i)) + slp(i) = slp_all(catid(i)) + else + Qclmt(i) = -9999 + slp(i) = -9999 + endif + end do + + ! Calculate modeled K values for all catchments + KImodel_all = (Qclmt_all**(exp_clmt)) * (slp_all**(exp_slp)) + + ! Calculate stream K values using the scaling factor + Kstr_all = fac_str * (Qstr_all**(exp_clmt)) * (slp_all**(exp_slp)) + + ! Write stream K values to an output file + open(88, file="output/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt") + do i = 1, nc + write(88, *) Kstr_all(i) + end do + close(88) + + ! Deallocate temporary arrays + deallocate(catchind, Qclmt_all, slp_all, Kstr_all, Qstr_all) + + end subroutine get_station_inf +!------------------------------------------------------------ + subroutine get_valide_stations_gageii(file_gage_id, file_gage_acar, ns, nc, catid_sta, flag_thres) + !------------------------------------------------------------ + ! Subroutine: get_valide_stations_gageii + ! Purpose : Compares station drainage area with GAGE-II dataset and applies an + ! area ratio threshold to determine valid stations. + ! + ! Input: + ! ns - Number of stations. + ! nc - Total number of catchments. + ! catid_sta - Array of catchment IDs for stations. + ! + ! Output: + ! flag_thres - Array indicating valid stations (1 for valid, 0 otherwise). + !------------------------------------------------------------ + character(len=900),intent(in) :: file_gage_id, file_gage_acar + integer, intent(in) :: ns, nc + integer, intent(in) :: catid_sta(ns) + integer, allocatable, intent(out) :: flag_thres(:) + + real :: thr_sel = 0.3 ! Threshold selection factor + + real, dimension(:), allocatable :: acar_pfaf + integer :: i, j, k, cid + character(len=20) :: id_gages(nga) + character(len=20) :: id_sta(ns) + integer :: flag_gageii(ns) + real :: acar_gages(nga) + real :: acar_gages_sta(ns), acar_sta(ns) + character(len=20) :: line + integer :: ios + + allocate(flag_thres(ns)) + + ! Initialize station area ratios with a missing value + acar_sta = -9999.0 + k = 0 + + ! Read GAGE-II station IDs from "input/id_gagesii.txt" + open(unit=10, file=trim(file_gage_id), status="old", action="read") + do j = 1, nga + read(10, '(A)', iostat=ios) id_gages(j) + if (ios /= 0) then + print *, "Error reading id_gagesii.txt" + stop + end if + end do + close(10) + + ! Read station IDs for the sites from "temp/id_for_site_nocomma.txt" + open(unit=11, file="temp/id_for_site_nocomma.txt", status="old", action="read") + do i = 1, ns + read(11, '(A)', iostat=ios) id_sta(i) + if (ios /= 0) then + print *, "Error reading id_for_site_nocomma.txt" + stop + end if + end do + close(11) + + ! Read area ratios for GAGE-II stations from "input/acar_gagesii.txt" + open(unit=12, file=trim(file_gage_acar), status="old", action="read") + do j = 1, nga + read(12, *, iostat=ios) acar_gages(j) + if (ios /= 0) then + print *, "Error reading acar_gagesii.txt" + stop + end if + end do + close(12) + + ! Initialize the GAGE-II flag array to zero (no match) + flag_gageii = 0 + ! Compare station IDs with GAGE-II IDs and mark matches + do i = 1, ns + do j = 1, nga + if (trim(id_gages(j)) == trim(id_sta(i))) then + acar_gages_sta(i) = acar_gages(j) + flag_gageii(i) = 1 + k = k + 1 + exit ! Exit loop after a match is found + end if + end do + end do + + print *, "Number of matches:", sum(flag_gageii) + + allocate(acar_pfaf(nc)) + open(77, file="temp/Pfaf_acar.txt") + read(77, *) acar_pfaf + close(77) + + ! For each station, assign the area ratio based on its catchment ID + do i = 1, ns + if (catid_sta(i) /= -9999) then + cid = catid_sta(i) + acar_sta(i) = acar_pfaf(cid) + else + acar_sta(i) = -9999. + end if + end do + + ! Apply threshold criteria to flag valid stations + flag_thres = 0 + do i = 1, ns + if (flag_gageii(i) == 1 .and. catid_sta(i) /= -9999) then + if (acar_sta(i) .ge. (1. - thr_sel) * acar_gages_sta(i) .and. & + acar_sta(i) .le. (1. + thr_sel) * acar_gages_sta(i)) then + flag_thres(i) = 1 + endif + endif + end do + + print *, "Number of valid:", sum(flag_thres) + + deallocate(acar_pfaf) + end subroutine get_valide_stations_gageii +!------------------------------------------------------------ + subroutine regression(nt, vel_ori, dis_ori, nv, ns, Qclmt, slp, KKobs, KImodel, exp_slp, exp_clmt, mm, MU) + !------------------------------------------------------------ + ! Subroutine: regression + ! Purpose : For each station with sufficient valid records, performs a + ! regression between discharge and velocity to obtain a calibration + ! factor, and then computes the observed K value (KKobs) for that station. + ! + ! Input: + ! nt - Total number of valid records. + ! ns - Number of stations. + ! nv - Array containing the count of valid records per station. + ! vel_ori - Original velocity data (in ft/s, will be converted). + ! dis_ori - Original discharge data (in ft^3/s, will be converted). + ! Qclmt - Climatology discharge data for each station. + ! slp - Slope data for each station. + ! exp_slp, exp_clmt - Exponents for slope and climatology discharge. + ! mm, MU - Model parameters. + ! + ! Output: + ! KKobs - Array of observed K values for each station. + ! KImodel - Array of modeled K values (init guess) for each station. + !------------------------------------------------------------ + integer, intent(in) :: nt, ns + real, intent(inout), allocatable :: vel_ori(:), dis_ori(:) + integer, intent(in) :: nv(ns) + real, intent(inout), allocatable :: Qclmt(:), slp(:) + real, intent(out), allocatable :: KKobs(:), KImodel(:) + real, intent(in) :: exp_slp, exp_clmt, mm, MU + + real, allocatable, dimension(:) :: x, y, yest + integer :: thres = 100 + integer :: i, j + real :: k(ns), cdtm(ns), med + integer :: acc(ns) + real, allocatable :: vel(:), dis(:) + + ! Convert velocity from ft/s to m/s and discharge from ft^3/s to m^3/s + allocate(vel(nt), dis(nt)) + vel = vel_ori * 0.3048 + dis = dis_ori * 0.0283168 + + ! Calculate cumulative counts to index into the valid records for each station + acc(1) = nv(1) + do i = 2, ns + acc(i) = acc(i - 1) + nv(i) + end do + + ! For each station with enough valid records, perform regression + do i = 1, ns + if (nv(i) >= thres) then + allocate(x(nv(i)), y(nv(i)), yest(nv(i))) + x = dis(acc(i) - nv(i) + 1 : acc(i))**mm + y = vel(acc(i) - nv(i) + 1 : acc(i)) + k(i) = sum(x * y) / sum(x * x) + yest = k(i) * x + cdtm(i) = cal_cdtm(y, yest) + deallocate(x, y, yest) + else + k(i) = -9999. + cdtm(i) = -9999. + endif + end do + med = median(cdtm) + + ! Invalidate calibration factors for stations with low determination coefficient + where(cdtm < 0.5) k = -9999. + + allocate(KKobs(ns)) + do i = 1, ns + if (k(i) /= -9999. .and. Qclmt(i) /= -9999.) then + KKobs(i) = k(i) / (Qclmt(i)**(MU - mm)) + else + KKobs(i) = -9999. + endif + end do + + ! Calculate modeled K values (init guess) using the provided exponents + allocate(KImodel(ns)) + KImodel = (Qclmt**(exp_clmt)) * (slp**(exp_slp)) + + deallocate(vel, dis) + end subroutine regression +!------------------------------------------------------------ + subroutine filter_station(nc, ns, np, lats_full, lons_full, Qclmt_full, slp_full, catid_full, KKobs_full, KImodel_full, Qclmt, slp, catid, KKobs, KImodel, flag_gageii) + !------------------------------------------------------------ + ! Subroutine: filter_station + ! Purpose : Filters out stations that do not meet several criteria: + ! valid catchment ID, valid K values, minimum slope threshold, + ! and a positive GAGE-II flag. It then outputs the filtered data. + ! + ! Input: + ! nc - Total number of catchments. + ! ns - Number of stations. + ! lats_full, lons_full - Full arrays of station latitudes and longitudes. + ! Qclmt_full, slp_full - Full climatology discharge and slope data for stations. + ! catid_full - Full catchment ID array for stations. + ! KKobs_full, KImodel_full - Full observed and modeled K values (initial guess). + ! flag_gageii - GAGE-II validation flags. + ! + ! Output: + ! np - Number of stations that passed the filter. + ! Qclmt, slp, KKobs, KImodel - Filtered arrays for clmt discharge, slope, observed and modeled K (init guess). + ! catid - Filtered catchment IDs for the valid stations. + !------------------------------------------------------------ + integer, intent(in) :: ns, nc + integer, intent(out) :: np + real, intent(inout), allocatable :: lats_full(:), lons_full(:), Qclmt_full(:), slp_full(:), KKobs_full(:), KImodel_full(:) + real, intent(out), allocatable :: Qclmt(:), slp(:), KKobs(:), KImodel(:) + integer, intent(inout), allocatable :: catid_full(:) + integer, intent(out), allocatable :: catid(:) + integer, intent(inout), allocatable :: flag_gageii(:) + + integer, allocatable :: flag_slp(:) + real, allocatable :: lats(:), lons(:) + integer :: i, k + integer, allocatable :: flag_7065(:) + + ! Allocate and read slope flag data from file "temp/Pfaf_slope_flag.txt" + allocate(flag_slp(nc)) + open(77, file="temp/Pfaf_slope_flag.txt") + read(77, *) flag_slp + + allocate(flag_7065(ns)) + flag_7065 = 0 + + k = 0 + ! Count stations that meet all filtering criteria + do i = 1, ns + if (catid_full(i) .ne. -9999 .and. KKobs_full(i) /= -9999. .and. & + slp_full(i) > 1.e-5 .and. flag_slp(catid_full(i)) == 1 .and. & + flag_gageii(i) == 1) then + k = k + 1 + endif + end do + np = k + print *, "number of valid stations: ", np + + ! Allocate filtered output arrays + allocate(Qclmt(np), slp(np), catid(np), KKobs(np), KImodel(np)) + allocate(lats(np), lons(np)) + k = 0 + do i = 1, ns + if (catid_full(i) .ne. -9999 .and. KKobs_full(i) /= -9999. .and. & + slp_full(i) > 1.e-5 .and. flag_slp(catid_full(i)) == 1 .and. & + flag_gageii(i) == 1) then + k = k + 1 + Qclmt(k) = Qclmt_full(i) + slp(k) = slp_full(i) + KKobs(k) = KKobs_full(i) + KImodel(k) = KImodel_full(i) + catid(k) = catid_full(i) + lats(k) = lats_full(i) + lons(k) = lons_full(i) + flag_7065(i) = 1 + endif + end do + + ! Deallocate temporary full arrays that are no longer needed + deallocate(Qclmt_full, slp_full, KKobs_full, KImodel_full, flag_slp, flag_gageii, lats, lons) + + end subroutine filter_station +!------------------------------------------------------------ + subroutine cal_Kmodel(ns, np, nc, MU, exp_slp, exp_clmt, Qclmt, slp, KKobs, KImodel, KImodel_all, catid, catid_full, ccr, rms) + !------------------------------------------------------------ + ! Subroutine: cal_Kmodel + ! Purpose : Calibrates the model by adjusting catchment K values with a scaling + ! factor computed from the percentiles of observed and modeled K values. + ! It then computes the correlation coefficient (ccr) and RMS error. + ! + ! Input/Output: + ! ns - Number of stations. + ! np - Number of valid stations. + ! nc - Total number of catchments. + ! MU, exp_slp, exp_clmt - Model parameters. + ! Qclmt, slp, KKobs, KImodel - Arrays for station data. + ! KImodel_all - Modeled K values for all catchments. + ! catid, catid_full - Filtered and full catchment ID arrays. + ! + ! Output: + ! ccr - Correlation coefficient between observed and calibrated K. + ! rms - RMS error between observed and calibrated K. + !------------------------------------------------------------ + integer, intent(in) :: ns, np, nc + real, intent(in) :: MU, exp_slp, exp_clmt + real, intent(inout), allocatable :: Qclmt(:), slp(:), KKobs(:), KImodel(:) + real, intent(inout), allocatable :: KImodel_all(:) + integer, intent(inout), allocatable :: catid(:), catid_full(:) + real, intent(inout) :: ccr, rms + + real, allocatable :: KKobs_sort(:), KImodel_sort(:), KKmodel_full(:) + real, allocatable, dimension(:) :: dis, sca, Kv, KKmodel + integer, allocatable, dimension(:) :: gear + + character(len=50) :: MU_s, exp_slp_s, exp_clmt_s + + integer :: bulk, i, lev + real :: Kper(11), KMper(11), rat(11), dis_full(11) + + ! Format model parameters into strings for output naming purposes + write(MU_s, '(f4.2)') MU + write(exp_slp_s, '(f4.2)') exp_slp + if (exp_clmt >= 0.) then + write(exp_clmt_s, '(f4.2)') exp_clmt + else + write(exp_clmt_s, '(f4.2)') -1.*exp_clmt + exp_clmt_s = "n" // trim(exp_clmt_s) + endif + + ! Allocate arrays for sorted K values + allocate(KKobs_sort(np), KImodel_sort(np)) + call sort(np, KKobs, KKobs_sort) + call sort(np, KImodel, KImodel_sort) + + ! Compute percentile thresholds by dividing sorted arrays into 10 equal parts + bulk = np / 10 + Kper(1) = KKobs_sort(1) + KMper(1) = KImodel_sort(1) + do i = 2, 10 + Kper(i) = KKobs_sort(bulk * (i - 1)) + KMper(i) = KImodel_sort(bulk * (i - 1)) + end do + Kper(11) = KKobs_sort(np) + KMper(11) = KImodel_sort(np) + rat = Kper / KMper + + ! Allocate arrays for scaling calculations over all catchments + allocate(gear(nc), dis(nc), sca(nc), Kv(nc)) + + ! Initialize gear to default (12) and compute distance to percentile thresholds + gear = 12 + dis = -9999. + do i = 1, nc + do lev = 1, 11 + if (KImodel_all(i) <= KMper(lev)) then + gear(i) = lev + dis(i) = KMper(lev) - KImodel_all(i) + exit + endif + end do + end do + + ! Calculate differences between consecutive percentile thresholds + dis_full(1) = KMper(1) + do i = 2, 11 + dis_full(i) = KMper(i) - KMper(i - 1) + end do + + ! Compute scaling factors for each catchment based on its percentile position + do i = 1, nc + if (gear(i) == 1) then + sca(i) = rat(1) + elseif (gear(i) == 12) then + sca(i) = rat(11) + else + sca(i) = ( rat(gear(i)-1) * dis(i) + rat(gear(i)) * (dis_full(gear(i)) - dis(i)) ) / dis_full(gear(i)) + endif + Kv(i) = KImodel_all(i) * sca(i) + end do + + ! Write scaled K values for each catchment to an output file + open(88, file="output/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt") + do i = 1, nc + write(88, *) Kv(i) + end do + close(88) + + ! For each station, assign the corresponding scaled K value from its catchment + allocate(KKmodel_full(ns)) + do i = 1, ns + if (catid_full(i) /= -9999) then + KKmodel_full(i) = Kv(catid_full(i)) + else + KKmodel_full(i) = -9999. + endif + end do + + ! For filtered stations, extract the modeled K values + allocate(KKmodel(np)) + do i = 1, np + KKmodel(i) = Kv(catid(i)) + end do + + ! Compute correlation coefficient and RMS error between observed and modeled K values + ccr = cal_ccr(KKobs, KKmodel) + rms = cal_rms(KKobs, KKmodel, np) + + ! Deallocate temporary arrays and full data arrays + deallocate(KKobs_sort, KImodel_sort) + deallocate(KImodel_all, gear, dis, sca, Kv) + deallocate(Qclmt, slp, KKobs, KImodel, catid, KKmodel, catid_full, KKmodel_full) + end subroutine cal_Kmodel + + subroutine sort(np, data, data_sort) + !------------------------------------------------------------ + ! Subroutine: sort + ! Purpose : Sorts an array of real numbers in ascending order using bubble sort. + ! + ! Input: + ! np - Number of elements in the array. + ! data - Input array to be sorted. + ! + ! Output: + ! data_sort - Sorted array. + !------------------------------------------------------------ + integer, intent(in) :: np ! Size of the array + real, intent(in) :: data(np) ! Input array + real, intent(out) :: data_sort(np) ! Output sorted array + integer :: i, j + real :: temp + + ! Copy the input array to the output array + data_sort = data + + ! Bubble sort algorithm + do i = 1, np - 1 + do j = 1, np - i + if (data_sort(j) > data_sort(j + 1)) then + temp = data_sort(j) + data_sort(j) = data_sort(j + 1) + data_sort(j + 1) = temp + end if + end do + end do + end subroutine sort + + function cal_ccr(y, yest) result(ccr) + !------------------------------------------------------------ + ! Function: cal_ccr + ! Purpose : Calculates the correlation coefficient between observed and + ! estimated arrays. + ! + ! Input: + ! y - Observed data array. + ! yest - Estimated (modeled) data array. + ! + ! Output: + ! ccr - Correlation coefficient. + !------------------------------------------------------------ + real, intent(in) :: y(:) + real, intent(in) :: yest(:) + real :: ccr + real :: mean_y, mean_yest + real :: sum_y, sum_yest + real :: sum_num, sum_den_y, sum_den_yest + integer :: n + integer :: i + + n = size(y) + if (n /= size(yest)) then + print *, "Error: Arrays must have the same length" + ccr = 0.0 + return + endif + + ! Compute means + sum_y = sum(y) + sum_yest = sum(yest) + mean_y = sum_y / n + mean_yest = sum_yest / n + + ! Compute numerator and denominators for the correlation coefficient + sum_num = 0.0 + sum_den_y = 0.0 + sum_den_yest = 0.0 + do i = 1, n + sum_num = sum_num + (y(i) - mean_y) * (yest(i) - mean_yest) + sum_den_y = sum_den_y + (y(i) - mean_y)**2 + sum_den_yest = sum_den_yest + (yest(i) - mean_yest)**2 + end do + + if (sum_den_y == 0.0 .or. sum_den_yest == 0.0) then + print *, "Error: Zero variance in input arrays" + ccr = 0.0 + else + ccr = sum_num / sqrt(sum_den_y * sum_den_yest) + end if + + end function cal_ccr + + function cal_rms(k_obs, k_model, n) result(rms) + !------------------------------------------------------------ + ! Function: cal_rms + ! Purpose : Calculates the relative root mean square error between observed + ! and modeled K values. + ! + ! Input: + ! k_obs - Observed K values array. + ! k_model - Modeled K values array. + ! n - Number of elements. + ! + ! Output: + ! rms - Relative RMS error. + !------------------------------------------------------------ + implicit none + integer, intent(in) :: n + real, intent(in) :: k_obs(n), k_model(n) + real :: rms + real :: sum_sq_diff + integer :: i + + sum_sq_diff = 0.0 + + do i = 1, n + sum_sq_diff = sum_sq_diff + ((k_model(i) - k_obs(i)) / k_obs(i))**2 + end do + + rms = sqrt(sum_sq_diff / n) + end function cal_rms + + function cal_cdtm(y, yest) result(dtmc) + !------------------------------------------------------------ + ! Function: cal_cdtm + ! Purpose : Computes the coefficient of determination (R^2) between observed + ! and estimated data. + ! + ! Input: + ! y - Observed data array. + ! yest - Estimated data array. + ! + ! Output: + ! dtmc - Coefficient of determination (R^2). + !------------------------------------------------------------ + real, intent(in) :: y(:) + real, intent(in) :: yest(:) + real :: dtmc + real :: ss_tot, ss_res + real :: mean_y + integer :: n, i + + n = size(y) + if (n /= size(yest)) then + print *, "Error: Arrays must have the same length" + dtmc = 0.0 + return + endif + + mean_y = sum(y) / n + ss_tot = sum((y - mean_y)**2) + ss_res = sum((y - yest)**2) + + if (ss_tot == 0.0) then + print *, "Error: Zero total sum of squares" + dtmc = 0.0 + else + dtmc = 1.0 - (ss_res / ss_tot) + endif + + end function cal_cdtm + + function median(data) result(med) + !------------------------------------------------------------ + ! Function: median + ! Purpose : Computes the median of an array, ignoring values equal to -9999.0. + ! + ! Input: + ! data - Array of real numbers. + ! + ! Output: + ! med - Median value. + !------------------------------------------------------------ + implicit none + real, intent(in) :: data(:) + real :: med + real :: sorted_data(size(data)) + integer :: n_valid + integer :: i + + n_valid = 0 + do i = 1, size(data) + if (data(i) /= -9999.0) then + n_valid = n_valid + 1 + sorted_data(n_valid) = data(i) + end if + end do + + if (n_valid == 0) then + med = -9999.0 + return + end if + + call sort2(sorted_data(1:n_valid)) + + if (mod(n_valid, 2) == 0) then + med = (sorted_data(n_valid/2) + sorted_data(n_valid/2 + 1)) / 2.0 + else + med = sorted_data((n_valid + 1) / 2) + end if + + end function median + + subroutine sort2(arr) + !------------------------------------------------------------ + ! Subroutine: sort2 + ! Purpose : Sorts an array of real numbers in ascending order using + ! insertion sort. + ! + ! Input/Output: + ! arr - Array to be sorted. + !------------------------------------------------------------ + implicit none + real, intent(inout) :: arr(:) + integer :: i, j + real :: temp + + do i = 2, size(arr) + temp = arr(i) + j = i - 1 + do while (j >= 1 .and. arr(j) > temp) + arr(j + 1) = arr(j) + j = j - 1 + end do + arr(j + 1) = temp + end do + end subroutine sort2 + +!------------------------------------------------------------ +end module k_module \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py new file mode 100755 index 000000000..f5989e826 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py @@ -0,0 +1,173 @@ +import sys +import numpy as np +from netCDF4 import Dataset +#Main purpose: Processes lake data to be used in the river routing model. + +file_lat1m, file_lon1m, file_catmap, file_lake_mantag, file_lakecat_manfix = sys.argv[1:6] + +# Define constants +nlat = 10800 +nlon = 21600 + +# Read data from files +lats = np.loadtxt("temp/outlet_lat.txt", dtype=float) # Latitude of outlets +lons = np.loadtxt("temp/outlet_lon.txt", dtype=float) # Longitude of outlets +lat1m = np.loadtxt(file_lat1m, dtype=float) # Latitude grid +lon1m = np.loadtxt(file_lon1m, dtype=float) # Longitude grid + +# Function to find the nearest index in a coordinate array +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +# Find nearest indices for latitudes and longitudes +lati = ind_nearest_coord(lats, lat1m)+1 +loni = ind_nearest_coord(lons, lon1m)+1 + +#------------------------------------------------------------------------------------------------------ +ns = 3917 + +# Allocate array +catchind = np.zeros((nlat, nlon), dtype=int) + +# Read NetCDF file +def read_ncfile_int2d(filepath, varname, shape): + # Open the NetCDF file and read the specified variable + with Dataset(filepath, 'r') as nc: + data = nc.variables[varname][:].reshape(shape) + # Check for missing values and replace them with a default value + fill_value = nc.variables[varname]._FillValue if hasattr(nc.variables[varname], '_FillValue') else None + if fill_value is not None: + data = np.where(data == fill_value, -9999, data) # Replace missing values with 0 + return data + +catchind = read_ncfile_int2d(file_catmap, "CatchIndex", (nlat, nlon)) + +# Calculate catid +catid = np.zeros(ns, dtype=int) +for i in range(ns): + # Ensure indices are within bounds + if 0 < loni[i] <= nlon and 0 < lati[i] <= nlat: + catid[i] = catchind[lati[i] - 1, loni[i] - 1] # Adjust for 0-based indexing in Python + else: + catid[i] = -1 # Assign a default value for out-of-bounds indices + +#------------------------------------------------------------------------------------------------------ +# Constants +nall = 291284 +nv = 1782 +nv3 = 2097 + +# Read input data +aca_all = np.loadtxt("temp/Pfaf_acar.txt") + +# Initialize aca_model array +aca_model = np.full(ns, -9999.0) + +# Map aca_model using catid +for i in range(ns): + if catid[i] != -9999: + cid = catid[i] + aca_model[i] = aca_all[cid - 1] + +# Read observation data +aca_obs = np.loadtxt("temp/outlet_lakeacaOBS.txt") +outid_INCON = np.zeros(nv, dtype=int) + +# Filter inconsistent data +k = 0 +for i in range(ns): + if not (0.7 * aca_model[i] <= aca_obs[i] <= 1.3 * aca_model[i]): + outid_INCON[k] = i + 1 + k += 1 + +#print(k) + +#------------------------------------------------------------------------------------------------------ +# Read tags +tag_INCON = np.loadtxt(file_lake_mantag, dtype=int) + +# Update catid and aca_model based on tags +for i in range(nv): + oid = outid_INCON[i] + tag = tag_INCON[i] + if tag >= 1: + cid = tag + catid[oid - 1] = cid + aca_model[oid - 1] = aca_all[cid - 1] + else: + catid[oid - 1] = -9999 + aca_model[oid - 1] = -9999.0 + +# Compute flag_out +flag_out = np.where(aca_model != -9999, 1, 0) +#print(np.sum(flag_out)) + +#------------------------------------------------------------------------------------------------------ +# Read lakeid_out and compute absolute differences +lakeid_out = np.loadtxt("temp/outlet_lakeid.txt", dtype=int) +acaABSDIF_out = np.abs(aca_model - aca_obs) + +# Initialize collections +lakeid_collect = np.zeros(nv3, dtype=int) +outletid_collect = np.zeros(nv3, dtype=int) +acaABSDIF_collect = np.full(nv3, 1e10) +flag_2097_out = np.zeros(ns, dtype=int) +k = 0 + +# Collect valid outlets +for i in range(ns): + if flag_out[i] == 1: + lid = lakeid_out[i] + flag = 1 + if k >= 1: + for j in range(k): + if lid == lakeid_collect[j]: + flag = 0 + if acaABSDIF_out[i] < acaABSDIF_collect[j]: + flag_2097_out[outletid_collect[j]] = 0 + outletid_collect[j] = i + acaABSDIF_collect[j] = acaABSDIF_out[i] + flag_2097_out[i] = 1 + if flag == 1: + lakeid_collect[k] = lid + outletid_collect[k] = i + acaABSDIF_collect[k] = acaABSDIF_out[i] + flag_2097_out[i] = 1 + k += 1 + +#print(np.sum(flag_2097_out)) +np.savetxt("output/lake_outlet_flag_valid_2097.txt", flag_2097_out, fmt="%d") + +#------------------------------------------------------------------------------------------------------ +# Update catid with valid flags +catid = np.where(flag_2097_out == 0, -9999, catid) + +# Collect valid outlet IDs +outidV = np.zeros(nv3, dtype=int) +k = 0 +for i in range(ns): + if flag_2097_out[i] == 1: + outidV[k] = i + k += 1 + +outidV += 1 + +# Fix multiple outlets in same catchment +catid_outfix_2097 = np.loadtxt(file_lakecat_manfix, dtype=int) +catid_outfix_out = np.full(ns, -9999, dtype=int) + +for i in range(nv3): + oid = outidV[i] + catid_outfix_out[oid - 1] = catid_outfix_2097[i] + +catid = np.where((catid_outfix_out != 0) & (catid_outfix_out != -9999), catid_outfix_out, catid) +np.savetxt("output/lake_outlet_catid.txt", catid, fmt="%d") + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 new file mode 100755 index 000000000..4557eba84 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 @@ -0,0 +1,129 @@ +program main +!Main purpose: Reads lake and lake outlets information from Lake-TopoCat database. + +use constant, only : no, nvl, nvo, nl=>nl_lake + + implicit none + + ! Declare arrays for outlet and lake data: + integer, allocatable, dimension(:) :: lakeid_out, outid_out, lakeid_lake, lakeid_outV, outid_outV + real, allocatable, dimension(:) :: lat_out, lon_out, lat_outV, lon_outV, & + lakeaca_lake, lakearea_lake, lakeaca_outV, lakearea_outV + + ! Arrays for raw lake data: + real, allocatable, dimension(:) :: area_lake, aca_lake + integer, allocatable, dimension(:) :: id_lake + character(len=900) :: area_lake_file, id_lake_file, aca_lake_file + integer :: i, j, k + + character(len=900) :: file_lake_area + character(len=900) :: file_lake_id + character(len=900) :: file_lake_aca + character(len=900) :: file_lakeo_lakeid + character(len=900) :: file_lakeo_id + character(len=900) :: file_lakeo_lat + character(len=900) :: file_lakeo_lon + + if (command_argument_count() /= 7) then + print *, "no appropriate files found" + stop + endif + call get_command_argument(1, file_lake_area) + call get_command_argument(2, file_lake_id) + call get_command_argument(3, file_lake_aca) + call get_command_argument(4, file_lakeo_lakeid) + call get_command_argument(5, file_lakeo_id) + call get_command_argument(6, file_lakeo_lat) + call get_command_argument(7, file_lakeo_lon) + + ! Allocate arrays for raw lake data (size nl): + allocate(area_lake(nl), aca_lake(nl), id_lake(nl)) + + ! Initialize file names for input lake data: + area_lake_file = file_lake_area + id_lake_file = file_lake_id + aca_lake_file = file_lake_aca + + ! Read lake area, lake ID, and lake "aca" data from the input CSV files: + open(77, file=trim(area_lake_file), status="old") + read(77, *) area_lake + open(77, file=trim(id_lake_file), status="old") + read(77, *) id_lake + open(77, file=trim(aca_lake_file), status="old") + read(77, *) aca_lake + + ! Allocate arrays for filtered lake data (size nvl): + allocate(lakearea_lake(nvl)) + allocate(lakeid_lake(nvl)) + allocate(lakeaca_lake(nvl)) + + k = 0 + ! Filter lakes: select only those with an area greater than or equal to 50. + do i = 1, nl + if (area_lake(i) .ge. 50.0) then + k = k + 1 + lakearea_lake(k) = area_lake(i) + lakeid_lake(k) = id_lake(i) + lakeaca_lake(k) = aca_lake(i) + end if + end do +!------------------------------------------------------------------------------------- + + ! Allocate arrays for outlet data (raw arrays with size 'no'): + allocate(lakeid_out(no), outid_out(no), lat_out(no), lon_out(no)) + ! Allocate arrays for matched outlet data (size 'nvo'): + allocate(lakeid_outV(nvo), outid_outV(nvo), lat_outV(nvo), lon_outV(nvo), lakeaca_outV(nvo), lakearea_outV(nvo)) + + ! Read outlet data from CSV files: + open(77, file=trim(file_lakeo_lakeid)) + read(77, *) lakeid_out + open(77, file=trim(file_lakeo_id)) + read(77, *) outid_out + open(77, file=trim(file_lakeo_lat)) + read(77, *) lat_out + open(77, file=trim(file_lakeo_lon)) + read(77, *) lon_out + + ! Match outlet records to filtered lakes: + k = 0 + do i = 1, no + do j = 1, nvl + if (lakeid_out(i) == lakeid_lake(j)) then + k = k + 1 + outid_outV(k) = outid_out(i) + lat_outV(k) = lat_out(i) + lon_outV(k) = lon_out(i) + lakeid_outV(k) = lakeid_lake(j) + lakeaca_outV(k) = lakeaca_lake(j) + lakearea_outV(k) = lakearea_lake(j) + end if + end do + end do + + ! Write matched outlet data to output text files: + open(88, file="temp/outlet_lat.txt") + do i = 1, nvo + write(88, *) lat_outV(i) + end do + + open(88, file="temp/outlet_lon.txt") + do i = 1, nvo + write(88, *) lon_outV(i) + end do + + open(88, file="temp/outlet_lakeid.txt") + do i = 1, nvo + write(88, *) lakeid_outV(i) + end do + + open(88, file="temp/outlet_lakeacaOBS.txt") + do i = 1, nvo + write(88, *) lakeaca_outV(i) + end do + + open(88, file="output/lake_outlet_lakearea.txt") + do i = 1, nvo + write(88, *) lakearea_outV(i) + end do + +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/readme.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/readme.txt new file mode 100644 index 000000000..947e08f81 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/readme.txt @@ -0,0 +1,165 @@ +v1 05/05/2025, Yujin Zeng + +The "preproc/routing_model" package is used for creating input data for the GEOS routing model. + +Usage: + • On NCCS/Discover: + 1. source g5_modules.sh + 2. python3 run_routing_preproc.py + • Off Discover: contact yujin.zeng@nasa.gov + +The tasks completed by each F90 or Python program are briefly described as follows: + +1. get_Pfaf_file.f90 + Reads the Pfafstetter code dataset and generates + files for the connectivity of catchments in the routing network. + +2. get_latloni_cellarea.py + Computes grid-cell index arrays and per-cell areas for 1-m high-res grid. + +3. get_num_sub_catchment_M09.f90 / get_num_sub_catchment_M36.f90 + Parses high-res map of catchment index to get the area and + coordinates (of model grid) of each sub-catchments within each main catchment. + +4. get_lonlat_bond_M09.f90 / get_lonlat_bond_M36.f90 + Extracts the latitude/longitude boundaries of each catchment-tile from + catchment definition files. + +5. get_lonlati_maptile_M09.py / get_lonlati_maptile_M36.py + Assigns a catchment‐tile index from catchment definition files to each model grid cell. + +6. get_isub_M09.f90 / get_isub_M36.f90 + Assigns a catchment‐tile index from maptile files to each sub-catchment. + +7. get_area_M09.f90 / get_area_M36.f90 + Gets the area for each catchment-tile. + +8. get_Qr_clmt.f90 + Reads SMAP L4 runoff data (2016–2023) from a NetCDF file and computes the climatological + mean discharge for each catchment. + +9. get_river_length.f90 + Determines main river channel lengths for each catchment by using HydroSHEDS + data of distance to sink. + +10. get_K_model_calik.f90 + Calculates the K parameter used in the river routing model. + +11. get_dam_data.py + Processes reservoir (dam) data: reads dam locations and usage information from GRanD database. + +12. read_input_TopoCat.f90 + Reads lake and lake outlets information from Lake-TopoCa database. + +13. process_lake_data.py + Processes lake data to be used in the river routing model. + +The explanations for the input files of this package can be found in the input directory. + +The outputs from this package, which are used as input to the river routing model, are listed as follows: + +downstream_1D_new_noadj.txt + Downstream catchment id for each catchment. + +Pfaf_area.txt + Catchment area (km^2) for each catchment. + +upstream_1D.txt + Upstream catchment id for each catchment. + +Pfaf_upnum.txt + Number of upstream catchments for each catchment. + +Pfaf_tosink.txt + Number of steps to final sink for each catchment. + +Pfaf_nsub_M09.txt / Pfaf_nsub_M36.txt + Count of sub‐catchments contained within each catchment at M09 and M36 resolutions, respectively. + +Pfaf_xsub_M09.txt / Pfaf_xsub_M36.txt + X (longitude) coordinates in M09 and M36 grid for each sub-catchemnt within each catchment, respectively. + +Pfaf_ysub_M09.txt / Pfaf_ysub_M36.txt + Y (longitude) coordinates in M09 and M36 grid for each sub-catchemnt within each catchment, respectively. + +Pfaf_asub_M09.txt / Pfaf_asub_M36.txt + Area (km^2) of each sub‐catchment within each catchment at M09 and M36 resolutions, respectively. + +Pfaf_isub_M09.txt / Pfaf_isub_M36.txt + Tile number (in the catchment definition file) of each sub‐catchment within each catchment at M09 and M36 resolutions, respectively. + +area_M09_1d.txt / area_M36_1d.txt + Area (km^2) of each tile (in the catchment definition file) for M09 and M36 grid, respectively. + +Pfaf_qstr.txt + Climatological mean runoff (m^3 s-1) for each catchment. + +Pfaf_qri.txt + Climatological mean discharge (m^3 s-1) for each catchment. + +Pfaf_qin.txt + Climatological mean inflow (m^3 s-1) from upstream for each catchment. + +Pfaf_lriv_PR.txt + Main river length scale (km) for each catchment. + +Pfaf_lstr_PR.txt + Mean local stream length scale (km) for each catchment. + +Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt + Calculated K parameters for local streams in each catchment. + +Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt + Calculated K parameters for main rivers in each catchment. + +area_skm_grand.txt + Reservoir surface areas (km^2) for the GRanD dams. + +cap_max_grand.txt + Maximum storage capacities (10^6 m^3) for the GRanD dams. + +catid_dam_corr_aca_grand5000.txt + Catchment IDs for the GRanD dams. + +flag_all_res.txt + In-use flags for the GRanD dams. + +irr_grand.txt + Flags for irrigation use for the GRanD dams. + +hydroelec_grand.txt + Flags for hydroelectric use for the GRanD dams. + +watersupply_grand.txt + Flags for water-supply use for the GRanD dams. + +nav_grand.txt + Flags for navigation use for the GRanD dams. + +rec_grand.txt + Flags for recreational use for the GRanD dams. + +fldmainsec_grand.txt + Flags for flood‐control use for the GRanD dams. + +other_grand.txt + Flags for other use for the GRanD dams. + +lake_outlet_lakearea.txt + Lake surface area (km^2) for each lake represented in the model. + +lake_outlet_flag_valid_2097.txt + In-use flags for the lakes. + +lake_outlet_catid.txt + Catchment IDs for the lakes represented in the model. + + + + + + + + + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 new file mode 100755 index 000000000..1ed66ce0b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 @@ -0,0 +1,193 @@ +module river_read +!module for reading river routing-related netcdf data + + implicit none + include 'netcdf.inc' + + public :: read_ncfile_int1d + public :: read_ncfile_real1d + public :: read_ncfile_double1d + + public :: read_ncfile_int2d + public :: read_ncfile_int3d + public :: read_ncfile_real2d + public :: read_ncfile_real3d + public :: read_ncfile_double2d + public :: read_ncfile_double3d + + contains +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + integer, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real*8, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + integer, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real*8, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double3d +!------------------------------------------------------------------------------------------ + subroutine check_ret(ret, calling) + integer, intent(in) :: ret + character(len=*) :: calling + + if (ret /= NF_NOERR) then + write(6,*)'netcdf error from ',trim(calling) + call endrun(nf_strerror(ret)) + end if + end subroutine check_ret +!----------------------------------------------------------------------- + subroutine endrun(msg,subname) + character(len=*), intent(in), optional :: msg + character(len=*), intent(in), optional :: subname + + if (present (subname)) then + write(6,*) 'ERROR in subroutine :', trim(subname) + end if + + if (present (msg)) then + write(6,*)'ENDRUN:', msg + else + write(6,*) 'ENDRUN: called without a message string' + end if + + stop + end subroutine endrun +!----------------------------------------------------------------------- + +end module river_read + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run.sh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run.sh new file mode 100755 index 000000000..00fc9a3cb --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run.sh @@ -0,0 +1,77 @@ +#!/bin/bash +set -e + + +#---copy some files---- +cp input/area_skm_grand.txt output/ +cp input/cap_max_grand.txt output/ + +#---river-------------- +echo get_Pfaf_file.f90 +./build get_Pfaf_file.f90 +./get_Pfaf_file.out + +echo get_latloni_cellarea.py +python3 get_latloni_cellarea.py + +echo get_num_sub_catchment_M09.f90 +./build get_num_sub_catchment_M09.f90 +./get_num_sub_catchment_M09.out + +echo get_num_sub_catchment_M36.f90 +./build get_num_sub_catchment_M36.f90 +./get_num_sub_catchment_M36.out + +echo get_lonlat_bond_M09.f90 +./build get_lonlat_bond_M09.f90 +./get_lonlat_bond_M09.out + +echo get_lonlat_bond_M36.f90 +./build get_lonlat_bond_M36.f90 +./get_lonlat_bond_M36.out + +echo get_lonlati_maptile_M09.py +python3 get_lonlati_maptile_M09.py +echo get_lonlati_maptile_M36.py +python3 get_lonlati_maptile_M36.py + +echo get_isub_M09.f90 +./build get_isub_M09.f90 +./get_isub_M09.out + +echo get_isub_M36.f90 +./build get_isub_M36.f90 +./get_isub_M36.out + +echo get_area_M09.f90 +./build get_area_M09.f90 +./get_area_M09.out + +echo get_area_M36.f90 +./build get_area_M36.f90 +./get_area_M36.out + +echo get_Qr_clmt.f90 +./build get_Qr_clmt.f90 +./get_Qr_clmt.out + +echo get_river_length.f90 +./build get_river_length.f90 +./get_river_length.out + +echo get_K_model_calik.f90 +./build get_K_model_calik.f90 +./get_K_model_calik.out + +#--------reservoir----------- +echo get_dam_data.py +python3 get_dam_data.py + +#--------lake---------------- +echo read_input_TopoCat.f90 +./build read_input_TopoCat.f90 +./read_input_TopoCat.out + +echo process_lake_data.py +python3 process_lake_data.py + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run_routing_preproc.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run_routing_preproc.py new file mode 100644 index 000000000..b334d4872 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run_routing_preproc.py @@ -0,0 +1,176 @@ +#!/usr/bin/env python3 + +#source g5_modules before run to get the necessary env + +import os +import shutil +import subprocess +from pathlib import Path + +def run(cmd): + """Run a command and exit on failure.""" + print(f">>> {' '.join(cmd)}") + subprocess.run(cmd, check=True) + +def main(): + # ----------------------------- + # Define input and output paths + # ----------------------------- + +# Path to "bcs_shared" directory: + file_path = "/discover/nobackup/yzeng3/data/river_preproc_input/" # NCCS Discover + #file_path = "/nobackup/gmao_SIteam/ModelData/bcs_shared/" # NAS + + + file_pfafrout = file_path + "/Pfafcatch-routing.dat" + file_lat1m = file_path + "/lat_1m.txt" + file_lon1m = file_path + "/lon_1m.txt" + file_lat = {"M09": file_path + "/lat_M09.txt", + "M36": file_path + "/lat_M36.txt"} + file_lon = {"M09": file_path + "/lon_M09.txt", + "M36": file_path + "/lon_M36.txt"} + file_catdef = {"M09": file_path + "/catchment_M09.def", + "M36": file_path + "/catchment_M36.def"} + file_clmtrunf = file_path + "/SMAPL4_OL7000_runoff_mean_2016_2023.nc" + file_pfafmap = file_path + "/SRTM_PfafData.nc" + file_ldn = file_path + "/hyd_glo_ldn_15s.nc" + file_hyelev = file_path + "/hyd_glo_dem_15s.nc" + file_vel = file_path + "/velocity.txt" + file_dis = file_path + "/discharge.txt" + file_usid = file_path + "/USGSID.txt" + file_lats = file_path + "/lat_for_site.txt" + file_lons = file_path + "/lon_for_site.txt" + file_gage_id = file_path + "/id_gagesii.txt" + file_gage_acar = file_path + "/acar_gagesii.txt" + + file_latdam = file_path + "/lat_dam_grand.txt" + file_londam = file_path + "/lon_dam_grand.txt" + file_acadam = file_path + "/catch_acar_grand.txt" + file_damcat_manfix = file_path + "/catid_dam_manfix.txt" + file_dam_manflag = file_path + "/flag_dam_manfix.txt" + file_dam_use = file_path + "/main_use_grand.txt" + file_damflood = file_path + "/flood_use_grand.txt" + file_damarea = file_path + "/area_skm_grand.txt" + file_damcap = file_path + "/cap_max_grand.txt" + + file_lake_area = file_path + "/Lake_area.csv" + file_lake_id = file_path + "/Hylak_id_lake.csv" + file_lake_aca = file_path + "/acar_lake.csv" + file_lakeo_lakeid = file_path + "/Hylak_id_lakeout.csv" + file_lakeo_id = file_path + "/Outlet_id_lakeout.csv" + file_lakeo_lat = file_path + "/Outlet_lat_lakeout.csv" + file_lakeo_lon = file_path + "/Outlet_lon_lakeout.csv" + file_lake_mantag = file_path + "/catid_lake_manfix.txt" + file_lakecat_manfix = file_path + "/catid_lake_multout_manfix.txt" + + + lib_path = "/discover/nobackup/yzeng3/lib" + old_ld = os.environ.get("LD_LIBRARY_PATH", "") + os.environ["LD_LIBRARY_PATH"] = f"{lib_path}:{old_ld}" + + # ----------------------------- + # Ensure output and temp directory exists + # ----------------------------- + subprocess.run(["mkdir", "-p", "output"], check=True) + subprocess.run(["mkdir", "-p", "temp"], check=True) + + # ----------------------------- + # Copy dam area and capacity files + # ----------------------------- + shutil.copy(file_damarea, "output/") + shutil.copy(file_damcap, "output/") + + # ----------------------------- + # River processing section + # ----------------------------- + # Compile and run Pfafcatch routing generator + run(["./build", "get_Pfaf_file.f90"]) + run(["./get_Pfaf_file.out", file_pfafrout]) + + # Generate latitude/longitude indices and cell areas + run([ + "python3", "get_latloni_cellarea.py", + file_lat["M36"], file_lon["M36"], + file_lat["M09"], file_lon["M09"], + file_lat1m, file_lon1m, + ]) + + # Compute number of sub-catchments for M09 and M36 resolutions + for res in ("M09", "M36"): + run(["./build", f"get_num_sub_catchment_{res}.f90"]) + run([f"./get_num_sub_catchment_{res}.out", file_pfafmap]) + + # Build longitude-latitude boundary files for each resolution + for res in ("M09", "M36"): + run(["./build", f"get_lonlat_bond_{res}.f90"]) + run([f"./get_lonlat_bond_{res}.out", file_catdef[res]]) + + # Map tile longitude/latitude for M09 and M36 + for res in ("M09", "M36"): + run(["python3", f"get_lonlati_maptile_{res}.py", file_lat[res], file_lon[res]]) + # Build and run isub calculators for both resolutions + for res in ("M09", "M36"): + run(["./build", f"get_isub_{res}.f90"]) + run([f"./get_isub_{res}.out"]) + + # Calculate area of each catchment + for res in ("M09", "M36"): + run(["./build", f"get_area_{res}.f90"]) + run([f"./get_area_{res}.out", file_pfafmap]) + + # Compute climatological runoff + run(["./build", "get_Qr_clmt.f90"]) + run(["./get_Qr_clmt.out", file_clmtrunf]) + + # Determine river lengths + run(["./build", "get_river_length.f90"]) + run([ + "./get_river_length.out", + file_pfafmap, file_ldn, + file_hyelev, file_pfafrout + ]) + + # Calibrate K model using velocity and discharge data + run(["./build", "get_K_model_calik.f90"]) + run([ + "./get_K_model_calik.out", + file_vel, file_dis, file_usid, + file_lats, file_lons, + file_lat1m, file_lon1m, + file_pfafmap, + file_gage_id, file_gage_acar + ]) + + # ----------------------------- + # Reservoir (dam) processing + # ----------------------------- + run([ + "python3", "get_dam_data.py", + file_latdam, file_londam, + file_lat1m, file_lon1m, + file_pfafmap, file_acadam, + file_damcat_manfix, file_dam_manflag, + file_dam_use, file_damflood + ]) + + # ----------------------------- + # Lake processing section + # ----------------------------- + run(["./build", "read_input_TopoCat.f90"]) + run([ + "./read_input_TopoCat.out", + file_lake_area, file_lake_id, + file_lake_aca, + file_lakeo_lakeid, file_lakeo_id, + file_lakeo_lat, file_lakeo_lon + ]) + + run([ + "python3", "process_lake_data.py", + file_lat1m, file_lon1m, + file_pfafmap, + file_lake_mantag, file_lakecat_manfix + ]) + +if __name__ == "__main__": + main() \ No newline at end of file