├── cime_config ├── testdefs │ ├── testmods_dirs │ │ └── mosart │ │ │ ├── iceOff │ │ │ ├── include_user_mods │ │ │ └── user_nl_mosart │ │ │ ├── decompOpts │ │ │ ├── include_user_mods │ │ │ └── user_nl_mosart │ │ │ ├── mosartCold │ │ │ ├── include_user_mods │ │ │ └── user_nl_mosart │ │ │ ├── qgrwlOpts │ │ │ ├── include_user_mods │ │ │ └── user_nl_mosart │ │ │ ├── inplacethreshold │ │ │ ├── include_user_mods │ │ │ └── user_nl_mosart │ │ │ ├── passChannelDepths │ │ │ ├── include_user_mods │ │ │ └── user_nl_cpl │ │ │ ├── mosartGridNull │ │ │ ├── shell_commands │ │ │ └── README │ │ │ ├── mosartOff │ │ │ └── shell_commands │ │ │ ├── nobypass │ │ │ └── user_nl_mosart │ │ │ ├── default │ │ │ └── user_nl_mosart │ │ │ └── clmAccelSpinupIgnoreWarn │ │ │ └── shell_commands │ ├── ExpectedTestFails.xml │ └── testlist_mosart.xml ├── user_nl_mosart ├── config_archive.xml ├── config_compsets.xml ├── buildlib ├── config_component.xml ├── namelist_definition_mosart.xml └── buildnml ├── docs └── index.html ├── .gitignore ├── src ├── riverroute │ ├── mosart_data.F90 │ ├── mosart_tctl_type.F90 │ ├── mosart_tparameter_type.F90 │ ├── mosart_vars.F90 │ ├── mosart_fileutils.F90 │ ├── mosart_tstatusflux_type.F90 │ ├── mosart_histflds.F90 │ ├── mosart_budget_type.F90 │ ├── mosart_restfile.F90 │ ├── mosart_physics.F90 │ └── mosart_tspatialunit_type.F90 └── cpl │ └── nuopc │ └── rof_import_export.F90 ├── README.rst └── LICENSE /cime_config/testdefs/testmods_dirs/mosart/iceOff/include_user_mods: -------------------------------------------------------------------------------- 1 | ../default 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/decompOpts/include_user_mods: -------------------------------------------------------------------------------- 1 | ../default 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/mosartCold/include_user_mods: -------------------------------------------------------------------------------- 1 | ../default 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/mosartCold/user_nl_mosart: -------------------------------------------------------------------------------- 1 | finidat = ' ' 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/include_user_mods: -------------------------------------------------------------------------------- 1 | ../default 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/decompOpts/user_nl_mosart: -------------------------------------------------------------------------------- 1 | decomp_option = '1d' 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/iceOff/user_nl_mosart: -------------------------------------------------------------------------------- 1 | ice_runoff = .false. 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/include_user_mods: -------------------------------------------------------------------------------- 1 | ../default 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/passChannelDepths/include_user_mods: -------------------------------------------------------------------------------- 1 | ../default 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/mosartGridNull/shell_commands: -------------------------------------------------------------------------------- 1 | ./xmlchange ROF_GRID=null 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/mosartOff/shell_commands: -------------------------------------------------------------------------------- 1 | ./xmlchange MOSART_MODE=null 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/passChannelDepths/user_nl_cpl: -------------------------------------------------------------------------------- 1 | flds_r2l_stream_channel_depths = .true. 2 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/nobypass/user_nl_mosart: -------------------------------------------------------------------------------- 1 | qgwl_runoff_option = 'all' 2 | bypass_routing_option = 'none' 3 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/qgrwlOpts/user_nl_mosart: -------------------------------------------------------------------------------- 1 | qgwl_runoff_option = 'all' 2 | bypass_routing_option = 'direct_to_outlet' 3 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/inplacethreshold/user_nl_mosart: -------------------------------------------------------------------------------- 1 | qgwl_runoff_option = 'threshold' 2 | bypass_routing_option = 'direct_in_place' 3 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/default/user_nl_mosart: -------------------------------------------------------------------------------- 1 | ! ice_runoff = .true. 2 | ndens = 1,1,1 3 | nhtfrq =-24,-8 4 | mfilt = 1,1 5 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/clmAccelSpinupIgnoreWarn/shell_commands: -------------------------------------------------------------------------------- 1 | ./xmlchange CLM_ACCELERATED_SPINUP=on 2 | ./xmlchange MOSART_IGNORE_WARNINGS=TRUE 3 | -------------------------------------------------------------------------------- /cime_config/testdefs/testmods_dirs/mosart/mosartGridNull/README: -------------------------------------------------------------------------------- 1 | Test for a case when the MOSART grid is NULL and hence MOSART should be turned off 2 | Since this happens at create_newcase this should be done for a grid where the ROF_GRID 3 | is already NULL, so for example a single point case. 4 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | MOSART 3 | 4 | 5 | 6 |

If your browser supports Refresh, you'll be transported to the 7 | CESM Website 8 | in 5 seconds, otherwise, select the link manually. 9 | 10 | -------------------------------------------------------------------------------- /cime_config/user_nl_mosart: -------------------------------------------------------------------------------- 1 | !---------------------------------------------------------------------------------- 2 | ! Users should add all user specific namelist changes below in the form of 3 | ! namelist_var = new_namelist_value 4 | ! NOTE: namelist variable delt_mosart (the time-step) CAN ONLY be changed by modifying the value 5 | ! of the xml variable ROF_NCPL in env_run.xml 6 | !---------------------------------------------------------------------------------- 7 | 8 | 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ignore svn directories 2 | **/.svn/** 3 | .svn/ 4 | 5 | # binary files 6 | *.nc 7 | 8 | # editor files 9 | *.swp 10 | *~ 11 | 12 | # mac files 13 | .DS_Store 14 | 15 | # cmake generated files 16 | build/ 17 | CMakeFiles/ 18 | 19 | # don't ignore cism build utilities directory 20 | !components/cism/**/build 21 | 22 | # build output 23 | *.o 24 | *.mod 25 | core.* 26 | *.gz 27 | *.log 28 | cime_config/buildnmlc 29 | __pycache__ 30 | 31 | # test and case directories 32 | tests/ 33 | scripts/testreporter.pl 34 | 35 | 36 | 37 | -------------------------------------------------------------------------------- /src/riverroute/mosart_data.F90: -------------------------------------------------------------------------------- 1 | module mosart_data 2 | 3 | use mosart_control_type, only : control_type 4 | use mosart_tctl_type, only : tctl_type 5 | use mosart_tspatialunit_type, only : tspatialunit_type 6 | use mosart_tstatusflux_type, only : tstatusflux_type 7 | use mosart_tparameter_type, only : tparameter_type 8 | 9 | implicit none 10 | private 11 | 12 | ! Derived types 13 | type(Tctl_type), public :: Tctl 14 | type(Tspatialunit_type), public :: TUnit 15 | type(TstatusFlux_type), public :: TRunoff 16 | type(Tparameter_type), public :: TPara 17 | type(control_type), public :: ctl 18 | 19 | end module mosart_data 20 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | ======================================== 2 | Model for Scale Adaptive River Transport 3 | ======================================== 4 | 5 | The Model for Scale Adaptive River Transport, Mosart, 6 | is part of the Community Earth System Model. 7 | 8 | IMPORTANT NOTE: MOSART is Obsolescent! 9 | 10 | MOSART is part of CESM3, but is obsolescent. 11 | 12 | We do not have support for creating input datasets for MOSART and 13 | as such can NOT use MOSART for Paleo work. 14 | 15 | Longer term MOSART will be removed in future versions of CESM and the new model 16 | mizuRoute will be used for Paleo work as well as present day. 17 | It's also possible that external collaborators will support the use of MOSART 18 | for present day climate even as mizuRoute becomes the default model for CESM. 19 | 20 | See the CESM web site for documentation and information: 21 | 22 | http://www.cesm.ucar.edu 23 | -------------------------------------------------------------------------------- /src/riverroute/mosart_tctl_type.F90: -------------------------------------------------------------------------------- 1 | module mosart_tctl_type 2 | 3 | use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL 4 | 5 | implicit none 6 | private 7 | 8 | type Tctl_type 9 | real(r8) :: DeltaT ! Time step in seconds 10 | integer :: DLevelH2R ! The base number of channel routing sub-time-steps within one hillslope routing step. 11 | ! Usually channel routing requires small time steps than hillslope routing. 12 | integer :: DLevelR ! The number of channel routing sub-time-steps at a higher level within one channel routing step at a lower level. 13 | integer :: RoutingMethod ! Flag for routing methods. 1 --> variable storage method from SWAT model 14 | contains 15 | procedure :: Init 16 | end type Tctl_type 17 | public :: Tctl_type 18 | 19 | contains 20 | 21 | subroutine Init(this) 22 | class(Tctl_type) :: this 23 | 24 | this%RoutingMethod = 1 25 | this%DLevelH2R = 5 26 | this%DLevelR = 3 27 | 28 | end subroutine Init 29 | 30 | end module mosart_tctl_type 31 | -------------------------------------------------------------------------------- /src/riverroute/mosart_tparameter_type.F90: -------------------------------------------------------------------------------- 1 | module mosart_tparameter_type 2 | 3 | ! parameters to be calibrated. Ideally, these parameters are supposed to be uniform for one region 4 | 5 | use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL 6 | 7 | implicit none 8 | private 9 | 10 | public :: Tparameter_type 11 | type Tparameter_type 12 | real(r8), pointer :: c_nr(:) ! coefficient to adjust the manning's roughness of channels NOT_USED 13 | real(r8), pointer :: c_nh(:) ! coefficient to adjust the manning's roughness of overland flow across hillslopes NOT_USED 14 | real(r8), pointer :: c_twid(:) ! coefficient to adjust the width of sub-reach channel 15 | contains 16 | procedure, public :: Init 17 | end type Tparameter_type 18 | 19 | contains 20 | 21 | subroutine Init(this, begr, endr) 22 | 23 | ! Arguments 24 | class(tparameter_type) :: this 25 | integer, intent(in) :: begr, endr 26 | 27 | ! Initialize TPara 28 | allocate (this%c_twid(begr:endr)) 29 | this%c_twid = 1.0_r8 30 | 31 | end subroutine Init 32 | 33 | end module mosart_tparameter_type 34 | -------------------------------------------------------------------------------- /cime_config/testdefs/ExpectedTestFails.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 29 | 30 | 31 | 32 | FAIL 33 | MOSART#109 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /cime_config/config_archive.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | r 5 | rh\da 6 | rh\di 7 | h\d*.*\.nc$ 8 | e 9 | locfnh 10 | 11 | rpointer.rof$NINST_STRING.$DATENAME 12 | $CASE.mosart$NINST_STRING.r.$DATENAME.nc 13 | 14 | 15 | rpointer.rof.1976-01-01-00000 16 | rpointer.rof.1976-01-02-00000 17 | rpointer.rof_9999.1976-01-01-00000 18 | casename.mosart.r.1976-01-01-00000.nc 19 | casename.mosart.rh4a.1976-01-01-00000.nc 20 | casename.mosart.rh4i.1976-01-01-00000.nc 21 | casename.mosart.h0a.1976-01-01-00000.nc 22 | casename.mosart.h0i.1976-01-01-00000.nc 23 | casename.mosart.e.1976-01-01-00000.nc 24 | casename.mosart.h0a.1976-01-01-00000.nc.base 25 | casename.mosart.h0i.1976-01-01-00000.nc.base 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /cime_config/config_compsets.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | ========================================= 7 | compset naming convention 8 | ========================================= 9 | The compset longname below has the specified order 10 | atm, lnd, ice, ocn, river, glc wave cesm-options 11 | 12 | The notation for the compset longname is 13 | TIME_ATM[%phys]_LND[%phys]_ICE[%phys]_OCN[%phys]_ROF[%phys]_GLC[%phys]_WAV[%phys][_BGC%phys] 14 | Where for the CAM specific compsets below the following is supported 15 | TIME = Time period (e.g. 2000, HIST, RCP8...) 16 | ATM = [CAM40, CAM50, CAM55, CAM60] 17 | LND = [CLM45, CLM50, DLND, SLND] 18 | ICE = [CICE, DICE, SICE] 19 | OCN = [DOCN, SOCN, POP2, MOM] 20 | ROF = [RTM, MOSART, MIZUROUTE, DROF, SROF] 21 | GLC = [CISM1, CISM2, SGLC] 22 | WAV = [SWAV, WWW] 23 | BGC = optional BGC scenario 24 | 25 | The OPTIONAL %phys attributes specify submodes of the given system 26 | For example DOCN%DOM is the data ocean model for DOCN 27 | ALL the possible %phys choices for each component are listed 28 | with the -list command for create_newcase 29 | ALL data models must have a %phys option that corresponds to the data model mode 30 | 31 | Each compset node is associated with the following elements 32 | - lname 33 | - alias 34 | - science_support (if this compset is supported scientifically with control simulations) 35 | 36 | 37 | 38 | 39 | 40 | 41 | R2000MOSART 42 | 2000_SATM_DLND%LCPL_SICE_SOCN_MOSART_SGLC_SWAV 43 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005-2017, University Corporation for Atmospheric Research (UCAR) 2 | All rights reserved. 3 | 4 | Developed by: 5 | University Corporation for Atmospheric Research - National Center for Atmospheric Research 6 | https://www2.cesm.ucar.edu/working-groups/sewg 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining 9 | a copy of this software and associated documentation files (the "Software"), 10 | to deal with the Software without restriction, including without limitation 11 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 12 | and/or sell copies of the Software, and to permit persons to whom 13 | the Software is furnished to do so, subject to the following conditions: 14 | 15 | - Redistributions of source code must retain the above copyright notice, 16 | this list of conditions and the following disclaimers. 17 | - Redistributions in binary form must reproduce the above copyright notice, 18 | this list of conditions and the following disclaimers in the documentation 19 | and/or other materials provided with the distribution. 20 | - Neither the names of [Name of Development Group, UCAR], 21 | nor the names of its contributors may be used to endorse or promote 22 | products derived from this Software without specific prior written permission. 23 | 24 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 25 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 26 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 27 | ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE 28 | LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 29 | CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 30 | SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 31 | INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 32 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 33 | ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 34 | POSSIBILITY OF SUCH DAMAGE. 35 | -------------------------------------------------------------------------------- /cime_config/buildlib: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | """ 3 | Build the mosart component library 4 | """ 5 | #pylint: disable=unused-wildcard-import, wildcard-import, multiple-imports 6 | #pylint: disable=wrong-import-position, invalid-name, too-many-locals 7 | import os, sys 8 | 9 | CIMEROOT = os.environ.get("CIMEROOT") 10 | if CIMEROOT is None: 11 | raise SystemExit("ERROR: must set CIMEROOT environment variable") 12 | sys.path.append(os.path.join(CIMEROOT, "scripts", "CIME", "Tools")) 13 | 14 | from standard_script_setup import * 15 | from CIME.case import Case 16 | from CIME.utils import expect, run_cmd 17 | from CIME.buildlib import parse_input 18 | from CIME.build import get_standard_makefile_args 19 | 20 | logger = logging.getLogger(__name__) 21 | 22 | ############################################################################### 23 | def _build_mosart(): 24 | ############################################################################### 25 | 26 | caseroot, libroot, bldroot = parse_input(sys.argv) 27 | 28 | with Case(caseroot) as case: 29 | casetools = case.get_value("CASETOOLS") 30 | gmake_j = case.get_value("GMAKE_J") 31 | gmake = case.get_value("GMAKE") 32 | 33 | # create Filepath file 34 | objroot = case.get_value("OBJROOT") 35 | filepath_file = os.path.join(objroot,"rof","obj","Filepath") 36 | driver = case.get_value("COMP_INTERFACE").lower() 37 | 38 | if not os.path.isfile(filepath_file): 39 | srcroot = case.get_value("SRCROOT") 40 | caseroot = case.get_value("CASEROOT") 41 | paths = [ os.path.join(caseroot,"SourceMods","src.mosart"), 42 | os.path.join(srcroot,"components","mosart","src","riverroute"), 43 | os.path.join(srcroot,"components","mosart","src","cpl",driver)] 44 | 45 | with open(filepath_file, "w") as filepath: 46 | filepath.write("\n".join(paths)) 47 | filepath.write("\n") 48 | 49 | # build the library 50 | complib = os.path.join(libroot, "librof.a") 51 | makefile = os.path.join(casetools, "Makefile") 52 | 53 | cmd = "{} complib -j {} MODEL=mosart COMPLIB={} -f {} {}" \ 54 | .format(gmake, gmake_j, complib, makefile, get_standard_makefile_args(case)) 55 | 56 | rc, out, err = run_cmd(cmd, from_dir=bldroot) 57 | expect(rc == 0, "Command %s failed rc=%d\nout=%s\nerr=%s" % (cmd, rc, out, err)) 58 | 59 | logger.info("Command %s completed with output %s\nerr %s", cmd, out, err) 60 | 61 | ############################################################################### 62 | 63 | if __name__ == "__main__": 64 | _build_mosart() 65 | -------------------------------------------------------------------------------- /cime_config/config_component.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 12 | 13 | MOSART: MOdel for Scale Adaptive River Transport 14 | MOSART model with flood: 15 | 16 | 17 | 18 | char 19 | mosart 20 | mosart 21 | case_comp 22 | env_case.xml 23 | Name of river component 24 | 25 | 26 | 27 | char 28 | ACTIVE,NULL 29 | ACTIVE 30 | 31 | NULL 32 | 33 | build_component_mosart 34 | env_build.xml 35 | mode for mosart model, NULL means mosart is turned off 36 | 37 | 38 | 39 | logical 40 | TRUE,FALSE 41 | FALSE 42 | run_component_mosart 43 | env_run.xml 44 | If warnings in namelist setttings from buildnml should be ignored or not 45 | 46 | 47 | 48 | char 49 | ACTIVE,NULL 50 | NULL 51 | 52 | ACTIVE 53 | 54 | build_component_mosart 55 | env_build.xml 56 | mode for mosart flood feature, NULL means mosart flood is turned off 57 | 58 | 59 | 60 | char 61 | 62 | 2000 63 | 64 | 1850 65 | 1850 66 | 1850 67 | 2000 68 | 69 | run_component_mosart 70 | env_run.xml 71 | Simulation year to start from -- build-namelist options (currently not used) 72 | 73 | 74 | ========================================= 75 | MOSART naming conventions 76 | ========================================= 77 | 78 | 79 | 80 | -------------------------------------------------------------------------------- /src/riverroute/mosart_vars.F90: -------------------------------------------------------------------------------- 1 | module mosart_vars 2 | 3 | use shr_kind_mod , only : r8 => shr_kind_r8, CL => SHR_KIND_CL, CS => shr_kind_CS 4 | use shr_const_mod , only : SHR_CONST_CDAY,SHR_CONST_REARTH 5 | use shr_sys_mod , only : shr_sys_abort 6 | use ESMF , only : ESMF_VM 7 | 8 | implicit none 9 | public 10 | 11 | ! MPI 12 | logical :: mainproc ! proc 0 logical for printing msgs 13 | integer :: iam ! processor number 14 | integer :: npes ! number of processors for mosart 15 | integer :: mpicom_rof ! communicator group for mosart 16 | logical :: barrier_timers = .false. ! barrier timers 17 | type(ESMF_VM) :: vm ! ESMF VM 18 | 19 | ! Constants 20 | integer , parameter :: iundef = -9999999 21 | integer , parameter :: rundef = -9999999._r8 22 | real(r8) , parameter :: secspday = SHR_CONST_CDAY ! Seconds per day 23 | integer , parameter :: isecspday = secspday ! Integer seconds per day 24 | real(r8) , parameter :: spval = 1.e36_r8 ! special value for real data 25 | integer , parameter :: ispval = -9999 ! special value for int data 26 | 27 | real(r8) :: re = SHR_CONST_REARTH*0.001_r8 ! radius of earth (km) 28 | 29 | ! Run startup 30 | integer , parameter :: nsrStartup = 0 ! Startup from initial conditions 31 | integer , parameter :: nsrContinue = 1 ! Continue from restart files 32 | integer , parameter :: nsrBranch = 2 ! Branch from restart files 33 | integer :: nsrest = iundef ! Type of run 34 | 35 | ! Namelist variables 36 | character(len=CL) :: frivinp ! MOSART input data file name 37 | logical :: ice_runoff ! true => runoff is split into liquid and ice, otherwise just liquid 38 | character(len=CS) :: decomp_option ! decomp option 39 | character(len=CS) :: bypass_routing_option ! bypass routing model method 40 | character(len=CS) :: qgwl_runoff_option ! method for handling qgwl runoff 41 | integer :: budget_frq = -24 ! budget check frequency 42 | 43 | ! Metadata variables used in history and restart generation 44 | character(len=CL) :: caseid = ' ' ! case id 45 | character(len=CL) :: ctitle = ' ' ! case title 46 | character(len=CL) :: hostname = ' ' ! Hostname of machine running on 47 | character(len=CL) :: username = ' ' ! username of user running program 48 | character(len=CL) :: version = " " ! version of program 49 | character(len=CL) :: conventions = "CF-1.0" ! dataset conventions 50 | character(len=CL) :: model_doi_url ! Web address of the Digital Object Identifier (DOI) for this model version 51 | character(len=CL) :: source = "Model for Scale Adaptive River Transport MOSART1.0" ! description of this source 52 | 53 | ! Stdout 54 | integer :: iulog = 6 ! "stdout" log file unit number, default is 6 55 | 56 | ! Instance control 57 | integer :: inst_index 58 | character(len=CS) :: inst_name 59 | character(len=CS) :: inst_suffix 60 | 61 | end module mosart_vars 62 | -------------------------------------------------------------------------------- /src/riverroute/mosart_fileutils.F90: -------------------------------------------------------------------------------- 1 | module mosart_fileutils 2 | 3 | ! Module containing file I/O utilities 4 | 5 | use shr_sys_mod , only : shr_sys_abort 6 | use shr_kind_mod, only : CL=>shr_kind_cl 7 | use mosart_vars , only : iulog, mainproc 8 | 9 | implicit none 10 | private 11 | 12 | ! !PUBLIC MEMBER FUNCTIONS: 13 | public :: get_filename !Returns filename given full pathname 14 | public :: getfil !Obtain local copy of file 15 | !----------------------------------------------------------------------- 16 | 17 | contains 18 | 19 | !----------------------------------------------------------------------- 20 | character(len=CL) function get_filename (fulpath) 21 | 22 | ! Returns filename given full pathname 23 | ! 24 | ! !ARGUMENTS: 25 | character(len=*), intent(in) :: fulpath !full pathname 26 | ! 27 | ! !LOCAL VARIABLES: 28 | integer i !loop index 29 | integer klen !length of fulpath character string 30 | !---------------------------------------------------------- 31 | 32 | klen = len_trim(fulpath) 33 | do i = klen, 1, -1 34 | if (fulpath(i:i) == '/') go to 10 35 | end do 36 | i = 0 37 | 10 get_filename = fulpath(i+1:klen) 38 | 39 | end function get_filename 40 | 41 | !------------------------------------------------------------------------ 42 | 43 | subroutine getfil (fulpath, locfn, iflag) 44 | 45 | ! Obtain local copy of file. First check current working directory, 46 | ! Next check full pathname[fulpath] on disk 47 | ! 48 | ! !ARGUMENTS: 49 | character(len=*), intent(in) :: fulpath !Archival or permanent disk full pathname 50 | character(len=*), intent(out) :: locfn !output local file name 51 | integer, intent(in) :: iflag !0=>abort if file not found 1=>do not abort 52 | 53 | ! !LOCAL VARIABLES: 54 | integer i !loop index 55 | logical lexist !true if local file exists 56 | !-------------------------------------------------- 57 | 58 | ! get local file name from full name 59 | locfn = get_filename( fulpath ) 60 | if (len_trim(locfn) == 0) then 61 | if (mainproc) write(iulog,*)'(GETFIL): local filename has zero length' 62 | call shr_sys_abort() 63 | else 64 | if (mainproc) write(iulog,*)'(GETFIL): attempting to find local file ',trim(locfn) 65 | endif 66 | 67 | ! first check if file is in current working directory. 68 | inquire (file=locfn,exist=lexist) 69 | if (lexist) then 70 | if (mainproc) write(iulog,*) '(GETFIL): using ',trim(locfn),' in current working directory' 71 | RETURN 72 | endif 73 | 74 | ! second check for full pathname on disk 75 | locfn = fulpath 76 | 77 | inquire (file=fulpath,exist=lexist) 78 | if (lexist) then 79 | if (mainproc) write(iulog,*) '(GETFIL): using ',trim(fulpath) 80 | RETURN 81 | else 82 | if (mainproc) write(iulog,*)'(GETFIL): failed getting file from full path: ', fulpath 83 | if (iflag==0) then 84 | call shr_sys_abort ('GETFIL: FAILED to get '//trim(fulpath)) 85 | else 86 | RETURN 87 | endif 88 | endif 89 | 90 | end subroutine getfil 91 | 92 | end module mosart_fileutils 93 | -------------------------------------------------------------------------------- /cime_config/testdefs/testlist_mosart.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | -------------------------------------------------------------------------------- /src/riverroute/mosart_tstatusflux_type.F90: -------------------------------------------------------------------------------- 1 | module mosart_tstatusflux_type 2 | 3 | ! status and flux variables 4 | 5 | use shr_kind_mod, only : r8 => shr_kind_r8, CL => SHR_KIND_CL 6 | 7 | implicit none 8 | private 9 | 10 | public :: TstatusFlux_type 11 | type TstatusFlux_type 12 | ! hillsloope 13 | !! states 14 | real(r8), pointer :: wh(:,:) ! storage of surface water, [m] 15 | real(r8), pointer :: dwh(:,:) ! change of water storage, [m/s] 16 | real(r8), pointer :: yh(:,:) ! depth of surface water, [m] 17 | real(r8), pointer :: wsat(:,:) ! storage of surface water within saturated area at hillslope [m] 18 | real(r8), pointer :: wunsat(:,:) ! storage of surface water within unsaturated area at hillslope [m] 19 | real(r8), pointer :: qhorton(:,:) ! Infiltration excess runoff generated from hillslope, [m/s] NOT_USED 20 | real(r8), pointer :: qdunne(:,:) ! Saturation excess runoff generated from hillslope, [m/s] NOT_USED 21 | real(r8), pointer :: qsur(:,:) ! Surface runoff generated from hillslope, [m/s] 22 | real(r8), pointer :: qsub(:,:) ! Subsurface runoff generated from hillslope, [m/s] 23 | real(r8), pointer :: qgwl(:,:) ! gwl runoff term from glacier, wetlands and lakes, [m/s] 24 | !! fluxes 25 | real(r8), pointer :: ehout(:,:) ! overland flow from hillslope into the sub-channel, [m/s] 26 | real(r8), pointer :: asat(:,:) ! saturated area fraction from hillslope, [-] 27 | real(r8), pointer :: esat(:,:) ! evaporation from saturated area fraction at hillslope, [m/s] 28 | 29 | ! subnetwork channel 30 | !! states 31 | real(r8), pointer :: tarea(:,:) ! area of channel water surface, [m2] 32 | real(r8), pointer :: wt(:,:) ! storage of surface water, [m3] 33 | real(r8), pointer :: dwt(:,:) ! change of water storage, [m3] 34 | real(r8), pointer :: yt(:,:) ! water depth, [m] 35 | real(r8), pointer :: mt(:,:) ! cross section area, [m2] 36 | real(r8), pointer :: rt(:,:) ! hydraulic radii, [m] 37 | real(r8), pointer :: pt(:,:) ! wetness perimeter, [m] 38 | real(r8), pointer :: vt(:,:) ! flow velocity, [m/s] 39 | real(r8), pointer :: tt(:,:) ! mean travel time of the water within the channel, [s] NOT_USED 40 | !! fluxes 41 | real(r8), pointer :: etin(:,:) ! lateral inflow from hillslope, including surface and subsurface runoff generation components, [m3/s] 42 | real(r8), pointer :: etout(:,:) ! discharge from sub-network into the main reach, [m3/s] 43 | 44 | ! main channel 45 | !! states 46 | real(r8), pointer :: rarea(:,:) ! area of channel water surface, [m2] 47 | real(r8), pointer :: wr(:,:) ! storage of surface water, [m3] 48 | real(r8), pointer :: dwr(:,:) ! change of water storage, [m3] 49 | real(r8), pointer :: yr(:,:) ! water depth. [m] 50 | real(r8), pointer :: mr(:,:) ! cross section area, [m2] 51 | real(r8), pointer :: rr(:,:) ! hydraulic radius, [m] 52 | real(r8), pointer :: pr(:,:) ! wetness perimeter, [m] 53 | real(r8), pointer :: vr(:,:) ! flow velocity, [m/s] 54 | real(r8), pointer :: tr(:,:) ! mean travel time of the water within the channel, [s] NOT_USED 55 | !! exchange fluxes 56 | real(r8), pointer :: erlateral(:,:) ! lateral flow from hillslope, including surface and subsurface runoff generation components, [m3/s] 57 | real(r8), pointer :: erin(:,:) ! inflow from upstream links, [m3/s] 58 | real(r8), pointer :: erout(:,:) ! outflow into downstream links, [m3/s] 59 | real(r8), pointer :: erout_prev(:,:) ! outflow into downstream links from previous timestep, [m3/s] 60 | real(r8), pointer :: eroutUp(:,:) ! outflow sum of upstream gridcells, instantaneous (m3/s) 61 | real(r8), pointer :: eroutUp_avg(:,:) ! outflow sum of upstream gridcells, average [m3/s] 62 | real(r8), pointer :: erlat_avg(:,:) ! erlateral average [m3/s] 63 | real(r8), pointer :: flow(:,:) ! streamflow from the outlet of the reach, [m3/s] 64 | real(r8), pointer :: erin1(:,:) ! inflow from upstream links during previous step, used for Muskingum method, [m3/s] NOT_USED 65 | real(r8), pointer :: erin2(:,:) ! inflow from upstream links during current step, used for Muskingum method, [m3/s] NOT_USED 66 | real(r8), pointer :: ergwl(:,:) ! flux item for the adjustment of water balance residual in glacie, wetlands and lakes dynamics [m3/s] NOT_USED 67 | 68 | !! for Runge-Kutta algorithm NOT_USED 69 | real(r8), pointer :: wrtemp(:,:) ! temporary storage item, for 4th order Runge-Kutta algorithm; 70 | real(r8), pointer :: erintemp(:,:) 71 | real(r8), pointer :: erouttemp(:,:) 72 | real(r8), pointer :: k1(:,:) 73 | real(r8), pointer :: k2(:,:) 74 | real(r8), pointer :: k3(:,:) 75 | real(r8), pointer :: k4(:,:) 76 | contains 77 | procedure, public :: Init 78 | end type TstatusFlux_type 79 | 80 | contains 81 | 82 | subroutine Init(this, begr, endr, ntracers) 83 | class(TstatusFlux_type) :: this 84 | integer, intent(in) :: begr, endr, ntracers 85 | 86 | ! Initialize water states and fluxes 87 | allocate (this%wh(begr:endr,ntracers)) 88 | this%wh = 0._r8 89 | allocate (this%dwh(begr:endr,ntracers)) 90 | this%dwh = 0._r8 91 | allocate (this%yh(begr:endr,ntracers)) 92 | this%yh = 0._r8 93 | allocate (this%qsur(begr:endr,ntracers)) 94 | this%qsur = 0._r8 95 | allocate (this%qsub(begr:endr,ntracers)) 96 | this%qsub = 0._r8 97 | allocate (this%qgwl(begr:endr,ntracers)) 98 | this%qgwl = 0._r8 99 | allocate (this%ehout(begr:endr,ntracers)) 100 | this%ehout = 0._r8 101 | allocate (this%tarea(begr:endr,ntracers)) 102 | this%tarea = 0._r8 103 | allocate (this%wt(begr:endr,ntracers)) 104 | this%wt= 0._r8 105 | allocate (this%dwt(begr:endr,ntracers)) 106 | this%dwt = 0._r8 107 | allocate (this%yt(begr:endr,ntracers)) 108 | this%yt = 0._r8 109 | allocate (this%mt(begr:endr,ntracers)) 110 | this%mt = 0._r8 111 | allocate (this%rt(begr:endr,ntracers)) 112 | this%rt = 0._r8 113 | allocate (this%pt(begr:endr,ntracers)) 114 | this%pt = 0._r8 115 | allocate (this%vt(begr:endr,ntracers)) 116 | this%vt = 0._r8 117 | allocate (this%tt(begr:endr,ntracers)) 118 | this%tt = 0._r8 119 | allocate (this%etin(begr:endr,ntracers)) 120 | this%etin = 0._r8 121 | allocate (this%etout(begr:endr,ntracers)) 122 | this%etout = 0._r8 123 | allocate (this%rarea(begr:endr,ntracers)) 124 | this%rarea = 0._r8 125 | allocate (this%wr(begr:endr,ntracers)) 126 | this%wr = 0._r8 127 | allocate (this%dwr(begr:endr,ntracers)) 128 | this%dwr = 0._r8 129 | allocate (this%yr(begr:endr,ntracers)) 130 | this%yr = 0._r8 131 | allocate (this%mr(begr:endr,ntracers)) 132 | this%mr = 0._r8 133 | allocate (this%rr(begr:endr,ntracers)) 134 | this%rr = 0._r8 135 | allocate (this%pr(begr:endr,ntracers)) 136 | this%pr = 0._r8 137 | allocate (this%vr(begr:endr,ntracers)) 138 | this%vr = 0._r8 139 | allocate (this%tr(begr:endr,ntracers)) 140 | this%tr = 0._r8 141 | allocate (this%erlateral(begr:endr,ntracers)) 142 | this%erlateral = 0._r8 143 | allocate (this%erin(begr:endr,ntracers)) 144 | this%erin = 0._r8 145 | allocate (this%erout(begr:endr,ntracers)) 146 | this%erout = 0._r8 147 | allocate (this%erout_prev(begr:endr,ntracers)) 148 | this%erout_prev = 0._r8 149 | allocate (this%eroutUp(begr:endr,ntracers)) 150 | this%eroutUp = 0._r8 151 | allocate (this%eroutUp_avg(begr:endr,ntracers)) 152 | this%eroutUp_avg = 0._r8 153 | allocate (this%erlat_avg(begr:endr,ntracers)) 154 | this%erlat_avg = 0._r8 155 | allocate (this%ergwl(begr:endr,ntracers)) 156 | this%ergwl = 0._r8 157 | allocate (this%flow(begr:endr,ntracers)) 158 | this%flow = 0._r8 159 | 160 | end subroutine Init 161 | 162 | end module mosart_tstatusflux_type 163 | -------------------------------------------------------------------------------- /cime_config/namelist_definition_mosart.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | logical 13 | mosart 14 | mosart_inparm 15 | 16 | .true. 17 | 18 | 19 | Default: .true. 20 | If .true., river runoff will be split up into liquid and ice streams, 21 | otherwise ice runoff will be zero and all runoff directed to liquid 22 | stream. 23 | 24 | 25 | 26 | 27 | integer 28 | mosart 29 | mosart_inparm 30 | 31 | MOSART coupling period to driver (sec). 32 | Can ONLY be set by modifying the value of the xml variable ROF_NCPL in env_run.xml. 33 | 34 | 35 | 36 | 37 | integer 38 | mosart 39 | mosart_inparm 40 | 41 | 3600 42 | 43 | 44 | MOSART time step (sec). Default: 3600 Internal mosart timestep, 45 | will be adjusted down to be integer multiple of coupling_period if 46 | necessary 47 | 48 | 49 | 50 | 51 | char 52 | mosart 53 | mosart_inparm 54 | basin,1d,roundrobin 55 | 56 | roundrobin 57 | 58 | 59 | Decomposition Option for mosart 60 | 61 | 62 | 63 | 64 | logical 65 | mosart 66 | mosart_inparm 67 | 68 | .false. 69 | 70 | 71 | If true, add capability to have halo option for mosart fields. 72 | In particular these can be used to create derivatives using halo values 73 | from neighboring cells. 74 | 75 | 76 | 77 | 78 | char 79 | mosart 80 | mosart_inparm 81 | direct_in_place,direct_to_outlet,none 82 | 83 | direct_to_outlet 84 | 85 | 86 | Method for bypassing routing model. 87 | 88 | 89 | 90 | 91 | char 92 | mosart 93 | mosart_inparm 94 | all,negative,threshold 95 | 96 | negative 97 | 98 | 99 | Method for handling of qgwl runoff inputs. 100 | (threshold is only valid for bypass_routing_option=direct_in_place) 101 | 102 | 103 | 104 | 105 | char 106 | mosart 107 | mosart_inparm 108 | abs 109 | 110 | UNSET 111 | 112 | 113 | Full pathname of initial conditions file. If blank or UNSET Mosart will startup from 114 | cold start initial conditions. 115 | 116 | 117 | 118 | 119 | char 120 | mosart 121 | mosart_inparm 122 | 123 | '' 124 | 125 | 126 | Name of master restart file for a branch run. (only used if RUN_TYPE is branch) 127 | 128 | 129 | 130 | 131 | char 132 | mosart 133 | abs 134 | mosart_inparm 135 | 136 | UNSET 137 | $DIN_LOC_ROOT/rof/mosart/MOSART_routing_Global_0.5x0.5_c170601.nc 138 | $DIN_LOC_ROOT/rof/mosart/MOSART_Global_8th_20191007.nc 139 | $DIN_LOC_ROOT/rof/mosart/MOSART_routing_0.125nldas2_cdf5_c200727.nc 140 | 141 | 142 | Full pathname of input mosart datafile 143 | 144 | 145 | 146 | 147 | char(1000) 148 | history 149 | mosart_inparm 150 | 151 | '' 152 | 153 | 154 | Fields to exclude from history tape series 1. 155 | 156 | 157 | 158 | 159 | char(1000) 160 | history 161 | mosart_inparm 162 | 163 | '' 164 | 165 | 166 | Fields to exclude from history tape series 2. 167 | 168 | 169 | 170 | 171 | char(1000) 172 | history 173 | mosart_inparm 174 | 175 | '' 176 | 177 | 178 | Fields to exclude from history tape series 3. 179 | 180 | 181 | 182 | 183 | char(1000) 184 | history 185 | mosart_inparm 186 | 187 | '' 188 | 189 | 190 | Fields to add to history tape series 1. 191 | 192 | 193 | 194 | 195 | char(1000) 196 | history 197 | mosart_inparm 198 | 199 | '' 200 | 201 | 202 | Fields to add to history tape series 2. 203 | 204 | 205 | 206 | 207 | char(1000) 208 | history 209 | mosart_inparm 210 | 211 | '' 212 | 213 | 214 | Fields to add to history tape series 3. 215 | 216 | 217 | 218 | 219 | integer(6) 220 | history 221 | mosart_inparm 222 | 223 | 1 224 | 225 | 226 | Per tape series maximum number of time samples. 227 | 228 | 229 | 230 | 231 | integer(6) 232 | history 233 | mosart_inparm 234 | 1 235 | 236 | 1 237 | 238 | 239 | Per tape series history file density (i.e. output precision) 240 | 1=double precision, 2=single precision (NOT working) 241 | 242 | 243 | 244 | 245 | integer(6) 246 | history 247 | mosart_inparm 248 | 249 | 0 250 | 251 | 252 | Per tape series history write frequency. 253 | positive means in time steps, 0=monthly, negative means hours 254 | (i.e. 24 means every 24 time-steps and -24 means every day 255 | 256 | 257 | 258 | 259 | char 260 | mosart 261 | mosart_inparm 262 | 263 | LIQ:ICE 264 | 265 | 266 | Colon delimited string of mosart tracers. 267 | 268 | 269 | 270 | 271 | char 272 | mosart 273 | mosart_inparm 274 | 275 | T:F 276 | 277 | 278 | Colon delimited string of toggle to turn on Euler algorithm for 279 | tracer name in mosart_tracers. 280 | 281 | 282 | 283 | 284 | integer(6) 285 | mosart 286 | mosart_inparm 287 | 288 | -24 289 | 290 | 291 | Frequency to perform budget check. Similar to nhtfrq, 292 | positive means in time steps, 0=monthly, negative means hours 293 | (i.e. 24 means every 24 time-steps and -24 means every day 294 | 295 | 296 | 297 | 298 | -------------------------------------------------------------------------------- /src/riverroute/mosart_histflds.F90: -------------------------------------------------------------------------------- 1 | module mosart_histflds 2 | 3 | ! Module containing initialization of history fields and files 4 | ! This is the module that the user must modify in order to add new 5 | ! history fields or modify defaults associated with existing history 6 | ! fields. 7 | 8 | use shr_kind_mod , only : r8 => shr_kind_r8 9 | use mosart_histfile , only : mosart_hist_addfld, mosart_hist_printflds 10 | use mosart_data , only : ctl, Trunoff 11 | 12 | implicit none 13 | private 14 | 15 | public :: mosart_histflds_init 16 | public :: mosart_histflds_set 17 | 18 | type, public :: hist_pointer_type 19 | real(r8), pointer :: data(:) => null() 20 | end type hist_pointer_type 21 | 22 | type(hist_pointer_type), allocatable :: h_runofflnd(:) 23 | type(hist_pointer_type), allocatable :: h_runoffocn(:) 24 | type(hist_pointer_type), allocatable :: h_runofftot(:) 25 | type(hist_pointer_type), allocatable :: h_direct(:) 26 | type(hist_pointer_type), allocatable :: h_direct_glc(:) 27 | type(hist_pointer_type), allocatable :: h_dvolrdtlnd(:) 28 | type(hist_pointer_type), allocatable :: h_dvolrdtocn(:) 29 | type(hist_pointer_type), allocatable :: h_volr(:) 30 | type(hist_pointer_type), allocatable :: h_qsur(:) 31 | type(hist_pointer_type), allocatable :: h_qsub(:) 32 | type(hist_pointer_type), allocatable :: h_qgwl(:) 33 | 34 | real(r8), pointer :: h_volr_mch(:) 35 | real(r8), pointer :: h_qglc_liq_input(:) 36 | real(r8), pointer :: h_qglc_ice_input(:) 37 | 38 | !------------------------------------------------------------------------ 39 | contains 40 | !----------------------------------------------------------------------- 41 | 42 | subroutine mosart_histflds_init(begr, endr, ntracers) 43 | 44 | ! Arguments 45 | integer, intent(in) :: begr 46 | integer, intent(in) :: endr 47 | integer, intent(in) :: ntracers 48 | 49 | ! Local variables 50 | integer :: nt 51 | 52 | !------------------------------------------------------- 53 | ! Allocate memory for module variables 54 | !------------------------------------------------------- 55 | 56 | allocate(h_runofflnd(ntracers)) 57 | allocate(h_runoffocn(ntracers)) 58 | allocate(h_runofftot(ntracers)) 59 | allocate(h_direct(ntracers)) 60 | allocate(h_dvolrdtlnd(ntracers)) 61 | allocate(h_dvolrdtocn(ntracers)) 62 | allocate(h_volr(ntracers)) 63 | allocate(h_qsur(ntracers)) 64 | allocate(h_qsub(ntracers)) 65 | allocate(h_qgwl(ntracers)) 66 | allocate(h_direct_glc(2)) 67 | 68 | do nt = 1,ntracers 69 | allocate(h_runofflnd(nt)%data(begr:endr)) 70 | allocate(h_runoffocn(nt)%data(begr:endr)) 71 | allocate(h_runofftot(nt)%data(begr:endr)) 72 | allocate(h_direct(nt)%data(begr:endr)) 73 | allocate(h_dvolrdtlnd(nt)%data(begr:endr)) 74 | allocate(h_dvolrdtocn(nt)%data(begr:endr)) 75 | allocate(h_volr(nt)%data(begr:endr)) 76 | allocate(h_qsur(nt)%data(begr:endr)) 77 | allocate(h_qsub(nt)%data(begr:endr)) 78 | allocate(h_qgwl(nt)%data(begr:endr)) 79 | end do 80 | allocate(h_direct_glc(ctl%nt_liq)%data(begr:endr)) 81 | allocate(h_direct_glc(ctl%nt_ice)%data(begr:endr)) 82 | 83 | allocate(h_volr_mch(begr:endr)) 84 | allocate(h_qglc_liq_input(begr:endr)) 85 | allocate(h_qglc_ice_input(begr:endr)) 86 | 87 | !------------------------------------------------------- 88 | ! Build master field list of all possible fields in a history file. 89 | ! Each field has associated with it a ``long\_name'' netcdf attribute that 90 | ! describes what the field is, and a ``units'' attribute. A subroutine is 91 | ! called to add each field to the masterlist. 92 | !------------------------------------------------------- 93 | 94 | do nt = 1,ctl%ntracers 95 | 96 | call mosart_hist_addfld (fname='RIVER_DISCHARGE_OVER_LAND'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 97 | avgflag='A', long_name='MOSART river basin flow: '//trim(ctl%tracer_names(nt)), & 98 | ptr_rof=h_runofflnd(nt)%data, default='active') 99 | 100 | call mosart_hist_addfld (fname='RIVER_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 101 | avgflag='A', long_name='MOSART river discharge into ocean: '//trim(ctl%tracer_names(nt)), & 102 | ptr_rof=h_runoffocn(nt)%data, default='active') 103 | 104 | call mosart_hist_addfld (fname='TOTAL_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 105 | avgflag='A', long_name='MOSART total discharge into ocean: '//trim(ctl%tracer_names(nt)), & 106 | ptr_rof=h_runofftot(nt)%data, default='active') 107 | 108 | call mosart_hist_addfld (fname='DIRECT_DISCHARGE_TO_OCEAN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 109 | avgflag='A', long_name='MOSART direct discharge into ocean: '//trim(ctl%tracer_names(nt)), & 110 | ptr_rof=h_direct(nt)%data, default='active') 111 | 112 | call mosart_hist_addfld (fname='DIRECT_DISCHARGE_TO_OCEAN_GLC'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 113 | avgflag='A', long_name='MOSART direct discharge into ocean from glc: '//trim(ctl%tracer_names(nt)), & 114 | ptr_rof=h_direct_glc(nt)%data, default='active') 115 | 116 | call mosart_hist_addfld (fname='STORAGE'//'_'//trim(ctl%tracer_names(nt)), units='m3', & 117 | avgflag='A', long_name='MOSART storage: '//trim(ctl%tracer_names(nt)), & 118 | ptr_rof=h_volr(nt)%data, default='inactive') 119 | 120 | call mosart_hist_addfld (fname='DVOLRDT_LND'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 121 | avgflag='A', long_name='MOSART land change in storage: '//trim(ctl%tracer_names(nt)), & 122 | ptr_rof=h_dvolrdtlnd(nt)%data, default='inactive') 123 | 124 | call mosart_hist_addfld (fname='DVOLRDT_OCN'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 125 | avgflag='A', long_name='MOSART ocean change of storage: '//trim(ctl%tracer_names(nt)), & 126 | ptr_rof=h_dvolrdtocn(nt)%data, default='inactive') 127 | 128 | call mosart_hist_addfld (fname='QSUR'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 129 | avgflag='A', long_name='MOSART input surface runoff: '//trim(ctl%tracer_names(nt)), & 130 | ptr_rof=h_qsur(nt)%data, default='inactive') 131 | 132 | call mosart_hist_addfld (fname='QSUB'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 133 | avgflag='A', long_name='MOSART input subsurface runoff: '//trim(ctl%tracer_names(nt)), & 134 | ptr_rof=h_qsub(nt)%data, default='inactive') 135 | 136 | call mosart_hist_addfld (fname='QGWL'//'_'//trim(ctl%tracer_names(nt)), units='m3/s', & 137 | avgflag='A', long_name='MOSART input GWL runoff: '//trim(ctl%tracer_names(nt)), & 138 | ptr_rof=h_qgwl(nt)%data, default='inactive') 139 | end do 140 | 141 | ! RTM and MOSART (unlike the CLM) do not have the history_tape_in_use 142 | ! capability, so both models throw an error when h0i is empty. For this 143 | ! reason RTM and MOSART always need at least one instantaneous field so 144 | ! that h0i will not be empty. 145 | call mosart_hist_addfld (fname='STORAGE_MCH', units='m3', & 146 | avgflag='I', long_name='MOSART main channelstorage', & 147 | ptr_rof=h_volr_mch, default='active') 148 | 149 | call mosart_hist_addfld (fname='QIRRIG_FROM_COUPLER', units='m3/s', & 150 | avgflag='A', long_name='Amount of water used for irrigation (total flux received from coupler)', & 151 | ptr_rof=ctl%qirrig, default='inactive') 152 | 153 | call mosart_hist_addfld (fname='QIRRIG_ACTUAL', units='m3/s', & 154 | avgflag='A', long_name='Actual irrigation (if limited by river storage)', & 155 | ptr_rof=ctl%qirrig_actual, default='inactive') 156 | 157 | call mosart_hist_addfld (fname='QGLC_LIQ_INPUT', units='m3', & 158 | avgflag='A', long_name='liquid runoff from glc input', & 159 | ptr_rof=h_qglc_liq_input, default='active') 160 | 161 | call mosart_hist_addfld (fname='QGLC_ICE_INPUT', units='m3', & 162 | avgflag='A', long_name='ice runoff from glc input', & 163 | ptr_rof=h_qglc_ice_input, default='active') 164 | 165 | ! print masterlist of history fields 166 | call mosart_hist_printflds() 167 | 168 | end subroutine mosart_histflds_init 169 | 170 | !----------------------------------------------------------------------- 171 | 172 | subroutine mosart_histflds_set(ntracers) 173 | 174 | !----------------------------------------------------------------------- 175 | ! Set mosart history fields as 1d pointer arrays 176 | !----------------------------------------------------------------------- 177 | 178 | ! Arguments 179 | integer, intent(in) :: ntracers 180 | 181 | ! Local variables 182 | integer :: nt 183 | integer :: nt_liq, nt_ice 184 | 185 | nt_liq = ctl%nt_liq 186 | nt_ice = ctl%nt_ice 187 | 188 | do nt = 1,ntracers 189 | h_runofflnd(nt)%data(:) = ctl%runofflnd(:,nt) 190 | h_runoffocn(nt)%data(:) = ctl%runoffocn(:,nt) 191 | h_runofftot(nt)%data(:) = ctl%runofftot(:,nt) 192 | h_direct(nt)%data(:) = ctl%direct(:,nt) 193 | h_dvolrdtlnd(nt)%data(:) = ctl%dvolrdtlnd(:,nt) 194 | h_dvolrdtocn(nt)%data(:) = ctl%dvolrdtocn(:,nt) 195 | h_qsub(nt)%data(:) = ctl%qsub(:,nt) 196 | h_qsur(nt)%data(:) = ctl%qsur(:,nt) 197 | h_qgwl(nt)%data(:) = ctl%qgwl(:,nt) 198 | end do 199 | h_volr_mch(:) = Trunoff%wr(:,1) 200 | h_qglc_liq_input(:) = ctl%qglc_liq(:) 201 | h_qglc_ice_input(:) = ctl%qglc_ice(:) 202 | h_direct_glc(nt_liq)%data(:) = ctl%direct_glc(:,nt_liq) 203 | h_direct_glc(nt_ice)%data(:) = ctl%direct_glc(:,nt_ice) 204 | 205 | end subroutine mosart_histflds_set 206 | 207 | end module mosart_histflds 208 | -------------------------------------------------------------------------------- /cime_config/buildnml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | 3 | """Namelist creator for CIME's data atmosphere model. 4 | """ 5 | 6 | # Typically ignore this. 7 | # pylint: disable=invalid-name 8 | 9 | # Disable these because this is our standard setup 10 | # pylint: disable=wildcard-import,unused-wildcard-import,wrong-import-position 11 | # pylint: disable=multiple-imports 12 | import os, shutil, sys 13 | 14 | CIMEROOT = os.environ.get("CIMEROOT") 15 | if CIMEROOT is None: 16 | raise SystemExit("ERROR: must set CIMEROOT environment variable") 17 | sys.path.append(os.path.join(CIMEROOT, "scripts", "CIME", "Tools")) 18 | 19 | from standard_script_setup import * 20 | from CIME.case import Case 21 | from CIME.nmlgen import NamelistGenerator 22 | from CIME.utils import expect 23 | from CIME.buildnml import create_namelist_infile, parse_input 24 | 25 | logger = logging.getLogger(__name__) 26 | 27 | # pylint: disable=too-many-arguments,too-many-locals,too-many-branches,too-many-statements 28 | #################################################################################### 29 | def _create_namelists(case, confdir, inst_string, infile, nmlgen, data_list_path): 30 | #################################################################################### 31 | """Write out the namelist for this component. 32 | 33 | Most arguments are the same as those for `NamelistGenerator`. The 34 | `inst_string` argument is used as a suffix to distinguish files for 35 | different instances. The `confdir` argument is used to specify the directory 36 | in which output files will be placed. 37 | """ 38 | #---------------------------------------------------- 39 | # Create config dictionary 40 | #---------------------------------------------------- 41 | config = {} 42 | config['mosart_mode'] = case.get_value("MOSART_MODE") 43 | config['ignore_warn'] = case.get_value("MOSART_IGNORE_WARNINGS") 44 | config['clm_accel'] = case.get_value("CLM_ACCELERATED_SPINUP") 45 | ignore_msg = "\n (Set MOSART_IGNORE_WARNINGS to TRUE with xmlchange in your case to ignore this message and continue anyway)" 46 | if ( config['clm_accel'] != "off" ): 47 | if ( config['mosart_mode'] != "NULL" ): 48 | message = "CLM_ACCELERATED_SPINUP is not off, but MOSART_MODE is not NULL, " + \ 49 | "normally you should switch it off to save computer time" 50 | if ( not config['ignore_warn'] ): 51 | expect(False, message+ignore_msg ) 52 | else: 53 | logger.warning( "WARNING::"+message ) 54 | 55 | config['mosart_flood_mode'] = case.get_value("MOSART_FLOOD_MODE") 56 | config['rof_grid'] = case.get_value("ROF_GRID") 57 | config['lnd_grid'] = case.get_value("LND_GRID") 58 | config['rof_ncpl'] = case.get_value("ROF_NCPL") 59 | config['simyr'] = case.get_value("MOSART_SIM_YEAR") 60 | 61 | logger.debug("River Transport Model (MOSART) mode is %s ", config['mosart_mode']) 62 | logger.debug(" MOSART lnd grid is %s ", config['lnd_grid']) 63 | logger.debug(" MOSART rof grid is %s ", config['rof_grid']) 64 | 65 | #---------------------------------------------------- 66 | # Check for incompatible options. 67 | #---------------------------------------------------- 68 | 69 | if config["rof_grid"] == "null" and config["mosart_mode"] != "NULL": 70 | expect(False, "ROF_GRID is null MOSART_MODE not NULL") 71 | 72 | #---------------------------------------------------- 73 | # Initialize namelist defaults 74 | #---------------------------------------------------- 75 | nmlgen.init_defaults(infile, config) 76 | 77 | #---------------------------------------------------- 78 | # Set values not obtained in the default settings 79 | #---------------------------------------------------- 80 | 81 | run_type = case.get_value("RUN_TYPE") 82 | finidat = str(nmlgen.get_value("finidat")) 83 | if run_type == 'branch' or run_type == 'hybrid': 84 | run_refcase = case.get_value("RUN_REFCASE") 85 | run_refdate = case.get_value("RUN_REFDATE") 86 | run_tod = case.get_value("RUN_REFTOD") 87 | rundir = case.get_value("RUNDIR") 88 | filename = "%s.mosart%s.r.%s-%s.nc" %(run_refcase, inst_string, run_refdate, run_tod) 89 | if not os.path.exists(os.path.join(rundir, filename)): 90 | filename = "%s.mosart.r.%s-%s.nc" %(run_refcase, run_refdate, run_tod) 91 | 92 | if run_type == "hybrid": 93 | nmlgen.add_default("finidat", value=filename, ignore_abs_path=True) 94 | else: 95 | 96 | nmlgen.add_default("nrevsn", value=filename) 97 | elif finidat.strip() == '': 98 | nmlgen.set_value('finidat', value=' ') 99 | else: 100 | if nmlgen.get_default('finidat') == 'UNSET': 101 | nmlgen.add_default('finidat', value=' ', ignore_abs_path=True) 102 | else: 103 | nmlgen.add_default("finidat") 104 | 105 | ncpl_base_period = case.get_value('NCPL_BASE_PERIOD') 106 | if ncpl_base_period == 'hour': 107 | basedt = 3600 108 | elif ncpl_base_period == 'day': 109 | basedt = 3600 * 24 110 | elif ncpl_base_period == 'year': 111 | if case.get_value('CALENDAR') == 'NO_LEAP': 112 | basedt = 3600 * 24 * 365 113 | else: 114 | expect(False, "Invalid CALENDAR for NCPL_BASE_PERIOD %s " %ncpl_base_period) 115 | elif ncpl_base_period == 'decade': 116 | if case.get_value('CALENDAR') == 'NO_LEAP': 117 | basedt = 3600 * 24 * 365 * 10 118 | else: 119 | expect(False, "invalid NCPL_BASE_PERIOD NCPL_BASE_PERIOD %s " %ncpl_base_period) 120 | else: 121 | expect(False, "invalid NCPL_BASE_PERIOD NCPL_BASE_PERIOD %s " %ncpl_base_period) 122 | 123 | if basedt < 0: 124 | expect(False, "basedt invalid overflow for NCPL_BASE_PERIOD %s " %ncpl_base_period) 125 | 126 | mosart_ncpl = case.get_value("ROF_NCPL") 127 | if basedt % mosart_ncpl != 0: 128 | expect(False, "mosart_ncpl %s doesn't divide evenly into basedt %s\n" 129 | %(mosart_ncpl, basedt)) 130 | else: 131 | coupling_period = basedt // mosart_ncpl 132 | nmlgen.set_value("coupling_period", value=coupling_period) 133 | 134 | if ( nmlgen.get_value("frivinp") == "UNSET" and config["mosart_mode"] != "NULL" ): 135 | raise SystemExit("ERROR: Direction file is NOT set and is required when MOSART is active: frivinp") 136 | 137 | bypass_routing_option = nmlgen.get_value("bypass_routing_option") 138 | qgwl_runoff_option = nmlgen.get_value("qgwl_runoff_option") 139 | if bypass_routing_option == "none" and qgwl_runoff_option != "all": 140 | raise SystemExit("ERROR: When bypass_routing_option is none, qgwl_runoff_option can only be all") 141 | 142 | if bypass_routing_option == "direct_to_outlet" and qgwl_runoff_option == "threshold": 143 | raise SystemExit("ERROR: When bypass_routing_option is direct_to_outlet, qgwl_runoff_option can not be threshold") 144 | 145 | #---------------------------------------------------- 146 | # Write output file 147 | #---------------------------------------------------- 148 | namelist_file = os.path.join(confdir, "mosart_in") 149 | nmlgen.write_output_file(namelist_file, data_list_path, groups=['mosart_inparm']) 150 | 151 | ############################################################################### 152 | def buildnml(case, caseroot, compname): 153 | ############################################################################### 154 | """Build the mosart namelist """ 155 | 156 | # Build the component namelist 157 | if compname != "mosart": 158 | raise AttributeError 159 | 160 | srcroot = case.get_value("SRCROOT") 161 | rundir = case.get_value("RUNDIR") 162 | ninst = case.get_value("NINST_ROF") 163 | 164 | # Determine configuration directory 165 | confdir = os.path.join(caseroot, "Buildconf", "mosartconf") 166 | if not os.path.isdir(confdir): 167 | os.makedirs(confdir) 168 | 169 | #---------------------------------------------------- 170 | # Construct the namelist generator 171 | #---------------------------------------------------- 172 | # Determine directory for user modified namelist_definitions.xml and namelist_defaults.xml 173 | user_xml_dir = os.path.join(caseroot, "SourceMods", "src.mosart") 174 | expect(os.path.isdir(user_xml_dir), 175 | "user_xml_dir %s does not exist "%user_xml_dir) 176 | 177 | # NOTE: User definition *replaces* existing definition. 178 | namelist_xml_dir = os.path.join(srcroot, "components", "mosart", "cime_config") 179 | definition_file = [os.path.join(namelist_xml_dir, "namelist_definition_mosart.xml")] 180 | user_definition = os.path.join(user_xml_dir, "namelist_definition_mosart.xml") 181 | if os.path.isfile(user_definition): 182 | definition_file = [user_definition] 183 | for file_ in definition_file: 184 | expect(os.path.isfile(file_), "Namelist XML file %s not found!" % file_) 185 | 186 | # Create the namelist generator object - independent of instance 187 | nmlgen = NamelistGenerator(case, definition_file) 188 | 189 | #---------------------------------------------------- 190 | # Clear out old data. 191 | #---------------------------------------------------- 192 | data_list_path = os.path.join(case.get_case_root(), "Buildconf", "mosart.input_data_list") 193 | if os.path.exists(data_list_path): 194 | os.remove(data_list_path) 195 | #---------------------------------------------------- 196 | # Loop over instances 197 | #---------------------------------------------------- 198 | for inst_counter in range(1, ninst+1): 199 | 200 | # determine instance string 201 | inst_string = "" 202 | if ninst > 1: 203 | inst_string = '_' + '%04d' % inst_counter 204 | 205 | # If multi-instance case does not have restart file, use 206 | # single-case restart for each instance 207 | rpointer = "rpointer.rof" 208 | if (os.path.isfile(os.path.join(rundir, rpointer)) and 209 | (not os.path.isfile(os.path.join(rundir, rpointer + inst_string)))): 210 | shutil.copy(os.path.join(rundir, rpointer), 211 | os.path.join(rundir, rpointer + inst_string)) 212 | 213 | inst_string_label = inst_string 214 | if not inst_string_label: 215 | inst_string_label = "\"\"" 216 | 217 | # create namelist output infile using user_nl_file as input 218 | user_nl_file = os.path.join(caseroot, "user_nl_mosart" + inst_string) 219 | expect(os.path.isfile(user_nl_file), 220 | "Missing required user_nl_file %s " %(user_nl_file)) 221 | infile = os.path.join(confdir, "namelist_infile") 222 | create_namelist_infile(case, user_nl_file, infile) 223 | namelist_infile = [infile] 224 | 225 | # create namelist and stream file(s) data component 226 | _create_namelists(case, confdir, inst_string, namelist_infile, nmlgen, data_list_path) 227 | 228 | # copy namelist files and stream text files, to rundir 229 | if os.path.isdir(rundir): 230 | file_src = os.path.join(confdir, 'mosart_in') 231 | file_dest = os.path.join(rundir, 'mosart_in') 232 | if inst_string: 233 | file_dest += inst_string 234 | shutil.copy(file_src, file_dest) 235 | 236 | ############################################################################### 237 | def _main_func(): 238 | 239 | caseroot = parse_input(sys.argv) 240 | with Case(caseroot) as case: 241 | buildnml(case, caseroot, "mosart") 242 | 243 | if __name__ == "__main__": 244 | _main_func() 245 | -------------------------------------------------------------------------------- /src/riverroute/mosart_budget_type.F90: -------------------------------------------------------------------------------- 1 | module mosart_budget_type 2 | 3 | ! Variables and routines used for 4 | ! calculating and checking tracer global and local budgets 5 | 6 | use shr_kind_mod, only: r8 => shr_kind_r8, CL => SHR_KIND_CL 7 | use shr_sys_mod, only: shr_sys_abort 8 | use shr_mpi_mod, only: shr_mpi_sum, shr_mpi_max 9 | use mosart_vars, only: re, spval, barrier_timers, iulog, mainproc, npes, iam, mpicom_rof 10 | use mosart_data, only: ctl, Tctl, Tunit, TRunoff, Tpara 11 | use mosart_timemanager, only: get_nstep, get_curr_date 12 | 13 | implicit none 14 | private 15 | 16 | type budget_type 17 | ! accumulated budget over run (not used for now) 18 | real(r8), pointer :: accum_grc(:, :) ! Gridcell level budget accumulator per tracer over the run (m3) 19 | real(r8), pointer :: accum_glob(:) ! Global budget accumulator (1e6 m3) 20 | 21 | ! budget terms per gridcell 22 | real(r8), pointer :: beg_vol_grc(:, :) ! volume begining of the timestep (m3) 23 | real(r8), pointer :: end_vol_grc(:, :) ! volume end of the timestep (m3) 24 | real(r8), pointer :: in_grc(:, :) ! budget in terms (m3) 25 | real(r8), pointer :: out_grc(:, :) ! budget out terms (m3) 26 | real(r8), pointer :: net_grc(:, :) ! net budget (dvolume + inputs - outputs) (m3) 27 | real(r8), pointer :: lag_grc(:, :) ! euler erout lagged (m3) 28 | 29 | ! budget global terms 30 | real(r8), pointer :: beg_vol_glob(:) ! volume begining of the timestep (1e6 m3) 31 | real(r8), pointer :: end_vol_glob(:) ! volume end of the timestep (1e6 m3) 32 | real(r8), pointer :: in_glob(:) ! budget in terms (1e6 m3) 33 | real(r8), pointer :: out_glob(:) ! budget out terms (1e6 m3) 34 | real(r8), pointer :: net_glob(:) ! net budget (dvolume + inputs - outputs) (1e6 m3) 35 | real(r8), pointer :: lag_glob(:) ! euler erout lagged (1e6 m3) 36 | 37 | ! budget parameters 38 | real(r8) :: tolerance = 1e-6_r8 ! budget absolute tolerance 39 | real(r8) :: rel_tolerance = 1e-6_r8 ! budget relative tolerance 40 | logical(r8), pointer :: do_budget(:) ! if budget should be checked (per tracer) 41 | contains 42 | procedure, public :: Init 43 | procedure, public :: set_budget 44 | procedure, public :: check_budget 45 | end type budget_type 46 | public :: budget_type 47 | 48 | integer, parameter :: index_beg_vol_grc = 1 49 | integer, parameter :: index_end_vol_grc = 2 50 | integer, parameter :: index_in_grc = 3 51 | integer, parameter :: index_out_grc = 4 52 | integer, parameter :: index_net_grc = 5 53 | integer, parameter :: index_lag_grc = 6 54 | 55 | character(*), parameter :: u_FILE_u = & 56 | __FILE__ 57 | 58 | !----------------------------------------------------------------------- 59 | contains 60 | !----------------------------------------------------------------------- 61 | 62 | subroutine Init(this, begr, endr, ntracers) 63 | 64 | ! Initialize budget type 65 | 66 | ! Arguments 67 | class(budget_type) :: this 68 | integer, intent(in) :: begr, endr, ntracers 69 | !------------------------------------------------- 70 | 71 | ! gridcell level: 72 | allocate (this%accum_grc(begr:endr, ntracers)) 73 | this%accum_grc = 0._r8 74 | 75 | allocate (this%beg_vol_grc(begr:endr, ntracers)) 76 | this%beg_vol_grc = 0._r8 77 | 78 | allocate (this%end_vol_grc(begr:endr, ntracers)) 79 | this%end_vol_grc = 0._r8 80 | 81 | allocate (this%in_grc(begr:endr, ntracers)) 82 | this%in_grc = 0._r8 83 | 84 | allocate (this%out_grc(begr:endr, ntracers)) 85 | this%out_grc = 0._r8 86 | 87 | allocate (this%net_grc(begr:endr, ntracers)) 88 | this%net_grc = 0._r8 89 | 90 | allocate (this%lag_grc(begr:endr, ntracers)) 91 | this%lag_grc = 0._r8 92 | 93 | ! global level: 94 | allocate (this%accum_glob(ntracers)) 95 | this%accum_glob = 0._r8 96 | 97 | allocate (this%beg_vol_glob(ntracers)) 98 | this%beg_vol_glob = 0._r8 99 | 100 | allocate (this%end_vol_glob(ntracers)) 101 | this%end_vol_glob = 0._r8 102 | 103 | allocate (this%in_glob(ntracers)) 104 | this%in_glob = 0._r8 105 | 106 | allocate (this%out_glob(ntracers)) 107 | this%out_glob = 0._r8 108 | 109 | allocate (this%net_glob(ntracers)) 110 | this%net_glob = 0._r8 111 | 112 | allocate (this%lag_glob(ntracers)) 113 | this%lag_glob = 0._r8 114 | 115 | allocate (this%do_budget(ntracers)) 116 | this%do_budget = .true. 117 | 118 | end subroutine Init 119 | 120 | !----------------------------------------------------------------------- 121 | 122 | subroutine set_budget(this, begr, endr, ntracers, dt) 123 | 124 | ! Arguments 125 | class(budget_type) :: this 126 | integer, intent(in) :: begr, endr, ntracers 127 | real(r8), intent(in) :: dt 128 | 129 | ! local variables 130 | integer :: nr, nt !indices 131 | integer :: nt_liq, nt_ice 132 | !------------------------------------------------- 133 | 134 | nt_liq = ctl%nt_liq 135 | nt_ice = ctl%nt_ice 136 | do nr = begr, endr 137 | do nt = 1, ntracers 138 | this%beg_vol_grc(nr, nt) = ctl%volr(nr, nt) 139 | if (nt == nt_ice) then 140 | this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt) + ctl%qglc_ice(nr)) * dt 141 | else if (nt == nt_liq) then 142 | this%in_grc(nr, nt) = (ctl%qsur(nr, nt) + ctl%qsub(nr, nt) + ctl%qgwl(nr, nt) + ctl%qglc_liq(nr)) * dt 143 | end if 144 | ! this was for budget_terms(17) 145 | !if (nt==1) then 146 | ! this%in_grc(nr,nt)=this%in_grc(nr,nt) +ctl%qirrig(nr) 147 | !endif 148 | end do 149 | end do 150 | 151 | this%end_vol_grc(:,:) = 0.0_r8 152 | this%out_grc(:,:) = 0.0_r8 153 | this%net_grc(:,:) = 0.0_r8 154 | this%lag_grc(:,:) = 0.0_r8 155 | 156 | this%beg_vol_glob(:) = 0.0_r8 157 | this%end_vol_glob(:) = 0.0_r8 158 | this%in_glob(:) = 0.0_r8 159 | this%out_glob(:) = 0.0_r8 160 | this%net_glob(:) = 0.0_r8 161 | this%lag_glob(:) = 0.0_r8 162 | 163 | end subroutine set_budget 164 | 165 | !----------------------------------------------------------------------- 166 | 167 | subroutine check_budget(this, begr, endr, ntracers, dt) 168 | 169 | ! Arguments 170 | class(budget_type) :: this 171 | integer, intent(in) :: begr, endr, ntracers 172 | real(r8), intent(in) :: dt 173 | 174 | ! Local variables 175 | integer :: nr, nt !indecies 176 | integer :: nt_liq ! liquid index 177 | integer :: yr,mon,day,ymd,tod !time vars 178 | real(r8) :: tmp_in(6, ntracers) ! array to pass to mpi_sum 179 | real(r8) :: tmp_glob(6, ntracers) ! array from mpi_sum 180 | logical :: error_budget ! flag for an error 181 | real(r8) :: abserr, relerr 182 | !------------------------------------------------- 183 | 184 | call get_curr_date(yr, mon, day, tod) 185 | ymd = yr*10000 + mon*100 + day 186 | tmp_in = 0.0_r8 187 | tmp_glob = 0.0_r8 188 | 189 | nt_liq = ctl%nt_liq 190 | do nr = begr, endr 191 | do nt = 1, ntracers 192 | this%end_vol_grc(nr, nt) = ctl%volr(nr, nt) 193 | this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%direct(nr, nt) + ctl%direct_glc(nr, nt) 194 | if (nt == nt_liq) then 195 | this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%flood(nr) 196 | end if 197 | if (ctl%mask(nr) >= 2) then 198 | this%out_grc(nr, nt) = this%out_grc(nr, nt) + ctl%runoff(nr, nt) 199 | else 200 | this%lag_grc(nr, nt) = this%lag_grc(nr, nt) - ctl%erout_prev(nr, nt) - ctl%flow(nr, nt) 201 | end if 202 | this%out_grc(nr,nt) = this%out_grc(nr,nt) * dt 203 | this%lag_grc(nr,nt) = this%lag_grc(nr,nt) * dt 204 | this%net_grc(nr,nt) = this%end_vol_grc(nr,nt) - this%beg_vol_grc(nr,nt) - (this%in_grc(nr,nt)-this%out_grc(nr,nt)) 205 | this%accum_grc(nr,nt) = this%accum_grc(nr,nt) + this%net_grc(nr,nt) 206 | end do 207 | end do 208 | 209 | do nt = 1, ntracers 210 | tmp_in(index_beg_vol_grc, nt) = sum(this%beg_vol_grc(:, nt)) 211 | tmp_in(index_end_vol_grc, nt) = sum(this%end_vol_grc(:, nt)) 212 | tmp_in(index_in_grc, nt) = sum(this%in_grc(:, nt)) 213 | tmp_in(index_out_grc, nt) = sum(this%out_grc(:, nt)) 214 | tmp_in(index_net_grc, nt) = sum(this%net_grc(:, nt)) 215 | tmp_in(index_lag_grc, nt) = sum(this%lag_grc(:, nt)) 216 | end do 217 | 218 | tmp_in = tmp_in*1e-6_r8 !convert to million m3 219 | call shr_mpi_sum(tmp_in, tmp_glob, mpicom_rof, 'mosart global budget', all=.false.) 220 | 221 | do nt = 1, ntracers 222 | error_budget = .false. 223 | abserr = 0.0_r8 224 | relerr = 0.0_r8 225 | this%beg_vol_glob(nt) = tmp_glob(index_beg_vol_grc, nt) 226 | this%end_vol_glob(nt) = tmp_glob(index_end_vol_grc, nt) 227 | this%in_glob(nt) = tmp_glob(index_in_grc, nt) 228 | this%out_glob(nt) = tmp_glob(index_out_grc, nt) 229 | this%net_glob(nt) = tmp_glob(index_net_grc, nt) 230 | this%lag_glob(nt) = tmp_glob(index_lag_grc, nt) 231 | if (this%do_budget(nt)) then 232 | if (abs(this%net_glob(nt) - this%lag_glob(nt)*dt) > this%tolerance) then 233 | error_budget = .true. 234 | abserr = abs(this%net_glob(nt) - this%lag_glob(nt)) 235 | end if 236 | if (abs(this%net_glob(nt) + this%lag_glob(nt)) > 1e-6) then 237 | if ( abs(this%net_glob(nt) - this%lag_glob(nt)) & 238 | /abs(this%net_glob(nt) + this%lag_glob(nt)) > this%rel_tolerance) then 239 | error_budget = .true. 240 | relerr = abs(this%net_glob(nt) - this%lag_glob(nt)) /abs(this%net_glob(nt) + this%lag_glob(nt)) 241 | end if 242 | end if 243 | if (mainproc) then 244 | write (iulog, '(a)') '-----------------------------------' 245 | write (iulog, '(a)') '*****MOSART BUDGET DIAGNOSTICS*****' 246 | write (iulog,'(a,i10,i6)') ' diagnostics for ', ymd, tod 247 | write (iulog, '(a,i4,2a)') ' tracer = ', nt, ' ', ctl%tracer_names(nt) 248 | write (iulog, '(a,f22.6,a)') ' time step size = ', dt, ' sec' 249 | write (iulog, '(a,f22.6,a)') ' volume begining of the step = ', this%beg_vol_glob(nt), ' (mil m3)' 250 | write (iulog, '(a,f22.6,a)') ' volume end of the step = ', this%end_vol_glob(nt), ' (mil m3)' 251 | write (iulog, '(a,f22.6,a)') ' inputs = ', this%in_glob(nt), ' (mil m3)' 252 | write (iulog, '(a,f22.6,a)') ' outputs = ', this%out_glob(nt), ' (mil m3)' 253 | write (iulog, '(a,f22.6,a)') ' net budget (dv -i + o) = ', this%net_glob(nt), ' (mil m3)' 254 | write (iulog, '(a,f22.6,a)') ' eul erout lag = ', this%lag_glob(nt), '(mil m3)' 255 | write (iulog, '(a,f22.6)') ' absolute budget error = ', abserr 256 | write (iulog, '(a,f22.6)') ' relative budget error = ', relerr 257 | if (error_budget) then 258 | write(iulog,'(a)') ' BUDGET OUT OF BALANCE WARNING ' 259 | endif 260 | write (iulog, '(a)') '-----------------------------------' 261 | end if 262 | end if 263 | end do 264 | 265 | end subroutine check_budget 266 | 267 | end module mosart_budget_type 268 | -------------------------------------------------------------------------------- /src/riverroute/mosart_restfile.F90: -------------------------------------------------------------------------------- 1 | module mosart_restfile 2 | 3 | ! Read from and write to the MOSART restart file. 4 | 5 | use shr_kind_mod, only : r8 => shr_kind_r8, CL => shr_kind_cl, CS => shr_kind_cs 6 | use shr_sys_mod, only : shr_sys_abort 7 | use mosart_vars, only : iulog, inst_suffix, caseid, nsrest, & 8 | spval, mainproc, nsrContinue, nsrBranch, nsrStartup, & 9 | ctitle, version, username, hostname, conventions, source 10 | use mosart_data, only : ctl, Trunoff 11 | use mosart_histfile, only : mosart_hist_restart 12 | use mosart_fileutils, only : getfil 13 | use mosart_timemanager, only : timemgr_restart, get_nstep, get_curr_date, get_prev_date 14 | use mosart_io, only : ncd_pio_createfile, ncd_enddef, ncd_pio_openfile, ncd_pio_closefile, & 15 | ncd_defdim, ncd_putatt, ncd_defvar, ncd_io, ncd_global, ncd_double, & 16 | ncd_getdatetime 17 | use pio, only : file_desc_t 18 | 19 | implicit none 20 | private 21 | 22 | ! public member functions: 23 | public :: mosart_rest_FileName 24 | public :: mosart_rest_FileRead 25 | public :: mosart_rest_FileWrite 26 | public :: mosart_rest_Getfile 27 | public :: mosart_rest_TimeManager 28 | public :: mosart_rest_restart 29 | ! 30 | ! private member functions: 31 | private :: restFile_read_pfile 32 | private :: restFile_write_pfile ! Writes restart pointer file 33 | private :: restFile_dimset 34 | 35 | ! true => allow case name to remain the same for branch run 36 | ! by default this is not allowed 37 | logical, public :: brnch_retain_casename = .false. 38 | 39 | ! file name for local restart pointer file 40 | character(len=CL) :: rpntfil = 'rpointer.rof' 41 | 42 | ! initial conditions file name 43 | character(len=CL), public :: finidat 44 | 45 | ! restart data file name for branch run 46 | character(len=CL), public :: nrevsn 47 | 48 | !----------------------------------------------------------------------- 49 | contains 50 | !----------------------------------------------------------------------- 51 | 52 | subroutine mosart_rest_FileWrite( file, rdate ) 53 | 54 | !------------------------------------- 55 | ! Read/write MOSART restart file. 56 | 57 | ! Arguments: 58 | character(len=*) , intent(in) :: file ! output netcdf restart file 59 | character(len=*) , intent(in) :: rdate ! restart file time stamp for name 60 | 61 | ! Local variables 62 | type(file_desc_t) :: ncid ! netcdf id 63 | integer :: i ! index 64 | logical :: ptrfile ! write out the restart pointer file 65 | !------------------------------------- 66 | 67 | ! Define dimensions and variables 68 | 69 | if (mainproc) then 70 | write(iulog,*) 71 | write(iulog,*)'restFile_open: writing MOSART restart dataset ' 72 | write(iulog,*) 73 | end if 74 | call ncd_pio_createfile(ncid, trim(file)) 75 | call restFile_dimset( ncid ) 76 | call mosart_rest_restart ( ncid, flag='define' ) 77 | call mosart_hist_restart ( ncid, flag='define', rdate=rdate ) 78 | call timemgr_restart( ncid, flag='define' ) 79 | call ncd_enddef(ncid) 80 | 81 | ! Write restart file variables 82 | call mosart_rest_restart( ncid, flag='write' ) 83 | call mosart_hist_restart ( ncid, flag='write' ) 84 | call timemgr_restart( ncid, flag='write' ) 85 | call ncd_pio_closefile(ncid) 86 | 87 | if (mainproc) then 88 | write(iulog,*) 'Successfully wrote local restart file ',trim(file) 89 | write(iulog,'(72a1)') ("-",i=1,60) 90 | write(iulog,*) 91 | end if 92 | 93 | ! Write restart pointer file 94 | call restFile_write_pfile( file ) 95 | 96 | ! Write out diagnostic info 97 | 98 | if (mainproc) then 99 | write(iulog,*) 'Successfully wrote out restart data at nstep = ',get_nstep() 100 | write(iulog,'(72a1)') ("-",i=1,60) 101 | end if 102 | 103 | end subroutine mosart_rest_FileWrite 104 | 105 | !----------------------------------------------------------------------- 106 | 107 | subroutine mosart_rest_FileRead( file ) 108 | 109 | !------------------------------------- 110 | ! Read a MOSART restart file. 111 | ! 112 | ! Arguments 113 | character(len=*), intent(in) :: file ! output netcdf restart file 114 | ! 115 | ! Local variables 116 | type(file_desc_t) :: ncid ! netcdf id 117 | integer :: i ! index 118 | !------------------------------------- 119 | 120 | ! Read file 121 | if (mainproc) write(iulog,*) 'Reading restart dataset' 122 | call ncd_pio_openfile (ncid, trim(file), 0) 123 | call mosart_rest_restart(ncid, flag='read') 124 | call mosart_hist_restart(ncid, flag='read') 125 | call ncd_pio_closefile(ncid) 126 | 127 | ! Write out diagnostic info 128 | if (mainproc) then 129 | write(iulog,'(72a1)') ("-",i=1,60) 130 | write(iulog,*) 'Successfully read restart data for restart run' 131 | write(iulog,*) 132 | end if 133 | 134 | end subroutine mosart_rest_FileRead 135 | 136 | !----------------------------------------------------------------------- 137 | 138 | subroutine mosart_rest_TimeManager( file ) 139 | 140 | !------------------------------------- 141 | ! Read a MOSART restart file. 142 | ! 143 | ! Arguments 144 | character(len=*), intent(in) :: file ! output netcdf restart file 145 | ! 146 | ! Local Variables: 147 | type(file_desc_t) :: ncid ! netcdf id 148 | integer :: i ! index 149 | !------------------------------------- 150 | 151 | ! Read file 152 | if (mainproc) write(iulog,*) 'Reading restart Timemanger' 153 | call ncd_pio_openfile (ncid, trim(file), 0) 154 | call timemgr_restart(ncid, flag='read') 155 | call ncd_pio_closefile(ncid) 156 | 157 | ! Write out diagnostic info 158 | if (mainproc) then 159 | write(iulog,'(72a1)') ("-",i=1,60) 160 | write(iulog,*) 'Successfully read restart data for restart run' 161 | write(iulog,*) 162 | end if 163 | 164 | end subroutine mosart_rest_TimeManager 165 | 166 | !----------------------------------------------------------------------- 167 | 168 | subroutine mosart_rest_Getfile( file ) 169 | 170 | !------------------------------------- 171 | ! Determine and obtain netcdf restart file 172 | 173 | ! Arguments: 174 | character(len=*), intent(out) :: file ! name of netcdf restart file 175 | 176 | ! Local variables: 177 | integer :: status ! return status 178 | integer :: length ! temporary 179 | character(len=CL) :: ftest,ctest ! temporaries 180 | character(len=CL) :: path ! full pathname of netcdf restart file 181 | !------------------------------------- 182 | 183 | ! Continue run: 184 | ! Restart file pathname is read restart pointer file 185 | if (nsrest==nsrContinue) then 186 | call restFile_read_pfile( path ) 187 | call getfil( path, file, 0 ) 188 | end if 189 | 190 | ! Branch run: 191 | ! Restart file pathname is obtained from namelist "nrevsn" 192 | if (nsrest==nsrBranch) then 193 | length = len_trim(nrevsn) 194 | if (nrevsn(length-2:length) == '.nc') then 195 | path = trim(nrevsn) 196 | else 197 | path = trim(nrevsn) // '.nc' 198 | end if 199 | call getfil( path, file, 0 ) 200 | 201 | ! Check case name consistency (case name must be different 202 | ! for branch run, unless brnch_retain_casename is set) 203 | ctest = 'xx.'//trim(caseid)//'.mosart' 204 | ftest = 'xx.'//trim(file) 205 | status = index(trim(ftest),trim(ctest)) 206 | if (status /= 0 .and. .not.(brnch_retain_casename)) then 207 | write(iulog,*) 'Must change case name on branch run if ',& 208 | 'brnch_retain_casename namelist is not set' 209 | write(iulog,*) 'previous case filename= ',trim(file),& 210 | ' current case = ',trim(caseid), ' ctest = ',trim(ctest), & 211 | ' ftest = ',trim(ftest) 212 | call shr_sys_abort() 213 | end if 214 | end if 215 | 216 | ! Initial run 217 | if (nsrest==nsrStartup) then 218 | call getfil( finidat, file, 0 ) 219 | end if 220 | 221 | end subroutine mosart_rest_Getfile 222 | 223 | !----------------------------------------------------------------------- 224 | 225 | subroutine restFile_read_pfile( pnamer ) 226 | use mpi, only : MPI_CHARACTER 227 | use mosart_vars, only : mpicom_rof 228 | !------------------------------------- 229 | ! Setup restart file and perform necessary consistency checks 230 | 231 | ! Arguments 232 | character(len=*), intent(out) :: pnamer ! full path of restart file 233 | 234 | ! Local variables 235 | integer :: nio ! restart unit 236 | integer :: ier ! error return from fortran open 237 | integer :: i ! index 238 | integer :: yr, mon, day, tod 239 | character(len=17) :: timestamp 240 | character(len=CL) :: locfn ! Restart pointer file name 241 | !------------------------------------- 242 | 243 | ! Obtain the restart file from the restart pointer file. 244 | ! For restart runs, the restart pointer file contains the full pathname 245 | ! of the restart file. For branch runs, the namelist variable 246 | ! [nrevsn] contains the full pathname of the restart file. 247 | ! New history files are always created for branch runs. 248 | 249 | if (mainproc) then 250 | call get_curr_date(yr, mon, day, tod) 251 | write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,tod 252 | locfn = './'// trim(rpntfil)//trim(inst_suffix)//timestamp 253 | 254 | write(iulog,*) 'Reading restart pointer file: '//trim(locfn) 255 | open (newunit=nio, file=trim(locfn), status='old', form='formatted', iostat=ier) 256 | if (ier /= 0) then 257 | locfn = './'// trim(rpntfil)//trim(inst_suffix) 258 | open (newunit=nio, file=trim(locfn), status='old', form='formatted', iostat=ier) 259 | if (ier /= 0) then 260 | write(iulog,'(a,i8)')'(restFile_read_pfile): failed to open file '//trim(locfn)//' ierr=',ier 261 | call shr_sys_abort() 262 | end if 263 | endif 264 | read (nio,'(a256)') pnamer 265 | close(nio) 266 | endif 267 | call mpi_bcast (pnamer, CL, MPI_CHARACTER, 0, mpicom_rof, ier) 268 | if(mainproc) then 269 | write(iulog,'(a)') 'Reading restart data: ',trim(pnamer) 270 | write(iulog,'(72a1)') ("-",i=1,60) 271 | end if 272 | 273 | end subroutine restFile_read_pfile 274 | 275 | !----------------------------------------------------------------------- 276 | 277 | subroutine restFile_write_pfile( fnamer ) 278 | 279 | !------------------------------------- 280 | ! Open restart pointer file. Write names of current netcdf restart file. 281 | ! 282 | ! Arguments 283 | character(len=*), intent(in) :: fnamer 284 | ! 285 | ! Local variables 286 | integer :: nio ! restart pointer file unit number 287 | integer :: ier ! error return from fortran open 288 | character(len=CL) :: filename ! local file name 289 | integer :: yr, mon, day, tod 290 | character(len=17) :: timestamp 291 | !------------------------------------- 292 | 293 | if (mainproc) then 294 | call get_curr_date(yr, mon, day, tod) 295 | write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr, mon, day, tod 296 | filename= './'// trim(rpntfil)//trim(inst_suffix)//timestamp 297 | open (newunit=nio, file=trim(filename), status='unknown', form='formatted', iostat=ier) 298 | if (ier /= 0) then 299 | write(iulog,'(a,i8)')'(restFile_write_pfile): failed to open file '//trim(filename)//' ierr=',ier 300 | call shr_sys_abort() 301 | end if 302 | write(nio,'(a)') fnamer 303 | close(nio) 304 | write(iulog,*)'Successfully wrote local restart pointer file: '//trim(filename) 305 | end if 306 | 307 | end subroutine restFile_write_pfile 308 | 309 | !----------------------------------------------------------------------- 310 | 311 | character(len=CL) function mosart_rest_FileName( rdate ) 312 | 313 | ! Arguments 314 | character(len=*), intent(in) :: rdate ! input date for restart file name 315 | 316 | mosart_rest_FileName = "./"//trim(caseid)//".mosart"//trim(inst_suffix)//".r."//trim(rdate)//".nc" 317 | if (mainproc) then 318 | write(iulog,*)'writing restart file ',trim(mosart_rest_FileName),' for model date = ',rdate 319 | end if 320 | 321 | end function mosart_rest_FileName 322 | 323 | !------------------------------------------------------------------------ 324 | 325 | subroutine restFile_dimset( ncid ) 326 | 327 | !------------------------------------- 328 | ! Read/Write initial data from/to netCDF instantaneous initial data file 329 | 330 | ! Arguments 331 | type(file_desc_t), intent(inout) :: ncid 332 | 333 | ! Local Variables: 334 | integer :: dimid ! netCDF dimension id 335 | integer :: ier ! error status 336 | character(len= 8) :: curdate ! current date 337 | character(len= 8) :: curtime ! current time 338 | character(len=CL) :: str 339 | character(len=*),parameter :: subname='restFile_dimset' 340 | !------------------------------------- 341 | 342 | ! Define dimensions 343 | 344 | call ncd_defdim(ncid, 'nlon' , ctl%nlon , dimid) 345 | call ncd_defdim(ncid, 'nlat' , ctl%nlat , dimid) 346 | call ncd_defdim(ncid, 'string_length', CS , dimid) 347 | 348 | ! Define global attributes 349 | 350 | call ncd_putatt(ncid, NCD_GLOBAL, 'Conventions', trim(conventions)) 351 | call ncd_getdatetime(curdate, curtime) 352 | str = 'created on ' // curdate // ' ' // curtime 353 | call ncd_putatt(ncid, NCD_GLOBAL, 'history' , trim(str)) 354 | call ncd_putatt(ncid, NCD_GLOBAL, 'username', trim(username)) 355 | call ncd_putatt(ncid, NCD_GLOBAL, 'host' , trim(hostname)) 356 | call ncd_putatt(ncid, NCD_GLOBAL, 'version' , trim(version)) 357 | call ncd_putatt(ncid, NCD_GLOBAL, 'source' , trim(source)) 358 | call ncd_putatt(ncid, NCD_GLOBAL, 'case_title' , trim(ctitle)) 359 | call ncd_putatt(ncid, NCD_GLOBAL, 'case_id' , trim(caseid)) 360 | call ncd_putatt(ncid, NCD_GLOBAL, 'title', & 361 | 'MOSART Restart information, required to continue a simulation' ) 362 | 363 | end subroutine restFile_dimset 364 | 365 | !----------------------------------------------------------------------- 366 | 367 | subroutine mosart_rest_restart(ncid, flag) 368 | 369 | !------------------------------------- 370 | ! Read/write MOSART restart data. 371 | ! 372 | ! Arguments: 373 | type(file_desc_t), intent(inout) :: ncid ! netcdf id 374 | character(len=*) , intent(in) :: flag ! 'read' or 'write' 375 | 376 | ! Local variables 377 | logical :: readvar ! determine if variable is on initial file 378 | integer :: n,nt,nv ! indices 379 | integer :: nvariables 380 | real(r8) , pointer :: dfld(:) ! temporary array 381 | character(len=CS) :: vname,uname 382 | character(len=CL) :: lname 383 | !------------------------------------- 384 | 385 | nvariables = 7 386 | do nv = 1,nvariables 387 | do nt = 1,ctl%ntracers 388 | 389 | if (nv == 1) then 390 | vname = 'VOLR_'//trim(ctl%tracer_names(nt)) 391 | lname = 'water volume in cell (volr)' 392 | uname = 'm3' 393 | dfld => ctl%volr(:,nt) 394 | elseif (nv == 2) then 395 | vname = 'RUNOFF_'//trim(ctl%tracer_names(nt)) 396 | lname = 'runoff (runoff)' 397 | uname = 'm3/s' 398 | dfld => ctl%runoff(:,nt) 399 | elseif (nv == 3) then 400 | vname = 'DVOLRDT_'//trim(ctl%tracer_names(nt)) 401 | lname = 'water volume change in cell (dvolrdt)' 402 | uname = 'mm/s' 403 | dfld => ctl%dvolrdt(:,nt) 404 | elseif (nv == 4) then 405 | vname = 'WH_'//trim(ctl%tracer_names(nt)) 406 | lname = 'surface water storage at hillslopes in cell' 407 | uname = 'm' 408 | dfld => Trunoff%wh(:,nt) 409 | elseif (nv == 5) then 410 | vname = 'WT_'//trim(ctl%tracer_names(nt)) 411 | lname = 'water storage in tributary channels in cell' 412 | uname = 'm3' 413 | dfld => Trunoff%wt(:,nt) 414 | elseif (nv == 6) then 415 | vname = 'WR_'//trim(ctl%tracer_names(nt)) 416 | lname = 'water storage in main channel in cell' 417 | uname = 'm3' 418 | dfld => Trunoff%wr(:,nt) 419 | elseif (nv == 7) then 420 | vname = 'EROUT_'//trim(ctl%tracer_names(nt)) 421 | lname = 'instataneous flow out of main channel in cell' 422 | uname = 'm3/s' 423 | dfld => Trunoff%erout(:,nt) 424 | else 425 | write(iulog,*) 'ERROR: illegal nv value a ',nv 426 | call shr_sys_abort() 427 | endif 428 | 429 | if (flag == 'define') then 430 | call ncd_defvar(ncid=ncid, varname=trim(vname), & 431 | xtype=ncd_double, dim1name='nlon', dim2name='nlat', & 432 | long_name=trim(lname), units=trim(uname), fill_value=spval) 433 | else if (flag == 'read' .or. flag == 'write') then 434 | call ncd_io(varname=trim(vname), data=dfld, dim1name='allrof', & 435 | ncid=ncid, flag=flag, readvar=readvar) 436 | if (flag=='read' .and. .not. readvar) then 437 | if (nsrest == nsrContinue) then 438 | call shr_sys_abort() 439 | else 440 | dfld = 0._r8 441 | end if 442 | end if 443 | end if 444 | 445 | enddo 446 | enddo 447 | 448 | if (flag == 'read') then 449 | do n = ctl%begr,ctl%endr 450 | do nt = 1,ctl%ntracers 451 | if (abs(ctl%volr(n,nt)) > 1.e30) ctl%volr(n,nt) = 0. 452 | if (abs(ctl%runoff(n,nt)) > 1.e30) ctl%runoff(n,nt) = 0. 453 | if (abs(ctl%dvolrdt(n,nt)) > 1.e30) ctl%dvolrdt(n,nt) = 0. 454 | if (abs(Trunoff%wh(n,nt)) > 1.e30) Trunoff%wh(n,nt) = 0. 455 | if (abs(Trunoff%wt(n,nt)) > 1.e30) Trunoff%wt(n,nt) = 0. 456 | if (abs(Trunoff%wr(n,nt)) > 1.e30) Trunoff%wr(n,nt) = 0. 457 | if (abs(Trunoff%erout(n,nt)) > 1.e30) Trunoff%erout(n,nt) = 0. 458 | end do 459 | if (ctl%mask(n) == 1) then 460 | do nt = 1,ctl%ntracers 461 | ctl%runofflnd(n,nt) = ctl%runoff(n,nt) 462 | ctl%dvolrdtlnd(n,nt)= ctl%dvolrdt(n,nt) 463 | end do 464 | elseif (ctl%mask(n) >= 2) then 465 | do nt = 1,ctl%ntracers 466 | ctl%runoffocn(n,nt) = ctl%runoff(n,nt) 467 | ctl%dvolrdtocn(n,nt)= ctl%dvolrdt(n,nt) 468 | enddo 469 | endif 470 | enddo 471 | endif 472 | 473 | end subroutine mosart_rest_restart 474 | 475 | end module mosart_restfile 476 | -------------------------------------------------------------------------------- /src/riverroute/mosart_physics.F90: -------------------------------------------------------------------------------- 1 | module mosart_physics 2 | 3 | !----------------------------------------------------------------------- 4 | ! Description: core code of MOSART. 5 | ! Contains routines for solving diffusion wave and update the state of 6 | ! hillslope, subnetwork and main channel variables 7 | ! Developed by Hongyi Li, 12/29/2011. 8 | !----------------------------------------------------------------------- 9 | 10 | use shr_kind_mod , only : r8 => shr_kind_r8 11 | use shr_const_mod , only : SHR_CONST_REARTH, SHR_CONST_PI 12 | use shr_sys_mod , only : shr_sys_abort 13 | use mosart_vars , only : iulog, barrier_timers, mpicom_rof, bypass_routing_option 14 | use mosart_data , only : Tctl, TUnit, TRunoff, TPara, ctl 15 | use perf_mod , only : t_startf, t_stopf 16 | use nuopc_shr_methods , only : chkerr 17 | use ESMF , only : ESMF_FieldGet, ESMF_FieldSMM, ESMF_Finalize, & 18 | ESMF_SUCCESS, ESMF_END_ABORT, ESMF_TERMORDER_SRCSEQ 19 | 20 | implicit none 21 | private 22 | 23 | public :: Euler 24 | public :: updatestate_hillslope 25 | public :: updatestate_subnetwork 26 | public :: updatestate_mainchannel 27 | public :: hillsloperouting 28 | public :: subnetworkrouting 29 | public :: mainchannelrouting 30 | 31 | private :: Routing_KW 32 | private :: CRVRMAN_nosqrt 33 | private :: CREHT_nosqrt 34 | private :: GRMR 35 | private :: GRHT 36 | private :: GRPT 37 | private :: GRRR 38 | private :: GRPR 39 | 40 | real(r8), parameter :: TINYVALUE = 1.0e-14_r8 ! double precision variable has a significance of about 16 decimal digits 41 | real(r8), parameter :: SLOPE1def = 0.1_r8 ! here give it a small value in order to avoid the abrupt change of hydraulic radidus etc. 42 | real(r8) :: sinatanSLOPE1defr ! 1.0/sin(atan(slope1)) 43 | 44 | character(*), parameter :: u_FILE_u = & 45 | __FILE__ 46 | 47 | !----------------------------------------------------------------------- 48 | contains 49 | !----------------------------------------------------------------------- 50 | 51 | subroutine Euler(rc) 52 | 53 | ! solve the ODEs with Euler algorithm 54 | 55 | ! Arguments 56 | integer, intent(out) :: rc 57 | 58 | ! Local variables 59 | integer :: nt, nr, m, k, unitUp, cnt, ier !local index 60 | real(r8) :: temp_erout, localDeltaT 61 | real(r8) :: negchan 62 | real(r8), pointer :: src_eroutUp(:,:) 63 | real(r8), pointer :: dst_eroutUp(:,:) 64 | 65 | !------------------ 66 | ! hillslope 67 | !------------------ 68 | 69 | rc = ESMF_SUCCESS 70 | 71 | call t_startf('mosartr_hillslope') 72 | do nt=1,ctl%ntracers 73 | if (TUnit%euler_calc(nt)) then 74 | do nr=ctl%begr,ctl%endr 75 | if(TUnit%mask(nr) > 0) then 76 | call hillslopeRouting(nr,nt,Tctl%DeltaT) 77 | TRunoff%wh(nr,nt) = TRunoff%wh(nr,nt) + TRunoff%dwh(nr,nt) * Tctl%DeltaT 78 | call UpdateState_hillslope(nr,nt) 79 | TRunoff%etin(nr,nt) = (-TRunoff%ehout(nr,nt) + TRunoff%qsub(nr,nt)) * TUnit%area(nr) * TUnit%frac(nr) 80 | endif 81 | end do 82 | endif 83 | end do 84 | call t_stopf('mosartr_hillslope') 85 | 86 | call ESMF_FieldGet(Tunit%srcfield, farrayPtr=src_eroutUp, rc=rc) 87 | if (chkerr(rc,__LINE__,u_FILE_u)) return 88 | call ESMF_FieldGet(Tunit%dstfield, farrayPtr=dst_eroutUp, rc=rc) 89 | if (chkerr(rc,__LINE__,u_FILE_u)) return 90 | src_eroutUp(:,:) = 0._r8 91 | dst_eroutUp(:,:) = 0._r8 92 | 93 | TRunoff%flow = 0._r8 94 | TRunoff%erout_prev = 0._r8 95 | TRunoff%eroutup_avg = 0._r8 96 | TRunoff%erlat_avg = 0._r8 97 | negchan = 9999.0_r8 98 | 99 | do m=1,Tctl%DLevelH2R 100 | 101 | ! accumulate/average erout at prior timestep (used in eroutUp calc) for budget analysis 102 | do nt=1,ctl%ntracers 103 | if (TUnit%euler_calc(nt)) then 104 | do nr=ctl%begr,ctl%endr 105 | TRunoff%erout_prev(nr,nt) = TRunoff%erout_prev(nr,nt) + TRunoff%erout(nr,nt) 106 | end do 107 | end if 108 | end do 109 | 110 | !------------------ 111 | ! subnetwork 112 | !------------------ 113 | 114 | call t_startf('mosartr_subnetwork') 115 | TRunoff%erlateral(:,:) = 0._r8 116 | do nt=1,ctl%ntracers 117 | if (TUnit%euler_calc(nt)) then 118 | do nr=ctl%begr,ctl%endr 119 | if(TUnit%mask(nr) > 0) then 120 | localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_t(nr) 121 | do k=1,TUnit%numDT_t(nr) 122 | call subnetworkRouting(nr,nt,localDeltaT) 123 | TRunoff%wt(nr,nt) = TRunoff%wt(nr,nt) + TRunoff%dwt(nr,nt) * localDeltaT 124 | call UpdateState_subnetwork(nr,nt) 125 | TRunoff%erlateral(nr,nt) = TRunoff%erlateral(nr,nt)-TRunoff%etout(nr,nt) 126 | end do ! numDT_t 127 | TRunoff%erlateral(nr,nt) = TRunoff%erlateral(nr,nt) / TUnit%numDT_t(nr) 128 | endif 129 | end do ! nr 130 | endif ! euler_calc 131 | end do ! nt 132 | call t_stopf('mosartr_subnetwork') 133 | 134 | !------------------ 135 | ! upstream interactions 136 | !------------------ 137 | 138 | if (barrier_timers) then 139 | call t_startf('mosartr_SMeroutUp_barrier') 140 | call mpi_barrier(mpicom_rof,ier) 141 | call t_stopf('mosartr_SMeroutUp_barrier') 142 | endif 143 | 144 | call t_startf('mosartr_SMeroutUp') 145 | 146 | !--- copy erout into src_eroutUp --- 147 | TRunoff%eroutUp = 0._r8 148 | src_eroutUp(:,:) = 0._r8 149 | cnt = 0 150 | do nr = ctl%begr,ctl%endr 151 | cnt = cnt + 1 152 | do nt = 1,ctl%ntracers 153 | src_eroutUp(nt,cnt) = TRunoff%erout(nr,nt) 154 | enddo 155 | enddo 156 | 157 | ! --- map src_eroutUp to dst_eroutUp 158 | call ESMF_FieldSMM(TUnit%srcfield, TUnit%dstField, TUnit%rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) 159 | if (chkerr(rc,__LINE__,u_FILE_u)) return 160 | 161 | !--- copy mapped eroutUp to TRunoff --- 162 | cnt = 0 163 | do nr = ctl%begr,ctl%endr 164 | cnt = cnt + 1 165 | do nt = 1,ctl%ntracers 166 | TRunoff%eroutUp(nr,nt) = dst_eroutUp(nt,cnt) 167 | enddo 168 | enddo 169 | 170 | call t_stopf('mosartr_SMeroutUp') 171 | 172 | TRunoff%eroutup_avg = TRunoff%eroutup_avg + TRunoff%eroutUp 173 | TRunoff%erlat_avg = TRunoff%erlat_avg + TRunoff%erlateral 174 | 175 | !------------------ 176 | ! channel routing 177 | !------------------ 178 | 179 | call t_startf('mosartr_chanroute') 180 | do nt=1,ctl%ntracers 181 | if (TUnit%euler_calc(nt)) then 182 | do nr=ctl%begr,ctl%endr 183 | if(TUnit%mask(nr) > 0) then 184 | localDeltaT = Tctl%DeltaT/Tctl%DLevelH2R/TUnit%numDT_r(nr) 185 | temp_erout = 0._r8 186 | do k=1,TUnit%numDT_r(nr) 187 | ! TODO: is it positive (TRunoff%wr) and negative afterwards 188 | call mainchannelRouting(nr,nt,localDeltaT) 189 | TRunoff%wr(nr,nt) = TRunoff%wr(nr,nt) + TRunoff%dwr(nr,nt) * localDeltaT 190 | ! check for negative channel storage 191 | ! if(TRunoff%wr(nr,1) < -1.e-10) then 192 | ! write(iulog,*) 'Negative channel storage! ', nr, TRunoff%wr(nr,1) 193 | ! call shr_sys_abort('mosart: negative channel storage') 194 | ! end if 195 | call UpdateState_mainchannel(nr,nt) 196 | ! erout here might be inflow to some downstream subbasin, so treat it differently than erlateral 197 | temp_erout = temp_erout + TRunoff%erout(nr,nt) 198 | end do 199 | temp_erout = temp_erout / TUnit%numDT_r(nr) 200 | TRunoff%erout(nr,nt) = temp_erout 201 | TRunoff%flow(nr,nt) = TRunoff%flow(nr,nt) - TRunoff%erout(nr,nt) 202 | endif 203 | end do ! nr 204 | endif ! euler_calc 205 | end do ! nt 206 | negchan = min(negchan, minval(TRunoff%wr(:,:))) 207 | 208 | call t_stopf('mosartr_chanroute') 209 | end do 210 | 211 | ! check for negative channel storage 212 | if (negchan < -1.e-10) then 213 | write(iulog,*) 'Warning: Negative channel storage found! ',negchan 214 | ! call shr_sys_abort('mosart: negative channel storage') 215 | endif 216 | TRunoff%flow = TRunoff%flow / Tctl%DLevelH2R 217 | TRunoff%erout_prev = TRunoff%erout_prev / Tctl%DLevelH2R 218 | TRunoff%eroutup_avg = TRunoff%eroutup_avg / Tctl%DLevelH2R 219 | TRunoff%erlat_avg = TRunoff%erlat_avg / Tctl%DLevelH2R 220 | 221 | end subroutine Euler 222 | 223 | !----------------------------------------------------------------------- 224 | 225 | subroutine hillslopeRouting(nr, nt, theDeltaT) 226 | ! Hillslope routing considering uniform runoff generation across hillslope 227 | 228 | ! Arguments 229 | integer, intent(in) :: nr, nt 230 | real(r8), intent(in) :: theDeltaT 231 | 232 | TRunoff%ehout(nr,nt) = -CREHT_nosqrt(TUnit%hslpsqrt(nr), TUnit%nh(nr), TUnit%Gxr(nr), TRunoff%yh(nr,nt)) 233 | if(TRunoff%ehout(nr,nt) < 0._r8 .and. & 234 | TRunoff%wh(nr,nt) + (TRunoff%qsur(nr,nt) + TRunoff%ehout(nr,nt)) * theDeltaT < TINYVALUE) then 235 | TRunoff%ehout(nr,nt) = -(TRunoff%qsur(nr,nt) + TRunoff%wh(nr,nt) / theDeltaT) 236 | end if 237 | TRunoff%dwh(nr,nt) = (TRunoff%qsur(nr,nt) + TRunoff%ehout(nr,nt)) 238 | 239 | end subroutine hillslopeRouting 240 | 241 | !----------------------------------------------------------------------- 242 | 243 | subroutine subnetworkRouting(nr,nt,theDeltaT) 244 | ! subnetwork channel routing 245 | 246 | ! Arguments 247 | integer, intent(in) :: nr,nt 248 | real(r8), intent(in) :: theDeltaT 249 | 250 | if(TUnit%tlen(nr) <= TUnit%hlen(nr)) then ! if no tributaries, not subnetwork channel routing 251 | TRunoff%etout(nr,nt) = -TRunoff%etin(nr,nt) 252 | else 253 | TRunoff%vt(nr,nt) = CRVRMAN_nosqrt(TUnit%tslpsqrt(nr), TUnit%nt(nr), TRunoff%rt(nr,nt)) 254 | TRunoff%etout(nr,nt) = -TRunoff%vt(nr,nt) * TRunoff%mt(nr,nt) 255 | if(TRunoff%wt(nr,nt) + (TRunoff%etin(nr,nt) + TRunoff%etout(nr,nt)) * theDeltaT < TINYVALUE) then 256 | TRunoff%etout(nr,nt) = -(TRunoff%etin(nr,nt) + TRunoff%wt(nr,nt)/theDeltaT) 257 | if(TRunoff%mt(nr,nt) > 0._r8) then 258 | TRunoff%vt(nr,nt) = -TRunoff%etout(nr,nt)/TRunoff%mt(nr,nt) 259 | end if 260 | end if 261 | end if 262 | TRunoff%dwt(nr,nt) = TRunoff%etin(nr,nt) + TRunoff%etout(nr,nt) 263 | 264 | ! check stability 265 | ! if(TRunoff%vt(nr,nt) < -TINYVALUE .or. TRunoff%vt(nr,nt) > 30) then 266 | ! write(iulog,*) "Numerical error in subnetworkRouting, ", nr,nt,TRunoff%vt(nr,nt) 267 | ! end if 268 | 269 | end subroutine subnetworkRouting 270 | 271 | !----------------------------------------------------------------------- 272 | 273 | subroutine mainchannelRouting(nr, nt, theDeltaT) 274 | ! main channel routing 275 | 276 | ! Arguments 277 | integer, intent(in) :: nr, nt 278 | real(r8), intent(in) :: theDeltaT 279 | 280 | if(Tctl%RoutingMethod == 1) then 281 | call Routing_KW(nr, nt, theDeltaT) 282 | else 283 | call shr_sys_abort( "mosart: Please check the routing method! There is only 1 method currently available." ) 284 | end if 285 | 286 | end subroutine mainchannelRouting 287 | 288 | !----------------------------------------------------------------------- 289 | 290 | subroutine Routing_KW(nr, nt, theDeltaT) 291 | ! classic kinematic wave routing method 292 | 293 | ! Arguments 294 | integer, intent(in) :: nr, nt 295 | real(r8), intent(in) :: theDeltaT 296 | 297 | ! Local variables 298 | integer :: k 299 | real(r8) :: temp_gwl, temp_dwr, temp_gwl0 300 | 301 | ! estimate the inflow from upstream units 302 | TRunoff%erin(nr,nt) = 0._r8 303 | TRunoff%erin(nr,nt) = TRunoff%erin(nr,nt) - TRunoff%eroutUp(nr,nt) 304 | 305 | ! estimate the outflow 306 | if(TUnit%rlen(nr) <= 0._r8) then ! no river network, no channel routing 307 | TRunoff%vr(nr,nt) = 0._r8 308 | TRunoff%erout(nr,nt) = -TRunoff%erin(nr,nt)-TRunoff%erlateral(nr,nt) 309 | else 310 | if(TUnit%areaTotal2(nr)/TUnit%rwidth(nr)/TUnit%rlen(nr) > 1e6_r8) then 311 | TRunoff%erout(nr,nt) = -TRunoff%erin(nr,nt)-TRunoff%erlateral(nr,nt) 312 | else 313 | TRunoff%vr(nr,nt) = CRVRMAN_nosqrt(TUnit%rslpsqrt(nr), TUnit%nr(nr), TRunoff%rr(nr,nt)) 314 | TRunoff%erout(nr,nt) = -TRunoff%vr(nr,nt) * TRunoff%mr(nr,nt) 315 | if(-TRunoff%erout(nr,nt) > TINYVALUE .and. TRunoff%wr(nr,nt) + & 316 | (TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt)) * theDeltaT < TINYVALUE) then 317 | TRunoff%erout(nr,nt) = -(TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%wr(nr,nt) / theDeltaT) 318 | if(TRunoff%mr(nr,nt) > 0._r8) then 319 | TRunoff%vr(nr,nt) = -TRunoff%erout(nr,nt) / TRunoff%mr(nr,nt) 320 | end if 321 | end if 322 | end if 323 | end if 324 | 325 | temp_gwl = TRunoff%qgwl(nr,nt) * TUnit%area(nr) * TUnit%frac(nr) 326 | 327 | TRunoff%dwr(nr,nt) = TRunoff%erlateral(nr,nt) + TRunoff%erin(nr,nt) + TRunoff%erout(nr,nt) + temp_gwl 328 | 329 | if ((TRunoff%wr(nr,nt)/theDeltaT + TRunoff%dwr(nr,nt)) < -TINYVALUE .and. (trim(bypass_routing_option)/='none') ) then 330 | write(iulog,*) 'mosart: ERROR main channel going negative: ', nr, nt 331 | write(iulog,*) theDeltaT, TRunoff%wr(nr,nt), & 332 | TRunoff%wr(nr,nt)/theDeltaT, TRunoff%dwr(nr,nt), temp_gwl 333 | write(iulog,*) ' ' 334 | endif 335 | 336 | ! check for stability 337 | ! if(TRunoff%vr(nr,nt) < -TINYVALUE .or. TRunoff%vr(nr,nt) > 30) then 338 | ! write(iulog,*) "Numerical error inRouting_KW, ", nr,nt,TRunoff%vr(nr,nt) 339 | ! end if 340 | 341 | ! check for negative wr 342 | ! if(TRunoff%wr(nr,nt) > 1._r8 .and. & 343 | ! (TRunoff%wr(nr,nt)/theDeltaT + TRunoff%dwr(nr,nt))/TRunoff%wr(nr,nt) < -TINYVALUE) then 344 | ! write(iulog,*) 'negative wr!', TRunoff%wr(nr,nt), TRunoff%dwr(nr,nt), temp_dwr, temp_gwl, temp_gwl0, theDeltaT 345 | ! stop 346 | ! end if 347 | 348 | end subroutine Routing_KW 349 | 350 | !----------------------------------------------------------------------- 351 | 352 | subroutine updateState_hillslope(nr,nt) 353 | ! update the state variables at hillslope 354 | 355 | ! Arguments 356 | integer, intent(in) :: nr, nt 357 | 358 | TRunoff%yh(nr,nt) = TRunoff%wh(nr,nt) !/ TUnit%area(nr) / TUnit%frac(nr) 359 | 360 | end subroutine updateState_hillslope 361 | 362 | !----------------------------------------------------------------------- 363 | 364 | subroutine updateState_subnetwork(nr,nt) 365 | ! update the state variables in subnetwork channel 366 | 367 | ! Arguments 368 | integer, intent(in) :: nr,nt 369 | 370 | if(TUnit%tlen(nr) > 0._r8 .and. TRunoff%wt(nr,nt) > 0._r8) then 371 | TRunoff%mt(nr,nt) = GRMR(TRunoff%wt(nr,nt), TUnit%tlen(nr)) 372 | TRunoff%yt(nr,nt) = GRHT(TRunoff%mt(nr,nt), TUnit%twidth(nr)) 373 | TRunoff%pt(nr,nt) = GRPT(TRunoff%yt(nr,nt), TUnit%twidth(nr)) 374 | TRunoff%rt(nr,nt) = GRRR(TRunoff%mt(nr,nt), TRunoff%pt(nr,nt)) 375 | else 376 | TRunoff%mt(nr,nt) = 0._r8 377 | TRunoff%yt(nr,nt) = 0._r8 378 | TRunoff%pt(nr,nt) = 0._r8 379 | TRunoff%rt(nr,nt) = 0._r8 380 | end if 381 | end subroutine updateState_subnetwork 382 | 383 | !----------------------------------------------------------------------- 384 | 385 | subroutine updateState_mainchannel(nr, nt) 386 | ! update the state variables in main channel 387 | 388 | ! Arguments 389 | integer, intent(in) :: nr, nt 390 | 391 | if(TUnit%rlen(nr) > 0._r8 .and. TRunoff%wr(nr,nt) > 0._r8) then 392 | TRunoff%mr(nr,nt) = GRMR(TRunoff%wr(nr,nt), TUnit%rlen(nr)) 393 | TRunoff%yr(nr,nt) = GRHR(TRunoff%mr(nr,nt), TUnit%rwidth(nr), TUnit%rwidth0(nr), TUnit%rdepth(nr)) 394 | TRunoff%pr(nr,nt) = GRPR(TRunoff%yr(nr,nt), TUnit%rwidth(nr), TUnit%rwidth0(nr), TUnit%rdepth(nr)) 395 | TRunoff%rr(nr,nt) = GRRR(TRunoff%mr(nr,nt), TRunoff%pr(nr,nt)) 396 | else 397 | TRunoff%mr(nr,nt) = 0._r8 398 | TRunoff%yr(nr,nt) = 0._r8 399 | TRunoff%pr(nr,nt) = 0._r8 400 | TRunoff%rr(nr,nt) = 0._r8 401 | end if 402 | end subroutine updateState_mainchannel 403 | 404 | !----------------------------------------------------------------------- 405 | 406 | function CRVRMAN_nosqrt(sqrtslp_, n_, rr_) result(v_) 407 | ! Function for calculating channel velocity according to Manning's equation. 408 | 409 | ! Arguments 410 | real(r8), intent(in) :: sqrtslp_, n_, rr_ ! sqrt(slope), manning's roughness coeff., hydraulic radius 411 | real(r8) :: v_ ! v_ is discharge 412 | 413 | ! Local varaibles 414 | real(r8) :: ftemp, vtemp 415 | 416 | if(rr_ <= 0._r8) then 417 | v_ = 0._r8 418 | else 419 | v_ = ((rr_*rr_)**(1._r8/3._r8)) * sqrtslp_ / n_ 420 | end if 421 | 422 | end function CRVRMAN_nosqrt 423 | 424 | !----------------------------------------------------------------------- 425 | 426 | function CREHT_nosqrt(sqrthslp_, nh_, Gxr_, yh_) result(eht_) 427 | ! Function for overland from hillslope into the sub-network channels 428 | 429 | ! Arguments 430 | real(r8), intent(in) :: sqrthslp_, nh_, Gxr_, yh_ ! topographic slope, manning's roughness coeff., drainage density, overland flow depth 431 | real(r8) :: eht_ ! velocity, specific discharge 432 | 433 | real(r8) :: vh_ 434 | vh_ = CRVRMAN_nosqrt(sqrthslp_,nh_,yh_) 435 | eht_ = Gxr_*yh_*vh_ 436 | 437 | end function CREHT_nosqrt 438 | 439 | !----------------------------------------------------------------------- 440 | 441 | function GRMR(wr_, rlen_) result(mr_) 442 | ! Function for estimate wetted channel area 443 | 444 | ! Arguments 445 | real(r8), intent(in) :: wr_, rlen_ ! storage of water, channel length 446 | real(r8) :: mr_ ! wetted channel area 447 | 448 | mr_ = wr_ / rlen_ 449 | end function GRMR 450 | 451 | !----------------------------------------------------------------------- 452 | 453 | function GRHT(mt_, twid_) result(ht_) 454 | ! Function for estimating water depth assuming rectangular channel 455 | 456 | ! Arguments 457 | real(r8), intent(in) :: mt_, twid_ ! wetted channel area, channel width 458 | real(r8) :: ht_ ! water depth 459 | 460 | if(mt_ <= TINYVALUE) then 461 | ht_ = 0._r8 462 | else 463 | ht_ = mt_ / twid_ 464 | end if 465 | end function GRHT 466 | 467 | !----------------------------------------------------------------------- 468 | 469 | function GRPT(ht_, twid_) result(pt_) 470 | ! Function for estimating wetted perimeter assuming rectangular channel 471 | 472 | ! Arguments 473 | real(r8), intent(in) :: ht_, twid_ ! water depth, channel width 474 | real(r8) :: pt_ ! wetted perimeter 475 | 476 | if(ht_ <= TINYVALUE) then 477 | pt_ = 0._r8 478 | else 479 | pt_ = twid_ + 2._r8 * ht_ 480 | end if 481 | end function GRPT 482 | 483 | !----------------------------------------------------------------------- 484 | 485 | function GRRR(mr_, pr_) result(rr_) 486 | ! Function for estimating hydraulic radius 487 | 488 | ! Arguments 489 | real(r8), intent(in) :: mr_, pr_ ! wetted area and perimeter 490 | real(r8) :: rr_ ! hydraulic radius 491 | 492 | if(pr_ <= TINYVALUE) then 493 | rr_ = 0._r8 494 | else 495 | rr_ = mr_ / pr_ 496 | end if 497 | end function GRRR 498 | 499 | !----------------------------------------------------------------------- 500 | 501 | function GRHR(mr_, rwidth_, rwidth0_, rdepth_) result(hr_) 502 | ! Function for estimating maximum water depth assuming rectangular channel and tropezoidal flood plain 503 | ! here assuming the channel cross-section consists of three parts, from bottom to up, 504 | ! part 1 is a rectangular with bankfull depth (rdep) and bankfull width (rwid) 505 | ! part 2 is a tropezoidal, bottom width rwid and top width rwid0, height 0.1*((rwid0-rwid)/2), assuming slope is 0.1 506 | ! part 3 is a rectagular with the width rwid0 507 | 508 | ! Arguments 509 | real(r8), intent(in) :: mr_, rwidth_, rwidth0_, rdepth_ ! wetted channel area, channel width, flood plain wid, water depth 510 | real(r8) :: hr_ ! water depth 511 | 512 | ! Local variables 513 | real(r8) :: SLOPE1 ! slope of flood plain, TO DO 514 | real(r8) :: deltamr_ 515 | 516 | SLOPE1 = SLOPE1def 517 | if(mr_ <= TINYVALUE) then 518 | hr_ = 0._r8 519 | else 520 | if(mr_ - rdepth_*rwidth_ <= TINYVALUE) then ! not flooded 521 | hr_ = mr_/rwidth_ 522 | else ! if flooded, the find out the equivalent depth 523 | if(mr_ > rdepth_*rwidth_ + (rwidth_ + rwidth0_)*SLOPE1*((rwidth0_-rwidth_)/2._r8)/2._r8 + TINYVALUE) then 524 | deltamr_ = mr_ - rdepth_*rwidth_ - (rwidth_ + rwidth0_)*SLOPE1*((rwidth0_ - rwidth_)/2._r8)/2._r8; 525 | hr_ = rdepth_ + SLOPE1*((rwidth0_ - rwidth_)/2._r8) + deltamr_/(rwidth0_); 526 | else 527 | deltamr_ = mr_ - rdepth_*rwidth_; 528 | hr_ = rdepth_ + (-rwidth_+sqrt((rwidth_*rwidth_)+4._r8*deltamr_/SLOPE1))*SLOPE1/2._r8 529 | end if 530 | end if 531 | end if 532 | end function GRHR 533 | 534 | !----------------------------------------------------------------------- 535 | 536 | function GRPR(hr_, rwidth_, rwidth0_,rdepth_) result(pr_) 537 | ! Function for estimating maximum water depth assuming rectangular channel and tropezoidal flood plain 538 | ! here assuming the channel cross-section consists of three parts, from bottom to up, 539 | ! part 1 is a rectangular with bankfull depth (rdep) and bankfull width (rwid) 540 | ! part 2 is a tropezoidal, bottom width rwid and top width rwid0, height 0.1*((rwid0-rwid)/2), assuming slope is 0.1 541 | ! part 3 is a rectagular with the width rwid0 542 | 543 | ! Arguments 544 | real(r8), intent(in) :: hr_, rwidth_, rwidth0_, rdepth_ ! wwater depth, channel width, flood plain wid, water depth 545 | real(r8) :: pr_ ! water depth 546 | 547 | ! Local variables 548 | real(r8) :: SLOPE1 ! slope of flood plain, TO DO 549 | real(r8) :: deltahr_ 550 | logical, save :: first_call = .true. 551 | 552 | SLOPE1 = SLOPE1def 553 | if (first_call) then 554 | sinatanSLOPE1defr = 1.0_r8/(sin(atan(SLOPE1def))) 555 | endif 556 | first_call = .false. 557 | 558 | if(hr_ < TINYVALUE) then 559 | pr_ = 0._r8 560 | else 561 | if(hr_ <= rdepth_ + TINYVALUE) then ! not flooded 562 | pr_ = rwidth_ + 2._r8*hr_ 563 | else 564 | if(hr_ > rdepth_ + ((rwidth0_-rwidth_)/2._r8)*SLOPE1 + TINYVALUE) then 565 | deltahr_ = hr_ - rdepth_ - ((rwidth0_-rwidth_)/2._r8)*SLOPE1 566 | pr_ = rwidth_ + 2._r8*(rdepth_ + ((rwidth0_-rwidth_)/2._r8)*SLOPE1*sinatanSLOPE1defr + deltahr_) 567 | else 568 | pr_ = rwidth_ + 2._r8*(rdepth_ + (hr_ - rdepth_)*sinatanSLOPE1defr) 569 | end if 570 | end if 571 | end if 572 | end function GRPR 573 | 574 | end module mosart_physics 575 | -------------------------------------------------------------------------------- /src/riverroute/mosart_tspatialunit_type.F90: -------------------------------------------------------------------------------- 1 | module mosart_tspatialunit_type 2 | 3 | ! Topographic and geometric properties, applicable for both grid- and subbasin-based representations 4 | 5 | use shr_kind_mod, only : r8=>shr_kind_r8, CL=>SHR_KIND_CL, CS=>SHR_KIND_CS 6 | use shr_sys_mod, only : shr_sys_abort 7 | use shr_mpi_mod, only : shr_mpi_sum, shr_mpi_max 8 | use shr_string_mod, only : shr_string_listGetName 9 | use mosart_io, only : ncd_pio_openfile, compDOF 10 | use mosart_vars, only : mainproc, mpicom_rof, iulog 11 | use nuopc_shr_methods, only : chkerr 12 | use ESMF, only : ESMF_Field, ESMF_RouteHandle, ESMF_Mesh, ESMF_FieldCreate, & 13 | ESMF_FieldSMMStore, ESMF_FieldGet, ESMF_FieldSMM, & 14 | ESMF_SUCCESS, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT, ESMF_TERMORDER_SRCSEQ 15 | use pio, only : iosystem_desc_t, var_desc_t, io_desc_t, file_desc_t, pio_seterrorhandling, & 16 | pio_inq_varid, pio_inq_vardimid, pio_inq_dimlen, pio_initdecomp, pio_closefile, & 17 | pio_int, pio_double, PIO_INTERNAL_ERROR, pio_read_darray, pio_freedecomp 18 | 19 | implicit none 20 | private 21 | 22 | type Tspatialunit_type 23 | 24 | ! grid properties 25 | integer , pointer :: mask(:) ! mosart mask of mosart cell, 0=null, 1=land with dnID, 2=outlet 26 | integer , pointer :: ID0(:) 27 | real(r8), pointer :: lat(:) ! latitude of the centroid of the cell 28 | real(r8), pointer :: lon(:) ! longitude of the centroid of the cell 29 | real(r8), pointer :: area(:) ! area of local cell, [m2] 30 | real(r8), pointer :: areaTotal(:) ! total upstream drainage area, [m2] 31 | real(r8), pointer :: areaTotal2(:)! computed total upstream drainage area, [m2] 32 | real(r8), pointer :: rlenTotal(:) ! length of all reaches, [m] 33 | real(r8), pointer :: Gxr(:) ! drainage density within the cell, [1/m] 34 | real(r8), pointer :: frac(:) ! fraction of cell included in the study area, [-] 35 | logical , pointer :: euler_calc(:) ! flag for calculating tracers in euler 36 | 37 | ! hillslope properties 38 | real(r8), pointer :: nh(:) ! manning's roughness of the hillslope (channel network excluded) 39 | real(r8), pointer :: hslp(:) ! slope of hillslope, [-] 40 | real(r8), pointer :: hslpsqrt(:) ! sqrt of slope of hillslope, [-] 41 | real(r8), pointer :: hlen(:) ! length of hillslope within the cell, [m] 42 | 43 | ! subnetwork channel properties 44 | real(r8), pointer :: nt(:) ! manning's roughness of the subnetwork at hillslope 45 | real(r8), pointer :: tslp(:) ! average slope of tributaries, [-] 46 | real(r8), pointer :: tslpsqrt(:) ! sqrt of average slope of tributaries, [-] 47 | real(r8), pointer :: tlen(:) ! length of all sub-network reach within the cell, [m] 48 | real(r8), pointer :: twidth(:) ! bankfull width of the sub-reach, [m] 49 | real(r8), pointer :: twidth0(:) ! unadjusted twidth 50 | 51 | ! main channel properties 52 | real(r8), pointer :: nr(:) ! manning's roughness of the main reach 53 | real(r8), pointer :: rlen(:) ! length of main river reach, [m] 54 | real(r8), pointer :: rslp(:) ! slope of main river reach, [-] 55 | real(r8), pointer :: rslpsqrt(:) ! sqrt of slope of main river reach, [-] 56 | real(r8), pointer :: rwidth(:) ! bankfull width of main reach, [m] 57 | real(r8), pointer :: rwidth0(:) ! total width of the flood plain, [m] 58 | real(r8), pointer :: rdepth(:) ! bankfull depth of river cross section, [m] 59 | ! 60 | integer , pointer :: dnID(:) ! IDs of the downstream units, corresponding to the subbasin ID in the input table 61 | integer , pointer :: iUp(:,:) ! IDs of upstream units, corresponding to the subbasin ID in the input table 62 | integer , pointer :: nUp(:) ! number of upstream units, maximum 8 63 | integer , pointer :: indexDown(:) ! indices of the downstream units in the ID array. sometimes subbasins IDs may not be continuous 64 | integer , pointer :: numDT_r(:) ! for a main reach, the number of sub-time-steps needed for numerical stability 65 | integer , pointer :: numDT_t(:) ! for a subnetwork reach, the number of sub-time-steps needed for numerical stability 66 | real(r8), pointer :: phi_r(:) ! the indicator used to define numDT_r 67 | real(r8), pointer :: phi_t(:) ! the indicator used to define numDT_t 68 | 69 | ! mapping 70 | type(ESMF_Field) :: srcField 71 | type(ESMF_Field) :: dstField 72 | type(ESMF_RouteHandle) :: rh_direct 73 | type(ESMF_RouteHandle) :: rh_eroutUp 74 | 75 | contains 76 | 77 | procedure, public :: Init 78 | procedure, private :: set_routehandles 79 | procedure, private :: set_subtimesteps 80 | procedure, private :: set_areatotal2 81 | 82 | end type Tspatialunit_type 83 | public :: Tspatialunit_type 84 | 85 | character(*), parameter :: u_FILE_u = & 86 | __FILE__ 87 | !----------------------------------------------------------------------- 88 | 89 | contains 90 | 91 | !----------------------------------------------------------------------- 92 | subroutine Init(this, begr, endr, ntracers, mosart_euler_calc, nlon, nlat, EMesh, & 93 | frivinp, IDkey, c_twid, DLevelR, area, gindex, outletg, pio_subsystem, rc) 94 | 95 | ! Arguments 96 | class(Tspatialunit_type) :: this 97 | integer , intent(in) :: begr, endr 98 | integer , intent(in) :: ntracers 99 | character(len=*) , intent(in) :: mosart_euler_calc 100 | real(r8) , intent(in) :: area(begr:endr) 101 | integer , intent(in) :: nlon, nlat 102 | character(len=*) , intent(in) :: frivinp 103 | integer , intent(in) :: IDkey(:) 104 | real(r8) , intent(in) :: c_twid(begr:endr) 105 | integer , intent(in) :: DLevelR 106 | type(iosystem_desc_t) , pointer :: pio_subsystem 107 | type(ESMF_Mesh) , intent(in) :: Emesh 108 | integer , intent(in) :: gindex(begr:endr) 109 | integer , intent(in) :: outletg(begr:endr) 110 | integer , intent(out) :: rc 111 | 112 | ! Local variables 113 | integer :: n 114 | integer :: ier 115 | type(file_desc_t) :: ncid ! pio file desc 116 | type(var_desc_t) :: vardesc ! pio variable desc 117 | type(io_desc_t) :: iodesc_dbl ! pio io desc 118 | type(io_desc_t) :: iodesc_int ! pio io desc 119 | integer :: dids(2) ! variable dimension ids 120 | integer :: dsizes(2) ! variable dimension lengths 121 | real(r8) :: hlen_max, rlen_min 122 | character(len=CS) :: ctemp 123 | character(len=*),parameter :: FORMI = '(2A,2i10)' 124 | character(len=*),parameter :: FORMR = '(2A,2g15.7)' 125 | character(len=*),parameter :: subname = '(mosart_tspatialunit_type_init) ' 126 | !-------------------------------------------------------------------------- 127 | 128 | rc = ESMF_SUCCESS 129 | 130 | ! Read in routing parameters 131 | call ncd_pio_openfile (ncid, trim(frivinp), 0) 132 | call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) 133 | 134 | ! Setup iodesc based on frac dids 135 | ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) 136 | ier = pio_inq_vardimid(ncid, vardesc, dids) 137 | ier = pio_inq_dimlen(ncid, dids(1),dsizes(1)) 138 | ier = pio_inq_dimlen(ncid, dids(2),dsizes(2)) 139 | call pio_initdecomp(pio_subsystem, pio_double, dsizes, compDOF, iodesc_dbl) 140 | call pio_initdecomp(pio_subsystem, pio_int , dsizes, compDOF, iodesc_int) 141 | 142 | allocate(this%euler_calc(ntracers)) 143 | do n = 1,ntracers 144 | call shr_string_listGetName(mosart_euler_calc, n, ctemp) 145 | if (trim(ctemp) == 'T') then 146 | this%euler_calc = .true. 147 | else if (trim(ctemp) == 'F') then 148 | this%euler_calc = .false. 149 | else 150 | call shr_sys_abort(trim(subname)//' mosart_euler_calc can only be T or F') 151 | end if 152 | end do 153 | 154 | ! TODO: Will be reworked after addition of extra tracers 155 | this%euler_calc = .true. 156 | 157 | allocate(this%frac(begr:endr)) 158 | ier = pio_inq_varid(ncid, name='frac', vardesc=vardesc) 159 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%frac, ier) 160 | if (mainproc) then 161 | write(iulog,FORMR) trim(subname),' read frac ',minval(this%frac),maxval(this%frac) 162 | end if 163 | 164 | ! read fdir, convert to mask 165 | ! fdir <0 ocean, 0=outlet, >0 land 166 | ! tunit mask is 0=ocean, 1=land, 2=outlet for mosart calcs 167 | 168 | allocate(this%mask(begr:endr)) 169 | ier = pio_inq_varid(ncid, name='fdir', vardesc=vardesc) 170 | call pio_read_darray(ncid, vardesc, iodesc_int, this%mask, ier) 171 | if (mainproc) then 172 | write(iulog,'(2A,2i10)') trim(subname),' read fdir mask ',minval(this%mask),maxval(this%mask) 173 | end if 174 | 175 | do n = begr, endr 176 | if (this%mask(n) < 0) then 177 | this%mask(n) = 0 178 | elseif (this%mask(n) == 0) then 179 | this%mask(n) = 2 180 | if (abs(this%frac(n)-1.0_r8)>1.0e-9) then 181 | write(iulog,*) subname,' ERROR frac ne 1.0',n,this%frac(n) 182 | call shr_sys_abort(subname//' ERROR frac ne 1.0') 183 | endif 184 | elseif (this%mask(n) > 0) then 185 | this%mask(n) = 1 186 | if (abs(this%frac(n)-1.0_r8)>1.0e-9) then 187 | write(iulog,*) subname,' ERROR frac ne 1.0',n,this%frac(n) 188 | call shr_sys_abort(subname//' ERROR frac ne 1.0') 189 | endif 190 | else 191 | call shr_sys_abort(subname//' this mask error') 192 | endif 193 | enddo 194 | 195 | allocate(this%ID0(begr:endr)) 196 | ier = pio_inq_varid(ncid, name='ID', vardesc=vardesc) 197 | call pio_read_darray(ncid, vardesc, iodesc_int, this%ID0, ier) 198 | if (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read ID0 ',minval(this%ID0),maxval(this%ID0) 199 | 200 | allocate(this%dnID(begr:endr)) 201 | ier = pio_inq_varid(ncid, name='dnID', vardesc=vardesc) 202 | call pio_read_darray(ncid, vardesc, iodesc_int, this%dnID, ier) 203 | if (mainproc) write(iulog,'(2A,2i10)') trim(subname),' read dnID ',minval(this%dnID),maxval(this%dnID) 204 | 205 | ! RESET ID0 and dnID indices using the IDkey to be consistent with standard gindex order 206 | do n=begr, endr 207 | this%ID0(n) = IDkey(this%ID0(n)) 208 | if (this%dnID(n) > 0 .and. this%dnID(n) <= nlon*nlat) then 209 | if (IDkey(this%dnID(n)) > 0 .and. IDkey(this%dnID(n)) <= nlon*nlat) then 210 | this%dnID(n) = IDkey(this%dnID(n)) 211 | else 212 | write(iulog,*) subname,' ERROR bad IDkey for this%dnID',n,this%dnID(n),IDkey(this%dnID(n)) 213 | call shr_sys_abort(subname//' ERROR bad IDkey for this%dnID') 214 | endif 215 | endif 216 | enddo 217 | 218 | allocate(this%area(begr:endr)) 219 | ier = pio_inq_varid(ncid, name='area', vardesc=vardesc) 220 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%area, ier) 221 | if (mainproc) write(iulog,FORMR) trim(subname),' read area ',minval(this%area),maxval(this%area) 222 | 223 | do n=begr, endr 224 | if (this%area(n) < 0._r8) this%area(n) = area(n) 225 | if (this%area(n) /= area(n)) then 226 | write(iulog,*) subname,' ERROR area mismatch',this%area(n),area(n) 227 | call shr_sys_abort(subname//' ERROR area mismatch') 228 | endif 229 | enddo 230 | 231 | allocate(this%areaTotal(begr:endr)) 232 | ier = pio_inq_varid(ncid, name='areaTotal', vardesc=vardesc) 233 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%areaTotal, ier) 234 | if (mainproc) write(iulog,FORMR) trim(subname),' read areaTotal ',minval(this%areaTotal),maxval(this%areaTotal) 235 | 236 | allocate(this%rlenTotal(begr:endr)) 237 | this%rlenTotal = 0._r8 238 | 239 | allocate(this%nh(begr:endr)) 240 | ier = pio_inq_varid(ncid, name='nh', vardesc=vardesc) 241 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nh, ier) 242 | if (mainproc) write(iulog,FORMR) trim(subname),' read nh ',minval(this%nh),maxval(this%nh) 243 | 244 | allocate(this%hslp(begr:endr)) 245 | ier = pio_inq_varid(ncid, name='hslp', vardesc=vardesc) 246 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%hslp, ier) 247 | if (mainproc) write(iulog,FORMR) trim(subname),' read hslp ',minval(this%hslp),maxval(this%hslp) 248 | 249 | allocate(this%hslpsqrt(begr:endr)) 250 | this%hslpsqrt = 0._r8 251 | 252 | allocate(this%gxr(begr:endr)) 253 | ier = pio_inq_varid(ncid, name='gxr', vardesc=vardesc) 254 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%gxr, ier) 255 | if (mainproc) write(iulog,FORMR) trim(subname),' read gxr ',minval(this%gxr),maxval(this%gxr) 256 | 257 | allocate(this%hlen(begr:endr)) 258 | this%hlen = 0._r8 259 | 260 | allocate(this%tslp(begr:endr)) 261 | ier = pio_inq_varid(ncid, name='tslp', vardesc=vardesc) 262 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%tslp, ier) 263 | if (mainproc) write(iulog,FORMR) trim(subname),' read tslp ',minval(this%tslp),maxval(this%tslp) 264 | 265 | allocate(this%tslpsqrt(begr:endr)) 266 | this%tslpsqrt = 0._r8 267 | 268 | allocate(this%tlen(begr:endr)) 269 | this%tlen = 0._r8 270 | 271 | allocate(this%twidth(begr:endr)) 272 | ier = pio_inq_varid(ncid, name='twid', vardesc=vardesc) 273 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%twidth, ier) 274 | if (mainproc) write(iulog,FORMR) trim(subname),' read twidth ',minval(this%twidth),maxval(this%twidth) 275 | 276 | ! save twidth before adjusted below 277 | allocate(this%twidth0(begr:endr)) 278 | this%twidth0(begr:endr)=this%twidth(begr:endr) 279 | 280 | allocate(this%nt(begr:endr)) 281 | ier = pio_inq_varid(ncid, name='nt', vardesc=vardesc) 282 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nt, ier) 283 | if (mainproc) write(iulog,FORMR) trim(subname),' read nt ',minval(this%nt),maxval(this%nt) 284 | 285 | allocate(this%rlen(begr:endr)) 286 | ier = pio_inq_varid(ncid, name='rlen', vardesc=vardesc) 287 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rlen, ier) 288 | if (mainproc) write(iulog,FORMR) trim(subname),' read rlen ',minval(this%rlen),maxval(this%rlen) 289 | 290 | allocate(this%rslp(begr:endr)) 291 | ier = pio_inq_varid(ncid, name='rslp', vardesc=vardesc) 292 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rslp, ier) 293 | if (mainproc) write(iulog,FORMR) trim(subname),' read rslp ',minval(this%rslp),maxval(this%rslp) 294 | 295 | allocate(this%rslpsqrt(begr:endr)) 296 | this%rslpsqrt = 0._r8 297 | 298 | allocate(this%rwidth(begr:endr)) 299 | ier = pio_inq_varid(ncid, name='rwid', vardesc=vardesc) 300 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rwidth, ier) 301 | if (mainproc) write(iulog,FORMR) trim(subname),' read rwidth ',minval(this%rwidth),maxval(this%rwidth) 302 | 303 | allocate(this%rwidth0(begr:endr)) 304 | ier = pio_inq_varid(ncid, name='rwid0', vardesc=vardesc) 305 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rwidth0, ier) 306 | if (mainproc) write(iulog,FORMR) trim(subname),' read rwidth0 ',minval(this%rwidth0),maxval(this%rwidth0) 307 | 308 | allocate(this%rdepth(begr:endr)) 309 | ier = pio_inq_varid(ncid, name='rdep', vardesc=vardesc) 310 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%rdepth, ier) 311 | if (mainproc) write(iulog,FORMR) trim(subname),' read rdepth ',minval(this%rdepth),maxval(this%rdepth) 312 | 313 | allocate(this%nr(begr:endr)) 314 | ier = pio_inq_varid(ncid, name='nr', vardesc=vardesc) 315 | call pio_read_darray(ncid, vardesc, iodesc_dbl, this%nr, ier) 316 | if (mainproc) write(iulog,FORMR) trim(subname),' read nr ',minval(this%nr),maxval(this%nr) 317 | 318 | allocate(this%nUp(begr:endr)) 319 | this%nUp = 0 320 | allocate(this%iUp(begr:endr,8)) 321 | this%iUp = 0 322 | allocate(this%indexDown(begr:endr)) 323 | this%indexDown = 0 324 | 325 | ! control parameters and some other derived parameters 326 | ! estimate derived input variables 327 | 328 | ! add minimum value to rlen (length of main channel); rlen values can 329 | ! be too small, leading to tlen values that are too large 330 | 331 | do n=begr,endr 332 | rlen_min = sqrt(this%area(n)) 333 | if(this%rlen(n) < rlen_min) then 334 | this%rlen(n) = rlen_min 335 | end if 336 | end do 337 | 338 | do n=begr,endr 339 | if(this%Gxr(n) > 0._r8) then 340 | this%rlenTotal(n) = this%area(n)*this%Gxr(n) 341 | end if 342 | end do 343 | 344 | do n=begr,endr 345 | if(this%rlen(n) > this%rlenTotal(n)) then 346 | this%rlenTotal(n) = this%rlen(n) 347 | end if 348 | end do 349 | 350 | do n=begr,endr 351 | 352 | if(this%rlen(n) > 0._r8) then 353 | this%hlen(n) = this%area(n) / this%rlenTotal(n) / 2._r8 354 | 355 | ! constrain hlen (hillslope length) values based on cell area 356 | hlen_max = max(1000.0_r8, sqrt(this%area(n))) 357 | if(this%hlen(n) > hlen_max) then 358 | this%hlen(n) = hlen_max ! allievate the outlier in drainag\e density estimation. TO DO 359 | end if 360 | 361 | this%tlen(n) = this%area(n) / this%rlen(n) / 2._r8 - this%hlen(n) 362 | 363 | if (this%twidth(n) < 0._r8) then 364 | this%twidth(n) = 0._r8 365 | end if 366 | if ( this%tlen(n) > 0._r8 .and. & 367 | (this%rlenTotal(n)-this%rlen(n))/this%tlen(n) > 1._r8 ) then 368 | this%twidth(n) = c_twid(n)*this%twidth(n) * & 369 | ((this%rlenTotal(n)-this%rlen(n))/this%tlen(n)) 370 | end if 371 | if (this%tlen(n) > 0._r8 .and. this%twidth(n) <= 0._r8) then 372 | this%twidth(n) = 0._r8 373 | end if 374 | else 375 | this%hlen(n) = 0._r8 376 | this%tlen(n) = 0._r8 377 | this%twidth(n) = 0._r8 378 | end if 379 | if(this%rslp(n) <= 0._r8) then 380 | this%rslp(n) = 0.0001_r8 381 | end if 382 | if(this%tslp(n) <= 0._r8) then 383 | this%tslp(n) = 0.0001_r8 384 | end if 385 | if(this%hslp(n) <= 0._r8) then 386 | this%hslp(n) = 0.005_r8 387 | end if 388 | 389 | this%rslpsqrt(n) = sqrt(this%rslp(n)) 390 | this%tslpsqrt(n) = sqrt(this%tslp(n)) 391 | this%hslpsqrt(n) = sqrt(this%hslp(n)) 392 | end do 393 | 394 | call pio_freedecomp(ncid, iodesc_dbl) 395 | call pio_freedecomp(ncid, iodesc_int) 396 | call pio_closefile(ncid) 397 | 398 | ! Create srcfield and dstfield - needed for mapping 399 | this%srcfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & 400 | ungriddedLBound=(/1/), ungriddedUBound=(/ntracers/), gridToFieldMap=(/2/), rc=rc) 401 | if (chkerr(rc,__LINE__,u_FILE_u)) return 402 | 403 | this%dstfield = ESMF_FieldCreate(EMesh, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & 404 | ungriddedLBound=(/1/), ungriddedUBound=(/ntracers/), gridToFieldMap=(/2/), rc=rc) 405 | if (chkerr(rc,__LINE__,u_FILE_u)) return 406 | 407 | ! Create route handles 408 | call this%set_routehandles(begr, endr, gindex, outletg, rc) 409 | if (chkerr(rc,__LINE__,u_FILE_u)) return 410 | 411 | ! Compute areatotal2 412 | ! this basically advects upstream areas downstream and 413 | ! adds them up as it goes until all upstream areas are accounted for 414 | allocate(this%areatotal2(begr:endr)) 415 | call this%set_areatotal2(begr, endr, nlon, nlat, area, rc) 416 | if (chkerr(rc,__LINE__,u_FILE_u)) return 417 | 418 | ! Determine subcycling time steps 419 | allocate(this%numDT_r(begr:endr)) 420 | allocate(this%numDT_t(begr:endr)) 421 | allocate(this%phi_r(begr:endr)) 422 | allocate(this%phi_t(begr:endr)) 423 | call this%set_subtimesteps(begr, endr, DLevelR) 424 | 425 | end subroutine Init 426 | 427 | !----------------------------------------------------------------------- 428 | 429 | subroutine set_routehandles(this, begr, endr, gindex, outletg, rc) 430 | 431 | ! Arguments 432 | class(Tspatialunit_type) :: this 433 | integer , intent(in) :: begr, endr 434 | integer , intent(in) :: gindex(begr:endr) 435 | integer , intent(in) :: outletg(begr:endr) 436 | integer , intent(out) :: rc 437 | 438 | ! Local variables 439 | integer :: nn, n, cnt, nr, nt 440 | real(r8), pointer :: src_direct(:,:) 441 | real(r8), pointer :: dst_direct(:,:) 442 | real(r8), pointer :: src_eroutUp(:,:) 443 | real(r8), pointer :: dst_eroutUp(:,:) 444 | real(r8), allocatable :: factorList(:) 445 | integer , allocatable :: factorIndexList(:,:) 446 | integer :: srcTermProcessing_Value = 0 447 | !-------------------------------------------------------------------------- 448 | 449 | rc = ESMF_SUCCESS 450 | 451 | ! --------------------------------------- 452 | ! Calculate map for direct to outlet mapping 453 | ! --------------------------------------- 454 | 455 | ! Set up pointer arrays into srcfield and dstfield 456 | call ESMF_FieldGet(this%srcfield, farrayPtr=src_direct, rc=rc) 457 | if (chkerr(rc,__LINE__,u_FILE_u)) return 458 | call ESMF_FieldGet(this%dstfield, farrayPtr=dst_direct, rc=rc) 459 | if (chkerr(rc,__LINE__,u_FILE_u)) return 460 | src_direct(:,:) = 0._r8 461 | dst_direct(:,:) = 0._r8 462 | 463 | ! The route handle rh_direct will then be used in mosart_run 464 | cnt = endr - begr + 1 465 | allocate(factorList(cnt)) 466 | allocate(factorIndexList(2,cnt)) 467 | cnt = 0 468 | do nr = begr,endr 469 | cnt = cnt + 1 470 | if (outletg(nr) > 0) then 471 | factorList(cnt) = 1.0_r8 472 | factorIndexList(1,cnt) = gindex(nr) 473 | factorIndexList(2,cnt) = outletg(nr) 474 | else 475 | factorList(cnt) = 1.0_r8 476 | factorIndexList(1,cnt) = gindex(nr) 477 | factorIndexList(2,cnt) = gindex(nr) 478 | endif 479 | enddo 480 | 481 | call ESMF_FieldSMMStore(this%srcField, this%dstField, this%rh_direct, factorList, factorIndexList, & 482 | ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) 483 | if (chkerr(rc,__LINE__,u_FILE_u)) return 484 | 485 | deallocate(factorList) 486 | deallocate(factorIndexList) 487 | 488 | if (mainproc) write(iulog,*) " Done initializing rh_direct " 489 | 490 | ! --------------------------------------- 491 | ! Compute map rh_eroutUp 492 | ! --------------------------------------- 493 | 494 | ! Set up pointer arrays into srcfield and dstfield 495 | call ESMF_FieldGet(this%srcfield, farrayPtr=src_eroutUp, rc=rc) 496 | if (chkerr(rc,__LINE__,u_FILE_u)) return 497 | call ESMF_FieldGet(this%dstfield, farrayPtr=dst_eroutUp, rc=rc) 498 | if (chkerr(rc,__LINE__,u_FILE_u)) return 499 | src_eroutUp(:,:) = 0._r8 500 | dst_eroutUp(:,:) = 0._r8 501 | 502 | cnt = 0 503 | do nr = begr,endr 504 | if (this%dnID(nr) > 0) then 505 | cnt = cnt + 1 506 | end if 507 | end do 508 | allocate(factorList(cnt)) 509 | allocate(factorIndexList(2,cnt)) 510 | cnt = 0 511 | do nr = begr,endr 512 | if (this%dnID(nr) > 0) then 513 | cnt = cnt + 1 514 | factorList(cnt) = 1.0_r8 515 | factorIndexList(1,cnt) = this%ID0(nr) 516 | factorIndexList(2,cnt) = this%dnID(nr) 517 | endif 518 | enddo 519 | if (mainproc) write(iulog,*) " Done initializing rh_eroutUp" 520 | 521 | call ESMF_FieldSMMStore(this%srcfield, this%dstfield, this%rh_eroutUp, factorList, factorIndexList, & 522 | ignoreUnmatchedIndices=.true., srcTermProcessing=srcTermProcessing_Value, rc=rc) 523 | if (chkerr(rc,__LINE__,u_FILE_u)) return 524 | 525 | deallocate(factorList) 526 | deallocate(factorIndexList) 527 | 528 | end subroutine set_routehandles 529 | 530 | !----------------------------------------------------------------------- 531 | 532 | subroutine set_areatotal2(this, begr, endr, nlon, nlat, area, rc) 533 | 534 | ! Arguments 535 | class(Tspatialunit_type) :: this 536 | integer , intent(in) :: begr, endr 537 | integer , intent(in) :: nlon,nlat 538 | real(r8) , intent(in) :: area(begr:endr) 539 | integer , intent(out) :: rc 540 | 541 | ! Local variables 542 | integer :: nr, cnt, tcnt ! indices 543 | real(r8) :: areatot_prev, areatot_tmp, areatot_new 544 | real(r8), pointer :: src_direct(:,:) 545 | real(r8), pointer :: dst_direct(:,:) 546 | real(r8), pointer :: src_eroutUp(:,:) 547 | real(r8), pointer :: dst_eroutUp(:,:) 548 | character(len=*),parameter :: subname = '(mosart_tspatialunit_type_set_areatotal2) ' 549 | ! -------------------------------------------------------------- 550 | 551 | rc = ESMF_SUCCESS 552 | 553 | ! --------------------------------------- 554 | ! compute areatot from area using dnID 555 | ! --------------------------------------- 556 | 557 | ! Set up pointer arrays into srcfield and dstfield 558 | call ESMF_FieldGet(this%srcfield, farrayPtr=src_eroutUp, rc=rc) 559 | if (chkerr(rc,__LINE__,u_FILE_u)) return 560 | call ESMF_FieldGet(this%dstfield, farrayPtr=dst_eroutUp, rc=rc) 561 | if (chkerr(rc,__LINE__,u_FILE_u)) return 562 | src_eroutUp(:,:) = 0._r8 563 | dst_eroutUp(:,:) = 0._r8 564 | 565 | ! this basically advects upstream areas downstream and 566 | ! adds them up as it goes until all upstream areas are accounted for 567 | 568 | this%areatotal2(:) = 0._r8 569 | 570 | ! initialize dst_eroutUp to local area and add that to areatotal2 571 | cnt = 0 572 | dst_eroutUp(:,:) = 0._r8 573 | do nr = begr,endr 574 | cnt = cnt + 1 575 | dst_eroutUp(1,cnt) = area(nr) 576 | this%areatotal2(nr) = area(nr) 577 | enddo 578 | 579 | tcnt = 0 580 | areatot_prev = -99._r8 581 | areatot_new = -50._r8 582 | do while (areatot_new /= areatot_prev .and. tcnt < nlon*nlat) 583 | 584 | tcnt = tcnt + 1 585 | 586 | ! copy dst_eroutUp to src_eroutUp for next downstream step 587 | src_eroutUp(:,:) = 0._r8 588 | cnt = 0 589 | do nr = begr,endr 590 | cnt = cnt + 1 591 | src_eroutUp(1,cnt) = dst_eroutUp(1,cnt) 592 | enddo 593 | 594 | dst_eroutUp(:,:) = 0._r8 595 | call ESMF_FieldSMM(this%srcfield, this%dstField, this%rh_eroutUp, termorderflag=ESMF_TERMORDER_SRCSEQ, rc=rc) 596 | if (chkerr(rc,__LINE__,u_FILE_u)) return 597 | 598 | ! add dst_eroutUp to areatot and compute new global sum 599 | cnt = 0 600 | areatot_prev = areatot_new 601 | areatot_tmp = 0._r8 602 | do nr = begr,endr 603 | cnt = cnt + 1 604 | this%areatotal2(nr) = this%areatotal2(nr) + dst_eroutUp(1,cnt) 605 | areatot_tmp = areatot_tmp + this%areatotal2(nr) 606 | enddo 607 | call shr_mpi_sum(areatot_tmp, areatot_new, mpicom_rof, 'areatot_new', all=.true.) 608 | 609 | if (mainproc) then 610 | write(iulog,*) trim(subname),' areatot calc ',tcnt,areatot_new 611 | endif 612 | enddo 613 | 614 | if (areatot_new /= areatot_prev) then 615 | write(iulog,*) trim(subname),' MOSART ERROR: areatot incorrect ',areatot_new, areatot_prev 616 | call shr_sys_abort(trim(subname)//' MOSART ERROR areatot incorrect') 617 | endif 618 | 619 | end subroutine set_areatotal2 620 | 621 | !----------------------------------------------------------------------- 622 | 623 | subroutine set_subtimesteps(this, begr, endr, DLevelR) 624 | 625 | ! Set the sub-time-steps for channel routing 626 | 627 | ! Arguments 628 | class(Tspatialunit_type) :: this 629 | integer, intent(in) :: begr, endr 630 | integer, intent(in) :: DLevelR 631 | 632 | ! Local variables 633 | integer :: nr !local index 634 | integer :: numDT_r, numDT_t 635 | character(len=*),parameter :: subname = '(mosart_tspatialunit_type_subtimestep) ' 636 | ! -------------------------------------------------------------- 637 | 638 | this%numDT_r(:) = 1 639 | this%numDT_t(:) = 1 640 | this%phi_r(:) = 0._r8 641 | this%phi_t(:) = 0._r8 642 | 643 | do nr = begr,endr 644 | if (this%mask(nr) > 0 .and. this%rlen(nr) > 0._r8) then 645 | this%phi_r(nr) = this%areaTotal2(nr)*sqrt(this%rslp(nr))/(this%rlen(nr)*this%rwidth(nr)) 646 | if (this%phi_r(nr) >= 10._r8) then 647 | this%numDT_r(nr) = (this%numDT_r(nr)*log10(this%phi_r(nr))*DLevelR) + 1 648 | else 649 | this%numDT_r(nr) = this%numDT_r(nr)*1.0_r8*DLevelR + 1 650 | end if 651 | end if 652 | if (this%numDT_r(nr) < 1) this%numDT_r(nr) = 1 653 | 654 | if (this%tlen(nr) > 0._r8) then 655 | this%phi_t(nr) = this%area(nr)*sqrt(this%tslp(nr))/(this%tlen(nr)*this%twidth(nr)) 656 | if (this%phi_t(nr) >= 10._r8) then 657 | this%numDT_t(nr) = (this%numDT_t(nr)*log10(this%phi_t(nr))*DLevelR) + 1 658 | else 659 | this%numDT_t(nr) = (this%numDT_t(nr)*1.0*DLevelR) + 1 660 | end if 661 | end if 662 | if (this%numDT_t(nr) < 1) this%numDT_t(nr) = 1 663 | end do 664 | 665 | call shr_mpi_max(maxval(this%numDT_r),numDT_r,mpicom_rof,'numDT_r',all=.false.) 666 | call shr_mpi_max(maxval(this%numDT_t),numDT_t,mpicom_rof,'numDT_t',all=.false.) 667 | if (mainproc) then 668 | write(iulog,*) subname,' DLevelR = ',DlevelR 669 | write(iulog,*) subname,' numDT_r = ',minval(this%numDT_r),maxval(this%numDT_r) 670 | write(iulog,*) subname,' numDT_r max = ',numDT_r 671 | write(iulog,*) subname,' numDT_t = ',minval(this%numDT_t),maxval(this%numDT_t) 672 | write(iulog,*) subname,' numDT_t max = ',numDT_t 673 | endif 674 | 675 | end subroutine set_subtimesteps 676 | 677 | end module mosart_tspatialunit_type 678 | -------------------------------------------------------------------------------- /src/cpl/nuopc/rof_import_export.F90: -------------------------------------------------------------------------------- 1 | module rof_import_export 2 | 3 | use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Mesh, ESMF_StateGet 4 | use ESMF , only : ESMF_KIND_R8, ESMF_SUCCESS, ESMF_MAXSTR, ESMF_LOGMSG_INFO 5 | use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LogFoundError 6 | use ESMF , only : ESMF_STATEITEM_NOTFOUND, ESMF_StateItem_Flag 7 | use ESMF , only : operator(/=), operator(==) 8 | use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_Advertise, NUOPC_IsConnected 9 | use NUOPC_Model , only : NUOPC_ModelGet 10 | use shr_kind_mod , only : r8 => shr_kind_r8 11 | use shr_sys_mod , only : shr_sys_abort 12 | use mosart_vars , only : iulog, mainproc, mpicom_rof, ice_runoff 13 | use mosart_data , only : ctl, TRunoff, TUnit 14 | use mosart_timemanager , only : get_nstep 15 | use nuopc_shr_methods , only : chkerr 16 | 17 | implicit none 18 | private ! except 19 | 20 | public :: advertise_fields 21 | public :: realize_fields 22 | public :: import_fields 23 | public :: export_fields 24 | 25 | private :: fldlist_add 26 | private :: fldlist_realize 27 | private :: state_getimport 28 | private :: state_setexport 29 | private :: check_for_nans 30 | private :: fldchk 31 | 32 | type fld_list_type 33 | character(len=128) :: stdname 34 | end type fld_list_type 35 | 36 | integer, parameter :: fldsMax = 100 37 | integer :: fldsToRof_num = 0 38 | integer :: fldsFrRof_num = 0 39 | logical :: flds_r2l_stream_channel_depths = .false. ! If should pass the channel depth fields needed for the hillslope model 40 | type (fld_list_type) :: fldsToRof(fldsMax) 41 | type (fld_list_type) :: fldsFrRof(fldsMax) 42 | 43 | ! area correction factors for fluxes send and received from mediator 44 | real(r8), allocatable :: mod2med_areacor(:) 45 | real(r8), allocatable :: med2mod_areacor(:) 46 | 47 | character(*),parameter :: F01 = "('(mosart_import_export) ',a,i5,2x,i8,2x,d21.14)" 48 | character(*),parameter :: u_FILE_u = & 49 | __FILE__ 50 | 51 | !=============================================================================== 52 | contains 53 | !=============================================================================== 54 | 55 | subroutine advertise_fields(gcomp, flds_scalar_name, rc) 56 | 57 | ! input/output variables 58 | type(ESMF_GridComp) :: gcomp 59 | character(len=*) , intent(in) :: flds_scalar_name 60 | integer , intent(out) :: rc 61 | 62 | ! local variables 63 | type(ESMF_State) :: importState 64 | type(ESMF_State) :: exportState 65 | character(ESMF_MAXSTR) :: cvalue ! Character string read from driver attribute 66 | logical :: isPresent ! Atribute is present 67 | logical :: isSet ! Atribute is set 68 | integer :: n, num 69 | character(len=128) :: fldname 70 | character(len=*), parameter :: subname='(rof_import_export:advertise_fields)' 71 | !------------------------------------------------------------------------------- 72 | 73 | rc = ESMF_SUCCESS 74 | 75 | call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) 76 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 77 | 78 | !-------------------------------- 79 | ! Advertise export fields 80 | !-------------------------------- 81 | 82 | call NUOPC_CompAttributeGet(gcomp, name="flds_r2l_stream_channel_depths", value=cvalue, & 83 | isPresent=isPresent, isSet=isSet, rc=rc) 84 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 85 | if (isPresent .and. isSet) read(cvalue,*) flds_r2l_stream_channel_depths 86 | 87 | call fldlist_add(fldsFrRof_num, fldsFrRof, trim(flds_scalar_name)) 88 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl') 89 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi') 90 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofl_glc') 91 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Forr_rofi_glc') 92 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_flood') 93 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volr') 94 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Flrr_volrmch') 95 | if ( flds_r2l_stream_channel_depths )then 96 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Sr_tdepth') 97 | call fldlist_add(fldsFrRof_num, fldsFrRof, 'Sr_tdepth_max') 98 | end if 99 | 100 | do n = 1,fldsFrRof_num 101 | call NUOPC_Advertise(exportState, standardName=fldsFrRof(n)%stdname, & 102 | TransferOfferGeomObject='will provide', rc=rc) 103 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 104 | enddo 105 | 106 | !-------------------------------- 107 | ! Advertise import fields 108 | !-------------------------------- 109 | 110 | call fldlist_add(fldsToRof_num, fldsToRof, trim(flds_scalar_name)) 111 | call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsur') 112 | call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofgwl') 113 | call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofsub') 114 | call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_rofi') 115 | call fldlist_add(fldsToRof_num, fldsToRof, 'Flrl_irrig') 116 | call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofl') ! liq runoff from glc 117 | call fldlist_add(fldsToRof_num, fldsToRof, 'Fgrg_rofi') ! ice runoff from glc 118 | 119 | do n = 1,fldsToRof_num 120 | call NUOPC_Advertise(importState, standardName=fldsToRof(n)%stdname, & 121 | TransferOfferGeomObject='will provide', rc=rc) 122 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 123 | enddo 124 | 125 | end subroutine advertise_fields 126 | 127 | !=============================================================================== 128 | subroutine realize_fields(gcomp, Emesh, flds_scalar_name, flds_scalar_num, rc) 129 | 130 | use ESMF , only : ESMF_GridComp, ESMF_StateGet 131 | use ESMF , only : ESMF_Mesh, ESMF_MeshGet 132 | use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldRegridGetArea 133 | use shr_const_mod , only : shr_const_rearth 134 | use shr_mpi_mod , only : shr_mpi_min, shr_mpi_max 135 | 136 | ! input/output variables 137 | type(ESMF_GridComp) , intent(inout) :: gcomp 138 | type(ESMF_Mesh) , intent(in) :: Emesh 139 | character(len=*) , intent(in) :: flds_scalar_name 140 | integer , intent(in) :: flds_scalar_num 141 | integer , intent(out) :: rc 142 | 143 | ! local variables 144 | type(ESMF_State) :: importState 145 | type(ESMF_State) :: exportState 146 | type(ESMF_Field) :: lfield 147 | integer :: numOwnedElements 148 | integer :: n,g 149 | real(r8), allocatable :: mesh_areas(:) 150 | real(r8), allocatable :: model_areas(:) 151 | real(r8), pointer :: dataptr(:) 152 | real(r8) :: re = shr_const_rearth*0.001_r8 ! radius of earth (km) 153 | real(r8) :: max_mod2med_areacor 154 | real(r8) :: max_med2mod_areacor 155 | real(r8) :: min_mod2med_areacor 156 | real(r8) :: min_med2mod_areacor 157 | real(r8) :: max_mod2med_areacor_glob 158 | real(r8) :: max_med2mod_areacor_glob 159 | real(r8) :: min_mod2med_areacor_glob 160 | real(r8) :: min_med2mod_areacor_glob 161 | character(len=*), parameter :: subname='(rof_import_export:realize_fields)' 162 | !--------------------------------------------------------------------------- 163 | 164 | rc = ESMF_SUCCESS 165 | 166 | call NUOPC_ModelGet(gcomp, importState=importState, exportState=exportState, rc=rc) 167 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 168 | 169 | call fldlist_realize( & 170 | state=ExportState, & 171 | fldList=fldsFrRof, & 172 | numflds=fldsFrRof_num, & 173 | flds_scalar_name=flds_scalar_name, & 174 | flds_scalar_num=flds_scalar_num, & 175 | tag=subname//':MosartExport',& 176 | mesh=Emesh, rc=rc) 177 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 178 | 179 | call fldlist_realize( & 180 | state=importState, & 181 | fldList=fldsToRof, & 182 | numflds=fldsToRof_num, & 183 | flds_scalar_name=flds_scalar_name, & 184 | flds_scalar_num=flds_scalar_num, & 185 | tag=subname//':MosartImport',& 186 | mesh=Emesh, rc=rc) 187 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 188 | 189 | ! Determine areas for regridding 190 | call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, rc=rc) 191 | if (chkerr(rc,__LINE__,u_FILE_u)) return 192 | call ESMF_StateGet(exportState, itemName=trim(fldsFrRof(2)%stdname), field=lfield, rc=rc) 193 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 194 | call ESMF_FieldRegridGetArea(lfield, rc=rc) 195 | if (chkerr(rc,__LINE__,u_FILE_u)) return 196 | call ESMF_FieldGet(lfield, farrayPtr=dataptr, rc=rc) 197 | if (chkerr(rc,__LINE__,u_FILE_u)) return 198 | allocate(mesh_areas(numOwnedElements)) 199 | mesh_areas(:) = dataptr(:) 200 | 201 | ! Determine model areas 202 | allocate(model_areas(numOwnedElements)) 203 | allocate(mod2med_areacor(numOwnedElements)) 204 | allocate(med2mod_areacor(numOwnedElements)) 205 | n = 0 206 | do g = ctl%begr,ctl%endr 207 | n = n + 1 208 | model_areas(n) = ctl%area(g)*1.0e-6_r8/(re*re) 209 | mod2med_areacor(n) = model_areas(n) / mesh_areas(n) 210 | med2mod_areacor(n) = mesh_areas(n) / model_areas(n) 211 | end do 212 | deallocate(model_areas) 213 | deallocate(mesh_areas) 214 | 215 | min_mod2med_areacor = minval(mod2med_areacor) 216 | max_mod2med_areacor = maxval(mod2med_areacor) 217 | min_med2mod_areacor = minval(med2mod_areacor) 218 | max_med2mod_areacor = maxval(med2mod_areacor) 219 | call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom_rof) 220 | call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom_rof) 221 | call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom_rof) 222 | call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom_rof) 223 | 224 | if (mainproc) then 225 | write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& 226 | min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOSART' 227 | write(iulog,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& 228 | min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOSART' 229 | end if 230 | 231 | if (fldchk(importState, 'Fgrg_rofl') .and. fldchk(importState, 'Fgrg_rofl')) then 232 | ctl%rof_from_glc = .true. 233 | else 234 | ctl%rof_from_glc = .false. 235 | end if 236 | if (mainproc) then 237 | write(iulog,'(A,l1)') trim(subname) //' rof from glc is ',ctl%rof_from_glc 238 | end if 239 | 240 | end subroutine realize_fields 241 | 242 | !=============================================================================== 243 | subroutine import_fields( gcomp, begr, endr, rc ) 244 | 245 | !--------------------------------------------------------------------------- 246 | ! Obtain the runoff input from the mediator and convert from kg/m2s to m3/s 247 | !--------------------------------------------------------------------------- 248 | 249 | ! input/output variables 250 | type(ESMF_GridComp) :: gcomp 251 | integer, intent(in) :: begr, endr 252 | integer, intent(out) :: rc 253 | 254 | ! Local variables 255 | type(ESMF_State) :: importState 256 | integer :: n,nt 257 | integer :: nliq, nice 258 | character(len=*), parameter :: subname='(rof_import_export:import_fields)' 259 | !--------------------------------------------------------------------------- 260 | 261 | rc = ESMF_SUCCESS 262 | call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) 263 | 264 | ! Get import state 265 | call NUOPC_ModelGet(gcomp, importState=importState, rc=rc) 266 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 267 | 268 | nliq = ctl%nt_liq 269 | nice = ctl%nt_ice 270 | 271 | ! determine output array and scale by unit convertsion 272 | ! NOTE: the call to state_getimport will convert from input kg/m2s to m3/s 273 | 274 | call state_getimport(importState, 'Flrl_rofsur', begr, endr, ctl%area, output=ctl%qsur(:,nliq), & 275 | do_area_correction=.true., rc=rc) 276 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 277 | 278 | call state_getimport(importState, 'Flrl_rofsub', begr, endr, ctl%area, output=ctl%qsub(:,nliq), & 279 | do_area_correction=.true., rc=rc) 280 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 281 | 282 | call state_getimport(importState, 'Flrl_rofgwl', begr, endr, ctl%area, output=ctl%qgwl(:,nliq), & 283 | do_area_correction=.true., rc=rc) 284 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 285 | 286 | call state_getimport(importState, 'Flrl_rofi', begr, endr, ctl%area, output=ctl%qsur(:,nice), & 287 | do_area_correction=.true., rc=rc) 288 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 289 | 290 | call state_getimport(importState, 'Flrl_irrig', begr, endr, ctl%area, output=ctl%qirrig(:), & 291 | do_area_correction=.true., rc=rc) 292 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 293 | 294 | ctl%qsub(begr:endr, nice) = 0.0_r8 295 | ctl%qgwl(begr:endr, nice) = 0.0_r8 296 | 297 | if (ctl%rof_from_glc) then 298 | call state_getimport(importState, 'Fgrg_rofl', begr, endr, ctl%area, output=ctl%qglc_liq(:), & 299 | do_area_correction=.true., rc=rc) 300 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 301 | call state_getimport(importState, 'Fgrg_rofi', begr, endr, ctl%area, output=ctl%qglc_ice(:), & 302 | do_area_correction=.true., rc=rc) 303 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 304 | else 305 | ctl%qglc_liq(:) = 0._r8 306 | ctl%qglc_ice(:) = 0._r8 307 | end if 308 | 309 | end subroutine import_fields 310 | 311 | !==================================================================================== 312 | subroutine export_fields (gcomp, begr, endr, rc) 313 | 314 | !--------------------------------------------------------------------------- 315 | ! Send the runoff model export state to the mediator and convert from m3/s to kg/m2s 316 | !--------------------------------------------------------------------------- 317 | 318 | ! input/output/variables 319 | type(ESMF_GridComp) :: gcomp 320 | integer, intent(in) :: begr, endr 321 | integer, intent(out) :: rc 322 | 323 | ! Local variables 324 | type(ESMF_State) :: exportState 325 | integer :: n,nt 326 | integer :: nliq, nice 327 | real(r8) :: rofl(begr:endr) 328 | real(r8) :: rofi(begr:endr) 329 | real(r8) :: rofl_glc(begr:endr) 330 | real(r8) :: rofi_glc(begr:endr) 331 | real(r8) :: flood(begr:endr) 332 | real(r8) :: volr(begr:endr) 333 | real(r8) :: volrmch(begr:endr) 334 | real(r8) :: tdepth(begr:endr) 335 | real(r8) :: tdepth_max(begr:endr) 336 | logical, save :: first_time = .true. 337 | character(len=*), parameter :: subname='(rof_import_export:export_fields)' 338 | !--------------------------------------------------------------------------- 339 | 340 | rc = ESMF_SUCCESS 341 | call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) 342 | 343 | ! Get export state 344 | call NUOPC_ModelGet(gcomp, exportState=exportState, rc=rc) 345 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 346 | 347 | ! Set tracers 348 | nliq = ctl%nt_liq 349 | nice = ctl%nt_ice 350 | 351 | if (first_time) then 352 | if (mainproc) then 353 | if ( ice_runoff )then 354 | write(iulog,*)'Snow capping will flow out in frozen river runoff' 355 | else 356 | write(iulog,*)'Snow capping will flow out in liquid river runoff' 357 | endif 358 | endif 359 | first_time = .false. 360 | end if 361 | 362 | if ( ice_runoff )then 363 | ! separate liquid and ice runoff 364 | do n = begr,endr 365 | rofl(n) = ctl%direct(n,nliq) / (ctl%area(n)*0.001_r8) 366 | rofi(n) = ctl%direct(n,nice) / (ctl%area(n)*0.001_r8) 367 | if (ctl%mask(n) >= 2) then 368 | ! liquid and ice runoff are treated separately - this is what goes to the ocean 369 | rofl(n) = rofl(n) + ctl%runoff(n,nliq) / (ctl%area(n)*0.001_r8) 370 | rofi(n) = rofi(n) + ctl%runoff(n,nice) / (ctl%area(n)*0.001_r8) 371 | end if 372 | end do 373 | else 374 | ! liquid and ice runoff added to liquid runoff, ice runoff is zero 375 | do n = begr,endr 376 | rofl(n) = (ctl%direct(n,nice) + ctl%direct(n,nliq)) / (ctl%area(n)*0.001_r8) 377 | if (ctl%mask(n) >= 2) then 378 | rofl(n) = rofl(n) + (ctl%runoff(n,nice) + ctl%runoff(n,nliq)) / (ctl%area(n)*0.001_r8) 379 | endif 380 | rofi(n) = 0._r8 381 | end do 382 | end if 383 | 384 | do n = begr,endr 385 | rofl_glc(n) = ctl%direct_glc(n,nliq) / (ctl%area(n)*0.001_r8) 386 | rofi_glc(n) = ctl%direct_glc(n,nice) / (ctl%area(n)*0.001_r8) 387 | end do 388 | 389 | ! Flooding back to land, sign convention is positive in land->rof direction 390 | ! so if water is sent from rof to land, the flux must be negative. 391 | ! scs: is there a reason for the wr+wt rather than volr (wr+wt+wh)? 392 | ! volr(n) = (Trunoff%wr(n,nliq) + Trunoff%wt(n,nliq)) / ctl%area(n) 393 | 394 | do n = begr, endr 395 | flood(n) = -ctl%flood(n) / (ctl%area(n)*0.001_r8) 396 | volr(n) = ctl%volr(n,nliq)/ ctl%area(n) 397 | volrmch(n) = Trunoff%wr(n,nliq) / ctl%area(n) 398 | if ( flds_r2l_stream_channel_depths )then 399 | tdepth(n) = Trunoff%yt(n,nliq) 400 | ! assume height to width ratio is the same for tributaries and main channel 401 | tdepth_max(n) = max(TUnit%twidth0(n),0._r8)*(TUnit%rdepth(n)/TUnit%rwidth(n)) 402 | end if 403 | end do 404 | 405 | call state_setexport(exportState, 'Forr_rofl', begr, endr, input=rofl, do_area_correction=.true., rc=rc) 406 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 407 | 408 | call state_setexport(exportState, 'Forr_rofi', begr, endr, input=rofi, do_area_correction=.true., rc=rc) 409 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 410 | 411 | call state_setexport(exportState, 'Forr_rofl_glc', begr, endr, input=rofl_glc, do_area_correction=.true., rc=rc) 412 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 413 | 414 | call state_setexport(exportState, 'Forr_rofi_glc', begr, endr, input=rofi_glc, do_area_correction=.true., rc=rc) 415 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 416 | 417 | call state_setexport(exportState, 'Flrr_flood', begr, endr, input=flood, do_area_correction=.true., rc=rc) 418 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 419 | 420 | call state_setexport(exportState, 'Flrr_volr', begr, endr, input=volr, do_area_correction=.true., rc=rc) 421 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 422 | 423 | call state_setexport(exportState, 'Flrr_volrmch', begr, endr, input=volrmch, do_area_correction=.true., rc=rc) 424 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 425 | 426 | if ( flds_r2l_stream_channel_depths ) then 427 | call state_setexport(exportState, 'Sr_tdepth', begr, endr, input=tdepth, do_area_correction=.true., rc=rc) 428 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 429 | 430 | call state_setexport(exportState, 'Sr_tdepth_max', begr, endr, input=tdepth_max, do_area_correction=.true., rc=rc) 431 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 432 | end if 433 | 434 | end subroutine export_fields 435 | 436 | !=============================================================================== 437 | subroutine fldlist_add(num, fldlist, stdname) 438 | integer, intent(inout) :: num 439 | type(fld_list_type), intent(inout) :: fldlist(:) 440 | character(len=*), intent(in) :: stdname 441 | 442 | ! local variables 443 | integer :: rc 444 | character(len=*), parameter :: subname='(rof_import_export:fldlist_add)' 445 | !------------------------------------------------------------------------------- 446 | 447 | ! Set up a list of field information 448 | 449 | num = num + 1 450 | if (num > fldsMax) then 451 | call ESMF_LogWrite(trim(subname)//": ERROR num > fldsMax "//trim(stdname), & 452 | ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__) 453 | return 454 | endif 455 | fldlist(num)%stdname = trim(stdname) 456 | 457 | end subroutine fldlist_add 458 | 459 | !=============================================================================== 460 | subroutine fldlist_realize(state, fldList, numflds, flds_scalar_name, flds_scalar_num, mesh, tag, rc) 461 | 462 | use NUOPC , only : NUOPC_IsConnected, NUOPC_Realize 463 | use ESMF , only : ESMF_MeshLoc_Element, ESMF_FieldCreate, ESMF_TYPEKIND_R8 464 | use ESMF , only : ESMF_MAXSTR, ESMF_Field, ESMF_State, ESMF_Mesh, ESMF_StateRemove 465 | use ESMF , only : ESMF_LogFoundError, ESMF_LOGMSG_INFO, ESMF_SUCCESS 466 | use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_ERROR, ESMF_LOGERR_PASSTHRU 467 | 468 | type(ESMF_State) , intent(inout) :: state 469 | type(fld_list_type) , intent(in) :: fldList(:) 470 | integer , intent(in) :: numflds 471 | character(len=*) , intent(in) :: flds_scalar_name 472 | integer , intent(in) :: flds_scalar_num 473 | character(len=*) , intent(in) :: tag 474 | type(ESMF_Mesh) , intent(in) :: mesh 475 | integer , intent(inout) :: rc 476 | 477 | ! local variables 478 | integer :: dbrc 479 | integer :: n 480 | type(ESMF_Field) :: field 481 | character(len=80) :: stdname 482 | character(len=*),parameter :: subname='(rof_import_export:fldlist_realize)' 483 | ! ---------------------------------------------- 484 | 485 | rc = ESMF_SUCCESS 486 | 487 | do n = 1, numflds 488 | stdname = fldList(n)%stdname 489 | if (NUOPC_IsConnected(state, fieldName=stdname)) then 490 | if (stdname == trim(flds_scalar_name)) then 491 | call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected on root pe", & 492 | ESMF_LOGMSG_INFO, rc=dbrc) 493 | ! Create the scalar field 494 | call SetScalarField(field, flds_scalar_name, flds_scalar_num, rc=rc) 495 | if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return 496 | else 497 | call ESMF_LogWrite(trim(subname)//trim(tag)//" Field = "//trim(stdname)//" is connected using mesh", & 498 | ESMF_LOGMSG_INFO, rc=dbrc) 499 | ! Create the field 500 | field = ESMF_FieldCreate(mesh, ESMF_TYPEKIND_R8, name=stdname, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc) 501 | if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return 502 | endif 503 | 504 | ! NOW call NUOPC_Realize 505 | call NUOPC_Realize(state, field=field, rc=rc) 506 | if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return 507 | else 508 | if (stdname /= trim(flds_scalar_name)) then 509 | call ESMF_LogWrite(subname // trim(tag) // " Field = "// trim(stdname) // " is not connected.", & 510 | ESMF_LOGMSG_INFO, rc=dbrc) 511 | call ESMF_StateRemove(state, (/stdname/), rc=rc) 512 | if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return 513 | end if 514 | end if 515 | end do 516 | 517 | contains !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 518 | 519 | subroutine SetScalarField(field, flds_scalar_name, flds_scalar_num, rc) 520 | ! ---------------------------------------------- 521 | ! create a field with scalar data on the root pe 522 | ! ---------------------------------------------- 523 | use ESMF, only : ESMF_Field, ESMF_DistGrid, ESMF_Grid 524 | use ESMF, only : ESMF_DistGridCreate, ESMF_GridCreate, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU 525 | use ESMF, only : ESMF_FieldCreate, ESMF_GridCreate, ESMF_TYPEKIND_R8 526 | 527 | type(ESMF_Field) , intent(inout) :: field 528 | character(len=*) , intent(in) :: flds_scalar_name 529 | integer , intent(in) :: flds_scalar_num 530 | integer , intent(inout) :: rc 531 | 532 | ! local variables 533 | type(ESMF_Distgrid) :: distgrid 534 | type(ESMF_Grid) :: grid 535 | character(len=*), parameter :: subname='(rof_import_export:SetScalarField)' 536 | ! ---------------------------------------------- 537 | 538 | rc = ESMF_SUCCESS 539 | 540 | ! create a DistGrid with a single index space element, which gets mapped onto DE 0. 541 | distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/1/), rc=rc) 542 | if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return 543 | 544 | grid = ESMF_GridCreate(distgrid, rc=rc) 545 | if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return 546 | 547 | field = ESMF_FieldCreate(name=trim(flds_scalar_name), grid=grid, typekind=ESMF_TYPEKIND_R8, & 548 | ungriddedLBound=(/1/), ungriddedUBound=(/flds_scalar_num/), gridToFieldMap=(/2/), rc=rc) 549 | if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) return 550 | 551 | end subroutine SetScalarField 552 | 553 | end subroutine fldlist_realize 554 | 555 | !=============================================================================== 556 | subroutine state_getimport(state, fldname, begr, endr, area, output, do_area_correction, rc) 557 | 558 | ! ---------------------------------------------- 559 | ! Map import state field to output array 560 | ! ---------------------------------------------- 561 | 562 | use ESMF, only : ESMF_StateGet, ESMF_FieldGet, ESMF_Field 563 | 564 | ! input/output variables 565 | type(ESMF_State) , intent(in) :: state 566 | character(len=*) , intent(in) :: fldname 567 | integer , intent(in) :: begr 568 | integer , intent(in) :: endr 569 | real(r8) , intent(in) :: area(begr:endr) 570 | logical , intent(in) :: do_area_correction 571 | real(r8) , intent(out) :: output(begr:endr) 572 | integer , intent(out) :: rc 573 | 574 | ! local variables 575 | type(ESMF_Field) :: lfield 576 | integer :: g, i 577 | real(R8), pointer :: fldptr(:) 578 | character(len=*), parameter :: subname='(rof_import_export:state_getimport)' 579 | ! ---------------------------------------------- 580 | 581 | rc = ESMF_SUCCESS 582 | 583 | ! get field pointer 584 | call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) 585 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 586 | call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) 587 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 588 | 589 | ! determine output array and scale by unit convertsion 590 | if (do_area_correction) then 591 | fldptr(:) = fldptr(:) * med2mod_areacor(:) 592 | end if 593 | do g = begr,endr 594 | output(g) = fldptr(g-begr+1) * area(g)*0.001_r8 595 | end do 596 | 597 | ! check for nans 598 | call check_for_nans(fldptr, trim(fldname), begr) 599 | 600 | end subroutine state_getimport 601 | 602 | !=============================================================================== 603 | subroutine state_setexport(state, fldname, begr, endr, input, do_area_correction, rc) 604 | 605 | ! ---------------------------------------------- 606 | ! Map input array to export state field 607 | ! ---------------------------------------------- 608 | 609 | use ESMF , only : ESMF_StateGet, ESMF_FieldGet, ESMF_Field 610 | use shr_const_mod, only : fillvalue=>shr_const_spval 611 | 612 | ! input/output variables 613 | type(ESMF_State) , intent(inout) :: state 614 | character(len=*) , intent(in) :: fldname 615 | integer , intent(in) :: begr 616 | integer , intent(in) :: endr 617 | real(r8) , intent(in) :: input(begr:endr) 618 | logical , intent(in) :: do_area_correction 619 | integer , intent(out) :: rc 620 | 621 | ! local variables 622 | type(ESMF_Field) :: lfield 623 | integer :: g, i 624 | real(R8), pointer :: fldptr(:) 625 | character(len=*), parameter :: subname='(rof_import_export:state_setexport)' 626 | ! ---------------------------------------------- 627 | 628 | rc = ESMF_SUCCESS 629 | 630 | ! get field pointer 631 | call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=rc) 632 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 633 | call ESMF_FieldGet(lfield, farrayPtr=fldptr, rc=rc) 634 | if (ChkErr(rc,__LINE__,u_FILE_u)) return 635 | 636 | ! set fldptr values to input array 637 | fldptr(:) = 0._r8 638 | do g = begr,endr 639 | fldptr(g-begr+1) = input(g) 640 | end do 641 | if (do_area_correction) then 642 | fldptr(:) = fldptr(:) * mod2med_areacor(:) 643 | end if 644 | 645 | ! check for nans 646 | call check_for_nans(fldptr, trim(fldname), begr) 647 | 648 | end subroutine state_setexport 649 | 650 | !=============================================================================== 651 | 652 | subroutine check_for_nans(array, fname, begg) 653 | 654 | ! uses 655 | use shr_infnan_mod, only : isnan => shr_infnan_isnan 656 | 657 | ! input/output variables 658 | real(r8) , pointer :: array(:) 659 | character(len=*) , intent(in) :: fname 660 | integer , intent(in) :: begg 661 | 662 | ! local variables 663 | integer :: i 664 | !------------------------------------------------------------------------------- 665 | 666 | ! Check if any input from mediator or output to mediator is NaN 667 | 668 | if (any(isnan(array))) then 669 | write(iulog,*) '# of NaNs = ', count(isnan(array)) 670 | write(iulog,*) 'Which are NaNs = ', isnan(array) 671 | do i = 1, size(array) 672 | if (isnan(array(i))) then 673 | write(iulog,*) "NaN found in field ", trim(fname), ' at gridcell index ',begg+i-1 674 | end if 675 | end do 676 | call shr_sys_abort(' ERROR: One or more of the output from MOSART to the coupler are NaN ' ) 677 | end if 678 | end subroutine check_for_nans 679 | 680 | !=============================================================================== 681 | logical function fldchk(state, fldname) 682 | ! ---------------------------------------------- 683 | ! Determine if field with fldname is in the input state 684 | ! ---------------------------------------------- 685 | 686 | ! input/output variables 687 | type(ESMF_State), intent(in) :: state 688 | character(len=*), intent(in) :: fldname 689 | 690 | ! local variables 691 | type(ESMF_StateItem_Flag) :: itemFlag 692 | ! ---------------------------------------------- 693 | call ESMF_StateGet(state, trim(fldname), itemFlag) 694 | if (itemflag /= ESMF_STATEITEM_NOTFOUND) then 695 | fldchk = .true. 696 | else 697 | fldchk = .false. 698 | endif 699 | end function fldchk 700 | 701 | end module rof_import_export 702 | --------------------------------------------------------------------------------