From 7faae9fb32e244532ef140f6c686c30643df14b1 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Wed, 23 Oct 2024 21:22:05 -0400 Subject: [PATCH 01/27] branch feature/yujinz/Routing_GEOSroute started, offline model was put in GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp --- .../GEOSroute_GridComp/build | 18 + .../GEOSroute_GridComp/interp_M36toPfaf.f90 | 157 + .../GEOSroute_GridComp/lake_mod.f90 | 109 + .../GEOSroute_GridComp/ncdioMod.f90 | 2582 +++++++++++++++++ .../GEOSroute_GridComp/res_mod.f90 | 348 +++ .../GEOSroute_GridComp/river_io_mod.f90 | 319 ++ .../GEOSroute_GridComp/river_routing.f90 | 248 ++ .../GEOSroute_GridComp/rwncMod.f90 | 516 ++++ 8 files changed, 4297 insertions(+) create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/interp_M36toPfaf.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/lake_mod.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/rwncMod.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build new file mode 100755 index 000000000..7145a5e6e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build @@ -0,0 +1,18 @@ +#!/bin/bash + +if [ $# -lt 1 ]; then + echo "no f90 specified" + exit +fi + +string=$1 +array=(${string//./ }) + +FILENAME=${array[0]} + +#NETCDF_PATH=/discover/nobackup/yzeng3/apps/netcdf-4.2.1.1 +NETCDF_PATH=/Users/zsp/apps/netcdf-4.2.1.1 + + + +ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -L/opt/intel/oneapi/compiler/2022.2.1/mac/compiler/lib -lnetcdf -lnetcdff -o ${FILENAME}.out diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/interp_M36toPfaf.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/interp_M36toPfaf.f90 new file mode 100644 index 000000000..c9ea88fcc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/interp_M36toPfaf.f90 @@ -0,0 +1,157 @@ +module interp + +use omp_lib ! Use OpenMP library for parallel processing +use rwncfile ! Use custom module for reading NetCDF files +implicit none + +private +public :: M36_to_cat ! Make the M36_to_cat function public +public :: M09_to_cat ! Make the M09_to_cat function public + +contains + +!------------------------------------------------------------------------------ +! This function maps runoff data from M36 resolution to catchments (cat) +function M36_to_cat(runoff,nlon,nlat,ncat,inputdir) result(Qrunf) + + integer,intent(in) :: nlon,nlat,ncat ! Input: number of longitude, latitude, and catchments + real*8,intent(in) :: runoff(nlon,nlat) ! Input: runoff array of size (nlon, nlat) + character(len=500),intent(in) :: inputdir ! Input: directory path for input files + real*8 :: Qrunf(ncat) ! Output: runoff mapped to catchments + + real*8,parameter :: small=1.D-12 ! Small value to avoid division by zero + + integer,parameter :: nmax=150 ! Maximum number of sub-areas per catchment + integer,parameter :: nc=291284 ! Total number of catchments + + real*8,allocatable,dimension(:,:) :: subarea,frac ! Arrays for sub-area and fractions + integer,allocatable,dimension(:,:) :: subx,suby ! Arrays for x and y coordinates of sub-areas + real*8,allocatable,dimension(:) :: tot,runfC,fracA ! Arrays for total area, calculated runoff, and fraction + integer,allocatable,dimension(:) :: nsub ! Array for number of sub-areas per catchment + + integer :: i,j,sx,sy ! Loop variables and coordinates for sub-areas + + ! Allocate memory for arrays + allocate(nsub(nc),subarea(nmax,nc),subx(nmax,nc),suby(nmax,nc),tot(nc)) + + ! Read sub-area data from text files + open(77,file=trim(inputdir)//"/Pfaf_nsub_M36.txt"); read(77,*)nsub + open(77,file=trim(inputdir)//"/Pfaf_asub_M36.txt"); read(77,*)subarea + open(77,file=trim(inputdir)//"/Pfaf_xsub_M36.txt"); read(77,*)subx + open(77,file=trim(inputdir)//"/Pfaf_ysub_M36.txt"); read(77,*)suby + open(77,file=trim(inputdir)//"/Pfaf_area.txt"); read(77,*)tot + + ! Allocate memory for fraction array + allocate(frac(nmax,nc)) + + ! Compute fraction of each sub-area relative to the total catchment area + do i=1,nc + frac(:,i)=subarea(:,i)/tot(i) + enddo + + ! Allocate memory for runoff and fraction arrays + allocate(runfC(nc),fracA(nc)) + runfC=0.D0 ! Initialize runoff array to zero + fracA=0.D0 ! Initialize fraction array to zero + + !$OMP PARALLEL default(shared) private(i,j,sx,sy) ! Start OpenMP parallel region + !$OMP DO + ! Loop over all catchments and sub-areas + do i=1,nc + if(nsub(i)>=1)then + do j=1,nsub(i) + sy=suby(j,i) ! Get y-coordinate of the sub-area + sx=subx(j,i) ! Get x-coordinate of the sub-area + ! Check for valid fraction and runoff values + if(frac(j,i)>0.D0.and.runoff(sx,sy)<1.D14)then + runfC(i)=runfC(i)+frac(j,i)*runoff(sx,sy) ! Accumulate runoff for the catchment + fracA(i)=fracA(i)+frac(j,i) ! Accumulate fraction + endif + enddo + endif + enddo + !$OMP END DO + !$OMP END PARALLEL ! End OpenMP parallel region + + ! Convert to kg/s by multiplying by area (in m虏) and dividing by time (in seconds) + Qrunf=runfC*(tot*1.D6)/86400.D0 + + ! Deallocate arrays to free memory + deallocate(subarea,subx,suby,tot,frac,& + runfC,fracA,nsub) + +end function M36_to_cat +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! This function maps runoff data from M09 resolution to catchments (cat) +function M09_to_cat(runoff,nlon,nlat,ncat,inputdir) result(Qrunf) + + integer,intent(in) :: nlon,nlat,ncat ! Input: number of longitude, latitude, and catchments + real*8,intent(in) :: runoff(nlon,nlat) ! Input: runoff array of size (nlon, nlat) + character(len=500),intent(in) :: inputdir ! Input: directory path for input files + real*8 :: Qrunf(ncat) ! Output: runoff mapped to catchments + + real*8,parameter :: small=1.D-12 ! Small value to avoid division by zero + + integer,parameter :: nmax=458 ! Maximum number of sub-areas per catchment + integer,parameter :: nc=291284 ! Total number of catchments + + real*8,allocatable,dimension(:,:) :: subarea,frac ! Arrays for sub-area and fractions + integer,allocatable,dimension(:,:) :: subx,suby ! Arrays for x and y coordinates of sub-areas + real*8,allocatable,dimension(:) :: tot,runfC,fracA ! Arrays for total area, calculated runoff, and fraction + integer,allocatable,dimension(:) :: nsub ! Array for number of sub-areas per catchment + + integer :: i,j,sx,sy ! Loop variables and coordinates for sub-areas + + ! Allocate memory for arrays + allocate(nsub(nc),subarea(nmax,nc),subx(nmax,nc),suby(nmax,nc),tot(nc)) + + ! Read sub-area data from text files + open(77,file=trim(inputdir)//"/Pfaf_nsub_M09.txt"); read(77,*)nsub + open(77,file=trim(inputdir)//"/Pfaf_asub_M09.txt"); read(77,*)subarea + open(77,file=trim(inputdir)//"/Pfaf_xsub_M09.txt"); read(77,*)subx + open(77,file=trim(inputdir)//"/Pfaf_ysub_M09.txt"); read(77,*)suby + open(77,file=trim(inputdir)//"/Pfaf_area.txt"); read(77,*)tot + + ! Allocate memory for fraction array + allocate(frac(nmax,nc)) + + ! Compute fraction of each sub-area relative to the total catchment area + do i=1,nc + frac(:,i)=subarea(:,i)/tot(i) + enddo + + ! Allocate memory for runoff and fraction arrays + allocate(runfC(nc),fracA(nc)) + runfC=0.D0 ! Initialize runoff array to zero + fracA=0.D0 ! Initialize fraction array to zero + + !$OMP PARALLEL default(shared) private(i,j,sx,sy) ! Start OpenMP parallel region + !$OMP DO + ! Loop over all catchments and sub-areas + do i=1,nc + do j=1,nmax + sy=suby(j,i) ! Get y-coordinate of the sub-area + sx=subx(j,i) ! Get x-coordinate of the sub-area + ! Check for valid fraction and runoff values + if(frac(j,i)>0.D0.and.runoff(sx,sy)<1.D14.and.runoff(sx,sy)>=0.D0)then + runfC(i)=runfC(i)+frac(j,i)*runoff(sx,sy) ! Accumulate runoff for the catchment + fracA(i)=fracA(i)+frac(j,i) ! Accumulate fraction + endif + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL ! End OpenMP parallel region + + ! Convert to kg/s by multiplying by area (in m虏) and dividing by time (in seconds) + Qrunf=runfC*(tot*1.D6)/86400.D0 + + ! Deallocate arrays to free memory + deallocate(subarea,subx,suby,tot,frac,& + runfC,fracA,nsub) + +end function M09_to_cat +!------------------------------------------------------------------------------ + +end module interp \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/lake_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/lake_mod.f90 new file mode 100644 index 000000000..0aab6d316 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/lake_mod.f90 @@ -0,0 +1,109 @@ +module lake + + +implicit none +private +public :: lake_init, lake_cal + +! Define parameters for small and large lakes +real*8, parameter :: fac_a_slake = 0.003D0 ! Factor for small lakes +real*8, parameter :: fac_b_slake = 0.40D0 ! Exponent for small lakes +real*8, parameter :: fac_a_llake = 0.01D0 ! Factor for large lakes +real*8, parameter :: fac_b_llake = 0.60D0 ! Exponent for large lakes +real*8, parameter :: thr_area_lake = 1D4 ! Threshold lake area (in km^2) + +! Define constants +real*8, parameter :: dt = 86400.D0 ! Time step in seconds (1 day) +real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 + +contains + +!------------------------------ +! Initialization subroutine for lakes +subroutine lake_init(input_dir, use_lake, nc, nlake, nres, active_res, active_lake, area_lake, Wr_lake, Q_lake) + character(len=500),intent(in) :: input_dir + logical, intent(in) :: use_lake ! Flag to use lake module + integer, intent(in) :: nc, nlake, nres ! Number of catchments, lakes, reservoirs + integer, intent(in) :: active_res(nres) ! Active reservoirs + integer, allocatable, intent(inout) :: active_lake(:) ! Active lakes (output) + real*8, allocatable, intent(inout) :: area_lake(:), Wr_lake(:), Q_lake(:) ! Lake areas, water storage, outflow + + integer, allocatable :: flag_valid_laked(:), catid_laked(:) + real*8, allocatable :: area_laked(:) + + integer :: i, cid + + ! Allocate arrays for lake attributes + allocate(flag_valid_laked(nlake), catid_laked(nlake), area_laked(nlake)) + allocate(active_lake(nc), area_lake(nc)) + allocate(Wr_lake(nc), Q_lake(nc)) + + ! Read lake outlet and area data from external files + open(77, file = trim(input_dir)//"/lake_outlet_flag_valid_2097.txt") + read(77, *) flag_valid_laked + open(77, file = trim(input_dir)//"/lake_outlet_catid.txt") + read(77, *) catid_laked + open(77, file = trim(input_dir)//"/lake_outlet_lakearea.txt") + read(77, *) area_laked ! km^2 + + ! Initialize lake attributes to zero + area_lake = 0.D0 + active_lake = 0 + + ! Assign active lakes and their areas based on data + do i = 1, nlake + if (flag_valid_laked(i) == 1) then + cid = catid_laked(i) + active_lake(cid) = 1 + area_lake(cid) = area_laked(i) + endif + enddo + + ! Deactivate lakes where reservoirs are active + where (active_res == 1) active_lake = 0 + + ! If lakes are not being used, set active lakes to zero + if (use_lake == .False.) active_lake = 0 + +end subroutine lake_init + +!------------------------------ +! Calculation subroutine for lakes +subroutine lake_cal(active_lake, area_lake, Q_lake, Wr_lake, Qout, B1, B2) + integer, intent(in) :: active_lake ! Flag indicating if lake is active + real*8, intent(in) :: area_lake, Qout ! Lake area, outlet flow rate + real*8, intent(inout) :: Q_lake, Wr_lake ! Lake inflow, water storage + real*8, intent(inout) :: B1, B2 ! Output variables (Q_lake, some other parameter) + + real*8 :: alp_lake ! Alpha parameter for lake flow calculation + + ! Process only active lakes + if (active_lake == 1) then + + ! Determine lake type based on area and calculate alpha + if (area_lake >= thr_area_lake) then + alp_lake = fac_a_llake * ( (1.D0 / sqrt(area_lake)) ** fac_b_llake ) / 3600.D0 + else + alp_lake = fac_a_slake * ( (1.D0 / sqrt(area_lake)) ** fac_b_slake ) / 3600.D0 + endif + + ! Compute lake outflow based on alpha and water storage + Q_lake = alp_lake * Wr_lake + + ! Ensure that outflow is non-negative and does not exceed available water + Q_lake = max(0.D0, Q_lake) + Q_lake = min(Q_lake, Wr_lake / dt + Qout) + + ! Update water storage in lake + Wr_lake = Wr_lake + dt * (Qout - Q_lake) + Wr_lake = max(0.D0, Wr_lake) + + ! Assign output values + B1 = Q_lake + B2 = 0.D0 + + endif + +end subroutine lake_cal + +end module lake \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 new file mode 100644 index 000000000..fdc73b0c5 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 @@ -0,0 +1,2582 @@ + +module ncdio + use netcdf +!----------------------------------------------------------------------- +!BOP +! +! !MODULE: ncdioMod +! +! !DESCRIPTION: +! Generic interfaces to write fields to netcdf files +! +! !USES: +! +! !PUBLIC TYPES: + implicit none + include 'netcdf.inc' !netcdf库文件 + save + public :: check_ret ! checks return status of netcdf calls + public :: check_var ! determine if variable is on netcdf file + public :: check_dim ! validity check on dimension + public :: ncd_defvar +! +! !REVISION HISTORY: +! +!EOP +! +! !PRIVATE METHODS: +! + interface ncd_iolocal + module procedure ncd_iolocal_int_1d + module procedure ncd_iolocal_real_1d + module procedure ncd_iolocal_double_1d + module procedure ncd_iolocal_int_2d + module procedure ncd_iolocal_real_2d + module procedure ncd_iolocal_double_2d + end interface + + interface ncd_ioglobal + module procedure ncd_ioglobal_int_var + module procedure ncd_ioglobal_real_var + module procedure ncd_ioglobal_double_var + module procedure ncd_ioglobal_int_1d + module procedure ncd_ioglobal_real_1d + module procedure ncd_ioglobal_double_1d + module procedure ncd_ioglobal_byte_2d + module procedure ncd_ioglobal_short_2d + module procedure ncd_ioglobal_int_2d + module procedure ncd_ioglobal_long_2d + module procedure ncd_ioglobal_real_2d + module procedure ncd_ioglobal_double_2d + module procedure ncd_ioglobal_int_3d + module procedure ncd_ioglobal_short_3d + module procedure ncd_ioglobal_real_3d + module procedure ncd_ioglobal_double_3d + end interface + + private :: endrun + logical, public, parameter :: nc_masterproc = .true. ! proc 0 logical for printing msgs + +!----------------------------------------------------------------------- + +contains + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: check_dim +! +! !INTERFACE: + subroutine check_dim(ncid, dimname, value) +! +! !DESCRIPTION: +! Validity check on dimension +! 判断nc文件中指定维数dimname的长度与指定值value相等 +! !ARGUMENTS: + implicit none + integer, intent(in) :: ncid + character(len=*), intent(in) :: dimname + integer, intent(in) :: value +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: dimid, dimlen ! temporaries +!----------------------------------------------------------------------- + + call check_ret(nf_inq_dimid (ncid, trim(dimname), dimid), 'check_dim') !查询维数的代码 + call check_ret(nf_inq_dimlen (ncid, dimid, dimlen), 'check_dim') !查询维数的大小 + if (dimlen /= value) then + write (6,*) 'CHECK_DIM error: mismatch of input dimension ',dimlen, & + ' with expected value ',value,' for variable ',trim(dimname) + call endrun() + end if + + end subroutine check_dim + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: check_var +! +! !INTERFACE: + subroutine check_var(ncid, varname, varid, readvar) +! 判断NC文件中是否含有名为varname的变量，如有则返回readvar=true且返回变量号varid，否则报错。 +! !DESCRIPTION: +! Check if variable is on netcdf file +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: ncid + character(len=*), intent(in) :: varname + integer, intent(out) :: varid + logical, intent(out) :: readvar +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: ret ! return value +!----------------------------------------------------------------------- + + readvar = .true. + if (nc_masterproc) then + ret = nf_inq_varid (ncid, varname, varid) + if (ret/=NF_NOERR) then + write(6,*)'CHECK_VAR: variable ',trim(varname),' is not on initial dataset' + readvar = .false. + end if + end if + end subroutine check_var + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: check_ret +! +! !INTERFACE: + subroutine check_ret(ret, calling) +! 返回NC文件操作是否正确 +! !DESCRIPTION: +! Check return status from netcdf call +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: ret + character(len=*) :: calling +! +! !REVISION HISTORY: +! +!EOP +!----------------------------------------------------------------------- + + if (ret /= NF_NOERR) then !如果打开nc文件出错，则提示出错信息 + write(6,*)'netcdf error from ',trim(calling) + call endrun(nf_strerror(ret)) + end if + + end subroutine check_ret + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_defvar +! +! !INTERFACE: + subroutine ncd_defvar(ncid, varname, xtype, & + dim1name, dim2name, dim3name, dim4name, dim5name, & + long_name, units, cell_method, missing_value, fill_value, & + imissing_value, ifill_value) +! 定义NC变量， +! ncid--NC文件号 +! varname--变量名称 +! xtype--变量类型 +! dim1name--第一维的名称 +! dim2name--第二维的名称 +! dim3name--第三维的名称 +! dim4name--第四维的名称 +! dim5name--第五维的名称 +! long_name--属性-变量的完整名称 +! units--属性-变量的单位 +! cell_method--属性-值的来源说明 +! missing_value--属性-实型缺测值 +! fill_value--属性-实型的缺省值 +! imissing_value--属性-整型的缺测值 +! ifill_value--属性-整型的缺省值 +! !DESCRIPTION: +! Define a netcdf variable +! +! !ARGUMENTS: + implicit none + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + integer , intent(in) :: xtype ! external type + character(len=*), intent(in), optional :: dim1name ! dimension name + character(len=*), intent(in), optional :: dim2name ! dimension name + character(len=*), intent(in), optional :: dim3name ! dimension name + character(len=*), intent(in), optional :: dim4name ! dimension name + character(len=*), intent(in), optional :: dim5name ! dimension name + character(len=*), intent(in), optional :: long_name ! attribute + character(len=*), intent(in), optional :: units ! attribute + character(len=*), intent(in), optional :: cell_method ! attribute + real , intent(in), optional :: missing_value ! attribute for real + real , intent(in), optional :: fill_value ! attribute for real + integer , intent(in), optional :: imissing_value ! attribute for int + integer , intent(in), optional :: ifill_value ! attribute for int +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: n ! indices + integer :: ndims ! dimension counter + integer :: dimid(5) ! dimension ids + integer :: varid ! variable id + integer :: itmp ! temporary + character(len=256) :: str ! temporary + character(len=32) :: subname='NCD_DEFVAR_REAL' ! subroutine name +!----------------------------------------------------------------------- + + if (.not. nc_masterproc) return + + ! Determine dimension ids for variable + + dimid(:) = 0 + ndims=0 + if (present(dim1name)) then + ndims=ndims+1 + call check_ret(nf_inq_dimid(ncid, dim1name, dimid(ndims)), subname) + end if + if (present(dim2name)) then + ndims=ndims+1 + call check_ret(nf_inq_dimid(ncid, dim2name, dimid(ndims)), subname) + end if + if (present(dim3name)) then + ndims=ndims+1 + call check_ret(nf_inq_dimid(ncid, dim3name, dimid(ndims)), subname) + end if + if (present(dim4name)) then + ndims=ndims+1 + call check_ret(nf_inq_dimid(ncid, dim4name, dimid(ndims)), subname) + end if + if (present(dim5name)) then + ndims=ndims+1 + call check_ret(nf_inq_dimid(ncid, dim5name, dimid(ndims)), subname) + end if + + + ! Define variable + + if (present(dim1name) .or. present(dim2name) .or. present(dim3name) .or. & + present(dim4name) .or. present(dim5name)) then + call check_ret(nf_def_var(ncid, trim(varname), xtype, ndims, dimid(1:ndims), varid), subname) + else + call check_ret(nf_def_var(ncid, varname, xtype, 0, 0, varid), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + if (present(cell_method)) then + str = 'time: ' // trim(cell_method) + call check_ret(nf_put_att_text(ncid, varid, 'cell_method', len_trim(str), trim(str)), subname) + end if + if (present(fill_value)) then + call check_ret(nf_put_att_real(ncid, varid, '_FillValue', xtype, 1, fill_value), subname) + end if + if (present(missing_value)) then + call check_ret(nf_put_att_real(ncid, varid, 'missing_value', xtype, 1, missing_value), subname) + end if + if (present(ifill_value)) then + call check_ret(nf_put_att_int(ncid, varid, '_FillValue', xtype, 1, ifill_value), subname) + end if + if (present(imissing_value)) then + call check_ret(nf_put_att_int(ncid, varid, 'missing_value', xtype, 1, imissing_value), subname) + end if + + end subroutine ncd_defvar + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_iolocal_int_1d +! +! !INTERFACE: + + subroutine ncd_iolocal_int_1d(varname, data, flag, ncid, & + lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & + long_name, units, readvar) +! 读/写局部一维实型变量:将一笔资料阵列写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! lb_lon--经向的起始号 +! lb_lat--纬向的起始号 +! lb_lvl--层次的起始号 +! lb_t--时间的起始号 +! ub_lon--经向的起始号 +! ub_lat--纬向的起始号 +! ub_lvl--层次的起始号 +! ub_t--时间的起始号 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O for 1d int field +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + integer , intent(inout) :: data(:) ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + integer , optional, intent(in) :: lb_lon ! start for longitude + integer , optional, intent(in) :: lb_lat ! start for latitute sizes + integer , optional, intent(in) :: lb_lvl ! start for level size + integer , optional, intent(in) :: lb_t ! start for time size + integer , optional, intent(in) :: ub_lon ! start for longitude + integer , optional, intent(in) :: ub_lat ! start for latitute sizes + integer , optional, intent(in) :: ub_lvl ! start for level size + integer , optional, intent(in) :: ub_t ! start for time size + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! variable id + integer :: ndim ! dimension counter + integer :: start(4) ! starting indices for netcdf field + integer :: count(4) ! count values for netcdf field + character(len=32) :: inq_name ! inquid variable name + character(len=8) :: inq_xtype ! inquid variable type + integer :: inq_ndims ! inquid variable dimention + integer :: inq_dimids(4) ! inquid variable dimention id + character(len=255) :: inq_natts ! inquid variable attachment + character(len=32) :: subname='NCD_IOLOCAL_INT_1D' ! subroutine name + logical :: varpresent ! if true, variable is on tape +!----------------------------------------------------------------------- + + ! Write field as 1d field + if (flag == 'write') then + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + ! Write 1d field + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_put_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if ! end of if-nc_masterproc block + ! Read field as 1d field + else if (flag == 'read') then + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + !read data + call check_ret(nf_get_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + else + call endrun('the varibal does not difined!',subname) + end if + end if + if (present(readvar)) readvar = varpresent + end if + + end subroutine ncd_iolocal_int_1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_iolocal_real_1d +! +! !INTERFACE: + subroutine ncd_iolocal_real_1d(varname, data, flag, ncid, & + lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & + long_name, units, readvar) +! 读/写局部一维实型变量:将一笔资料阵列写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! lb_lon--经向的起始号 +! lb_lat--纬向的起始号 +! lb_lvl--层次的起始号 +! lb_t--时间的起始号 +! ub_lon--经向的起始号 +! ub_lat--纬向的起始号 +! ub_lvl--层次的起始号 +! ub_t--时间的起始号 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O for 1d int field +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + real, intent(inout) :: data(:) ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + integer , optional, intent(in) :: lb_lon ! start for longitude + integer , optional, intent(in) :: lb_lat ! start for latitute sizes + integer , optional, intent(in) :: lb_lvl ! start for level size + integer , optional, intent(in) :: lb_t ! start for time size + integer , optional, intent(in) :: ub_lon ! start for longitude + integer , optional, intent(in) :: ub_lat ! start for latitute sizes + integer , optional, intent(in) :: ub_lvl ! start for level size + integer , optional, intent(in) :: ub_t ! start for time size + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! variable id + integer :: ndim ! dimension counter + integer :: start(4) ! starting indices for netcdf field + integer :: count(4) ! count values for netcdf field + character(len=32) :: inq_name ! inquid variable name + character(len=8) :: inq_xtype ! inquid variable type + integer :: inq_ndims ! inquid variable dimention + integer :: inq_dimids(4) ! inquid variable dimention id + character(len=255) :: inq_natts ! inquid variable attachment + character(len=32) :: subname='NCD_IOLOCAL_REAL_1D' ! subroutine name + logical :: varpresent ! if true, variable is on tape +!----------------------------------------------------------------------- + + ! Write field as 1d field + if (flag == 'write') then + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + ! Write 1d field + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_put_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if ! end of if-nc_masterproc block + ! Read field as 1d field + else if (flag == 'read') then + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + !read data + call check_ret(nf_get_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + else + call endrun('the varibal does not difined!',subname) + end if + end if + if (present(readvar)) readvar = varpresent + end if + + end subroutine ncd_iolocal_real_1d +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_iolocal_real_1d +! +! !INTERFACE: + subroutine ncd_iolocal_double_1d(varname, data, flag, ncid, & + lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & + long_name, units, readvar) +! 读/写局部一维实型变量:将一笔资料阵列写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! lb_lon--经向的起始号 +! lb_lat--纬向的起始号 +! lb_lvl--层次的起始号 +! lb_t--时间的起始号 +! ub_lon--经向的起始号 +! ub_lat--纬向的起始号 +! ub_lvl--层次的起始号 +! ub_t--时间的起始号 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O for 1d int field +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + real*8, intent(inout) :: data(:) ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + integer , optional, intent(in) :: lb_lon ! start for longitude + integer , optional, intent(in) :: lb_lat ! start for latitute sizes + integer , optional, intent(in) :: lb_lvl ! start for level size + integer , optional, intent(in) :: lb_t ! start for time size + integer , optional, intent(in) :: ub_lon ! start for longitude + integer , optional, intent(in) :: ub_lat ! start for latitute sizes + integer , optional, intent(in) :: ub_lvl ! start for level size + integer , optional, intent(in) :: ub_t ! start for time size + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! variable id + integer :: ndim ! dimension counter + integer :: start(4) ! starting indices for netcdf field + integer :: count(4) ! count values for netcdf field + character(len=32) :: inq_name ! inquid variable name + character(len=8) :: inq_xtype ! inquid variable type + integer :: inq_ndims ! inquid variable dimention + integer :: inq_dimids(4) ! inquid variable dimention id + character(len=255) :: inq_natts ! inquid variable attachment + character(len=32) :: subname='NCD_IOLOCAL_REAL_1D' ! subroutine name + logical :: varpresent ! if true, variable is on tape +!----------------------------------------------------------------------- + + ! Write field as 1d field + if (flag == 'write') then + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + ! Write 1d field + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_put_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if ! end of if-nc_masterproc block + ! Read field as 1d field + else if (flag == 'read') then + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + !read data + call check_ret(nf_get_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + else + call endrun('the varibal does not difined!',subname) + end if + end if + if (present(readvar)) readvar = varpresent + end if + + end subroutine ncd_iolocal_double_1d +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_iolocal_int_2d +! +! !INTERFACE: + subroutine ncd_iolocal_int_2d(varname, data, flag, ncid, & + lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & + long_name, units, readvar) +! 读/写局部二维整型变量:将一笔资料阵列写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! lb_lon--经向的起始号 +! lb_lat--纬向的起始号 +! lb_lvl--层次的起始号 +! lb_t--时间的起始号 +! ub_lon--经向的起始号 +! ub_lat--纬向的起始号 +! ub_lvl--层次的起始号 +! ub_t--时间的起始号 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O for 2d real field +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + integer , intent(inout) :: data(:,:) ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + integer , optional, intent(in) :: lb_lon ! start for longitude + integer , optional, intent(in) :: lb_lat ! start for latitute sizes + integer , optional, intent(in) :: lb_lvl ! start for level size + integer , optional, intent(in) :: lb_t ! start for time size + integer , optional, intent(in) :: ub_lon ! start for longitude + integer , optional, intent(in) :: ub_lat ! start for latitute sizes + integer , optional, intent(in) :: ub_lvl ! start for level size + integer , optional, intent(in) :: ub_t ! start for time size + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! variable id + integer :: ndim ! dimension counter + integer :: start(4) ! starting indices for netcdf field + integer :: count(4) ! count values for netcdf field + character(len=32) :: inq_name ! inquid variable name + character(len=8) :: inq_xtype ! inquid variable type + integer :: inq_ndims ! inquid variable dimention + integer :: inq_dimids(4) ! inquid variable dimention id + character(len=255) :: inq_natts ! inquid variable attachment + character(len=32) :: subname='NCD_IOLOCAL_INT_2D' ! subroutine name + logical :: varpresent ! if true, variable is on tape +!----------------------------------------------------------------------- + + ! Write field as 2d field + if (flag == 'write') then + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + ! Write 2d field + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_put_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if ! end of if-nc_masterproc block + ! Read field as 1d field + else if (flag == 'read') then + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_get_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + else + call endrun('the varibal does not difined!',subname) + end if + end if + if (present(readvar)) readvar = varpresent + end if + + end subroutine ncd_iolocal_int_2d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_iolocal_real_2d +! +! !INTERFACE: + subroutine ncd_iolocal_real_2d(varname, data, flag, ncid, & + lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & + long_name, units, readvar) +! 读/写局部二维实型变量:将一笔资料阵列写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! lb_lon--经向的起始号 +! lb_lat--纬向的起始号 +! lb_lvl--层次的起始号 +! lb_t--时间的起始号 +! ub_lon--经向的起始号 +! ub_lat--纬向的起始号 +! ub_lvl--层次的起始号 +! ub_t--时间的起始号 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O for 2d real field +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + real, intent(inout) :: data(:,:) ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + integer , optional, intent(in) :: lb_lon ! start for longitude + integer , optional, intent(in) :: lb_lat ! start for latitute sizes + integer , optional, intent(in) :: lb_lvl ! start for level size + integer , optional, intent(in) :: lb_t ! start for time size + integer , optional, intent(in) :: ub_lon ! start for longitude + integer , optional, intent(in) :: ub_lat ! start for latitute sizes + integer , optional, intent(in) :: ub_lvl ! start for level size + integer , optional, intent(in) :: ub_t ! start for time size + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! variable id + integer :: ndim ! dimension counter + integer :: start(4) ! starting indices for netcdf field + integer :: count(4) ! count values for netcdf field + character(len=32) :: inq_name ! inquid variable name + character(len=8) :: inq_xtype ! inquid variable type + integer :: inq_ndims ! inquid variable dimention + integer :: inq_dimids(4) ! inquid variable dimention id + character(len=255) :: inq_natts ! inquid variable attachment + character(len=32) :: subname='NCD_IOLOCAL_REAL_2D' ! subroutine name + logical :: varpresent ! if true, variable is on tape +!----------------------------------------------------------------------- + + ! Write field as 2d field + if (flag == 'write') then + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + ! Write 2d field + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_put_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if ! end of if-nc_masterproc block + ! Read field as 1d field + else if (flag == 'read') then + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_get_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + else + call endrun('the varibal does not difined!',subname) + end if + end if + if (present(readvar)) readvar = varpresent + end if + + end subroutine ncd_iolocal_real_2d + + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_iolocal_real_2d +! +! !INTERFACE: + subroutine ncd_iolocal_double_2d(varname, data, flag, ncid, & + lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & + long_name, units, readvar) +! 读/写局部二维实型变量:将一笔资料阵列写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! lb_lon--经向的起始号 +! lb_lat--纬向的起始号 +! lb_lvl--层次的起始号 +! lb_t--时间的起始号 +! ub_lon--经向的起始号 +! ub_lat--纬向的起始号 +! ub_lvl--层次的起始号 +! ub_t--时间的起始号 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O for 2d real field +! +! !USES: +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + real*8, intent(inout) :: data(:,:) ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + integer , optional, intent(in) :: lb_lon ! start for longitude + integer , optional, intent(in) :: lb_lat ! start for latitute sizes + integer , optional, intent(in) :: lb_lvl ! start for level size + integer , optional, intent(in) :: lb_t ! start for time size + integer , optional, intent(in) :: ub_lon ! start for longitude + integer , optional, intent(in) :: ub_lat ! start for latitute sizes + integer , optional, intent(in) :: ub_lvl ! start for level size + integer , optional, intent(in) :: ub_t ! start for time size + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! variable id + integer :: ndim ! dimension counter + integer :: start(4) ! starting indices for netcdf field + integer :: count(4) ! count values for netcdf field + character(len=32) :: inq_name ! inquid variable name + character(len=8) :: inq_xtype ! inquid variable type + integer :: inq_ndims ! inquid variable dimention + integer :: inq_dimids(4) ! inquid variable dimention id + character(len=255) :: inq_natts ! inquid variable attachment + character(len=32) :: subname='NCD_IOLOCAL_REAL_2D' ! subroutine name + logical :: varpresent ! if true, variable is on tape +!----------------------------------------------------------------------- + + ! Write field as 2d field + if (flag == 'write') then + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + ! Write 2d field + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_put_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if ! end of if-nc_masterproc block + ! Read field as 1d field + else if (flag == 'read') then + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + ndim=0 + count=1 + if (present(lb_lon) .and. present(ub_lon)) then + ndim=ndim+1 + start(ndim)=lb_lon + count(ndim)=ub_lon-lb_lon+1 + else if(present(lb_lon) .neqv. present(ub_lon))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lat)) then + ndim=ndim+1 + start(ndim)=lb_lat + count(ndim)=ub_lat-lb_lat+1 + else if(present(lb_lat) .neqv. present(ub_lat))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_lvl)) then + ndim=ndim+1 + start(ndim)=lb_lvl + count(ndim)=ub_lvl-lb_lvl+1 + else if(present(lb_lvl) .neqv. present(ub_lvl))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + if (present(lb_t)) then + ndim=ndim+1 + start(ndim)=lb_t + count(ndim)=ub_t-lb_t+1 + else if(present(lb_t) .neqv. present(lb_t))then + call endrun('must specify the low and up boundary at the same time!',subname) + endif + + if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & + (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then + call endrun('must specify one dimention!',subname) + endif + + call check_ret(nf_get_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) + else + call endrun('the varibal does not difined!',subname) + end if + end if + if (present(readvar)) readvar = varpresent + end if + + end subroutine ncd_iolocal_double_2d + + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_int_var +! +! !INTERFACE: + subroutine ncd_ioglobal_int_var(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局零维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O of integer variable +! + +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + integer , intent(inout) :: data ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + integer , optional, intent(in) :: nt ! time sample index + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: ier ! error status + integer :: dimid(1) ! dimension id + integer :: start(1), count(1) ! output bounds + integer :: varid ! variable id + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_INT_VAR' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = nt; count(1) = 1 + call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_int(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_int_var + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_var +! +! !INTERFACE: + subroutine ncd_ioglobal_real_var(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局零维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O of real variable +! + +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + real , intent(inout) :: data ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: ier ! error status + integer :: dimid(1) ! dimension id + integer :: start(1), count(1) ! output bounds + integer :: varid ! variable id + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_VAR' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = nt; count(1) = 1 + call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_real(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_real(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_real_var + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_var +! +! !INTERFACE: + subroutine ncd_ioglobal_double_var(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局零维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! I/O of real variable +! + +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: varname ! variable name + real*8 , intent(inout) :: data ! local decomposition data + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: ier ! error status + integer :: dimid(1) ! dimension id + integer :: start(1), count(1) ! output bounds + integer :: varid ! variable id + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_VAR' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = nt; count(1) = 1 + call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_double(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_double(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_double_var + +!---------------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_int_1d +! +! !INTERFACE: + subroutine ncd_ioglobal_int_1d(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局一维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! Master I/O for 1d integer data +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + integer , intent(inout) :: data(:) ! local decomposition data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: dimid(2), ndims ! dimension ids + integer :: start(2), count(2) ! output bounds + integer :: ier ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_INT_1D' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data) + start(2) = nt; count(2) = 1 + call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_int(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_int_1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_1d +! +! !INTERFACE: + subroutine ncd_ioglobal_real_1d(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局一维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! Master I/O for 1d real data +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + real , intent(inout) :: data(:) ! local decomposition input data + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: ier ! error code + integer :: dimid(2), ndims ! dimension ids + integer :: start(2), count(2) ! output bounds + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_1D' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data) + start(2) = nt; count(2) = 1 + call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) + else +! call check_ret(nf_put_var_real(ncid, varid, data), subname) +call check_ret(nf_put_var_real(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_real(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_real_1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_1d +! +! !INTERFACE: + subroutine ncd_ioglobal_double_1d(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局一维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! Master I/O for 1d real data +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + real*8 , intent(inout) :: data(:) ! local decomposition input data + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: ier ! error code + integer :: dimid(2), ndims ! dimension ids + integer :: start(2), count(2) ! output bounds + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_1D' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data) + start(2) = nt; count(2) = 1 + call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) + else +! call check_ret(nf_put_var_double(ncid, varid, data), subname) +call check_ret(nf_put_var_double(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_double(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_double_1d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_int_2d +! +! !INTERFACE: + subroutine ncd_ioglobal_int_2d(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 2d integer array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + integer , intent(inout) :: data(:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: dimid(3), ndims ! dimension ids + integer :: start(3), count(3) ! output bounds + integer :: ier ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_2D_INT_IO' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = nt; count(3) = 1 + call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_int(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_int_2d + +!----------------------------------------------------------------------- + +!BOP +! +! !IROUTINE: ncd_ioglobal_int_2d +! +! !INTERFACE: + subroutine ncd_ioglobal_long_2d(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 2d integer array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + integer*8 , intent(inout) :: data(:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: dimid(3), ndims ! dimension ids + integer :: start(3), count(3) ! output bounds + integer :: ier ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_2D_INT_IO' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = nt; count(3) = 1 + call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_int(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_long_2d + +!----------------------------------------------------------------------- + +!BOP +! +! !IROUTINE: ncd_ioglobal_byte_2d +! +! !INTERFACE: + subroutine ncd_ioglobal_byte_2d(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 2d integer array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + byte, intent(inout) :: data(:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: dimid(3), ndims ! dimension ids + integer :: start(3), count(3) ! output bounds + integer :: ier ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_2D_INT1_IO' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = nt; count(3) = 1 + call check_ret(nf_put_vara_int1(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int1(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_int1(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_byte_2d +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_short_2d +! +! !INTERFACE: + subroutine ncd_ioglobal_short_2d(varname, data, flag, ncid, long_name, units, nt, readvar) +! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 2d integer array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + integer*2, intent(inout) :: data(:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: dimid(3), ndims ! dimension ids + integer :: start(3), count(3) ! output bounds + integer :: ier ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_2D_INT2_IO' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = nt; count(3) = 1 + call check_ret(nf_put_vara_int2(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int2(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_int2(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_short_2d +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_2d +! +! !INTERFACE: + subroutine ncd_ioglobal_real_2d(varname, data, flag, & + ncid, long_name, units, nt, readvar) +! 读/写全局二维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! long_name--属性-变量全称 +! units--属性-变量单位 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 2d real array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + real , intent(inout) :: data(:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: ier ! error code + integer :: dimid(3), ndims ! dimension ids + integer :: start(3), count(3) ! output bounds + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_2D' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = nt; count(3) = 1 +! call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) +call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_real(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_real(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_real_2d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_2d +! +! !INTERFACE: + subroutine ncd_ioglobal_double_2d(varname, data, flag, & + ncid, long_name, units, nt, readvar) +! 读/写全局二维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! long_name--属性-变量全称 +! units--属性-变量单位 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 2d real array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + real*8 , intent(inout) :: data(:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: ier ! error code + integer :: dimid(3), ndims ! dimension ids + integer :: start(3), count(3) ! output bounds + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_2D' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = nt; count(3) = 1 +! call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) +call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_double(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + call check_ret(nf_get_var_double(ncid, varid, data), subname) + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_double_2d +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_short_3d +! +! !INTERFACE: + subroutine ncd_ioglobal_short_3d(varname, data, flag, & + ncid, long_name, units, nt, readvar) +! 读/写全局三维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! long_name--属性-变量全称 +! units--属性-变量单位 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 3d integer array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + integer*2 , intent(inout) :: data(:,:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: dimid(4), ndims ! dimension ids + integer :: start(4), count(4) ! output bounds + integer :: ier ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_3D_INT2_IO' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_put_vara_int2(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int2(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_get_vara_int2(ncid, varid, start, count, data), subname) + else + call check_ret(nf_get_var_int2(ncid, varid, data), subname) + end if + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_short_3d +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_int_3d +! +! !INTERFACE: + subroutine ncd_ioglobal_int_3d(varname, data, flag, & + ncid, long_name, units, nt, readvar) +! 读/写全局三维整型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! long_name--属性-变量全称 +! units--属性-变量单位 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 3d integer array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + integer , intent(inout) :: data(:,:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: dimid(4), ndims ! dimension ids + integer :: start(4), count(4) ! output bounds + integer :: ier ! error code + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_3D_INT_IO' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_int(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_get_vara_int(ncid, varid, start, count, data), subname) + else + call check_ret(nf_get_var_int(ncid, varid, data), subname) + end if + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_int_3d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_3d +! +! !INTERFACE: + subroutine ncd_ioglobal_real_3d(varname, data, flag, & + ncid, long_name, units, nt, readvar) +! 读/写全局三维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! long_name--属性-变量全称 +! units--属性-变量单位 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 3d real array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + real, intent(inout) :: data(:,:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: ier ! error code + integer :: dimid(4), ndims ! dimension ids + integer :: start(4), count(4) ! output bounds + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_3D' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_real(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_get_vara_real(ncid, varid, start, count, data), subname) + else + call check_ret(nf_get_var_real(ncid, varid, data), subname) + end if + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_real_3d + +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ncd_ioglobal_real_3d +! +! !INTERFACE: + subroutine ncd_ioglobal_double_3d(varname, data, flag, & + ncid, long_name, units, nt, readvar) +! 读/写全局三维实型变量:将所有的资料阵列均写入档案中 +! varname--变量名 +! data--变量存储数组 +! long_name--属性-变量全称 +! units--属性-变量单位 +! flag--读/写的标记 +! ncid--NC文件对应的文件号 +! nt--时间步 +! readvar--所读取的变量是否存在于该NC文件中 +! !DESCRIPTION: +! netcdf I/O of global 3d real array +! +! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: flag ! 'read' or 'write' + integer , intent(in) :: ncid ! input unit + character(len=*), intent(in) :: varname ! variable name + real*8, intent(inout) :: data(:,:,:) ! local decomposition input data + character(len=*), optional, intent(in) :: long_name ! variable long name + character(len=*), optional, intent(in) :: units ! variable units + logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) + integer , optional, intent(in) :: nt ! time sample index +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer :: varid ! netCDF variable id + integer :: ier ! error code + integer :: dimid(4), ndims ! dimension ids + integer :: start(4), count(4) ! output bounds + logical :: varpresent ! if true, variable is on tape + character(len=32) :: subname='NCD_IOGLOBAL_REAL_3D' ! subroutine name +!----------------------------------------------------------------------- + + if (flag == 'write') then + + if (nc_masterproc) then + call check_ret(nf_inq_varid(ncid, varname, varid), subname) + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) + else + call check_ret(nf_put_var_double(ncid, varid, data), subname) + end if + if (present(long_name)) then + call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) + end if + if (present(units)) then + call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) + end if + end if + + else if (flag == 'read') then + + if (nc_masterproc) then + call check_var(ncid, varname, varid, varpresent) + if (varpresent) then + if (present(nt)) then + start(1) = 1; count(1) = size(data, dim=1) + start(2) = 1; count(2) = size(data, dim=2) + start(3) = 1; count(3) = size(data, dim=3) + start(4) = nt; count(4) = 1 + call check_ret(nf_get_vara_double(ncid, varid, start, count, data), subname) + else + call check_ret(nf_get_var_double(ncid, varid, data), subname) + end if + else + call endrun('the varibal does not difined!',subname) + endif + end if + if (present(readvar)) readvar = varpresent + + end if + + end subroutine ncd_ioglobal_double_3d + +!----------------------------------------------------------------------- +!BOP +! !IROUTINE: endrun +! +! !INTERFACE: +subroutine endrun(msg,subname) +! +! !DESCRIPTION: +! Abort the model for abnormal termination + implicit none +! !ARGUMENTS: + character(len=*), intent(in), optional :: msg ! string to be printed + character(len=*), intent(in), optional :: subname ! subname + + if (present (subname)) then + write(6,*) 'ERROR in subroutine :', trim(subname) + end if + + if (present (msg)) then + write(6,*)'ENDRUN:', msg + else + write(6,*) 'ENDRUN: called without a message string' + end if + + stop +end subroutine endrun + +end module ncdio + + + + + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 new file mode 100644 index 000000000..228cf4bea --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 @@ -0,0 +1,348 @@ +module reservoir + +use rwncfile + +implicit none +private +public :: res_init, res_cal + +!----Reservoir module constants---------- + +real*8, parameter :: fac_elec_a = 0.30D0 ! Coefficient for hydropower calculation +real*8, parameter :: fac_elec_b = 2.00D0 ! Exponent for hydropower calculation +real*8, parameter :: fac_irr_a = 0.225D0 ! Coefficient for irrigation calculation (arid areas) +real*8, parameter :: fac_irr_b = 100.D0 ! Scaling factor for irrigation (arid areas) +real*8, parameter :: fac_sup_a = 0.03D0 ! Coefficient for water supply calculation +real*8, parameter :: fac_sup_b = 2.00D0 ! Exponent for water supply calculation +real*8, parameter :: fac_other_a = 0.20D0 ! Coefficient for other reservoir types +real*8, parameter :: fac_other_b = 2.00D0 ! Exponent for other reservoir types +integer, parameter :: fac_fld = 1 ! Flood control parameter + +real*8, parameter :: dt = 86400.D0 ! Time step in seconds (1 day) + +real*8, parameter :: ai_thres = 0.5D0 ! Aridity index threshold for irrigation reservoirs +real*8, parameter :: rho = 1.D3 ! Water density (kg/m^3) + +!----------------------------------------- + +contains + +!------------------------------------------ +! Initialization subroutine for reservoirs +subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,cap_res,Qavg_res,ai_res,fld_res,Qfld_thres,irr_sea_frac,cat2res,wid_res) + character(len=500),intent(in) :: input_dir + ! Define the number of reservoirs (nres) and the number of catchments (nc) + integer,intent(in) :: nres,nc + ! Logical variable to check if reservoirs are used + logical,intent(in) :: use_res + ! Input/output arrays for reservoir attributes: active reservoirs, types, capacities, etc. + integer,intent(inout),allocatable :: active_res(:),type_res(:),fld_res(:),cat2res(:) + real*8,intent(inout),allocatable :: Wr_res(:),Q_res(:),cap_res(:),Qavg_res(:),ai_res(:),Qfld_thres(:),irr_sea_frac(:,:) + real*8,intent(inout),allocatable :: wid_res(:) + + ! Internal arrays for various reservoir-related data + integer,allocatable,dimension(:) :: flag_grand,catid_grand,elec_grand,irrsup_grand,fld_grand,supply_grand,irr_grand,realuse_grand + integer,allocatable,dimension(:) :: nav_grand,rec_grand,other_grand + real*8,allocatable,dimension(:) :: cap_grand,area_max_res,Qavg_grand,ai_grand,area_grand,power_grand,area_res + real*8,allocatable,dimension(:,:) :: Wres_tar + + ! Define the flood threshold variable and a counter variable + character(len=2) :: fld_thres + integer :: i,cid,rid + +!----------reservoir module-------------- + ! Allocate memory for each array + allocate(flag_grand(nres),catid_grand(nres),active_res(nc)) + allocate(Wr_res(nc),Q_res(nc)) + allocate(elec_grand(nres),type_res(nc),cap_grand(nres),cap_res(nc),area_grand(nres),power_grand(nres)) + allocate(area_res(nc),area_max_res(nc)) + allocate(Qavg_grand(nres),Qavg_res(nc)) + allocate(ai_grand(nres),irrsup_grand(nres),ai_res(nc)) + allocate(fld_grand(nres),fld_res(nc),Qfld_thres(nc),supply_grand(nres)) + allocate(irr_sea_frac(nres,12),irr_grand(nres)) + allocate(cat2res(nc)) + allocate(nav_grand(nres),rec_grand(nres)) + allocate(other_grand(nres)) + allocate(Wres_tar(365,nres)) + allocate(wid_res(nc)) + allocate(realuse_grand(nres)) + + ! Open reservoir-related data files and read the corresponding arrays + open(77,file=trim(input_dir)//"/catid_dam_corr_aca_grand5000.txt") + read(77,*)catid_grand + open(77,file=trim(input_dir)//"/flag_all_res.txt") + read(77,*)flag_grand + open(77,file=trim(input_dir)//"/cap_max_grand.txt") + read(77,*)cap_grand + cap_grand=cap_grand*1.D6*rho ! Convert capacity from million cubic meters (MCM) to kilograms (kg) + open(77,file=trim(input_dir)//"/hydroelec_grand.txt") + read(77,*)elec_grand + open(77,file=trim(input_dir)//"/Qavg_res_2016_2020_OL7000.txt") + read(77,*)Qavg_grand + Qavg_grand=Qavg_grand*rho ! Convert flow rate from cubic meters per second (m3/s) to kilograms per second (kg/s) + open(77,file=trim(input_dir)//"/ai_grand.txt") + read(77,*)ai_grand + open(77,file=trim(input_dir)//"/irrmainsec_noelec_grand.txt") + read(77,*)irrsup_grand + open(77,file=trim(input_dir)//"/fldmainsec_grand.txt") + read(77,*)fld_grand + write(fld_thres,'(I2.2)')fac_fld + open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt") + read(77,*)Qfld_thres ! Read flood thresholds in cubic meters per second (m3/s) + Qfld_thres=Qfld_thres*rho ! Convert threshold from cubic meters per second to kilograms per second (kg/s) + open(77,file=trim(input_dir)//"/watersupply_grand.txt") + read(77,*)supply_grand + open(77,file=trim(input_dir)//"/irr_grand.txt") + read(77,*)irr_grand + open(77,file=trim(input_dir)//"/nav_grand.txt") + read(77,*)nav_grand + open(77,file=trim(input_dir)//"/rec_grand.txt") + read(77,*)rec_grand + open(77,file=trim(input_dir)//"/other_grand.txt") + read(77,*)other_grand + open(77,file=trim(input_dir)//"/area_skm_grand.txt") + read(77,*)area_grand + area_grand=area_grand*1.D6 ! Convert area from square kilometers (km2) to square meters (m2) + open(77,file=trim(input_dir)//"/power_grand.txt") + read(77,*)power_grand + + ! Set initial reservoir ID mapping + cat2res=0 + do i=1,nres + if(flag_grand(i)==1)then + cid=catid_grand(i) + cat2res(cid)=i ! Link reservoirs with catchments: multiple reservoirs in a catchment share attributes that can be accessed via cat2res + endif + enddo + + ! Initialize reservoir properties + cap_res = 0.D0 ! Set reservoir capacity to zero + area_res = 0.D0 ! Set reservoir area to zero + area_max_res = 0.D0 ! Set max reservoir area to zero + type_res = 0 ! Set reservoir type to zero + Qavg_res = 0.D0 ! Set average reservoir flow rate to zero + ai_res = 0.D0 ! Set irrigation index to zero + fld_res = 0 ! Set flood status to zero + active_res = 0 ! Set active reservoirs to zero + realuse_grand = 0 ! Initialize real use for each reservoir to zero + + ! Loop over all reservoirs + do i = 1, nres + if(flag_grand(i) == 1) then ! If the reservoir is flagged as active + cid = catid_grand(i) ! Get the catchment ID for the reservoir + cap_res(cid) = cap_res(cid) + cap_grand(i) ! Sum up the capacities for reservoirs in the same catchment + area_res(cid) = area_res(cid) + area_grand(i) ! Sum up the areas for reservoirs in the same catchment + Qavg_res(cid) = Qavg_grand(i) ! Assign average flow rate to the catchment + if(fld_grand(i) == 1) fld_res(cid) = 1 ! Mark the catchment if it has flood control + endif + enddo + + ! Compute reservoir width from area (square root of the area) + wid_res = sqrt(area_res) + + ! Assign reservoir type 7 (Other use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(other_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 7 ! Type 7 for other uses + cat2res(cid) = i ! Map the catchment to the reservoir + area_max_res(cid) = area_grand(i) ! Update the maximum area for the catchment + endif + endif + enddo + + ! Assign reservoir type 6 (Recreational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(rec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 6 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 5 (Navigational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(nav_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 5 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 4 (Water supply) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(supply_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 4 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 3 (Irrigation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(irr_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 3 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 2 (Electricity generation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(elec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 2 + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 1 (Irrigation supply) with specific conditions + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(irrsup_grand(i) == 1 .and. ai_grand(i) <= ai_thres .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 1 ! Assign type 1 for irrigation supply + ai_res(cid) = ai_grand(i) ! Assign irrigation index to the catchment + cat2res(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Mark active reservoirs based on type or flood control status + do i = 1, nc + if(type_res(i) /= 0 .or. fld_res(i) == 1) then + active_res(i) = 1 + endif + enddo + + ! Assign real reservoir usage based on type, with error checking + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + rid = cat2res(cid) + if(rid > 0) then + if(type_res(cid) == 0 .and. fld_res(cid) == 0) then + print *, "type_res(cid) == 0" + stop + endif + if(type_res(cid) == 0) then + realuse_grand(i) = -1 ! Invalid reservoir use type + else + realuse_grand(i) = type_res(cid) ! Assign the actual use type + endif + else + print *, "rid == 0" + stop + endif + endif + enddo + + ! Read irrigation and reservoir target data from NetCDF files + call read_ncfile_double2d(trim(input_dir)//"/irr_grand_frac.nc", "data", irr_sea_frac, nres, 12) + call read_ncfile_double2d(trim(input_dir)//"/Wr_tar_Dang.nc", "data", Wres_tar, 365, nres) + + Wres_tar = Wres_tar * 1.D6 * rho ! Convert from million cubic meters (MCM) to kilograms (kg) + + ! Deactivate reservoirs if the use_res flag is set to False + if(use_res == .False.) active_res = 0 + +end subroutine res_init + +!----------------------- +! Reservoir calculation subroutine +subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,ai_res,cat2res,irr_sea_frac,Q_res,Qavg_res,wid_res,fld_res,Wr_res,Qfld_thres,cap_res,B1,B2) + integer, intent(in) :: active_res, type_res, active_lake, cat2res, fld_res + real*8, intent(in) :: Qout, Q_lake, ai_res, irr_sea_frac, Qavg_res, wid_res, Qfld_thres, cap_res + real*8, intent(inout) :: Q_res, Wr_res, B1, B2 + + integer :: rid ! Reservoir ID + real*8 :: Qin_res, coe, irrfac, alp_res ! Variables for inflow, coefficients, and factors + + ! If the reservoir is active + if (active_res == 1) then + + ! Determine the inflow to the reservoir (from river or lake) + if (active_lake == 0) then + Qin_res = Qout ! Inflow from river + else + Qin_res = Q_lake ! Inflow from lake + endif + + ! Irrigation reservoir in arid regions + if (type_res == 1) then + if (ai_res <= 0.2D0) then + ! Calculate the coefficient for very arid regions + coe = fac_irr_a * log(fac_irr_b * ai_res) + else if (ai_res <= ai_thres) then + ! Calculate coefficient based on aridity index + rid = cat2res + irrfac = irr_sea_frac * 12.D0 ! Seasonal irrigation factor + coe = (fac_irr_a * log(fac_irr_b * 0.2D0) * (ai_thres - ai_res) + irrfac * (ai_res - 0.2D0)) / (ai_thres - 0.2D0) + else + coe = irrfac ! Irrigation factor for higher aridity index + endif + coe = min(coe, 5.D0) ! Limit maximum coefficient + coe = max(0.D0, coe) ! Ensure coefficient is non-negative + Q_res = coe * Qavg_res ! Calculate the reservoir outflow based on average flow + + ! Hydropower reservoir + else if (type_res == 2) then + alp_res = fac_elec_a * ((1.D0 / (wid_res / 1.D3)) ** fac_elec_b) / 3600.D0 ! Hydropower coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage + + ! Irrigation reservoir + else if (type_res == 3) then + rid = cat2res + irrfac = irr_sea_frac * 12.D0 ! Seasonal irrigation factor + Q_res = irrfac * Qavg_res ! Outflow based on irrigation factor and average flow + + ! Water supply reservoir + else if (type_res == 4) then + alp_res = fac_sup_a * ((1.D0 / (wid_res / 1.D3)) ** fac_sup_b) / 3600.D0 ! Supply coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage + + ! Other reservoir types + else if (type_res == 5 .or. type_res == 6 .or. type_res == 7 .or. type_res == 0) then + alp_res = fac_other_a * ((1.D0 / (wid_res / 1.D3)) ** fac_other_b) / 3600.D0 ! Generic reservoir coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage + endif + + ! Ensure outflow is within reasonable bounds + Q_res = max(0.D0, Q_res) ! Ensure non-negative outflow + Q_res = min(Q_res, Wr_res / dt + Qin_res) ! Limit outflow to prevent exceeding inflow and storage + if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control + Wr_res = Wr_res + dt * (Qin_res - Q_res) ! Update water storage in the reservoir + Wr_res = max(0.D0, Wr_res) ! Ensure non-negative storage + + ! If the storage exceeds capacity, adjust outflow and storage + if (Wr_res > cap_res) then + if (type_res /= 1) Q_res = Q_res + (Wr_res - cap_res) / dt ! Adjust outflow for overflow + Wr_res = cap_res ! Limit storage to reservoir capacity + endif + + ! Output the calculated outflow and zero out the second output variable (B2) + B1 = Q_res + B2 = 0.D0 + + endif + +end subroutine res_cal + +end module reservoir \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 new file mode 100644 index 000000000..ce78a064c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 @@ -0,0 +1,319 @@ +module river_io + +use interp +use rwncfile + +implicit none +private + +public :: read_input,read_restart,read_runoff,write_output + +real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 +character(len=500) :: input_dir="input/" ! Directory for input files +character(len=500) :: output_dir="/Users/zsp/Desktop/work/ROUTING_PR/results_temp_PR/" ! Directory for output files +character(len=500) :: runoff_dir="/Users/zsp/Desktop/work/river/SMAP_Nature_v10.0_M36/" ! Directory for runoff files + +integer :: nlon=964 !for M36, change to 3856 for M09 +integer :: nlat=406 !for M36, change to 1624 for M09 + +contains + +!------------------------------ +subroutine read_input(nc,ny,upmax,days_in_year,fac_kstr,qstr_clmt,qri_clmt,nts,upID,nup,llc_ori,lstr,qin_clmt,K,Kstr,days_acc_year,days_acc_noleap,days_acc_leap,inputdir) + ! Input parameters: + integer,intent(in) :: nc, ny, upmax ! nc: number of catchments, ny: number of years, upmax: max number of upstream catchments + integer,intent(in) :: days_in_year(ny) ! Array of days in each year + real*8,intent(in) :: fac_kstr ! Scaling factor for streamflow + real*8,intent(out) :: qstr_clmt(nc), qri_clmt(nc) ! Climate streamflow (qstr_clmt) and routing inflow (qri_clmt) in kg/s + integer,intent(out) :: nts(nc), upID(upmax,nc), nup(nc) ! Number of time steps, upstream IDs, and number of upstream catchments + real*8,intent(out) :: llc_ori(nc), lstr(nc), qin_clmt(nc), K(nc), Kstr(nc) ! Original stream length (llc_ori), stream length (lstr), climate inflow (qin_clmt), and hydraulic parameters (K, Kstr) + integer,intent(out) :: days_acc_year(ny), days_acc_noleap(12), days_acc_leap(12) ! Accumulated days in regular and leap years + character(len=500),intent(out) :: inputdir + + ! Days in each month for no-leap and leap years + integer,dimension(12) :: days_in_mon_noleap=(/31,28,31,30,31,30,31,31,30,31,30,31/) + integer,dimension(12) :: days_in_mon_leap=(/31,29,31,30,31,30,31,31,30,31,30,31/) + integer :: i + + inputdir=input_dir + ! Read input data from files + open(77,file=trim(input_dir)//"/Pfaf_qstr.txt") + read(77,*)qstr_clmt ! Read streamflow climatology (m3/s) + qstr_clmt=qstr_clmt*rho ! Convert to kg/s + + open(77,file=trim(input_dir)//"/Pfaf_qri.txt") + read(77,*)qri_clmt ! Read routing inflow (m3/s) + qri_clmt=qri_clmt*rho ! Convert to kg/s + + open(77,file=trim(input_dir)//"/Pfaf_qin.txt") + read(77,*)qin_clmt ! Read climate inflow (m3/s) + qin_clmt=qin_clmt*rho ! Convert to kg/s + + open(77,file=trim(input_dir)//"/Pfaf_tosink.txt") + read(77,*)nts ! Read number of steps to endpoint + + open(77,file=trim(input_dir)//"/upstream_1D.txt") + read(77,*)upID ! Read upstream IDs + + open(77,file=trim(input_dir)//"/Pfaf_upnum.txt") + read(77,*)nup ! Read number of upstream catchments + + open(77,file=trim(input_dir)//"/Pfaf_lriv_PR.txt") + read(77,*)llc_ori ! Read original stream length (km) + llc_ori=llc_ori*1.D3 ! Convert km to meters + + open(77,file=trim(input_dir)//"/Pfaf_lstr_PR.txt") + read(77,*)lstr ! Read stream length (km) + lstr=lstr*1.D3 ! Convert km to meters + + open(77,file=trim(input_dir)//"Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt") + read(77,*)K ! Read hydraulic parameter K + + open(77,file=trim(input_dir)//"Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt") + read(77,*)Kstr ! Read hydraulic parameter Kstr + Kstr=fac_kstr*Kstr ! Apply scaling factor to Kstr + + ! Calculate accumulated days for regular years + days_acc_year(1)=0 + do i=2,ny + days_acc_year(i)=days_acc_year(i-1)+days_in_year(i-1) + end do + + ! Calculate accumulated days for no-leap and leap years + days_acc_noleap(1)=0 + days_acc_leap(1)=0 + do i=2,12 + days_acc_noleap(i)=days_acc_noleap(i-1)+days_in_mon_noleap(i-1) + days_acc_leap(i)=days_acc_leap(i-1)+days_in_mon_leap(i-1) + end do + +end subroutine read_input +!------------------------------ +subroutine read_restart(iter,is_coldstart,ny,nc,days_acc_year,days_acc_noleap,days_acc_leap,Ws,Wr,Wr_res,Wr_lake) + ! Input parameters: + integer,intent(in) :: iter ! Current iteration + logical,intent(inout) :: is_coldstart ! Flag for cold start condition + integer,intent(in) :: ny, nc ! ny: number of years, nc: number of catchments + integer,intent(in) :: days_acc_year(ny), days_acc_noleap(12), days_acc_leap(12) ! Accumulated days for each year and for no-leap/leap years + real*8,intent(inout) :: Ws(nc), Wr(nc), Wr_res(nc), Wr_lake(nc) ! Water storage in soil (Ws), routing (Wr), reservoir (Wr_res), and lake (Wr_lake) + + ! Local variables: + character(len=50) :: iter_s, yr_s, mon_s, day_s ! Strings for iteration, year, month, and day + integer :: step_prev, i, yr_cur, mon_cur, day_cur, d_res ! Step count, loop index, current year, month, day, and day residual + integer :: days_acc_mon(12) ! Accumulated days per month + + ! Convert iteration number to string format + write(iter_s,'(I5.5)')iter + print *,trim(iter_s) + + ! If first iteration or cold start, read initial data + if(iter==1.or.is_coldstart)then + ! Read initial water storage data from files for cold start + open(77,file=trim(input_dir)//"/Pfaf_Ws_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Ws ! Read soil water storage (Ws) + + open(77,file=trim(input_dir)//"/Pfaf_Wr_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Wr ! Read routing water storage (Wr) + + !----reservoir module------- + open(77,file=trim(input_dir)//"/Pfaf_Wr_res_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Wr_res ! Read reservoir water storage (Wr_res) + + !----lake module------------ + open(77,file=trim(input_dir)//"/Pfaf_Wr_lake_Kv_M0.10_mm0.40_20170330_OL7000.txt") + read(77,*)Wr_lake ! Read lake water storage (Wr_lake) + + ! Set cold start flag to False after initialization + is_coldstart=.False. + + else + ! For non-cold start, calculate the current year and day from the previous iteration + step_prev = iter - 1 + do i = ny, 1, -1 + if(step_prev > days_acc_year(i))then + yr_cur = 1989 + i ! Calculate the current year + d_res = step_prev - days_acc_year(i) ! Calculate residual days + exit + endif + enddo + + ! Determine whether the current year is a leap year + if(mod(yr_cur,4) == 0)then + days_acc_mon = days_acc_leap ! Use leap year days if it is a leap year + else + days_acc_mon = days_acc_noleap ! Use no-leap year days if it is not a leap year + endif + + ! Determine the current month and day from the residual days + do i = 12, 1, -1 + if(d_res > days_acc_mon(i))then + mon_cur = i ! Current month + day_cur = d_res - days_acc_mon(i) ! Current day + exit + endif + enddo + + ! Convert year, month, and day to string format + write(yr_s,'(I4)')yr_cur + write(mon_s,'(I2.2)')mon_cur + write(day_s,'(I2.2)')day_cur + + ! Read water storage data for the specific date (year, month, day) + open(77,file=trim(output_dir)//"/Pfaf_Ws_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Ws ! Read soil water storage (Ws) + + open(77,file=trim(output_dir)//"/Pfaf_Wr_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Wr ! Read routing water storage (Wr) + + !----reservoir module------- + open(77,file=trim(output_dir)//"Pfaf_Wr_res_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Wr_res ! Read reservoir water storage (Wr_res) + + !----lake module------------ + open(77,file=trim(output_dir)//"Pfaf_Wr_lake_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + read(77,*)Wr_lake ! Read lake water storage (Wr_lake) + + ! Optionally scale the water storage values (commented out) + ! Ws = Ws * 1.D9 + ! Wr = Wr * 1.D9 + endif + +end subroutine read_restart +!------------------------------ +subroutine read_runoff(nc,ny,iter,days_acc_year,days_acc_noleap,days_acc_leap,Qrunf,yr_s,mon_s,day_s,d_res,mon_cur) + integer,intent(in) :: nc,ny,iter + integer,intent(in) :: days_acc_year(ny),days_acc_noleap(12),days_acc_leap(12) + real*8,intent(inout) :: Qrunf(nc) + character(len=50),intent(inout) :: yr_s,mon_s,day_s + integer,intent(out) :: d_res,mon_cur + + real*8,allocatable,dimension(:,:,:) :: runoff,runoffr,baseflow ! Declare 3D arrays for runoff and baseflow + + integer :: i,yr_cur,day_cur + integer :: days_acc_mon(12) ! Array to store accumulated days for current month + + + ! Determine current year based on iteration days + do i=ny,1,-1 + if(iter>days_acc_year(i))then + yr_cur=1989+i ! Set current year + d_res=iter-days_acc_year(i) ! Calculate residual days + exit + endif + enddo + + ! Set days_acc_mon based on whether the current year is a leap year + if(mod(yr_cur,4)==0)then + days_acc_mon=days_acc_leap ! Use leap year days + else + days_acc_mon=days_acc_noleap ! Use non-leap year days + endif + + ! Determine current month and day based on residual days + do i=12,1,-1 + if(d_res>days_acc_mon(i))then + mon_cur=i ! Set current month + day_cur=d_res-days_acc_mon(i) ! Set current day + exit + endif + enddo + + ! Write current year, month, and day as strings + write(yr_s,'(I4)')yr_cur + write(mon_s,'(I2.2)')mon_cur + write(day_s,'(I2.2)')day_cur + print *,trim(yr_s)," ",trim(mon_s)," ",trim(day_s) + + ! Allocate memory for runoff, runoffr, and baseflow arrays + allocate(runoff(nlon,nlat,1),runoffr(nlon,nlat,1),baseflow(nlon,nlat,1)) + + ! Read runoff and baseflow data from NetCDF files + call read_ncfile_double3d(trim(runoff_dir)//"/Y"//trim(yr_s)//"/M"//trim(mon_s)//"/SMAP_Nature_v10.0_M36.tavg24_2d_lnd_Nx."//trim(yr_s)//trim(mon_s)//trim(day_s)//"_1200z.nc4","RUNOFF",runoff,nlon,nlat,1) + call read_ncfile_double3d(trim(runoff_dir)//"/Y"//trim(yr_s)//"/M"//trim(mon_s)//"/SMAP_Nature_v10.0_M36.tavg24_2d_lnd_Nx."//trim(yr_s)//trim(mon_s)//trim(day_s)//"_1200z.nc4","BASEFLOW",baseflow,nlon,nlat,1) + + ! Combine runoff and baseflow, and convert to daily values + runoff=runoff+baseflow + runoff=runoff*86400.D0 ! Convert to mm/day + + ! Reverse the y-direction of the runoff array + do i=1,406 + runoffr(:,i,:)=runoff(:,407-i,:) + enddo + runoff=runoffr + + ! Convert from mm/day to kg/s and store in Qrunf + Qrunf=M36_to_cat(runoff(:,:,1),nlon,nlat,nc,input_dir) + + ! Deallocate the arrays to free memory + deallocate(runoff,runoffr,baseflow) + + ! The following lines are commented out, but they suggest reading runoff from a text file instead of NetCDF + !open(77,file="/Users/zsp/Desktop/work/river/OL7000_Pfaf/runoff_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt") + !read(77,*)Qrunf + !Qrunf=Qrunf*rho !m3/s -> kg/s + +end subroutine read_runoff +!------------------------------ +subroutine write_output(nc,yr_s,mon_s,day_s,Qout,Ws,Wr,Q_res,Wr_res,Q_lake,Wr_lake) + integer,intent(in) :: nc + character(len=50),intent(in) :: yr_s,mon_s,day_s + real*8,intent(in) :: Qout(nc),Ws(nc),Wr(nc),Q_res(nc),Wr_res(nc),Q_lake(nc),Wr_lake(nc) + + integer :: i + + ! Open file to write Qout (discharge) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Qr_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Qout(i)/1.D3 ! Convert from m^3/s to km^3/s + enddo + + ! Open file to write Ws (soil water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Ws_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Ws(i) ! Write Ws values, unit in kg + enddo + + ! Open file to write Wr (river water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Wr_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Wr(i) ! Write Wr values, unit in kg + enddo + + !-----------reservoir module---------------- + ! Open file to write Q_res (reservoir discharge) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Q_res_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Q_res(i)/1.D3 ! Convert from m^3/s to km^3/s + enddo + + ! Open file to write Wr_res (reservoir water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Wr_res_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Wr_res(i) ! Write Wr_res values, unit in kg + enddo + !------------------------------------------- + + !-----------lake module--------------------- + ! Open file to write Q_lake (lake discharge) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Q_lake_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Q_lake(i)/1.D3 ! Convert from m^3/s to km^3/s + enddo + + ! Open file to write Wr_lake (lake water storage) values and write to the file + open(88,file=trim(output_dir)//"/Pfaf_Wr_lake_Kv_"//trim(yr_s)//trim(mon_s)//trim(day_s)//"_OL7000.txt") + do i=1,nc + write(88,*)Wr_lake(i) ! Write Wr_lake values, unit in kg + enddo + !------------------------------------------- + + ! Print out the sum of Wr (river water storage) in petagrams (10^12 kg) + print *,"sum of Wr is ", sum(Wr)/1.D12 + ! Print out the sum of Wr_lake (lake water storage) in petagrams (10^12 kg) + print *,"sum of Wr_lake is ", sum(Wr_lake)/1.D12 + ! Print out the sum of Wr_res (reservoir water storage) in petagrams (10^12 kg) + print *,"sum of Wr_res is ", sum(Wr_res)/1.D12 + +end subroutine write_output + +end module river_io \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 new file mode 100644 index 000000000..b2674e01d --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 @@ -0,0 +1,248 @@ +program main + +use omp_lib ! OpenMP library for parallel computing +use reservoir ! Module for reservoir operations +use lake ! Module for lake operations +use river_io ! Module for river input/output + +implicit none + +! Define parameters and constants +real*8, parameter :: small = 1.D-48 ! A small value threshold for numerical comparisons +integer, parameter :: step_start = 9221 ! Start timestep (represents 1990-01-01) +integer, parameter :: step_end = 9226 ! End timestep (adjusted for different ranges) +logical :: is_coldstart = .True. ! Logical flag for cold start +integer, parameter :: ny = 33 ! Number of years (33 years) + +real*8, parameter :: fac_kstr = 0.025D0 ! Factor for local stream scaling +real*8, parameter :: M = 0.45D0 ! Parameter in hydraulic geometry formula +real*8, parameter :: mm = 0.35D0 ! Parameter in hydraulic geometry formula + +real*8, parameter :: dt = 86400.D0 ! Time step in seconds (1 day) + +integer, parameter :: nmax = 373 ! Maximum number of catchments in a river +integer, parameter :: upmax = 34 ! Maximum number of upstream basins +integer, parameter :: nc = 291284 ! Total number of river cells +real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 + +! Declare variables +integer :: i, j, n, iter ! Loop indices and iteration variable + +! Allocate dynamic arrays for variables +integer, allocatable, dimension(:) :: nts ! Array for timestep indices +real*8, allocatable, dimension(:) :: qstr_clmt, qri_clmt, qin_clmt, & + llc_ori, llc, lstr, & + Qrunf, nume, deno, & + alp_s, alp_r, K, Kstr +real*8, allocatable, dimension(:) :: Ws, Wr ! Water storage arrays for stream and river +real*8, allocatable, dimension(:) :: Qs0, ks, Ws_last, Qs, & + Qr0, kr, Cl, Al +real*8, allocatable, dimension(:) :: C1, C2, Qout, Qin, A1, P, B1, B2 +integer, allocatable, dimension(:) :: nup ! Number of upstream nodes +integer, allocatable, dimension(:,:) :: upID ! IDs of upstream cells +real*8 :: co1, co2, co3 ! Coefficients used in calculations +integer :: ui ! Temporary upstream index variable + +real*8, allocatable, dimension(:) :: lon, lat ! Longitude and latitude arrays + +! Reservoir module variables +logical, parameter :: use_res = .True. ! Flag to enable reservoir module +integer, parameter :: nres = 7250 ! Number of reservoirs +integer, allocatable, dimension(:) :: active_res, fld_res, cat2res ! Reservoir attributes +real*8, allocatable, dimension(:) :: Wr_res, Q_res, cap_res, Qavg_res, ai_res, Qfld_thres, wid_res +integer, allocatable, dimension(:) :: type_res ! Type of reservoir (0=inactive, 1-7=different functions) +real*8, allocatable, dimension(:,:) :: irr_sea_frac ! Irrigation and sea fraction for reservoirs + +! Lake module variables +logical, parameter :: use_lake = .True. ! Flag to enable lake module +integer, parameter :: nlake = 3917 ! Number of lakes +integer, allocatable, dimension(:) :: active_lake ! Active lake flag +real*8, allocatable, dimension(:) :: area_lake, Wr_lake, Q_lake ! Lake attributes + +! Time-related variables +integer,dimension(ny) :: days_in_year=(/365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,& + 365,365,366,365,365/) ! Number of days per year from 1990 to 2020 +integer :: days_acc_year(ny), days_acc_noleap(12), days_acc_leap(12) ! Accumulated days for leap and non-leap years +integer :: yr_cur, mon_cur, day_cur, d_res, step_prev ! Current date variables and previous step +character(len=50) :: yr_s, mon_s, day_s ! Year, month, day strings +character(len=500) :: inputdir ! Input directory path + +! Allocate memory for variables +allocate(nts(nc)) +allocate(qstr_clmt(nc), qri_clmt(nc), qin_clmt(nc)) +allocate(llc_ori(nc), llc(nc), lstr(nc)) +allocate(Qrunf(nc), nume(nc), deno(nc), alp_s(nc), alp_r(nc)) +allocate(Ws(nc), Wr(nc)) +allocate(Qs0(nc), ks(nc), Ws_last(nc), Qs(nc)) +allocate(Qr0(nc), kr(nc), Cl(nc), Al(nc)) +allocate(C1(nc), C2(nc), Qout(nc), Qin(nc), A1(nc), P(nc), B1(nc), B2(nc)) +allocate(nup(nc)) +allocate(upID(upmax,nc)) +allocate(K(nc), Kstr(nc)) + +! Read input data +call read_input(nc, ny, upmax, days_in_year, fac_kstr, qstr_clmt, qri_clmt, nts, upID, nup, llc_ori, lstr, qin_clmt, K, Kstr, days_acc_year, days_acc_noleap, days_acc_leap, inputdir) + +! Initialize reservoir module +call res_init(inputdir, nres, nc, use_res, active_res, Wr_res, Q_res, type_res, cap_res, Qavg_res, ai_res, fld_res, Qfld_thres, irr_sea_frac, cat2res, wid_res) + +! Initialize lake module +call lake_init(inputdir, use_lake, nc, nlake, nres, active_res, active_lake, area_lake, Wr_lake, Q_lake) + +! Calculate llc (length of river channel) +nume = qri_clmt**(2.D0-M) - qin_clmt**(2.D0-M) ! Numerator for the llc calculation +deno = (2.D0-M) * (qri_clmt - qin_clmt) * (qri_clmt**(1.D0-M)) ! Denominator for the llc calculation +where(abs(deno) > small) llc = llc_ori * (nume / deno) ! Compute llc where denominator is not too small +where(abs(deno) <= small) llc = llc_ori * 0.5D0 ! Set llc to half of original value if denominator is small + +! Calculate alp_s (slope coefficient) and alp_r (river coefficient) +where(qstr_clmt > small) alp_s = (rho**(-M) * qstr_clmt**(M-mm) * Kstr * (0.5D0*lstr)**(-1.D0))**(1.D0/(1.D0-mm)) ! For non-zero streamflow +where(qstr_clmt <= small) alp_s = 0.D0 ! If streamflow is too small, set alp_s to 0 + +where(qri_clmt > small) alp_r = (rho**(-M) * qri_clmt**(M-mm) * K * llc**(-1.D0))**(1.D0/(1.D0-mm)) ! For non-zero river input +where(qri_clmt <= small) alp_r = 0.D0 ! If river input is too small, set alp_r to 0 + +!temporal loop +DO iter=step_start,step_end + + ! Read the state of the system from a restart file for the current iteration + call read_restart(iter,is_coldstart,ny,nc,days_acc_year,days_acc_noleap,days_acc_leap,Ws,Wr,Wr_res,Wr_lake) + + ! Read runoff data for the current time step + call read_runoff(nc,ny,iter,days_acc_year,days_acc_noleap,days_acc_leap,Qrunf,yr_s,mon_s,day_s,d_res,mon_cur) + + !$omp parallel default(shared) + !$omp workshare + + ! Update state variables: ks, Ws, and Qs + where(Qrunf<=small)Qrunf=0.D0 ! Set runoff to zero if it's too small + Qs0=max(0.D0,alp_s * Ws**(1.D0/(1.D0-mm))) ! Initial flow from stream storage (kg/s) + ks=max(0.D0,(alp_s/(1.D0-mm)) * Ws**(mm/(1.D0-mm))) ! Flow coefficient (s^-1) + Ws_last=Ws ! Store the current water storage + where(ks>small) Ws=Ws + (Qrunf-Qs0)/ks*(1.D0-exp(-ks*dt)) ! Update storage (kg) + where(ks<=small) Ws=Ws + (Qrunf-Qs0)*dt ! Simplified update if ks is small + Ws=max(0.D0,Ws) ! Ensure storage is non-negative + Qs=max(0.D0,Qrunf-(Ws-Ws_last)/dt) ! Calculate the stream flow (kg/s) + + ! Calculate variables related to river routing: Qr0, kr + Qr0=max(0.D0,alp_r * Wr**(1.D0/(1.D0-mm))) ! River flow based on water storage (kg/s) + kr=max(0.D0,(alp_r/(1.D0-mm)) * Wr**(mm/(1.D0-mm))) ! Flow coefficient for river (s^-1) + + ! Update Cl and Al + where(kr>small.and.abs(kr-ks)>small) Cl=Wr + (Qrunf-Qr0)/kr*(1.D0-exp(-kr*dt)) + (Qrunf-Qs0)/(kr-ks)*(exp(-kr*dt)-exp(-ks*dt)) + where(kr>small.and.abs(kr-ks)<=small) Cl=Wr + (Qrunf-Qr0)/kr*(1.D0-exp(-kr*dt)) - (Qrunf-Qs0)*dt*exp(-kr*dt) + where(kr<=small.and.ks>small) Cl=Wr + (Qrunf-Qr0)*dt - (Qrunf-Qs0)/ks*(1.D0-exp(-ks*dt)) + where(kr<=small.and.ks<=small) Cl=Wr + (Qs0-Qr0)*dt + Al=Qs+Wr/dt-Cl/dt ! Update flow variables + + ! Initialize variables for river routing process + C1=0.D0 + C2=0.D0 + Qin=0.D0 + Qout=0.D0 + A1=0.D0 + P=0.D0 + B1=0.D0 + B2=0.D0 + + !$omp end workshare + !$omp end parallel + + ! Reservoir module: reset reservoir flow + Q_res=0.D0 + if(d_res==366)d_res=365 ! Handle leap year day adjustment + + ! Lake module: reset lake flow + Q_lake=0.D0 + + ! Process river routing by going through each node from upstream to downstream + do n=nmax,0,-1 + + !$OMP PARALLEL default(shared) private(i,j,ui,co1,co2,co3) + !$OMP DO + + ! Loop over each catchment to update the water storage and flow + do i=1,nc + if(nts(i)==n)then ! If the current node matches the iteration step + + ! Process upstream dependencies if any exist + if(nup(i)>=1)then + do j=1,nup(i) + ui=upID(j,i) + if(ui==-1)exit ! Exit loop if no more upstream IDs + + ! Calculate flow coefficients based on flow conditions + if(kr(i)>small)then + co1=max(0.D0,(1.D0-exp(-kr(i)*dt))/kr(i)) + else + co1=dt + endif + C1(i)=C1(i)+co1*B1(ui) + + if(abs(kr(i)-kr(ui))>small)then + co2=-(exp(-kr(i)*dt)-exp(-kr(ui)*dt))/(kr(i)-kr(ui)) + else + co2=dt*exp(-kr(i)*dt) + endif + C2(i)=C2(i)+co2*B2(ui) + + ! Process reservoir and lake flows, if active + if(active_res(ui)==1.and.active_lake(ui)==0)then + Qin(i)=Qin(i)+Q_res(ui) + else if(active_res(ui)==0.and.active_lake(ui)==1)then + Qin(i)=Qin(i)+Q_lake(ui) + else if(active_res(ui)==1.and.active_lake(ui)==1)then + Qin(i)=Qin(i)+Q_res(ui) + else + Qin(i)=Qin(i)+Qout(ui) + endif + enddo + endif + + ! Update water storage in the current node + Wr(i)=max(0.D0,Cl(i)+C1(i)+C2(i)) + A1(i)=Qin(i)-C1(i)/dt-C2(i)/dt + Qout(i)=max(0.D0,Al(i)+A1(i)) + + ! Calculate flow parameters based on river flow characteristics + if(kr(i)>small.and.Qin(i)+Qrunf(i)>small)then + co3=max(0.D0,(1.D0-exp(-kr(i)*dt))/kr(i)) + P(i)=(dt*Qout(i)-co3*Qr0(i))/((Qin(i)+Qrunf(i))*(dt-co3)) + if(P(i)>0.5D0.and.P(i)<1.5D0)then + B1(i)=P(i)*(Qin(i)+Qrunf(i)) + B2(i)=-P(i)*(Qin(i)+Qrunf(i))+Qr0(i) + else + B1(i)=Qout(i) + B2(i)=0.D0 + endif + else + B1(i)=Qout(i) + B2(i)=0.D0 + P(i)=-9999. + endif + + ! Call lake and reservoir calculation subroutines + call lake_cal(active_lake(i),area_lake(i),Q_lake(i),Wr_lake(i),Qout(i),B1(i),B2(i)) + call res_cal(active_res(i),active_lake(i),Qout(i),Q_lake(i),type_res(i),ai_res(i),cat2res(i),& + irr_sea_frac(cat2res(i),mon_cur),Q_res(i),Qavg_res(i),wid_res(i),fld_res(i),Wr_res(i),Qfld_thres(i),cap_res(i),B1(i),B2(i)) + + endif + enddo + + !$OMP END DO + !$OMP END PARALLEL + + enddo + + ! Write the output for the current time step + call write_output(nc,yr_s,mon_s,day_s,Qout,Ws,Wr,Q_res,Wr_res,Q_lake,Wr_lake) + +ENDDO + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/rwncMod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/rwncMod.f90 new file mode 100644 index 000000000..3b076e14a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/rwncMod.f90 @@ -0,0 +1,516 @@ +module rwncfile + + use ncdio + implicit none + + public :: read_ncfile_int1d + public :: read_ncfile_real1d + public :: read_ncfile_double1d + + public :: read_ncfile_int2d + public :: read_ncfile_int3d + public :: read_ncfile_real2d + public :: read_ncfile_real3d + public :: read_ncfile_double2d + public :: read_ncfile_double3d + + public :: write_ncfile_int2d + public :: write_ncfile_real2d + public :: write_ncfile_double2d + + public :: create_ncfile_byte2d + public :: create_ncfile_short2d + public :: create_ncfile_short3d + public :: create_ncfile_int3d + public :: create_ncfile_int2d + + public :: create_ncfile_long2d + public :: create_ncfile_real2d + public :: create_ncfile_real3d + public :: create_ncfile_double2d + + contains +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + integer, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real*8, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + integer, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double2d + + + subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real*8, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double3d +!------------------------------------------------------------------------------------------ + subroutine write_ncfile_int2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="write" + integer :: ncid, varid, omode + + call check_ret(nf_open(filename, nf_write, ncid), subname) + call check_ret(nf_set_fill(ncid, nf_nofill, omode), subname) + call ncd_ioglobal(varname=varname, data=var, ncid=ncid, flag='write') + call check_ret(nf_sync(ncid), subname) + call check_ret(nf_close(ncid), subname) + end subroutine write_ncfile_int2d +!------------------------------------------------------------------------------------------ + subroutine write_ncfile_real2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="write" + integer :: ncid, varid, omode + + call check_ret(nf_open(filename, nf_write, ncid), subname) + call check_ret(nf_set_fill(ncid, nf_nofill, omode), subname) + call ncd_ioglobal(varname=varname, data=var, ncid=ncid, flag='write') + call check_ret(nf_sync(ncid), subname) + call check_ret(nf_close(ncid), subname) + end subroutine write_ncfile_real2d +!------------------------------------------------------------------------------------------ + subroutine write_ncfile_double2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="write" + integer :: ncid, varid, omode + + call check_ret(nf_open(filename, nf_write, ncid), subname) + call check_ret(nf_set_fill(ncid, nf_nofill, omode), subname) + call ncd_ioglobal(varname=varname, data=var, ncid=ncid, flag='write') + call check_ret(nf_sync(ncid), subname) + call check_ret(nf_close(ncid), subname) + end subroutine write_ncfile_double2d +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_int2d(filename,varname,var,lon,lat,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) + real*8, intent(in) :: lon(nlon),lat(nlat) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat) + + lon1=lon + lat1=lat + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_int, dim1name='lon', & + dim2name='lat', long_name=varname, units='unitless', fill_value=-9999.) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_int2d + + subroutine create_ncfile_long2d(filename,varname,var,lon,lat,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer*8, intent(inout) :: var(nlon,nlat) + real*8, intent(in) :: lon(nlon),lat(nlat) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat) + + lon1=lon + lat1=lat + call check_ret(nf_create(trim(filename), NF_NETCDF4, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon',& + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat',& + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_int64, dim1name='lon',& + dim2name='lat', long_name=varname, units='unitless',fill_value=-9999.) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_long2d + +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_byte2d(filename,varname,var,lon,lat,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + byte, intent(inout) :: var(nlon,nlat) + real*8, intent(in) :: lon(nlon),lat(nlat) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat) + + lon1=lon + lat1=lat + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_byte, dim1name='lon', & + dim2name='lat', long_name=varname, units='unitless',fill_value=-128. ) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_byte2d + +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_short2d(filename,varname,var,lon,lat,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer*2, intent(inout) :: var(nlon,nlat) + real*8, intent(in) :: lon(nlon),lat(nlat) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat) + + lon1=lon + lat1=lat + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_short, dim1name='lon', & + dim2name='lat', long_name=varname, units='unitless',fill_value=-9999. ) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_short2d + + +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_real2d(filename,varname,var,lon,lat,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) + real*8, intent(in) :: lon(nlon),lat(nlat) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat) + + lon1=lon + lat1=lat + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_float, dim1name='lon', & + dim2name='lat', long_name=varname, units='unitless', fill_value=-9999.) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_real2d + +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_short3d(filename,varname,var,lon,lat,lev,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + integer*2, intent(inout) :: var(nlon,nlat,nlev) + real*8, intent(in) :: lon(nlon),lat(nlat),lev(nlev) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat), lev1(nlev) + + lon1=lon + lat1=lat + lev1=lev + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call check_ret(nf_def_dim(ncid,'lev',nlev, dimid), subname) + + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname='lev', xtype=nf_double, dim2name='lev', & + long_name='level', units='unitless') + + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_short, dim1name='lon', & + dim2name='lat', dim3name='lev', long_name=varname, units='unitless', fill_value=-9999.) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lev', data=lev1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_short3d +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_int3d(filename,varname,var,lon,lat,lev,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + integer, intent(inout) :: var(nlon,nlat,nlev) + real*8, intent(in) :: lon(nlon),lat(nlat),lev(nlev) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat), lev1(nlev) + + lon1=lon + lat1=lat + lev1=lev + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call check_ret(nf_def_dim(ncid,'lev',nlev, dimid), subname) + + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname='lev', xtype=nf_double, dim2name='lev', & + long_name='level', units='unitless') + + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_int, dim1name='lon', & + dim2name='lat', dim3name='lev', long_name=varname, units='unitless', fill_value=-9999.) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lev', data=lev1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_int3d +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_real3d(filename,varname,var,lon,lat,lev,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real, intent(inout) :: var(nlon,nlat,nlev) + real*8, intent(in) :: lon(nlon),lat(nlat),lev(nlev) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat), lev1(nlev) + + lon1=lon + lat1=lat + lev1=lev + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call check_ret(nf_def_dim(ncid,'lev',nlev, dimid), subname) + + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname='lev', xtype=nf_double, dim2name='lev', & + long_name='level', units='unitless') + + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_float, dim1name='lon', & + dim2name='lat', dim3name='lev', long_name=varname, units='unitless', fill_value=-9999.) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lev', data=lev1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_real3d + +!------------------------------------------------------------------------------------------ + subroutine create_ncfile_double2d(filename,varname,var,lon,lat,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) + real*8, intent(in) :: lon(nlon),lat(nlat) + + character(len=4) :: subname="create" + integer :: ncid, varid, dimid + real*8 :: lon1(nlon), lat1(nlat) + + lon1=lon + lat1=lat + call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) + call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) + call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) + call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & + long_name='longtitude', units='degrees_east') + call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & + long_name='latitude', units='degrees_north') + call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_double, dim1name='lon', & + dim2name='lat', long_name=varname, units='unitless', fill_value=-9999.) + call check_ret(nf_enddef(ncid), subname) + call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) + call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) + call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) + call check_ret(nf_close(ncid), subname) + end subroutine create_ncfile_double2d +!------------------------------------------------------------------------------------------ +end module rwncfile + From 54950b8f1a70dddec77b37cd228649d36841494e Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Mon, 28 Oct 2024 16:22:34 -0400 Subject: [PATCH 02/27] change some paths for Discover --- .../GEOSland_GridComp/GEOSroute_GridComp/build | 7 ++----- .../GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 | 8 ++++---- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build index 7145a5e6e..9db6a49b4 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build @@ -10,9 +10,6 @@ array=(${string//./ }) FILENAME=${array[0]} -#NETCDF_PATH=/discover/nobackup/yzeng3/apps/netcdf-4.2.1.1 -NETCDF_PATH=/Users/zsp/apps/netcdf-4.2.1.1 +NETCDF_PATH=/discover/nobackup/yzeng3/apps/netcdf-4.2.1.1 - - -ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -L/opt/intel/oneapi/compiler/2022.2.1/mac/compiler/lib -lnetcdf -lnetcdff -o ${FILENAME}.out +ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -L/usr/local/intel/oneapi/2021/compiler/2021.4.0/linux/lib -lnetcdf -lnetcdff -o ${FILENAME}.out diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 index ce78a064c..d8472d8fe 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 @@ -9,9 +9,9 @@ module river_io public :: read_input,read_restart,read_runoff,write_output real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 -character(len=500) :: input_dir="input/" ! Directory for input files -character(len=500) :: output_dir="/Users/zsp/Desktop/work/ROUTING_PR/results_temp_PR/" ! Directory for output files -character(len=500) :: runoff_dir="/Users/zsp/Desktop/work/river/SMAP_Nature_v10.0_M36/" ! Directory for runoff files +character(len=500) :: input_dir="/discover/nobackup/yzeng3/work/river_routing_model_offline/input/" ! Directory for input files +character(len=500) :: output_dir="/discover/nobackup/yzeng3/river_output/" ! Directory for output files +character(len=500) :: runoff_dir="/discover/nobackup/yzeng3/GEOldas_output/" ! Directory for runoff files integer :: nlon=964 !for M36, change to 3856 for M09 integer :: nlat=406 !for M36, change to 1624 for M09 @@ -316,4 +316,4 @@ subroutine write_output(nc,yr_s,mon_s,day_s,Qout,Ws,Wr,Q_res,Wr_res,Q_lake,Wr_la end subroutine write_output -end module river_io \ No newline at end of file +end module river_io From 982bdd91e35300385f9f9dbf098ef6905f5c58a8 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Tue, 29 Oct 2024 10:48:58 -0400 Subject: [PATCH 03/27] script build is replaced by run --- .../GEOSroute_GridComp/build | 15 ------------- .../GEOSland_GridComp/GEOSroute_GridComp/run | 22 +++++++++++++++++++ 2 files changed, 22 insertions(+), 15 deletions(-) delete mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build deleted file mode 100755 index 9db6a49b4..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/build +++ /dev/null @@ -1,15 +0,0 @@ -#!/bin/bash - -if [ $# -lt 1 ]; then - echo "no f90 specified" - exit -fi - -string=$1 -array=(${string//./ }) - -FILENAME=${array[0]} - -NETCDF_PATH=/discover/nobackup/yzeng3/apps/netcdf-4.2.1.1 - -ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -L/usr/local/intel/oneapi/2021/compiler/2021.4.0/linux/lib -lnetcdf -lnetcdff -o ${FILENAME}.out diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/run b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/run new file mode 100755 index 000000000..d8ec1089f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/run @@ -0,0 +1,22 @@ +#!/bin/bash + +module load comp/intel/2021.3.0 + +if [ $# -lt 1 ]; then + echo "no f90 specified" + exit +fi + +string=$1 +array=(${string//./ }) + +FILENAME=${array[0]} + +NETCDF_PATH=/discover/nobackup/yzeng3/apps/netcdf-4.2.1.1 +LD_LIBRARY_PATH=$NETCDF_PATH/lib:$LD_LIBRARY_PATH + +#ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -L/usr/local/intel/oneapi/2021/compiler/2021.4.0/linux/lib -lnetcdf -lnetcdff -o ${FILENAME}.out + +ifort -qopenmp ncdioMod.f90 rwncMod.f90 interp_M36toPfaf.f90 river_io_mod.f90 res_mod.f90 lake_mod.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out + +./${FILENAME}.out From f2a19dafc955e01e70bef0b417043c27752c16e2 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Tue, 29 Oct 2024 15:06:38 -0400 Subject: [PATCH 04/27] readme.txt added --- .../GEOSroute_GridComp/readme.txt | 49 +++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/readme.txt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/readme.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/readme.txt new file mode 100644 index 000000000..51eba9619 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/readme.txt @@ -0,0 +1,49 @@ +README - River Routing Model Offline Version +Last Updated: 10/28/2024 +Contact: yujin.zeng@nasa.gov +Overview + +This directory contains the code required to run the offline version of the river routing model. Note that not all files in this directory pertain to the offline model. Key files include: + + run: Script for building and running the model. + ncdioMod.f90: Local NetCDF library. + rwncMod.f90: Local NetCDF I/O library. + interp_M36toPfaf.f90: Interpolation module. + river_io_mod.f90: I/O module. + res_mod.f90: Reservoir module. + lake_mod.f90: Lake module. + river_routing.f90: Main program. + +Running the Offline Model + + Set Directory Paths + In river_io_mod.f90, set: + input_dir: Path for input data, e.g., /discover/nobackup/yzeng3/work/river_routing_model_offline/input/ + runoff_dir: Path for runoff data (e.g., Catchment model 2D output in M36 or M09 resolutions). + Example for M36 resolution: /discover/nobackup/yzeng3/GEOldas_output + output_dir: Path for output data. + + Define Start and End Dates + In river_routing.f90, set step_start (start date) and step_end (end date) as days since January 1, 1990 (Day 1). Ensure these dates align with the runoff forcing period. + + Build and Run + Compile and run the model using: + ./run river_routing.f90 + +Output Format + +The output files are in .txt format, generated daily with date information in each filename. The output variables are as follows: + + Main river discharge (Pfaf_Qr_Kv_*.txt) [m鲁/s] + Main river storage (Pfaf_Wr_Kv_*.txt) [kg] + Local stream storage (Pfaf_Ws_Kv_*.txt) [kg] + Reservoir outflow (Pfaf_Q_res_Kv_*.txt) [m鲁/s] (0 for catchments without reservoirs) + Reservoir water storage (Pfaf_Wr_res_Kv_*.txt) [kg] (0 for catchments without reservoirs) + Lake outflow (Pfaf_Q_lake_Kv_*.txt) [m鲁/s] (0 for catchments without lakes) + Lake water storage (Pfaf_Wr_lake_Kv_*.txt) [kg] (0 for catchments without lakes) + +Each .txt file contains a list of 291,284 values corresponding to catchments indexed from 1 to 291,284. To convert these lists into spatial maps, use the catchment distribution map at 1-minute resolution in CatchIndex from SRTM_PfafData.nc: + + Path: /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/topo/v1/SRTM-TopoData/SRTM_PfafData.nc + +For further assistance, please contact yujin.zeng@nasa.gov. \ No newline at end of file From bf8b9a82b0da4c2e81948515f1e875fc6616b978 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Wed, 30 Oct 2024 21:17:56 -0400 Subject: [PATCH 05/27] update K_str --- .../GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 index b2674e01d..c67f63d75 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 @@ -14,7 +14,7 @@ program main logical :: is_coldstart = .True. ! Logical flag for cold start integer, parameter :: ny = 33 ! Number of years (33 years) -real*8, parameter :: fac_kstr = 0.025D0 ! Factor for local stream scaling +real*8, parameter :: fac_kstr = 0.01D0 ! Factor for local stream scaling real*8, parameter :: M = 0.45D0 ! Parameter in hydraulic geometry formula real*8, parameter :: mm = 0.35D0 ! Parameter in hydraulic geometry formula From c6e341b91fb05af136213bf438bf37663f60d0d2 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Thu, 31 Oct 2024 14:02:08 -0400 Subject: [PATCH 06/27] removing some Chinese characters in the comments --- .../GEOSroute_GridComp/ncdioMod.f90 | 235 +----------------- 1 file changed, 4 insertions(+), 231 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 index fdc73b0c5..94b50af1a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 @@ -13,7 +13,7 @@ module ncdio ! ! !PUBLIC TYPES: implicit none - include 'netcdf.inc' !netcdf库文件 + include 'netcdf.inc' ! save public :: check_ret ! checks return status of netcdf calls public :: check_var ! determine if variable is on netcdf file @@ -71,7 +71,6 @@ subroutine check_dim(ncid, dimname, value) ! ! !DESCRIPTION: ! Validity check on dimension -! 判断nc文件中指定维数dimname的长度与指定值value相等 ! !ARGUMENTS: implicit none integer, intent(in) :: ncid @@ -86,8 +85,8 @@ subroutine check_dim(ncid, dimname, value) integer :: dimid, dimlen ! temporaries !----------------------------------------------------------------------- - call check_ret(nf_inq_dimid (ncid, trim(dimname), dimid), 'check_dim') !查询维数的代码 - call check_ret(nf_inq_dimlen (ncid, dimid, dimlen), 'check_dim') !查询维数的大小 + call check_ret(nf_inq_dimid (ncid, trim(dimname), dimid), 'check_dim') + call check_ret(nf_inq_dimlen (ncid, dimid, dimlen), 'check_dim') if (dimlen /= value) then write (6,*) 'CHECK_DIM error: mismatch of input dimension ',dimlen, & ' with expected value ',value,' for variable ',trim(dimname) @@ -103,7 +102,6 @@ end subroutine check_dim ! ! !INTERFACE: subroutine check_var(ncid, varname, varid, readvar) -! 判断NC文件中是否含有名为varname的变量，如有则返回readvar=true且返回变量号varid，否则报错。 ! !DESCRIPTION: ! Check if variable is on netcdf file ! @@ -139,7 +137,6 @@ end subroutine check_var ! ! !INTERFACE: subroutine check_ret(ret, calling) -! 返回NC文件操作是否正确 ! !DESCRIPTION: ! Check return status from netcdf call ! @@ -153,7 +150,7 @@ subroutine check_ret(ret, calling) !EOP !----------------------------------------------------------------------- - if (ret /= NF_NOERR) then !如果打开nc文件出错，则提示出错信息 + if (ret /= NF_NOERR) then write(6,*)'netcdf error from ',trim(calling) call endrun(nf_strerror(ret)) end if @@ -170,22 +167,6 @@ subroutine ncd_defvar(ncid, varname, xtype, & dim1name, dim2name, dim3name, dim4name, dim5name, & long_name, units, cell_method, missing_value, fill_value, & imissing_value, ifill_value) -! 定义NC变量， -! ncid--NC文件号 -! varname--变量名称 -! xtype--变量类型 -! dim1name--第一维的名称 -! dim2name--第二维的名称 -! dim3name--第三维的名称 -! dim4name--第四维的名称 -! dim5name--第五维的名称 -! long_name--属性-变量的完整名称 -! units--属性-变量的单位 -! cell_method--属性-值的来源说明 -! missing_value--属性-实型缺测值 -! fill_value--属性-实型的缺省值 -! imissing_value--属性-整型的缺测值 -! ifill_value--属性-整型的缺省值 ! !DESCRIPTION: ! Define a netcdf variable ! @@ -292,20 +273,6 @@ end subroutine ncd_defvar subroutine ncd_iolocal_int_1d(varname, data, flag, ncid, & lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & long_name, units, readvar) -! 读/写局部一维实型变量:将一笔资料阵列写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! lb_lon--经向的起始号 -! lb_lat--纬向的起始号 -! lb_lvl--层次的起始号 -! lb_t--时间的起始号 -! ub_lon--经向的起始号 -! ub_lat--纬向的起始号 -! ub_lvl--层次的起始号 -! ub_t--时间的起始号 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O for 1d int field ! @@ -456,20 +423,6 @@ end subroutine ncd_iolocal_int_1d subroutine ncd_iolocal_real_1d(varname, data, flag, ncid, & lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & long_name, units, readvar) -! 读/写局部一维实型变量:将一笔资料阵列写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! lb_lon--经向的起始号 -! lb_lat--纬向的起始号 -! lb_lvl--层次的起始号 -! lb_t--时间的起始号 -! ub_lon--经向的起始号 -! ub_lat--纬向的起始号 -! ub_lvl--层次的起始号 -! ub_t--时间的起始号 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O for 1d int field ! @@ -619,20 +572,6 @@ end subroutine ncd_iolocal_real_1d subroutine ncd_iolocal_double_1d(varname, data, flag, ncid, & lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & long_name, units, readvar) -! 读/写局部一维实型变量:将一笔资料阵列写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! lb_lon--经向的起始号 -! lb_lat--纬向的起始号 -! lb_lvl--层次的起始号 -! lb_t--时间的起始号 -! ub_lon--经向的起始号 -! ub_lat--纬向的起始号 -! ub_lvl--层次的起始号 -! ub_t--时间的起始号 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O for 1d int field ! @@ -782,20 +721,6 @@ end subroutine ncd_iolocal_double_1d subroutine ncd_iolocal_int_2d(varname, data, flag, ncid, & lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & long_name, units, readvar) -! 读/写局部二维整型变量:将一笔资料阵列写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! lb_lon--经向的起始号 -! lb_lat--纬向的起始号 -! lb_lvl--层次的起始号 -! lb_t--时间的起始号 -! ub_lon--经向的起始号 -! ub_lat--纬向的起始号 -! ub_lvl--层次的起始号 -! ub_t--时间的起始号 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O for 2d real field ! @@ -945,20 +870,6 @@ end subroutine ncd_iolocal_int_2d subroutine ncd_iolocal_real_2d(varname, data, flag, ncid, & lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & long_name, units, readvar) -! 读/写局部二维实型变量:将一笔资料阵列写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! lb_lon--经向的起始号 -! lb_lat--纬向的起始号 -! lb_lvl--层次的起始号 -! lb_t--时间的起始号 -! ub_lon--经向的起始号 -! ub_lat--纬向的起始号 -! ub_lvl--层次的起始号 -! ub_t--时间的起始号 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O for 2d real field ! @@ -1109,20 +1020,6 @@ end subroutine ncd_iolocal_real_2d subroutine ncd_iolocal_double_2d(varname, data, flag, ncid, & lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & long_name, units, readvar) -! 读/写局部二维实型变量:将一笔资料阵列写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! lb_lon--经向的起始号 -! lb_lat--纬向的起始号 -! lb_lvl--层次的起始号 -! lb_t--时间的起始号 -! ub_lon--经向的起始号 -! ub_lat--纬向的起始号 -! ub_lvl--层次的起始号 -! ub_t--时间的起始号 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O for 2d real field ! @@ -1271,13 +1168,6 @@ end subroutine ncd_iolocal_double_2d ! ! !INTERFACE: subroutine ncd_ioglobal_int_var(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局零维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O of integer variable ! @@ -1347,13 +1237,6 @@ end subroutine ncd_ioglobal_int_var ! ! !INTERFACE: subroutine ncd_ioglobal_real_var(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局零维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O of real variable ! @@ -1423,13 +1306,6 @@ end subroutine ncd_ioglobal_real_var ! ! !INTERFACE: subroutine ncd_ioglobal_double_var(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局零维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! I/O of real variable ! @@ -1499,13 +1375,6 @@ end subroutine ncd_ioglobal_double_var ! ! !INTERFACE: subroutine ncd_ioglobal_int_1d(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局一维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! Master I/O for 1d integer data ! @@ -1575,13 +1444,6 @@ end subroutine ncd_ioglobal_int_1d ! ! !INTERFACE: subroutine ncd_ioglobal_real_1d(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局一维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! Master I/O for 1d real data ! @@ -1652,13 +1514,6 @@ end subroutine ncd_ioglobal_real_1d ! ! !INTERFACE: subroutine ncd_ioglobal_double_1d(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局一维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! Master I/O for 1d real data ! @@ -1729,13 +1584,6 @@ end subroutine ncd_ioglobal_double_1d ! ! !INTERFACE: subroutine ncd_ioglobal_int_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 2d integer array ! @@ -1807,13 +1655,6 @@ end subroutine ncd_ioglobal_int_2d ! ! !INTERFACE: subroutine ncd_ioglobal_long_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 2d integer array ! @@ -1885,13 +1726,6 @@ end subroutine ncd_ioglobal_long_2d ! ! !INTERFACE: subroutine ncd_ioglobal_byte_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 2d integer array ! @@ -1961,13 +1795,6 @@ end subroutine ncd_ioglobal_byte_2d ! ! !INTERFACE: subroutine ncd_ioglobal_short_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! 读/写全局二维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 2d integer array ! @@ -2038,15 +1865,6 @@ end subroutine ncd_ioglobal_short_2d ! !INTERFACE: subroutine ncd_ioglobal_real_2d(varname, data, flag, & ncid, long_name, units, nt, readvar) -! 读/写全局二维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! long_name--属性-变量全称 -! units--属性-变量单位 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 2d real array ! @@ -2119,15 +1937,6 @@ end subroutine ncd_ioglobal_real_2d ! !INTERFACE: subroutine ncd_ioglobal_double_2d(varname, data, flag, & ncid, long_name, units, nt, readvar) -! 读/写全局二维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! long_name--属性-变量全称 -! units--属性-变量单位 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 2d real array ! @@ -2199,15 +2008,6 @@ end subroutine ncd_ioglobal_double_2d ! !INTERFACE: subroutine ncd_ioglobal_short_3d(varname, data, flag, & ncid, long_name, units, nt, readvar) -! 读/写全局三维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! long_name--属性-变量全称 -! units--属性-变量单位 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 3d integer array ! @@ -2287,15 +2087,6 @@ end subroutine ncd_ioglobal_short_3d ! !INTERFACE: subroutine ncd_ioglobal_int_3d(varname, data, flag, & ncid, long_name, units, nt, readvar) -! 读/写全局三维整型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! long_name--属性-变量全称 -! units--属性-变量单位 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 3d integer array ! @@ -2376,15 +2167,6 @@ end subroutine ncd_ioglobal_int_3d ! !INTERFACE: subroutine ncd_ioglobal_real_3d(varname, data, flag, & ncid, long_name, units, nt, readvar) -! 读/写全局三维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! long_name--属性-变量全称 -! units--属性-变量单位 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 3d real array ! @@ -2465,15 +2247,6 @@ end subroutine ncd_ioglobal_real_3d ! !INTERFACE: subroutine ncd_ioglobal_double_3d(varname, data, flag, & ncid, long_name, units, nt, readvar) -! 读/写全局三维实型变量:将所有的资料阵列均写入档案中 -! varname--变量名 -! data--变量存储数组 -! long_name--属性-变量全称 -! units--属性-变量单位 -! flag--读/写的标记 -! ncid--NC文件对应的文件号 -! nt--时间步 -! readvar--所读取的变量是否存在于该NC文件中 ! !DESCRIPTION: ! netcdf I/O of global 3d real array ! From d2a0c9571f70ce75a66aff838bd5e05c575a367b Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Tue, 5 Nov 2024 11:45:27 -0500 Subject: [PATCH 07/27] more cleaning up --- .../GEOSroute_GridComp/res_mod.f90 | 72 +++++++------------ .../GEOSroute_GridComp/river_routing.f90 | 4 +- 2 files changed, 28 insertions(+), 48 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 index 228cf4bea..3082a0bfe 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 @@ -10,8 +10,8 @@ module reservoir real*8, parameter :: fac_elec_a = 0.30D0 ! Coefficient for hydropower calculation real*8, parameter :: fac_elec_b = 2.00D0 ! Exponent for hydropower calculation -real*8, parameter :: fac_irr_a = 0.225D0 ! Coefficient for irrigation calculation (arid areas) -real*8, parameter :: fac_irr_b = 100.D0 ! Scaling factor for irrigation (arid areas) +real*8, parameter :: fac_irr_a = 0.01D0 ! Coefficient for irrigation calculation (arid areas) +real*8, parameter :: fac_irr_b = 3.00D0 ! Scaling factor for irrigation (arid areas) real*8, parameter :: fac_sup_a = 0.03D0 ! Coefficient for water supply calculation real*8, parameter :: fac_sup_b = 2.00D0 ! Exponent for water supply calculation real*8, parameter :: fac_other_a = 0.20D0 ! Coefficient for other reservoir types @@ -54,16 +54,14 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c ! Allocate memory for each array allocate(flag_grand(nres),catid_grand(nres),active_res(nc)) allocate(Wr_res(nc),Q_res(nc)) - allocate(elec_grand(nres),type_res(nc),cap_grand(nres),cap_res(nc),area_grand(nres),power_grand(nres)) + allocate(elec_grand(nres),type_res(nc),cap_grand(nres),cap_res(nc),area_grand(nres)) allocate(area_res(nc),area_max_res(nc)) - allocate(Qavg_grand(nres),Qavg_res(nc)) - allocate(ai_grand(nres),irrsup_grand(nres),ai_res(nc)) + allocate(irrsup_grand(nres)) allocate(fld_grand(nres),fld_res(nc),Qfld_thres(nc),supply_grand(nres)) - allocate(irr_sea_frac(nres,12),irr_grand(nres)) + allocate(irr_grand(nres)) allocate(cat2res(nc)) allocate(nav_grand(nres),rec_grand(nres)) allocate(other_grand(nres)) - allocate(Wres_tar(365,nres)) allocate(wid_res(nc)) allocate(realuse_grand(nres)) @@ -77,11 +75,11 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c cap_grand=cap_grand*1.D6*rho ! Convert capacity from million cubic meters (MCM) to kilograms (kg) open(77,file=trim(input_dir)//"/hydroelec_grand.txt") read(77,*)elec_grand - open(77,file=trim(input_dir)//"/Qavg_res_2016_2020_OL7000.txt") - read(77,*)Qavg_grand - Qavg_grand=Qavg_grand*rho ! Convert flow rate from cubic meters per second (m3/s) to kilograms per second (kg/s) - open(77,file=trim(input_dir)//"/ai_grand.txt") - read(77,*)ai_grand + !open(77,file=trim(input_dir)//"/Qavg_res_2016_2020_OL7000.txt") + !read(77,*)Qavg_grand + !Qavg_grand=Qavg_grand*rho ! Convert flow rate from cubic meters per second (m3/s) to kilograms per second (kg/s) + !open(77,file=trim(input_dir)//"/ai_grand.txt") + !read(77,*)ai_grand open(77,file=trim(input_dir)//"/irrmainsec_noelec_grand.txt") read(77,*)irrsup_grand open(77,file=trim(input_dir)//"/fldmainsec_grand.txt") @@ -103,8 +101,8 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c open(77,file=trim(input_dir)//"/area_skm_grand.txt") read(77,*)area_grand area_grand=area_grand*1.D6 ! Convert area from square kilometers (km2) to square meters (m2) - open(77,file=trim(input_dir)//"/power_grand.txt") - read(77,*)power_grand + !open(77,file=trim(input_dir)//"/power_grand.txt") + !read(77,*)power_grand ! Set initial reservoir ID mapping cat2res=0 @@ -120,8 +118,8 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c area_res = 0.D0 ! Set reservoir area to zero area_max_res = 0.D0 ! Set max reservoir area to zero type_res = 0 ! Set reservoir type to zero - Qavg_res = 0.D0 ! Set average reservoir flow rate to zero - ai_res = 0.D0 ! Set irrigation index to zero + !Qavg_res = 0.D0 ! Set average reservoir flow rate to zero + !ai_res = 0.D0 ! Set irrigation index to zero fld_res = 0 ! Set flood status to zero active_res = 0 ! Set active reservoirs to zero realuse_grand = 0 ! Initialize real use for each reservoir to zero @@ -132,7 +130,7 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c cid = catid_grand(i) ! Get the catchment ID for the reservoir cap_res(cid) = cap_res(cid) + cap_grand(i) ! Sum up the capacities for reservoirs in the same catchment area_res(cid) = area_res(cid) + area_grand(i) ! Sum up the areas for reservoirs in the same catchment - Qavg_res(cid) = Qavg_grand(i) ! Assign average flow rate to the catchment + !Qavg_res(cid) = Qavg_grand(i) ! Assign average flow rate to the catchment if(fld_grand(i) == 1) fld_res(cid) = 1 ! Mark the catchment if it has flood control endif enddo @@ -216,9 +214,9 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c do i = 1, nres if(flag_grand(i) == 1) then cid = catid_grand(i) - if(irrsup_grand(i) == 1 .and. ai_grand(i) <= ai_thres .and. area_grand(i) >= area_max_res(cid)) then + if(irrsup_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then type_res(cid) = 1 ! Assign type 1 for irrigation supply - ai_res(cid) = ai_grand(i) ! Assign irrigation index to the catchment + !ai_res(cid) = ai_grand(i) ! Assign irrigation index to the catchment cat2res(cid) = i area_max_res(cid) = area_grand(i) endif @@ -255,10 +253,10 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c enddo ! Read irrigation and reservoir target data from NetCDF files - call read_ncfile_double2d(trim(input_dir)//"/irr_grand_frac.nc", "data", irr_sea_frac, nres, 12) - call read_ncfile_double2d(trim(input_dir)//"/Wr_tar_Dang.nc", "data", Wres_tar, 365, nres) + ! call read_ncfile_double2d(trim(input_dir)//"/irr_grand_frac.nc", "data", irr_sea_frac, nres, 12) + ! call read_ncfile_double2d(trim(input_dir)//"/Wr_tar_Dang.nc", "data", Wres_tar, 365, nres) - Wres_tar = Wres_tar * 1.D6 * rho ! Convert from million cubic meters (MCM) to kilograms (kg) + ! Wres_tar = Wres_tar * 1.D6 * rho ! Convert from million cubic meters (MCM) to kilograms (kg) ! Deactivate reservoirs if the use_res flag is set to False if(use_res == .False.) active_res = 0 @@ -267,9 +265,9 @@ end subroutine res_init !----------------------- ! Reservoir calculation subroutine -subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,ai_res,cat2res,irr_sea_frac,Q_res,Qavg_res,wid_res,fld_res,Wr_res,Qfld_thres,cap_res,B1,B2) +subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,cat2res,Q_res,wid_res,fld_res,Wr_res,Qfld_thres,cap_res,B1,B2) integer, intent(in) :: active_res, type_res, active_lake, cat2res, fld_res - real*8, intent(in) :: Qout, Q_lake, ai_res, irr_sea_frac, Qavg_res, wid_res, Qfld_thres, cap_res + real*8, intent(in) :: Qout, Q_lake, wid_res, Qfld_thres, cap_res real*8, intent(inout) :: Q_res, Wr_res, B1, B2 integer :: rid ! Reservoir ID @@ -285,34 +283,16 @@ subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,ai_res,cat2res,ir Qin_res = Q_lake ! Inflow from lake endif - ! Irrigation reservoir in arid regions - if (type_res == 1) then - if (ai_res <= 0.2D0) then - ! Calculate the coefficient for very arid regions - coe = fac_irr_a * log(fac_irr_b * ai_res) - else if (ai_res <= ai_thres) then - ! Calculate coefficient based on aridity index - rid = cat2res - irrfac = irr_sea_frac * 12.D0 ! Seasonal irrigation factor - coe = (fac_irr_a * log(fac_irr_b * 0.2D0) * (ai_thres - ai_res) + irrfac * (ai_res - 0.2D0)) / (ai_thres - 0.2D0) - else - coe = irrfac ! Irrigation factor for higher aridity index - endif - coe = min(coe, 5.D0) ! Limit maximum coefficient - coe = max(0.D0, coe) ! Ensure coefficient is non-negative - Q_res = coe * Qavg_res ! Calculate the reservoir outflow based on average flow + ! Irrigation reservoir + if (type_res == 1 .or. type_res == 3) then + alp_res = fac_irr_a * ((1.D0 / (wid_res / 1.D3)) ** fac_irr_b) / 3600.D0 ! irrigation coefficient + Q_res = alp_res * Wr_res ! Outflow based on water storage ! Hydropower reservoir else if (type_res == 2) then alp_res = fac_elec_a * ((1.D0 / (wid_res / 1.D3)) ** fac_elec_b) / 3600.D0 ! Hydropower coefficient Q_res = alp_res * Wr_res ! Outflow based on water storage - ! Irrigation reservoir - else if (type_res == 3) then - rid = cat2res - irrfac = irr_sea_frac * 12.D0 ! Seasonal irrigation factor - Q_res = irrfac * Qavg_res ! Outflow based on irrigation factor and average flow - ! Water supply reservoir else if (type_res == 4) then alp_res = fac_sup_a * ((1.D0 / (wid_res / 1.D3)) ** fac_sup_b) / 3600.D0 ! Supply coefficient diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 index c67f63d75..f17167930 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 @@ -229,8 +229,8 @@ program main ! Call lake and reservoir calculation subroutines call lake_cal(active_lake(i),area_lake(i),Q_lake(i),Wr_lake(i),Qout(i),B1(i),B2(i)) - call res_cal(active_res(i),active_lake(i),Qout(i),Q_lake(i),type_res(i),ai_res(i),cat2res(i),& - irr_sea_frac(cat2res(i),mon_cur),Q_res(i),Qavg_res(i),wid_res(i),fld_res(i),Wr_res(i),Qfld_thres(i),cap_res(i),B1(i),B2(i)) + call res_cal(active_res(i),active_lake(i),Qout(i),Q_lake(i),type_res(i),cat2res(i),& + Q_res(i),wid_res(i),fld_res(i),Wr_res(i),Qfld_thres(i),cap_res(i),B1(i),B2(i)) endif enddo From 5e9377af09475c2258ffa4afd2298e16d35d20fc Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Mon, 2 Dec 2024 15:02:57 -0500 Subject: [PATCH 08/27] move offline model to dir offline --- .../GEOSroute_GridComp/{ => offline}/interp_M36toPfaf.f90 | 0 .../GEOSroute_GridComp/{ => offline}/lake_mod.f90 | 0 .../GEOSroute_GridComp/{ => offline}/ncdioMod.f90 | 0 .../GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/readme.txt | 0 .../GEOSroute_GridComp/{ => offline}/res_mod.f90 | 0 .../GEOSroute_GridComp/{ => offline}/river_io_mod.f90 | 0 .../GEOSroute_GridComp/{ => offline}/river_routing.f90 | 0 .../GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/run | 0 .../GEOSroute_GridComp/{ => offline}/rwncMod.f90 | 0 9 files changed, 0 insertions(+), 0 deletions(-) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/interp_M36toPfaf.f90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/lake_mod.f90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/ncdioMod.f90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/readme.txt (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/res_mod.f90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/river_io_mod.f90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/river_routing.f90 (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/run (100%) rename GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/{ => offline}/rwncMod.f90 (100%) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/interp_M36toPfaf.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/interp_M36toPfaf.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/lake_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/lake_mod.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/ncdioMod.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/ncdioMod.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/ncdioMod.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/readme.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/readme.txt similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/readme.txt rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/readme.txt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/res_mod.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_io_mod.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_routing.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/river_routing.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_routing.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/run b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/run similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/run rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/rwncMod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/rwncMod.f90 similarity index 100% rename from GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/rwncMod.f90 rename to GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/rwncMod.f90 From 7ceed5a523a6a050fc704e2deba4e7cbb6ef5097 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Mon, 2 Dec 2024 16:11:47 -0500 Subject: [PATCH 09/27] routing model was implemented to GEOSldas --- .../GEOSland_GridComp/GEOS_LandGridComp.F90 | 71 +- .../GEOSroute_GridComp/CMakeLists.txt | 4 +- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 1282 +++++++++-------- .../GEOSroute_GridComp/routing_model.F90 | 99 +- 4 files changed, 775 insertions(+), 681 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 index 69d73008e..59910cdd6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 @@ -31,7 +31,7 @@ module GEOS_LandGridCompMod use GEOS_CatchGridCompMod, only : CatchSetServices => SetServices use GEOS_CatchCNGridCompMod, only : CatchCNSetServices => SetServices use GEOS_IgniGridCompMod, only : IgniSetServices => SetServices -! use GEOS_RouteGridCompMod, only : RouteSetServices => SetServices + use GEOS_RouteGridCompMod, only : RouteSetServices => SetServices implicit none private @@ -195,19 +195,21 @@ subroutine SetServices ( GC, RC ) END SELECT -! IF(RUN_ROUTE == 1) THEN -! if (NUM_CATCH == 1) then -! ROUTE(1) = MAPL_AddChild(GC, NAME='ROUTE', SS=RouteSetServices, RC=STATUS) -! VERIFY_(STATUS) -! else -! do I = 1, NUM_CATCH -! WRITE(TMP,'(I3.3)') I -! GCName = 'ens' // trim(TMP) // ':ROUTE' -! ROUTE(I) = MAPL_AddChild(GC, NAME=GCName, SS=RouteSetServices, RC=STATUS) -! VERIFY_(STATUS) -! end do -! end if -! ENDIF + allocate (ROUTE(NUM_CATCH), stat=status) + VERIFY_(STATUS) + IF(RUN_ROUTE == 1) THEN + if (NUM_CATCH == 1) then + ROUTE(1) = MAPL_AddChild(GC, NAME='ROUTE', SS=RouteSetServices, RC=STATUS) + VERIFY_(STATUS) + else + do I = 1, NUM_CATCH + WRITE(TMP,'(I3.3)') I + GCName = 'ens' // trim(TMP) // ':ROUTE' + ROUTE(I) = MAPL_AddChild(GC, NAME=GCName, SS=RouteSetServices, RC=STATUS) + VERIFY_(STATUS) + end do + end if + ENDIF if (DO_FIRE_DANGER) then IGNI = MAPL_AddChild(GC, NAME='IGNI'//trim(tmp), SS=IgniSetServices, RC=STATUS) @@ -1453,16 +1455,16 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) end if -! IF(RUN_ROUTE == 1) THEN -! call MAPL_AddConnectivity ( & -! GC ,& -! SHORT_NAME = (/'RUNOFF '/) ,& -! SRC_ID = CATCH(I) ,& -! DST_ID = ROUTE(I) ,& -! -! RC=STATUS ) -! VERIFY_(STATUS) -! ENDIF + IF(RUN_ROUTE == 1) THEN + call MAPL_AddConnectivity ( & + GC ,& + SHORT_NAME = (/'RUNOFF '/) ,& + SRC_ID = CATCH(I) ,& + DST_ID = ROUTE(I) ,& + + RC=STATUS ) + VERIFY_(STATUS) + ENDIF CASE (2,3) call MAPL_AddConnectivity ( & @@ -1486,16 +1488,16 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) end if -! IF(RUN_ROUTE == 1) THEN -! call MAPL_AddConnectivity ( & -! GC ,& -! SHORT_NAME = (/'RUNOFF '/) ,& -! SRC_ID = CATCHCN(I) ,& -! DST_ID = ROUTE(I) ,& -! -! RC=STATUS ) -! VERIFY_(STATUS) -! ENDIF + IF(RUN_ROUTE == 1) THEN + call MAPL_AddConnectivity ( & + GC ,& + SHORT_NAME = (/'RUNOFF '/) ,& + SRC_ID = CATCHCN(I) ,& + DST_ID = ROUTE(I) ,& + + RC=STATUS ) + VERIFY_(STATUS) + ENDIF END SELECT END DO @@ -1669,6 +1671,7 @@ subroutine Run1(GC, IMPORT, EXPORT, CLOCK, RC ) !-------------------------------- DO I = 1, size(GCS) + if (trim(GCnames(i)) == "ROUTE") cycle call MAPL_TimerOn(MAPL,trim(GCnames(i)), RC=STATUS ); VERIFY_(STATUS) call ESMF_GridCompRun(GCS(I), importState=GIM(I), exportState=GEX(I), & CLOCK=CLOCK, PHASE=1, userRC=STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt index 8a502e3e7..7629ae8f1 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt @@ -1,10 +1,10 @@ esma_set_this () set (srcs - #GEOS_RouteGridComp.F90 + GEOS_RouteGridComp.F90 routing_model.F90 ) -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL ESMF::ESMF NetCDF::NetCDF_Fortran) +esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL esmf NetCDF::NetCDF_Fortran) install(PROGRAMS build_rivernetwork.py DESTINATION bin) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index ad2be4db2..f7628ee38 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -18,8 +18,6 @@ module GEOS_RouteGridCompMod ! All of its calculations are done on Pfafstetter watershed space. {\tt GEOS\_Route} has no children. \\ ! ! IMPORTS : RUNOFF \\ -! INTERNALS : AREACAT, LENGSC2, DNSTR, WSTREAM, WRIVER, LRIVERMOUTH, ORIVERMOUTH \\ -! EXPORTS : QSFLOW, QINFLOW, QOUTFLOW \\ ! !USES: @@ -27,14 +25,19 @@ module GEOS_RouteGridCompMod use MAPL_Mod use MAPL_ConstantsMod use ROUTING_MODEL, ONLY: & - river_routing, ROUTE_DT + river_routing_lin, river_routing_hyd, ROUTE_DT #if 0 USE catch_constants, ONLY: & N_CatG => N_Pfaf_Catchs #endif + use, intrinsic :: iso_c_binding implicit none integer, parameter :: N_CatG = 291284 + integer,parameter :: upmax=34 + character(len=500) :: inputdir="/discover/nobackup/yzeng3/data/river_input/" + integer,save :: nmax + private type T_RROUTE_STATE @@ -42,15 +45,57 @@ module GEOS_RouteGridCompMod type (ESMF_RouteHandle) :: routeHandle type (ESMF_Field) :: field integer :: nTiles + integer :: nt_global + integer :: nt_local integer :: comm integer :: nDes integer :: myPe integer :: minCatch integer :: maxCatch integer, pointer :: pfaf(:) => NULL() - real, pointer :: tile_area(:) => NULL() + real, pointer :: tile_area(:) => NULL() !m2 + integer, pointer :: nsub(:) => NULL() + integer, pointer :: subi(:,:) => NULL() + real, pointer :: subarea(:,:) => NULL() !m2 + + integer, pointer :: scounts_global(:) => NULL() + integer, pointer :: rdispls_global(:) => NULL() + integer, pointer :: scounts_cat(:) => NULL() + integer, pointer :: rdispls_cat(:) => NULL() + + real, pointer :: runoff_save(:) => NULL() + real, pointer :: areacat(:) => NULL() !m2 + real, pointer :: lengsc(:) => NULL() !m + + real, pointer :: wstream(:) => NULL() !m3 + real, pointer :: wriver(:) => NULL() !m3 + integer, pointer :: downid(:) => NULL() + integer, pointer :: upid(:,:) => NULL() + + real, pointer :: wriver_acc(:) => NULL() + real, pointer :: wstream_acc(:) => NULL() + real, pointer :: qoutflow_acc(:) => NULL() + real, pointer :: qsflow_acc(:) => NULL() + + real, pointer :: lstr(:) => NULL() !m + real, pointer :: qri_clmt(:) => NULL() !m3/s + real, pointer :: qin_clmt(:) => NULL() !m3/s + real, pointer :: qstr_clmt(:) =>NULL() !m3/s + real, pointer :: K(:) => NULL() + real, pointer :: Kstr(:) => NULL() + end type T_RROUTE_STATE + + interface + function mkdir(path,mode) bind(c,name="mkdir") + use iso_c_binding + integer(c_int) :: mkdir + character(kind=c_char,len=1) :: path(*) + integer(c_int16_t), value :: mode + end function mkdir + end interface + ! Wrapper for extracting internal state ! ------------------------------------- type RROUTE_WRAP @@ -132,7 +177,11 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, RC=STATUS ) VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint (GC, ESMF_METHOD_RUN, Run, RC=STATUS) +! call MAPL_GridCompSetEntryPoint (GC, ESMF_METHOD_RUN, Run, RC=STATUS) +! VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN1, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN2, RC=STATUS ) VERIFY_(STATUS) !------------------------------------------------------------ @@ -186,104 +235,8 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) -! ----------------------------------------------------------- -! INTERNAL STATE -! ----------------------------------------------------------- - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'area_of_catchment' ,& - UNITS = 'km+2' ,& - SHORT_NAME = 'AREACAT' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'length_of_channel_segment',& - UNITS = 'km+2' ,& - SHORT_NAME = 'LENGSC' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'index_of_downtream_catchment',& - UNITS = '1' ,& - SHORT_NAME = 'DNSTR' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'volume_of_water_in_local_stream',& - UNITS = 'm+3' ,& - SHORT_NAME = 'WSTREAM' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'volume_of_water_in_river' ,& - UNITS = 'm+3' ,& - SHORT_NAME = 'WRIVER' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'TileID_of_the_lake_tile_at_the_river_mouth' ,& - UNITS = '1' ,& - SHORT_NAME = 'LRIVERMOUTH' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) - - call MAPL_AddInternalSpec(GC ,& - LONG_NAME = 'TileID_of_the_ocean_tile_at_the_river_mouth' ,& - UNITS = '1' ,& - SHORT_NAME = 'ORIVERMOUTH' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RESTART = MAPL_RestartRequired ,& - RC=STATUS ) -! ----------------------------------------------------------- -! EXPORT STATE: -! ----------------------------------------------------------- - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transfer_of_moisture_from_stream_variable_to_river_variable' ,& - UNITS = 'm+3 s-1' ,& - SHORT_NAME = 'QSFLOW' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transfer_of_river_water_from_upstream_catchments' ,& - UNITS = 'm+3 s-1' ,& - SHORT_NAME = 'QINFLOW' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - - call MAPL_AddExportSpec(GC, & - LONG_NAME = 'transfer_of_river_water_to_downstream_catchments' ,& - UNITS = 'm+3 s-1' ,& - SHORT_NAME = 'QOUTFLOW' ,& - DIMS = MAPL_DimsCatchOnly ,& - VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) - !EOS - call MAPL_TimerAdd(GC, name="RUN" ,RC=STATUS) - VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="-RRM" ,RC=STATUS) VERIFY_(STATUS) @@ -307,7 +260,9 @@ subroutine SetServices ( GC, RC ) call MAPL_TimerAdd(GC, name="INITIALIZE" ,RC=STATUS) VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="RUN" ,RC=STATUS) + call MAPL_TimerAdd(GC, name="RUN1" ,RC=STATUS) + VERIFY_(STATUS) + call MAPL_TimerAdd(GC, name="RUN2" ,RC=STATUS) VERIFY_(STATUS) ! All done @@ -367,22 +322,50 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) integer, pointer :: ims(:) => NULL() integer, pointer :: pfaf(:) => NULL() integer, pointer :: arbSeq(:) => NULL() + integer, pointer :: arbSeq_pf(:) => NULL() + integer, pointer :: arbSeq_ori(:) => NULL() integer, allocatable :: arbIndex(:,:) real, pointer :: tile_area_src(:) => NULL() - real, pointer :: tile_area(:) => NULL() + integer,pointer :: local_id(:) => NULL() + real, pointer :: tile_area_local(:) => NULL(), tile_area_global(:) => NULL() + real, pointer :: tile_area(:) => NULL() real, pointer :: ptr2(:) => NULL() + + real,pointer :: subarea_global(:,:)=> NULL(),subarea(:,:)=> NULL() ! Arrays for sub-area and fractions + integer,pointer :: subi_global(:,:)=> NULL(),subi(:,:)=> NULL() + integer,pointer :: nsub_global(:)=> NULL(),nsub(:)=> NULL() + real,pointer :: area_cat_global(:)=> NULL(),area_cat(:)=> NULL() + integer,pointer :: scounts(:)=>NULL() + integer,pointer :: scounts_global(:)=>NULL(),rdispls_global(:)=>NULL() + integer,pointer :: scounts_cat(:)=>NULL(),rdispls_cat(:)=>NULL() + + real,pointer :: runoff_save(:)=>NULL(), areacat(:)=>NULL() + real,pointer :: lengsc_global(:)=>NULL(), lengsc(:)=>NULL(), buff_global(:)=>NULL() + integer,pointer :: downid_global(:)=>NULL(), downid(:)=>NULL() + integer,pointer :: upid_global(:,:)=>NULL(), upid(:,:)=>NULL() + + real,pointer :: wstream(:)=>NULL(),wriver(:)=>NULL() + real,pointer :: wstream_global(:)=>NULL(),wriver_global(:)=>NULL() type (T_RROUTE_STATE), pointer :: route => null() type (RROUTE_wrap) :: wrap + type(ESMF_Time) :: CurrentTime + integer :: YY,MM,DD,HH,MMM,SS + character(len=4) :: yr_s + character(len=2) :: mon_s,day_s + character(len=3) :: resname + + real, pointer :: dataPtr(:) + integer :: j,nt_local,mpierr,it ! ------------------ ! begin + call ESMF_UserCompGetInternalState ( GC, 'RiverRoute_state',wrap,status ) VERIFY_(STATUS) route => wrap%ptr - ! get vm ! extract comm call ESMF_VMGetCurrent(VM, RC=STATUS) @@ -398,152 +381,268 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%comm = comm route%ndes = ndes route%mype = mype - + + allocate(ims(1:ndes)) ! define minCatch, maxCatch call MAPL_DecomposeDim ( n_catg,ims,ndes ) ! ims(mype+1) gives the size of my partition ! myPE is 0-based! beforeMe = sum(ims(1:mype)) minCatch = beforeMe + 1 maxCatch = beforeMe + ims(myPe+1) - + ! get LocStream call MAPL_Get(MAPL, LocStream = locstream, RC=status) - VERIFY_(STATUS) - ! extract Pfaf (TILEI on the "other" grid) - call MAPL_LocStreamGet(locstream, tilei=pfaf, OnAttachedGrid=.false., & + VERIFY_(STATUS) + ! extract Pfaf (TILEI on the "other" grid) + call MAPL_LocStreamGet(locstream, & tileGrid=tilegrid, nt_global=nt_global, RC=status) - VERIFY_(STATUS) - + VERIFY_(STATUS) + route%nt_global = nt_global + + if(nt_global==112573)then + resname="M36" + nmax=150 + else if(nt_global==1684725)then + resname="M09" + nmax=458 + else + if(mapl_am_I_root())then + print *,"unknown grid for routing model" + stop + endif + endif ! exchange Pfaf across PEs - ntiles = 0 - !loop over total_n_tiles - do i = 1, nt_global - pf = pfaf(i) - if (pf >= minCatch .and. pf <= maxCatch) then ! I want this! - ntiles = ntiles+1 - !realloc if needed - arbSeq(ntiles) = i - end if - end do ! global tile loop - - distgrid = ESMF_DistGridCreate(arbSeqIndexList=arbSeq, rc=status) - VERIFY_(STATUS) - - newTileGRID = ESMF_GridEmptyCreate(rc=status) - VERIFY_(STATUS) - - allocate(arbIndex(nTiles,1), stat=status) - VERIFY_(STATUS) - - arbIndex(:,1) = arbSeq - - call ESMF_GridSet(newTileGrid, & - name='redist_tile_grid_for_'//trim(COMP_NAME), & - distgrid=distgrid, & - gridMemLBound=(/1/), & - indexFlag=ESMF_INDEX_USER, & - distDim = (/1/), & - localArbIndexCount=ntiles, & - localArbIndex=arbIndex, & - minIndex=(/1/), & - maxIndex=(/NT_GLOBAL/), & - rc=status) - VERIFY_(STATUS) - - deallocate(arbIndex) - - call ESMF_GridCommit(newTileGrid, rc=status) - VERIFY_(STATUS) - - - ! now create a "catch" grid to be the "native" grid for this component - distgrid = ESMF_DistGridCreate(arbSeqIndexList=(/minCatch:maxCatch/), & - rc=status) - VERIFY_(STATUS) - - catchGRID = ESMF_GridEmptyCreate(rc=status) - VERIFY_(STATUS) - - allocate(arbIndex(ims(myPE+1),1), stat=status) - VERIFY_(STATUS) - - arbIndex(:,1) = (/minCatch:maxCatch/) - - call ESMF_GridSet(catchGrid, & - name='catch_grid_for_'//trim(COMP_NAME), & - distgrid=distgrid, & - gridMemLBound=(/1/), & - indexFlag=ESMF_INDEX_USER, & - distDim = (/1/), & - localArbIndexCount=ims(myPE+1), & - localArbIndex=arbIndex, & - minIndex=(/1/), & - maxIndex=(/N_CatG/), & - rc=status) - VERIFY_(STATUS) - - deallocate(arbIndex) - - call ESMF_GridCommit(catchGrid, rc=status) - VERIFY_(STATUS) - - call ESMF_GridCompSet(gc, grid=catchGrid, RC=status) - VERIFY_(STATUS) - - call MAPL_LocStreamGet(locstream, TILEAREA = tile_area_src, RC=status) - VERIFY_(STATUS) - - field0 = ESMF_FieldCreate(grid=tilegrid, datacopyflag=ESMF_DATACOPY_VALUE, & - farrayPtr=tile_area_src, name='TILE_AREA_SRC', RC=STATUS) - VERIFY_(STATUS) - ! create field on the "new" tile grid - allocate(tile_area(ntiles), stat=status) - VERIFY_(STATUS) - field = ESMF_FieldCreate(grid=newtilegrid, datacopyflag=ESMF_DATACOPY_VALUE, & - farrayPtr=tile_area, name='TILE_AREA', RC=STATUS) - VERIFY_(STATUS) - - ! create routehandle - call ESMF_FieldRedistStore(srcField=field0, dstField=field, & - routehandle=route%routehandle, rc=status) - VERIFY_(STATUS) - - ! redist tile_area - call ESMF_FieldRedist(srcField=FIELD0, dstField=FIELD, & - routehandle=route%routehandle, rc=status) - VERIFY_(STATUS) - - call ESMF_FieldDestroy(field, rc=status) - VERIFY_(STATUS) - call ESMF_FieldDestroy(field0, rc=status) - VERIFY_(STATUS) + call MAPL_LocStreamGet(locstream, TILEAREA = tile_area_src, LOCAL_ID=local_id, RC=status) + VERIFY_(STATUS) + nt_local=size(tile_area_src,1) + route%nt_local=nt_local + ntiles = maxCatch-minCatch+1 + allocate(arbSeq_pf(maxCatch-minCatch+1)) + arbSeq_pf = [(i, i = minCatch, maxCatch)] + ! redist pfaf (NOTE: me might need a second routehandle for integers) - route%pfaf => arbSeq - route%ntiles = ntiles + route%pfaf => arbSeq_pf + route%ntiles = ntiles route%minCatch = minCatch - route%maxCatch = maxCatch - - allocate(ptr2(ntiles), stat=status) - VERIFY_(STATUS) - route%field = ESMF_FieldCreate(grid=newtilegrid, datacopyflag=ESMF_DATACOPY_VALUE, & - farrayPtr=ptr2, name='RUNOFF', RC=STATUS) - VERIFY_(STATUS) + route%maxCatch = maxCatch + ! Read sub-area data from text files + allocate(nsub_global(N_CatG),subarea_global(nmax,N_CatG)) + open(77,file=trim(inputdir)//"/Pfaf_nsub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)nsub_global; close(77) + open(77,file=trim(inputdir)//"/Pfaf_asub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)subarea_global; close(77) + allocate(nsub(ntiles),subarea(nmax,ntiles)) + nsub=nsub_global(minCatch:maxCatch) + subarea=subarea_global(:,minCatch:maxCatch) + subarea=subarea*1.e6 !km2->m2 + deallocate(nsub_global,subarea_global) + + route%nsub => nsub + route%subarea => subarea + allocate(subi_global(nmax,N_CatG),subi(nmax,ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_isub_"//trim(resname)//".txt",status="old",action="read");read(77,*)subi_global;close(77) + subi=subi_global(:,minCatch:maxCatch) + route%subi => subi + deallocate(subi_global) + + + allocate(scounts(ndes),scounts_global(ndes),rdispls_global(ndes)) + scounts=0 + scounts(mype+1)=nt_local + call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_global, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) + rdispls_global(1)=0 + do i=2,nDes + rdispls_global(i)=rdispls_global(i-1)+scounts_global(i-1) + enddo + deallocate(scounts) + route%scounts_global=>scounts_global + route%rdispls_global=>rdispls_global + + allocate(scounts(ndes),scounts_cat(ndes),rdispls_cat(ndes)) + scounts=0 + scounts(mype+1)=ntiles + call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_cat, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) + rdispls_cat(1)=0 + do i=2,nDes + rdispls_cat(i)=rdispls_cat(i-1)+scounts_cat(i-1) + enddo + deallocate(scounts) + route%scounts_cat=>scounts_cat + route%rdispls_cat=>rdispls_cat + + allocate(runoff_save(1:nt_local)) + route%runoff_save => runoff_save + route%runoff_save=0. + + allocate(tile_area_local(nt_local),tile_area_global(nt_global)) + open(77,file=trim(inputdir)//"/area_"//trim(resname)//"_1d.txt",status="old",action="read");read(77,*)tile_area_global;close(77) + tile_area_local=tile_area_global(rdispls_global(mype+1)+1:rdispls_global(mype+1)+nt_local)*1.e6 !km2->m2 + route%tile_area => tile_area_local + deallocate(tile_area_global) + + allocate(areacat(1:ntiles)) + areacat=0. + do i=1,ntiles + do j=1,nmax + it=route%subi(j,i) + if(it>0)then + areacat(i)=areacat(i)+route%subarea(j,i) + endif + if(it==0)exit + enddo + enddo + route%areacat=>areacat + + allocate(lengsc_global(n_catg),lengsc(ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_lriv_PR.txt",status="old",action="read");read(77,*)lengsc_global;close(77) + lengsc=lengsc_global(minCatch:maxCatch)*1.e3 !km->m + route%lengsc=>lengsc + deallocate(lengsc_global) + + allocate(downid_global(n_catg),downid(ntiles)) + open(77,file=trim(inputdir)//"/downstream_1D_new_noadj.txt",status="old",action="read");read(77,*)downid_global;close(77) + downid=downid_global(minCatch:maxCatch) + route%downid=>downid + deallocate(downid_global) + + allocate(upid_global(upmax,n_catg),upid(upmax,ntiles)) + open(77,file=trim(inputdir)//"/upstream_1D.txt",status="old",action="read");read(77,*)upid_global;close(77) + upid=upid_global(:,minCatch:maxCatch) + route%upid=>upid + deallocate(upid_global) + + call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) + call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) + write(yr_s,'(I4.4)')YY + write(mon_s,'(I2.2)')MM + write(day_s,'(I2.2)')DD + if(mapl_am_I_root())print *, "init time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS + allocate(wriver(ntiles),wstream(ntiles)) + allocate(wriver_global(n_catg),wstream_global(n_catg)) + open(77,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(77,*)wriver_global;close(77) + else + close(77) + open(78,file=trim(inputdir)//"/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wriver_global;close(78) + else + close(78) + open(79,file=trim(inputdir)//"/river_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wriver_global;close(79) + else + close(79) + wriver_global=0. + endif + endif + endif + open(77,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(77,*)wstream_global;close(77) + else + close(77) + open(78,file=trim(inputdir)//"/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wstream_global;close(78) + else + close(78) + open(79,file=trim(inputdir)//"/stream_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wstream_global;close(79) + else + close(79) + wstream_global=0. + endif + endif + endif + if(mapl_am_I_root())print *, "init river storage is: ",sum(wriver_global)/1.e9 + if(mapl_am_I_root())print *, "init stream storage is: ",sum(wstream_global)/1.e9 + wriver=wriver_global(minCatch:maxCatch) + wstream=wstream_global(minCatch:maxCatch) + deallocate(wriver_global,wstream_global) + route%wstream=>wstream + route%wriver=>wriver + + allocate(route%wriver_acc(ntiles),route%wstream_acc(ntiles),route%qoutflow_acc(ntiles),route%qsflow_acc(ntiles)) + route%wriver_acc=0. + route%wstream_acc=0. + route%qoutflow_acc=0. + route%qsflow_acc=0. + + !input for geometry hydraulic + allocate(buff_global(n_catg),route%lstr(ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_lstr_PR.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%lstr=buff_global(minCatch:maxCatch)*1.e3 !km->m + deallocate(buff_global) + + allocate(buff_global(n_catg),route%K(ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%K=buff_global(minCatch:maxCatch) + deallocate(buff_global) + + allocate(buff_global(n_catg),route%Kstr(ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%Kstr=buff_global(minCatch:maxCatch) + deallocate(buff_global) + + allocate(buff_global(n_catg),route%qri_clmt(ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_qri.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%qri_clmt=buff_global(minCatch:maxCatch) !m3/s + deallocate(buff_global) + + allocate(buff_global(n_catg),route%qin_clmt(ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_qin.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%qin_clmt=buff_global(minCatch:maxCatch) !m3/s + deallocate(buff_global) + + allocate(buff_global(n_catg),route%qstr_clmt(ntiles)) + open(77,file=trim(inputdir)//"/Pfaf_qstr.txt",status="old",action="read");read(77,*)buff_global;close(77) + route%qstr_clmt=buff_global(minCatch:maxCatch) !m3/s + deallocate(buff_global) + + !if (mapl_am_I_root())then + ! open(88,file="nsub.txt",action="write") + ! open(89,file="subarea.txt",action="write") + ! open(90,file="subi.txt",action="write") + ! open(91,file="tile_area.txt",action="write") + ! do i=1,nTiles + ! write(88,*)route%nsub(i) + ! write(89,'(150(1x,f10.4))')route%subarea(:,i) + ! write(90,'(150(i7))')route%subi(:,i) + ! write(91,*)route%tile_area(i) + ! enddo + ! stop + !endif + deallocate(ims) call MAPL_GenericInitialize ( GC, import, export, clock, rc=status ) VERIFY_(STATUS) - RETURN_(ESMF_SUCCESS) + RETURN_(ESMF_SUCCESS) end subroutine INITIALIZE ! ----------------------------------------------------------- ! RUN -- Run method for the route component ! ----------------------------------------------------------- + subroutine RUN1 (GC,IMPORT, EXPORT, CLOCK, RC ) + +! ----------------------------------------------------------- +! !ARGUMENTS: +! ----------------------------------------------------------- + + type(ESMF_GridComp), intent(inout) :: GC + type(ESMF_State), intent(inout) :: IMPORT + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(inout) :: CLOCK + integer, optional, intent( out) :: RC + end subroutine RUN1 - subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) + + subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) ! ----------------------------------------------------------- ! !ARGUMENTS: @@ -559,7 +658,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) ! ErrLog Variables ! ----------------------------------------------------------- - character(len=ESMF_MAXSTR) :: IAm="Run" + character(len=ESMF_MAXSTR) :: IAm="Run2" integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME @@ -578,6 +677,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) ! ----------------------------------------------------- real, dimension(:), pointer :: RUNOFF + real, dimension(:), pointer :: RUNOFF_SRC0 ! ----------------------------------------------------- ! INTERNAL pointers @@ -607,6 +707,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Grid) :: TILEGRID type (MAPL_LocStream) :: LOCSTREAM + integer :: NTILES, N_CatL, N_CYC logical, save :: FirstTime=.true. real, pointer, dimension(:) :: tile_area @@ -615,502 +716,403 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) INTEGER, DIMENSION(:,:), POINTER, SAVE :: AllActive,DstCatchID INTEGER, DIMENSION(:), ALLOCATABLE, SAVE :: srcProcsID, LocDstCatchID integer, dimension (:),allocatable, SAVE :: GlbActive - INTEGER, SAVE :: N_Active, ThisCycle + INTEGER, SAVE :: N_Active, ThisCycle=1 INTEGER :: Local_Min, Local_Max integer :: K, N, I, req REAL :: mm2m3, rbuff, HEARTBEAT REAL, ALLOCATABLE, DIMENSION(:) :: RUNOFF_CATCH, RUNOFF_ACT,AREACAT_ACT,& - LENGSC_ACT, WSTREAM_ACT,WRIVER_ACT, QSFLOW_ACT,QOUTFLOW_ACT, runoff_save + LENGSC_ACT, QSFLOW_ACT,QOUTFLOW_ACT INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_index type(ESMF_Field) :: runoff_src integer :: ndes, mype type (T_RROUTE_STATE), pointer :: route => null() type (RROUTE_wrap) :: wrap - - ! ------------------ - ! begin + INTEGER, DIMENSION(:) ,ALLOCATABLE :: scounts, scounts_global,rdispls, rcounts + real, dimension(:), pointer :: runoff_global,runoff_local,area_local,runoff_cat_global + + integer :: mpierr, nt_global,nt_local, it, j, upid,cid,temp(1),tid,istat + integer,save :: nstep_per_day + + type(ESMF_Time) :: CurrentTime, nextTime + integer :: YY,MM,DD,HH,MMM,SS,YY_next,MM_next,DD_next + character(len=4) :: yr_s + character(len=2) :: mon_s,day_s + + real,pointer :: runoff_save(:)=>NULL() + real,pointer :: WSTREAM_ACT(:)=>NULL() + real,pointer :: WRIVER_ACT(:)=>NULL() + real,allocatable :: runoff_save_m3(:),runoff_global_m3(:),QOUTFLOW_GLOBAL(:) + real,allocatable :: WTOT_BEFORE(:),WTOT_AFTER(:),QINFLOW_LOCAL(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) + real,allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) + real,allocatable :: wriver_global(:),wstream_global(:),qsflow_global(:) + ! ------------------ + ! begin call ESMF_UserCompGetInternalState ( GC, 'RiverRoute_state',wrap,status ) VERIFY_(STATUS) - route => wrap%ptr ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- call ESMF_GridCompGet(GC, name=COMP_NAME, CONFIG=CF, RC=STATUS ) - VERIFY_(STATUS) - - Iam = trim(COMP_NAME) // "RUN" + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // "RUN2" ! Get my internal MAPL_Generic state ! ----------------------------------------------------------- call MAPL_GetObjectFromGC(GC, MAPL, STATUS) VERIFY_(STATUS) - call MAPL_Get(MAPL, HEARTBEAT = HEARTBEAT, RC=STATUS) VERIFY_(STATUS) - + !if (mapl_am_I_root()) print *, "HEARTBEAT=",HEARTBEAT ! Start timers ! ------------ - call MAPL_TimerOn(MAPL,"RUN") - + call MAPL_TimerOn(MAPL,"RUN2") ! Get parameters from generic state ! --------------------------------- - call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS) - VERIFY_(STATUS) - + ! call MAPL_Get(MAPL, INTERNAL_ESMF_STATE=INTERNAL, RC=STATUS) + ! VERIFY_(STATUS) ! get pointers to inputs variables ! ---------------------------------- + ndes = route%ndes + mype = route%mype + ntiles = route%ntiles + nt_global = route%nt_global + runoff_save => route%runoff_save + nt_local = route%nt_local + ! get the field from IMPORT call ESMF_StateGet(IMPORT, 'RUNOFF', field=runoff_src, RC=STATUS) - VERIFY_(STATUS) - - ! redist RunOff - call ESMF_FieldRedist(srcField=runoff_src, dstField=route%field, & - routehandle=route%routehandle, rc=status) - VERIFY_(STATUS) - - call ESMF_FieldGet(route%field, farrayPtr=RUNOFF, rc=status) - VERIFY_(STATUS) - - pfaf_code => route%pfaf - tile_area => route%tile_area - -! get pointers to internal variables -! ---------------------------------- - - call MAPL_GetPointer(INTERNAL, AREACAT , 'AREACAT', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, LENGSC , 'LENGSC', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, DNSTR , 'DNSTR' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, WSTREAM , 'WSTREAM', RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, WRIVER , 'WRIVER' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, LRIVERMOUTH, 'LRIVERMOUTH' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(INTERNAL, ORIVERMOUTH, 'ORIVERMOUTH' , RC=STATUS) - VERIFY_(STATUS) - -! get pointers to EXPORTS -! ----------------------- + VERIFY_(STATUS) + call ESMF_FieldGet(runoff_src, farrayPtr=RUNOFF_SRC0, rc=status) + VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QSFLOW, 'QSFLOW' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QINFLOW, 'QINFLOW' , RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QOUTFLOW, 'QOUTFLOW', RC=STATUS) - VERIFY_(STATUS) - call MAPL_Get(MAPL, LocStream=LOCSTREAM, RC=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call MAPL_LocStreamGet(LOCSTREAM, TILEGRID=TILEGRID, RC=STATUS) VERIFY_(STATUS) - call MAPL_TimerOn ( MAPL, "-RRM" ) - call MAPL_LocStreamGet(LocStream, NT_LOCAL=NTILES, RC=STATUS ) - N_CatL = size(AREACAT) - -!@@ ALLOCATE (pfaf_code (1:NTILES)) ! 9th_coulumn_in_TILFILE - - ! NOTES : - !Need below area and pfaf_index from the .til file (Maybe, they are already in LocStream) - ! - ! TILFILE: /discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0090x6C_DE1440xPE0720/CF0090x6C_DE1440xPE0720-Pfafstetter.til - ! The 8-line header is followed by 1061481 number of rows. - ! do n = 1,475330 - ! read (10,*)type,area, longitude, latitude, ig, jg, cell_frac, integer, & - ! pfaf_code, pfaf_index, pfaf_frac - ! end do - ! - ! where for each tile: - ! (1) type [-] tile type (100-land; 19-lakes; 20-ice) - ! (2) area [x EarthRadius^2 km2] tile area - ! (3) longitude [degree] longitude at the centroid of the tile - ! (4) latitude [degree] latitude at the centroid of the tile - ! (5) ig [-] i-index of the AGCM grid cell where the tile is located - ! (6) jg [-] j-index of the AGCM grid cell where the tile is located - ! (7) cell_frac [-] fraction of the AGCM grid cell - ! (8) integer some integer that matters only for OGCM tiles, I suppose. - ! (9) pfaf_code [-] catchment index (1-291284) after sorting Pfafstetter codes in ascending order - ! (10) pfaf_index[-] catchment index (1-290188) after sorting Pfafstetter codes - ! and removing submerged in ascending order - ! (11) pfaf_frac [-] fraction of the pfafstetter catchment - - !call MAPL_LocStreamGet(LocStream, 9th_coulumn_in_TILFILE=pfaf_code, RC=STATUS ) - - Local_Min = route%minCatch - Local_Max = route%maxCatch - - FIRST_TIME : IF (FirstTime) THEN - - ! Pfafstetter catchment Domain Decomposition : - ! -------------------------------------------- - - ! AllActive : Processor(s) where the catchment is active (identical in any processor). - ! srcProcsID : For all active catchments anywhere tells which processor is the principal owner of the catchment (identical in any processor). - ! DstCatchID : 2-D array contains downstream catchID and downstream processor (identical in any processor) - ! LocDstCatchID : Downstream catchID when for catchments that are local to the processor. - - ndes = route%ndes - mype = route%mype - allocate (AllActive (1:N_CatG, 1: nDEs)) - allocate (DstCatchID(1:N_CatG, 1: nDEs)) - allocate (srcProcsID (1:N_CatG )) - allocate (LocDstCatchID(1:N_CatG )) - - AllActive = -9999 - srcProcsID = -9999 - DstCatchID = -9999 - LocDstCatchID = NINT(DNSTR) - - call InitializeRiverRouting(MYPE, nDEs, MAPL_am_I_root(vm),pfaf_code, & - AllActive, DstCatchID, srcProcsID, LocDstCatchID, rc=STATUS) - - VERIFY_(STATUS) + ! For efficiency, the time step to call the river routing model is set at ROUTE_DT - N_Active = count (srcProcsID == MYPE) + N_CYC = ROUTE_DT/HEARTBEAT + RUN_MODEL : if (ThisCycle == N_CYC) then - allocate (GlbActive(1 : N_Active)) - allocate (tmp_index(1 : N_CatG )) + runoff_save = runoff_save + RUNOFF_SRC0/real (N_CYC) - forall (N=1:N_CatG) tmp_index(N) = N + call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) + call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) + call ESMF_ClockGetNextTime(clock, nextTime=nextTime, rc=status) + call ESMF_TimeGet(nextTime, yy=YY_next, mm=MM_next, dd=DD_next, rc=status) + write(yr_s,'(I4.4)')YY + write(mon_s,'(I2.2)')MM + write(day_s,'(I2.2)')DD - GlbActive = pack (tmp_index, mask = (srcProcsID == MYPE)) + allocate(runoff_global(nt_global)) + call MPI_allgatherv ( & + runoff_save, route%scounts_global(mype+1) ,MPI_REAL, & + runoff_global, route%scounts_global, route%rdispls_global,MPI_REAL, & + MPI_COMM_WORLD, mpierr) - ! Initialize the cycle counter and sum (runoff) + if(FirstTime.and.mapl_am_I_root()) print *,"nmax=",nmax + allocate(RUNOFF_ACT(ntiles)) + RUNOFF_ACT=0. + do i=1,ntiles + do j=1,nmax + it=route%subi(j,i) + if(it>0)then + RUNOFF_ACT(i)=RUNOFF_ACT(i)+route%subarea(j,i)*runoff_global(it)/1000. + endif + if(it==0)exit + enddo + enddo - allocate (runoff_save (1:NTILES)) + deallocate(runoff_global) - runoff_save = 0. - ThisCycle = 1 - FirstTime = .false. + allocate (AREACAT_ACT (1:ntiles)) + allocate (LENGSC_ACT (1:ntiles)) + allocate (QSFLOW_ACT (1:ntiles)) + allocate (QOUTFLOW_ACT(1:ntiles)) - deallocate (tmp_index) - - ENDIF FIRST_TIME + LENGSC_ACT=route%lengsc/1.e3 !m->km + AREACAT_ACT=route%areacat/1.e6 !m2->km2 - ! For efficiency, the time step to call the river routing model is set at ROUTE_DT + WSTREAM_ACT => route%wstream + WRIVER_ACT => route%wriver - N_CYC = ROUTE_DT/HEARTBEAT + + allocate(WTOT_BEFORE(ntiles)) + WTOT_BEFORE=WSTREAM_ACT+WRIVER_ACT - RUN_MODEL : if (ThisCycle == N_CYC) then - - runoff_save = runoff_save + runoff/real (N_CYC) - - ! Here we aggreagate GEOS_Catch/GEOS_CatchCN produced RUNOFF from TILES to CATCHMENTS - ! Everything is local to the parallel block. Units: RUNOFF [kg m-2 s-1], - ! RUNOFF_CATCH [m3 s-1] - ! ----------------------------------------------------------------------------------- - - ! Unit conversion - - mm2m3 = MAPL_RADIUS * MAPL_RADIUS / 1000. - - ALLOCATE (RUNOFF_CATCH(1:N_CatG)) - - RUNOFF_CATCH = 0. - - DO N = 1, NTILES - RUNOFF_CATCH (pfaf_code(n)) = RUNOFF_CATCH (pfaf_code(n)) + mm2m3 * RUNOFF_SAVE (N) * TILE_AREA (N) - END DO - - ! Inter-processor communication 1 - ! For catchment-tiles that contribute to the main catchment in some other processor, - ! send runoff to the corresponding srcProcsID(N) - ! ----------------------------------------------------------------------------------- - - do N = Local_Min, Local_Max - - if ((AllActive (N,MYPE+1) > 0).and.(srcProcsID(N) /= MYPE)) then - - rbuff = RUNOFF_CATCH (N) - - call MPI_ISend(rbuff,1,MPI_real,srcProcsID(N),999,MPI_COMM_WORLD,req,status) - call MPI_WAIT (req ,MPI_STATUS_IGNORE,status) - - RUNOFF_CATCH (N) = 0. - - else - - if(srcProcsID(N) == MYPE) then - - do i = 1,nDEs - if((i-1 /= MYPE).and.(AllActive (N,i) > 0)) then - - call MPI_RECV(rbuff,1,MPI_real,i-1,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,status) - RUNOFF_CATCH (N) = RUNOFF_CATCH (N) + rbuff - - endif - end do - endif - endif - end do - - ! Now compress and create subsets of arrays that only contain active catchments - ! in the local processor - ! ----------------------------------------------------------------------------- - - if(allocated (LENGSC_ACT ) .eqv. .false.) allocate (LENGSC_ACT (1:N_Active)) - if(allocated (AREACAT_ACT ) .eqv. .false.) allocate (AREACAT_ACT (1:N_Active)) - if(allocated (WSTREAM_ACT ) .eqv. .false.) allocate (WSTREAM_ACT (1:N_Active)) - if(allocated (WRIVER_ACT ) .eqv. .false.) allocate (WRIVER_ACT (1:N_Active)) - if(allocated (QSFLOW_ACT ) .eqv. .false.) allocate (QSFLOW_ACT (1:N_Active)) - if(allocated (QOUTFLOW_ACT) .eqv. .false.) allocate (QOUTFLOW_ACT(1:N_Active)) - if(allocated (RUNOFF_ACT ) .eqv. .false.) allocate (RUNOFF_ACT (1:N_Active)) - - DO N = 1, size (GlbActive) - - I = GlbActive (N) - RUNOFF_ACT (N) = RUNOFF_CATCH (I) - - I = GlbActive (N) - Local_Min + 1 - WSTREAM_ACT (N) = WSTREAM (I) - WRIVER_ACT (N) = WRIVER (I) - LENGSC_ACT (N) = LENGSC (I) - AREACAT_ACT (N) = AREACAT (I) - - END DO - - QSFLOW_ACT = 0. - QOUTFLOW_ACT = 0. - QSFLOW = 0. - QOUTFLOW = 0. - QINFLOW = 0. - ! Call river_routing_model - ! ------------------------ - - CALL RIVER_ROUTING (N_Active, RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT, & - WSTREAM_ACT,WRIVER_ACT, QSFLOW_ACT,QOUTFLOW_ACT) - - DO N = 1, size (GlbActive) - - I = GlbActive (N) - Local_Min + 1 - - WSTREAM (I) = WSTREAM_ACT (N) - WRIVER (I) = WRIVER_ACT (N) - QSFLOW (I) = QSFLOW_ACT (N) - QOUTFLOW(I) = QOUTFLOW_ACT(N) - - if (LocDstCatchID (GlbActive (N)) == GlbActive (N)) then - - ! This catchment drains to the ocean, lake or a sink - ! if(ORIVERMOUTH(... ) > 0) send QOUTFLOW(I) [m3/s] to ORIVERMOUTH(N) th ocean tile - ! if(LRIVERMOUTH(... ) > 0) send QOUTFLOW(I) [m3/s] to LRIVERMOUTH(N) th lake tile - - endif - END DO - - ! Inter-processor communication-2 - ! Update down stream catchments - ! ------------------------------- - - do N = 1,N_CatG - - if ((srcProcsID (N) == MYPE).and.(srcProcsID (LocDstCatchID (N)) == MYPE)) then ! destination is local - - I = LocDstCatchID (N) - Local_Min + 1 ! Downstream index in the local processor - K = N - Local_Min + 1 ! Source index in the local processor - - if(LocDstCatchID (N) /= N) then ! ensure not to refill the reservoir by itself - - QINFLOW(I) = QINFLOW(I) + QOUTFLOW (K) - WRIVER (I) = WRIVER (I) + QOUTFLOW (K) * real(route_dt) - - endif - - elseif ((srcProcsID (N) == MYPE).and.(srcProcsID (LocDstCatchID (N)) /= MYPE)) then - - if(srcProcsID (LocDstCatchID (N)) >= 0) then - - ! Send to downstream processor - - K = N - Local_Min + 1 ! Source index in the local processor - - call MPI_ISend(QOUTFLOW(K),1,MPI_real,srcProcsID (LocDstCatchID (N)),999,MPI_COMM_WORLD,req,status) - call MPI_WAIT(req,MPI_STATUS_IGNORE,status) - - endif - - elseif ((srcProcsID (N) /= MYPE).and.(srcProcsID (N) >= 0)) then - - K = srcProcsID (dstCatchID(N,srcProcsID (N)+1)) - - if (k == MYPE) then - - do i = 1,nDEs - - if(MYPE /= i-1) then - - if((srcProcsID (n) == i-1).and.(srcProcsID (dstCatchID(N, i)) == MYPE))then - call MPI_RECV(rbuff,1,MPI_real, srcProcsID (N),999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,status) - K = dstCatchID(N,i) - Local_Min + 1 - QINFLOW (K) = QINFLOW (K) + rbuff - WRIVER (K) = WRIVER (K) + rbuff * real(route_dt) - - endif - endif - end do - endif - - endif - - end do - - ! initialize the cycle counter and sum (runoff_tile) + ! ------------------------ + !CALL RIVER_ROUTING_LIN (ntiles, RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT, & + ! WSTREAM_ACT,WRIVER_ACT, QSFLOW_ACT,QOUTFLOW_ACT) + + CALL RIVER_ROUTING_HYD (ntiles, & + RUNOFF_ACT, route%lengsc, route%lstr, & + route%qstr_clmt, route%qri_clmt, route%qin_clmt, & + route%K, route%Kstr, & + WSTREAM_ACT,WRIVER_ACT, & + QSFLOW_ACT,QOUTFLOW_ACT) + + allocate(QOUTFLOW_GLOBAL(n_catg)) + call MPI_allgatherv ( & + QOUTFLOW_ACT, route%scounts_cat(mype+1) ,MPI_REAL, & + QOUTFLOW_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + + allocate(QINFLOW_LOCAL(ntiles)) + QINFLOW_LOCAL=0. + do i=1,nTiles + do j=1,upmax + if(route%upid(j,i)>0)then + upid=route%upid(j,i) + WRIVER_ACT(i)=WRIVER_ACT(i)+QOUTFLOW_GLOBAL(upid)*real(route_dt) + QINFLOW_LOCAL(i)=QINFLOW_LOCAL(i)+QOUTFLOW_GLOBAL(upid) + else + exit + endif + enddo + enddo + + !call check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUTFLOW_ACT,FirstTime,yr_s,mon_s) + + if(FirstTime) nstep_per_day = 86400/route_dt + route%wriver_acc = route%wriver_acc + WRIVER_ACT/real(nstep_per_day) + route%wstream_acc = route%wstream_acc + WSTREAM_ACT/real(nstep_per_day) + route%qoutflow_acc = route%qoutflow_acc + QOUTFLOW_ACT/real(nstep_per_day) + route%qsflow_acc = route%qsflow_acc + QSFLOW_ACT/real(nstep_per_day) + + deallocate(RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT,QOUTFLOW_ACT,QINFLOW_LOCAL,QOUTFLOW_GLOBAL,QSFLOW_ACT,WTOT_BEFORE) + !initialize the cycle counter and sum (runoff_tile) + WSTREAM_ACT=>NULL() + WRIVER_ACT=>NULL() runoff_save = 0. - ThisCycle = 1 + ThisCycle = 1 + ! output + !if(mapl_am_I_root())print *, "nstep_per_day=",nstep_per_day + if(mapl_am_I_root())print *, "Current time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS, ", next MM_next:",MM_next + if(FirstTime)then + if(mapl_am_I_root()) istat = mkdir("../river", int(o'755',c_int16_t)) + endif + if(HH==23)then + allocate(wriver_global(n_catg),wstream_global(n_catg),qoutflow_global(n_catg),qsflow_global(n_catg)) + !call MPI_allgatherv ( & + ! route%wriver_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + !call MPI_allgatherv ( & + ! route%wstream_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + route%qoutflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + qoutflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + !call MPI_allgatherv ( & + ! route%qsflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! qsflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + !open(88,file="../river/river_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + !open(89,file="../river/stream_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(90,file="../river/river_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + !open(91,file="../river/stream_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + !write(88,*)wriver_global(i) + !write(89,*)wstream_global(i) + write(90,*)qoutflow_global(i) + !write(91,*)qsflow_global(i) + enddo + close(90) + !close(88);close(89);close(90)!;close(91) + !print *, "output river storage is: ",sum(wriver_global)/1.e9 + !print *, "output stream storage is: ",sum(wstream_global)/1.e9 + endif + deallocate(wriver_global,wstream_global,qoutflow_global,qsflow_global) + route%wriver_acc = 0. + route%wstream_acc = 0. + route%qoutflow_acc = 0. + route%qsflow_acc = 0. + endif + + !restart + if(MM_next/=MM)then + allocate(wriver_global(n_catg),wstream_global(n_catg)) + call MPI_allgatherv ( & + route%wstream, route%scounts_cat(mype+1) ,MPI_REAL, & + wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + route%wriver, route%scounts_cat(mype+1) ,MPI_REAL, & + wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + write(yr_s,'(I4.4)')YY_next + write(mon_s,'(I2.2)')MM_next + write(day_s,'(I2.2)')DD_next + open(88,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(89,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(88,*)wriver_global(i) + write(89,*)wstream_global(i) + enddo + close(88);close(89) + print *, "saved river storage is: ",sum(wriver_global)/1.e9 + print *, "saved stream storage is: ",sum(wstream_global)/1.e9 + endif + deallocate(wriver_global,wstream_global) + endif + + if(FirstTime) FirstTime=.False. else - runoff_save = runoff_save + runoff/real (N_CYC) + runoff_save = runoff_save + RUNOFF_SRC0/real (N_CYC) ThisCycle = ThisCycle + 1 - - endif RUN_MODEL - call MAPL_TimerOff ( MAPL, "-RRM" ) + endif RUN_MODEL + + runoff_save => NULL() ! All done ! -------- + call MAPL_TimerOff ( MAPL, "-RRM" ) + call MAPL_TimerOff(MAPL,"RUN2") + !call MPI_Barrier(MPI_COMM_WORLD, mpierr) - call MAPL_TimerOff(MAPL,"RUN") RETURN_(ESMF_SUCCESS) + end subroutine RUN2 - end subroutine RUN - -! --------------------------------------------------------------------------- - - subroutine InitializeRiverRouting(MYPE, numprocs, root_proc, & - pfaf_code, AllActive, AlldstCatchID, srcProcsID, LocDstCatchID, rc) - - implicit none - INTEGER, INTENT (IN) :: MYPE, numprocs - LOGICAL, INTENT (IN) :: root_proc - INTEGER, DIMENSION (:), INTENT (IN) :: pfaf_code - INTEGER, DIMENSION (N_CatG), INTENT (INOUT) :: srcProcsID, LocDstCatchID - INTEGER, DIMENSION (N_CatG,numprocs), INTENT (INOUT) :: Allactive, AlldstCatchID - - INTEGER, DIMENSION(:) ,ALLOCATABLE :: global_buff, scounts, rdispls, rcounts, LocalActive - INTEGER :: N_active, I,J,K,N,i1,i2,NProcs, Local_Min, Local_Max +! -------------------------------------------------------- - integer, optional, intent(OUT):: rc - integer :: mpierr - character(len=ESMF_MAXSTR), parameter :: Iam='InitializeRiverRouting' + subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUTFLOW_ACT,FirstTime,yr_s,mon_s) + + type(T_RROUTE_STATE), intent(in) :: route + integer, intent(in) :: ntiles,nt_local + real,intent(in) :: runoff_save(nt_local),WRIVER_ACT(ntiles),WSTREAM_ACT(ntiles),WTOT_BEFORE(ntiles),RUNOFF_ACT(ntiles) + real,intent(in) :: QINFLOW_LOCAL(ntiles),QOUTFLOW_ACT(ntiles) + logical,intent(in) :: FirstTime + character(len=*), intent(in) :: yr_s,mon_s + + real,allocatable :: runoff_cat_global(:) + real,allocatable :: runoff_save_m3(:),runoff_global_m3(:) + real,allocatable :: WTOT_AFTER(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) + real,allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) - ! STEP 1: Identify active catchments within the local processor. If the catchment is active in - ! more than 1 processor, choose an owner. - ! -------------------------------------------------------------------------------------------- + integer :: i, nt_global,mype,cid,temp(1),tid,mpierr + real :: wr_error, wr_tot, runf_tot - allocate (LocalActive (1:N_CatG)) - LocalActive = -9999 - - Local_Min = minval (pfaf_code) - Local_Max = maxval (pfaf_code) - - do N = 1, size (pfaf_code) - LocalActive(pfaf_code(n)) = pfaf_code(n) - end do + nt_global = route%nt_global + mype = route%mype - allocate (global_buff (N_CatG * numprocs)) - allocate (scounts(numprocs),rdispls(numprocs),rcounts(numprocs)) + allocate(WTOT_AFTER(ntiles),UNBALANCE(ntiles),UNBALANCE_GLOBAL(n_catg),runoff_cat_global(n_catg)) + allocate(QFLOW_SINK(ntiles),QFLOW_SINK_GLOBAL(n_catg),WTOT_BEFORE_GLOBAL(n_catg),WTOT_AFTER_GLOBAL(n_catg)) + allocate(runoff_save_m3(nt_local),runoff_global_m3(nt_global),ERROR(ntiles),ERROR_GLOBAL(n_catg)) - scounts = N_CatG - rcounts = N_CatG - - rdispls(1) = 0 - global_buff= 0 - - do i=2,numprocs - rdispls(i)=rdispls(i-1)+rcounts(i-1) - enddo - - call MPI_allgatherv ( & - LocalActive, scounts ,MPI_INTEGER, & - global_buff, rcounts, rdispls,MPI_INTEGER, & - MPI_COMM_WORLD, mpierr) - do i=1,numprocs - Allactive (:,i) = global_buff((i-1)*N_CatG+1:i*N_CatG) - enddo - if (root_proc) then - - DO N = 1, N_CatG - NPROCS = count(Allactive(N,:) >= 1) - if(NPROCS > 0)then - if (NPROCS == 1) then - srcProcsID (N) = maxloc(Allactive(N,:),dim=1) - 1 - else - i1 = MAX(N - 5,1) - i2 = MIN(N + 5, N_CatG) - N_active = 0 - do I = 1,numprocs - if(Allactive (N,I) >= 1) then - if(count (Allactive(I1:I2,I) > 0) > N_active) then - N_active = count (Allactive(I1:I2,I) > 0) - J = I - endif - endif - end do - srcProcsID (N) = J - 1 - endif - endif - END DO + WTOT_AFTER=WRIVER_ACT+WSTREAM_ACT + ERROR = WTOT_AFTER - (WTOT_BEFORE + RUNOFF_ACT*route_dt + QINFLOW_LOCAL*route_dt - QOUTFLOW_ACT*route_dt) + where(QOUTFLOW_ACT>0.) UNBALANCE = abs(ERROR)/(QOUTFLOW_ACT*route_dt) + where(QOUTFLOW_ACT<=0.) UNBALANCE = 0. + call MPI_allgatherv ( & + UNBALANCE, route%scounts_cat(mype+1) ,MPI_REAL, & + UNBALANCE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + QFLOW_SINK=0. + do i=1,ntiles + if(route%downid(i)==-1)then + QFLOW_SINK(i) = QOUTFLOW_ACT(i) + endif + enddo + call MPI_allgatherv ( & + QFLOW_SINK, route%scounts_cat(mype+1) ,MPI_REAL, & + QFLOW_SINK_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + WTOT_BEFORE, route%scounts_cat(mype+1) ,MPI_REAL, & + WTOT_BEFORE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + WTOT_AFTER, route%scounts_cat(mype+1) ,MPI_REAL, & + WTOT_AFTER_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + runoff_save_m3=runoff_save*route%tile_area/1000. + call MPI_allgatherv ( & + runoff_save_m3, route%scounts_global(mype+1) ,MPI_REAL, & + runoff_global_m3, route%scounts_global, route%rdispls_global,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + RUNOFF_ACT, route%scounts_cat(mype+1) ,MPI_REAL, & + runoff_cat_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(88,file="../runoff_tile_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(runoff_global_m3) + close(88) + open(88,file="../runoff_cat_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(runoff_cat_global) + close(88) + !print *,"sum(runoff_global_m3)=",sum(runoff_global_m3) + !print *,"sum(runoff_cat_global)=",sum(runoff_cat_global) + endif + if(mapl_am_I_root())then + open(88,file="../WTOT_AFTER_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(WTOT_AFTER_GLOBAL) + close(88) + open(88,file="../WTOT_BEFORE_RUNOFF_QSINK_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt + close(88) + wr_error=sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt) + runf_tot=sum(runoff_global_m3)*route_dt + wr_tot=sum(WTOT_AFTER_GLOBAL) + open(88,file="../WTOT_ERROR_2_RUNOFF_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) wr_error/runf_tot + close(88) + open(88,file="../WTOT_ERROR_2_WTOT_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) wr_error/wr_tot + close(88) + !print *,"WTOT_ERROR_2_RUNOFF:",(sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt))/(sum(runoff_global_m3)*route_dt) + endif + + call MPI_allgatherv ( & + ERROR, route%scounts_cat(mype+1) ,MPI_REAL, & + ERROR_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + temp = maxloc(abs(ERROR_GLOBAL)) + cid = temp(1) + if(cid>=route%minCatch.and.cid<=route%maxCatch)then + tid=cid-route%minCatch+1 + print *,"my PE is:",mype,", max abs value of ERROR=", ERROR(tid)," at pfafid: ",route%minCatch+tid-1,", W_BEFORE=",WTOT_BEFORE(tid),", RUNOFF=",RUNOFF_ACT(tid)*route_dt,", QINFLOW=",QINFLOW_LOCAL(tid)*route_dt,", QOUTFLOW=",QOUTFLOW_ACT(tid)*route_dt,", W_AFTER=",WTOT_AFTER(tid) + endif + !if(FirstTime)then + ! if(mapl_am_I_root())then + ! open(88,file="ERROR_TOTAL.txt",action="write") + ! do i=1,n_catg + ! write(88,*)ERROR_GLOBAL(i) + ! enddo + ! endif + !endif + + deallocate(WTOT_AFTER,UNBALANCE,UNBALANCE_GLOBAL,ERROR,QFLOW_SINK,QFLOW_SINK_GLOBAL,WTOT_BEFORE_GLOBAL,WTOT_AFTER_GLOBAL) + deallocate(runoff_save_m3,runoff_global_m3,ERROR_GLOBAL,runoff_cat_global) + + + end subroutine check_balance - endif - - call MPI_BCAST (srcProcsID, N_CatG, MPI_INTEGER, 0,MPI_COMM_WORLD,mpierr) - - ! STEP 2: reset downstream catchment indeces (from -1 OR 1:291284) of catchments that are - ! in the local processor to full domain indeces. - ! ------------------------------------------------------------------------------------------ - - do N = Local_Min, Local_Max - - if(LocalActive (N) >=1) then - - if (LocDstCatchID (N) == -1) then - ! (a) DNST Catch is a sink hole, ocean or lake so water drains to self - LocDstCatchID (N) = N - - endif - - else - - LocDstCatchID (N) = -9999 ! is inactive - - endif - end do - global_buff= 0 - - call MPI_allgatherv ( & - LocDstCatchID, scounts ,MPI_INTEGER, & - global_buff, rcounts, rdispls,MPI_INTEGER, & - MPI_COMM_WORLD, mpierr) - - do i=1,numprocs - AlldstCatchID (:,i) = global_buff((i-1)*N_CatG+1:i*N_CatG) - enddo - - deallocate (global_buff, scounts, rdispls, rcounts, LocalActive) - - RETURN_(ESMF_SUCCESS) - end subroutine InitializeRiverRouting end module GEOS_RouteGridCompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 index 4d0f6a2da..922a17e14 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 @@ -3,7 +3,7 @@ MODULE routing_model IMPLICIT NONE private - public :: river_routing, SEARCH_DNST, ROUTE_DT + public :: river_routing_lin, river_routing_hyd, SEARCH_DNST, ROUTE_DT integer , parameter :: ROUTE_DT = 3600 CONTAINS @@ -11,7 +11,7 @@ MODULE routing_model ! ------------------------------------------------------------------------ - SUBROUTINE RIVER_ROUTING ( & + SUBROUTINE RIVER_ROUTING_LIN ( & NCAT, & RUNCATCH,AREACAT,LENGSC, & WSTREAM,WRIVER, & @@ -24,8 +24,9 @@ SUBROUTINE RIVER_ROUTING ( & REAL, INTENT(OUT), DIMENSION (NCAT) :: QSFLOW,QOUTFLOW REAL, PARAMETER :: K_SIMPLE = 0.111902, K_RES_MAX = 0.8 ! m1_r2com_c1 + REAL, PARAMETER :: CUR_AVG = 1.4 REAL, PARAMETER :: P1 = 0.010611, P2 = 0.188556, P3 = 0.096864, & - P4 = 0.691310, P5 = 0.365747, P6 = 0.009831 ! m5_calib_240 + P4 = 0.691310, P5 = 0.1, P6 = 0.009831 ! m5_calib_240, ori P5 = 0.365747, INTEGER :: N,I,J REAL :: COEFF, LS, COEFF1, COEFF2,ROFF @@ -58,7 +59,7 @@ SUBROUTINE RIVER_ROUTING ( & ! Updating WSTREAM WSTREAM(N) = WSTREAM(N) + RUNCATCH(N) * REAL (ROUTE_DT) - LS = AREACAT(N) / (AMAX1(1.,LENGSC (N))) + LS = AREACAT(N) / (AMAX1(1.,LENGSC (N))) /4. * CUR_AVG ROFF = RUNCATCH(N) * AREACAT(N) IF(ROFF < 2. ) THEN COEFF = RESCONST (LS, P1, P2) @@ -84,6 +85,7 @@ SUBROUTINE RIVER_ROUTING ( & IF(COEFF > K_RES_MAX) COEFF = K_SIMPLE QOUTFLOW(N) = COEFF * WRIVER(N) + QOUTFLOW(N) = MIN(QOUTFLOW(N), WRIVER(N)) !make WRIVER(N) >=0. WRIVER(N) = WRIVER(N) - QOUTFLOW(N) QOUTFLOW(N) = QOUTFLOW(N) / REAL (ROUTE_DT) @@ -91,7 +93,7 @@ SUBROUTINE RIVER_ROUTING ( & RETURN - END SUBROUTINE RIVER_ROUTING + END SUBROUTINE RIVER_ROUTING_LIN ! ------------------------------------------------------------------------------------------------------- @@ -136,4 +138,91 @@ END SUBROUTINE SEARCH_DNST ! ------------------------------------------------------------------------------------------------------- + SUBROUTINE RIVER_ROUTING_HYD ( & + NCAT, & + Qrunf0,llc_ori,lstr, & + qstr_clmt0, qri_clmt0, qin_clmt0, & + K, Kstr0, & + Ws0,Wr0, & + Qs,Qout) + + IMPLICIT NONE + INTEGER, INTENT(IN) :: NCAT + REAL, INTENT(IN), DIMENSION (NCAT) :: Qrunf0,llc_ori,lstr + REAL, INTENT(IN), DIMENSION (NCAT) :: qstr_clmt0,qri_clmt0,qin_clmt0 + REAL, INTENT(IN), DIMENSION (NCAT) :: K, Kstr0 + REAL, INTENT(INOUT),DIMENSION (NCAT) :: Ws0,Wr0 + REAL, INTENT(OUT), DIMENSION (NCAT) :: Qs,Qout + + + + real, parameter :: small = 1.e-20 + real, parameter :: fac_kstr = 0.025 ! Factor for local stream scaling + real, parameter :: M = 0.45 ! Parameter in hydraulic geometry formula + real, parameter :: mm = 0.35 ! Parameter in hydraulic geometry formula + real, parameter :: rho = 1000. + real, parameter :: cur_avg = 1.4 + + real,dimension(NCAT) :: Qrunf,qstr_clmt,qri_clmt,qin_clmt,Ws,Wr,Kstr + real,dimension(NCAT) :: nume,deno,llc,alp_s,alp_r,Qs0,ks,Ws_last + real :: dt + + integer :: i,j + + + Qrunf = Qrunf0 * rho !m3/s -> kg/s + !llc_ori = llc_ori0 * 1.e3 !km -> m + !lstr = lstr0 * 1.e3 !km -> m + qstr_clmt = qstr_clmt0 * rho !m3/s -> kg/s + qri_clmt = qri_clmt0 * rho !m3/s -> kg/s + qin_clmt = qin_clmt0 * rho !m3/s -> kg/s + Ws = Ws0 * rho !m3 -> kg + Wr = Wr0 * rho !m3 -> kg + Kstr = fac_kstr * Kstr0 + dt = ROUTE_DT + + ! Calculate llc (length of river channel) + nume = qri_clmt**(2.-M) - qin_clmt**(2.-M) ! Numerator for the llc calculation + deno = (2.-M) * (qri_clmt - qin_clmt) * (qri_clmt**(1.-M)) ! Denominator for the llc calculation + where(abs(deno) > small) llc = llc_ori * (nume / deno) ! Compute llc where denominator is not too small + where(abs(deno) <= small) llc = llc_ori * 0.5 ! Set llc to half of original value if denominator is small + + ! Calculate alp_s (stream coefficient) and alp_r (river coefficient) + where(qstr_clmt > small) alp_s = (rho**(-M) * qstr_clmt**(M-mm) * Kstr * (0.5*lstr)**(-1.))**(1./(1.-mm)) ! For non-zero streamflow + where(qstr_clmt <= small) alp_s = 0. ! If streamflow is too small, set alp_s to 0 + where(qri_clmt > small) alp_r = (rho**(-M) * qri_clmt**(M-mm) * K * llc**(-1.))**(1./(1.-mm)) ! For non-zero river input + where(qri_clmt <= small) alp_r = 0. ! If river input is too small, set alp_r to 0 + + ! Update state variables: ks, Ws, and Qs + where(Qrunf<=small)Qrunf=0. ! Set runoff to zero if it's too small + Qs0=max(0.,alp_s * Ws**(1./(1.-mm))) ! Initial flow from stream storage (kg/s) + ks=max(0.,(alp_s/(1.-mm)) * Ws**(mm/(1.D0-mm))) ! Flow coefficient (s^-1) + Ws_last=Ws ! Store the current water storage + where(ks>small) Ws=Ws + (Qrunf-Qs0)/ks*(1.-exp(-ks*dt)) ! Update storage (kg) + where(ks<=small) Ws=Ws + (Qrunf-Qs0)*dt ! Simplified update if ks is small + Ws=max(0.,Ws) ! Ensure storage is non-negative + Qs=max(0.,Qrunf-(Ws-Ws_last)/dt) ! Calculate the stream flow (kg/s) + + ! Calculate variables related to river routing: Qr0, kr + Wr=Wr+Qs*dt + Qout=max(0.,alp_r * Wr**(1./(1.-mm))) ! River flow based on water storage (kg/s) + Qout=min(Qout,Wr/dt) + Wr=max(0.,Wr-Qout*dt) + + Ws0 = Ws/rho !kg -> m3 + Wr0 = Wr/rho !kg -> m3 + Qs = Qs/rho !kg/s -> m3/s + Qout = Qout/rho !kg/s -> m3/s + + RETURN + + END SUBROUTINE RIVER_ROUTING_HYD + + + + +! ------------------------------------------------------------------------------------------------------- + + + END MODULE routing_model From 17b7d4b0a685df4b99f7a9e7f806da3d4c95e429 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Fri, 6 Dec 2024 12:40:55 -0500 Subject: [PATCH 10/27] back to TAKI --- .../GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index f7628ee38..412b39e93 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -35,7 +35,7 @@ module GEOS_RouteGridCompMod implicit none integer, parameter :: N_CatG = 291284 integer,parameter :: upmax=34 - character(len=500) :: inputdir="/discover/nobackup/yzeng3/data/river_input/" + character(len=500) :: inputdir="/umbc/xfs1/yujinz/users/yujinz/GEOSldas/river_input/" integer,save :: nmax private From 431674c544555842a166b2964d3719bea099118e Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Fri, 6 Dec 2024 12:42:12 -0500 Subject: [PATCH 11/27] back to Discover --- .../GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 412b39e93..f7628ee38 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -35,7 +35,7 @@ module GEOS_RouteGridCompMod implicit none integer, parameter :: N_CatG = 291284 integer,parameter :: upmax=34 - character(len=500) :: inputdir="/umbc/xfs1/yujinz/users/yujinz/GEOSldas/river_input/" + character(len=500) :: inputdir="/discover/nobackup/yzeng3/data/river_input/" integer,save :: nmax private From 5d98b30b963567de0e9db871061fdb1f7f001ac5 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Wed, 18 Dec 2024 15:08:33 -0500 Subject: [PATCH 12/27] a small bug fix for the offline model --- .../GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 index 3082a0bfe..68c4cfe4f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 @@ -313,7 +313,7 @@ subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,cat2res,Q_res,wid ! If the storage exceeds capacity, adjust outflow and storage if (Wr_res > cap_res) then - if (type_res /= 1) Q_res = Q_res + (Wr_res - cap_res) / dt ! Adjust outflow for overflow + Q_res = Q_res + (Wr_res - cap_res) / dt ! Adjust outflow for overflow Wr_res = cap_res ! Limit storage to reservoir capacity endif @@ -325,4 +325,4 @@ subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,cat2res,Q_res,wid end subroutine res_cal -end module reservoir \ No newline at end of file +end module reservoir From abcf705324000c8c48f3ae7cf7a7468e90da45aa Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Tue, 7 Jan 2025 20:47:28 -0500 Subject: [PATCH 13/27] update the offline model to the coupled model --- .../offline/interp_M36toPfaf.f90 | 2 +- .../GEOSroute_GridComp/offline/res_mod.f90 | 46 +++++++------------ 2 files changed, 18 insertions(+), 30 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 index c9ea88fcc..e3b831370 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 @@ -131,7 +131,7 @@ function M09_to_cat(runoff,nlon,nlat,ncat,inputdir) result(Qrunf) !$OMP DO ! Loop over all catchments and sub-areas do i=1,nc - do j=1,nmax + do j=1,nsub(i) sy=suby(j,i) ! Get y-coordinate of the sub-area sx=subx(j,i) ! Get x-coordinate of the sub-area ! Check for valid fraction and runoff values diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 index 68c4cfe4f..f3aed2c77 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 @@ -56,7 +56,7 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c allocate(Wr_res(nc),Q_res(nc)) allocate(elec_grand(nres),type_res(nc),cap_grand(nres),cap_res(nc),area_grand(nres)) allocate(area_res(nc),area_max_res(nc)) - allocate(irrsup_grand(nres)) + !allocate(irrsup_grand(nres)) allocate(fld_grand(nres),fld_res(nc),Qfld_thres(nc),supply_grand(nres)) allocate(irr_grand(nres)) allocate(cat2res(nc)) @@ -80,8 +80,8 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c !Qavg_grand=Qavg_grand*rho ! Convert flow rate from cubic meters per second (m3/s) to kilograms per second (kg/s) !open(77,file=trim(input_dir)//"/ai_grand.txt") !read(77,*)ai_grand - open(77,file=trim(input_dir)//"/irrmainsec_noelec_grand.txt") - read(77,*)irrsup_grand + !open(77,file=trim(input_dir)//"/irrmainsec_noelec_grand.txt") + !read(77,*)irrsup_grand open(77,file=trim(input_dir)//"/fldmainsec_grand.txt") read(77,*)fld_grand write(fld_thres,'(I2.2)')fac_fld @@ -138,35 +138,23 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c ! Compute reservoir width from area (square root of the area) wid_res = sqrt(area_res) - ! Assign reservoir type 7 (Other use) to the largest reservoir in a catchment + ! Assign reservoir type 6 (Other use) to the largest reservoir in a catchment do i = 1, nres if(flag_grand(i) == 1) then cid = catid_grand(i) if(other_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then - type_res(cid) = 7 ! Type 7 for other uses + type_res(cid) = 6 ! Type 7 for other uses cat2res(cid) = i ! Map the catchment to the reservoir area_max_res(cid) = area_grand(i) ! Update the maximum area for the catchment endif endif enddo - ! Assign reservoir type 6 (Recreational use) to the largest reservoir in a catchment + ! Assign reservoir type 5 (Recreational use) to the largest reservoir in a catchment do i = 1, nres if(flag_grand(i) == 1) then cid = catid_grand(i) if(rec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then - type_res(cid) = 6 - cat2res(cid) = i - area_max_res(cid) = area_grand(i) - endif - endif - enddo - - ! Assign reservoir type 5 (Navigational use) to the largest reservoir in a catchment - do i = 1, nres - if(flag_grand(i) == 1) then - cid = catid_grand(i) - if(nav_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then type_res(cid) = 5 cat2res(cid) = i area_max_res(cid) = area_grand(i) @@ -174,11 +162,11 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c endif enddo - ! Assign reservoir type 4 (Water supply) to the largest reservoir in a catchment + ! Assign reservoir type 4 (Navigational use) to the largest reservoir in a catchment do i = 1, nres if(flag_grand(i) == 1) then cid = catid_grand(i) - if(supply_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + if(nav_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then type_res(cid) = 4 cat2res(cid) = i area_max_res(cid) = area_grand(i) @@ -186,11 +174,11 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c endif enddo - ! Assign reservoir type 3 (Irrigation) to the largest reservoir in a catchment + ! Assign reservoir type 3 (Water supply) to the largest reservoir in a catchment do i = 1, nres if(flag_grand(i) == 1) then cid = catid_grand(i) - if(irr_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + if(supply_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then type_res(cid) = 3 cat2res(cid) = i area_max_res(cid) = area_grand(i) @@ -210,13 +198,13 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c endif enddo - ! Assign reservoir type 1 (Irrigation supply) with specific conditions + + ! Assign reservoir type 1 (Irrigation) to the largest reservoir in a catchment do i = 1, nres if(flag_grand(i) == 1) then cid = catid_grand(i) - if(irrsup_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then - type_res(cid) = 1 ! Assign type 1 for irrigation supply - !ai_res(cid) = ai_grand(i) ! Assign irrigation index to the catchment + if(irr_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res(cid) = 1 cat2res(cid) = i area_max_res(cid) = area_grand(i) endif @@ -284,7 +272,7 @@ subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,cat2res,Q_res,wid endif ! Irrigation reservoir - if (type_res == 1 .or. type_res == 3) then + if (type_res == 1) then alp_res = fac_irr_a * ((1.D0 / (wid_res / 1.D3)) ** fac_irr_b) / 3600.D0 ! irrigation coefficient Q_res = alp_res * Wr_res ! Outflow based on water storage @@ -294,12 +282,12 @@ subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,cat2res,Q_res,wid Q_res = alp_res * Wr_res ! Outflow based on water storage ! Water supply reservoir - else if (type_res == 4) then + else if (type_res == 3) then alp_res = fac_sup_a * ((1.D0 / (wid_res / 1.D3)) ** fac_sup_b) / 3600.D0 ! Supply coefficient Q_res = alp_res * Wr_res ! Outflow based on water storage ! Other reservoir types - else if (type_res == 5 .or. type_res == 6 .or. type_res == 7 .or. type_res == 0) then + else if (type_res == 4 .or. type_res == 5 .or. type_res == 6 .or. type_res == 0) then alp_res = fac_other_a * ((1.D0 / (wid_res / 1.D3)) ** fac_other_b) / 3600.D0 ! Generic reservoir coefficient Q_res = alp_res * Wr_res ! Outflow based on water storage endif From 96cbcd69a2d3931316f8234c99e6015d6fbf92a5 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Mon, 10 Mar 2025 15:08:56 -0400 Subject: [PATCH 14/27] reservoir module added --- .../GEOSroute_GridComp/CMakeLists.txt | 1 + .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 164 +++++++-- .../GEOSroute_GridComp/reservoir.F90 | 331 ++++++++++++++++++ .../GEOSroute_GridComp/routing_model.F90 | 3 +- 4 files changed, 461 insertions(+), 38 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt index 7629ae8f1..58f3cf452 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt @@ -3,6 +3,7 @@ esma_set_this () set (srcs GEOS_RouteGridComp.F90 routing_model.F90 + reservoir.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL esmf NetCDF::NetCDF_Fortran) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index e3be3540a..2697658c0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -26,6 +26,7 @@ module GEOS_RouteGridCompMod use MAPL_ConstantsMod use ROUTING_MODEL, ONLY: & river_routing_lin, river_routing_hyd, ROUTE_DT + use reservoir #if 0 USE catch_constants, ONLY: & N_CatG => N_Pfaf_Catchs @@ -36,14 +37,29 @@ module GEOS_RouteGridCompMod integer, parameter :: N_CatG = 291284 integer,parameter :: upmax=34 character(len=500) :: inputdir="/discover/nobackup/yzeng3/data/river_input/" + logical,parameter :: use_res = .True. integer,save :: nmax private + type RES_STATE + integer, pointer :: active_res(:) + integer, pointer :: active_up(:,:) + real, pointer :: Wr_res(:) !m3 + integer, pointer :: type_res(:) + real, pointer :: cap_res(:) !m3 + real, pointer :: wid_res(:) !m + integer, pointer :: fld_res(:) + real, pointer :: Qfld_thres(:) !m3/s + integer, pointer :: cat2res(:) + real, pointer :: qres_acc(:) + end type RES_STATE + type T_RROUTE_STATE private type (ESMF_RouteHandle) :: routeHandle type (ESMF_Field) :: field + type (RES_STATE) :: reservoir integer :: nTiles integer :: nt_global integer :: nt_local @@ -344,10 +360,11 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) integer,pointer :: downid_global(:)=>NULL(), downid(:)=>NULL() integer,pointer :: upid_global(:,:)=>NULL(), upid(:,:)=>NULL() - real,pointer :: wstream(:)=>NULL(),wriver(:)=>NULL() - real,pointer :: wstream_global(:)=>NULL(),wriver_global(:)=>NULL() + real,pointer :: wstream(:)=>NULL(),wriver(:)=>NULL(),wres(:)=>NULL() + real,pointer :: wstream_global(:)=>NULL(),wriver_global(:)=>NULL(),wres_global(:)=>NULL() type (T_RROUTE_STATE), pointer :: route => null() + type (RES_STATE), pointer :: res => NULL() type (RROUTE_wrap) :: wrap type(ESMF_Time) :: CurrentTime @@ -519,8 +536,8 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) write(mon_s,'(I2.2)')MM write(day_s,'(I2.2)')DD if(mapl_am_I_root())print *, "init time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS - allocate(wriver(ntiles),wstream(ntiles)) - allocate(wriver_global(n_catg),wstream_global(n_catg)) + allocate(wriver(ntiles),wstream(ntiles),wres(ntiles)) + allocate(wriver_global(n_catg),wstream_global(n_catg),wres_global(n_catg)) open(77,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then read(77,*)wriver_global;close(77) @@ -559,19 +576,42 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) endif endif endif + open(77,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(77,*)wres_global;close(77) + else + close(77) + open(78,file=trim(inputdir)//"/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wres_global;close(78) + else + close(78) + open(79,file=trim(inputdir)//"/res_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wres_global;close(79) + else + close(79) + wres_global=0. + endif + endif + endif if(mapl_am_I_root())print *, "init river storage is: ",sum(wriver_global)/1.e9 - if(mapl_am_I_root())print *, "init stream storage is: ",sum(wstream_global)/1.e9 + if(mapl_am_I_root())print *, "init stream storage is: ",sum(wstream_global)/1.e9 + if(mapl_am_I_root())print *, "init reservoir storage is: ",sum(wres_global)/1.e9 wriver=wriver_global(minCatch:maxCatch) wstream=wstream_global(minCatch:maxCatch) - deallocate(wriver_global,wstream_global) + wres=wres_global(minCatch:maxCatch) + deallocate(wriver_global,wstream_global,wres_global) route%wstream=>wstream route%wriver=>wriver + route%reservoir%Wr_res=>wres - allocate(route%wriver_acc(ntiles),route%wstream_acc(ntiles),route%qoutflow_acc(ntiles),route%qsflow_acc(ntiles)) + allocate(route%wriver_acc(ntiles),route%wstream_acc(ntiles),route%qoutflow_acc(ntiles),route%qsflow_acc(ntiles),route%reservoir%qres_acc(ntiles)) route%wriver_acc=0. route%wstream_acc=0. route%qoutflow_acc=0. route%qsflow_acc=0. + route%reservoir%qres_acc=0. !input for geometry hydraulic allocate(buff_global(n_catg),route%lstr(ntiles)) @@ -604,6 +644,10 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%qstr_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) + res => route%reservoir + call res_init(inputdir,n_catg,ntiles,minCatch,maxCatch,use_res,res%active_res,res%type_res,res%cap_res,res%fld_res,res%Qfld_thres,res%cat2res,res%wid_res) + if(mapl_am_I_root()) print *,"reservoir init success" + !if (mapl_am_I_root())then ! open(88,file="nsub.txt",action="write") ! open(89,file="subarea.txt",action="write") @@ -721,7 +765,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) integer :: K, N, I, req REAL :: mm2m3, rbuff, HEARTBEAT REAL, ALLOCATABLE, DIMENSION(:) :: RUNOFF_CATCH, RUNOFF_ACT,AREACAT_ACT,& - LENGSC_ACT, QSFLOW_ACT,QOUTFLOW_ACT + LENGSC_ACT, QSFLOW_ACT,QOUTFLOW_ACT,QRES_ACT,QOUT_CAT INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_index type(ESMF_Field) :: runoff_src @@ -742,10 +786,11 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) real,pointer :: runoff_save(:)=>NULL() real,pointer :: WSTREAM_ACT(:)=>NULL() real,pointer :: WRIVER_ACT(:)=>NULL() - real,allocatable :: runoff_save_m3(:),runoff_global_m3(:),QOUTFLOW_GLOBAL(:) + type (RES_STATE), pointer :: res => NULL() + real,allocatable :: runoff_save_m3(:),runoff_global_m3(:),QOUTFLOW_GLOBAL(:),Qres_global(:) real,allocatable :: WTOT_BEFORE(:),WTOT_AFTER(:),QINFLOW_LOCAL(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) real,allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) - real,allocatable :: wriver_global(:),wstream_global(:),qsflow_global(:) + real,allocatable :: wriver_global(:),wstream_global(:),qsflow_global(:),wres_global(:) ! ------------------ ! begin @@ -786,6 +831,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) nt_global = route%nt_global runoff_save => route%runoff_save nt_local = route%nt_local + res => route%reservoir ! get the field from IMPORT call ESMF_StateGet(IMPORT, 'RUNOFF', field=runoff_src, RC=STATUS) @@ -836,11 +882,12 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) deallocate(runoff_global) - allocate (AREACAT_ACT (1:ntiles)) - allocate (LENGSC_ACT (1:ntiles)) - allocate (QSFLOW_ACT (1:ntiles)) - allocate (QOUTFLOW_ACT(1:ntiles)) + allocate (AREACAT_ACT (ntiles)) + allocate (LENGSC_ACT (ntiles)) + allocate (QSFLOW_ACT (ntiles)) + allocate (QOUTFLOW_ACT(ntiles),QRES_ACT(ntiles),QOUT_CAT(ntiles)) + QRES_ACT=0. LENGSC_ACT=route%lengsc/1.e3 !m->km AREACAT_ACT=route%areacat/1.e6 !m2->km2 @@ -849,7 +896,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) allocate(WTOT_BEFORE(ntiles)) - WTOT_BEFORE=WSTREAM_ACT+WRIVER_ACT + WTOT_BEFORE=WSTREAM_ACT+WRIVER_ACT+res%Wr_res ! Call river_routing_model ! ------------------------ @@ -861,13 +908,20 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) route%qstr_clmt, route%qri_clmt, route%qin_clmt, & route%K, route%Kstr, & WSTREAM_ACT,WRIVER_ACT, & - QSFLOW_ACT,QOUTFLOW_ACT) + QSFLOW_ACT,QOUTFLOW_ACT) + do i=1,ntiles + call res_cal(res%active_res(i),QOUTFLOW_ACT(i),res%type_res(i),res%cat2res(i),& + QRES_ACT(i),res%wid_res(i),res%fld_res(i),res%Wr_res(i),res%Qfld_thres(i),res%cap_res(i),real(route_dt)) + enddo + QOUT_CAT = QOUTFLOW_ACT + where(res%active_res==1) QOUT_CAT=QRES_ACT + allocate(QOUTFLOW_GLOBAL(n_catg)) call MPI_allgatherv ( & - QOUTFLOW_ACT, route%scounts_cat(mype+1) ,MPI_REAL, & + QOUT_CAT, route%scounts_cat(mype+1) ,MPI_REAL, & QOUTFLOW_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + MPI_COMM_WORLD, mpierr) allocate(QINFLOW_LOCAL(ntiles)) QINFLOW_LOCAL=0. @@ -883,15 +937,16 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) enddo enddo - !call check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUTFLOW_ACT,FirstTime,yr_s,mon_s) + call check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUT_CAT,FirstTime,yr_s,mon_s) if(FirstTime) nstep_per_day = 86400/route_dt route%wriver_acc = route%wriver_acc + WRIVER_ACT/real(nstep_per_day) route%wstream_acc = route%wstream_acc + WSTREAM_ACT/real(nstep_per_day) route%qoutflow_acc = route%qoutflow_acc + QOUTFLOW_ACT/real(nstep_per_day) route%qsflow_acc = route%qsflow_acc + QSFLOW_ACT/real(nstep_per_day) + res%qres_acc = res%qres_acc + QRES_ACT/real(nstep_per_day) - deallocate(RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT,QOUTFLOW_ACT,QINFLOW_LOCAL,QOUTFLOW_GLOBAL,QSFLOW_ACT,WTOT_BEFORE) + deallocate(RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT,QOUTFLOW_ACT,QINFLOW_LOCAL,QOUTFLOW_GLOBAL,QSFLOW_ACT,WTOT_BEFORE,QRES_ACT,QOUT_CAT) !initialize the cycle counter and sum (runoff_tile) WSTREAM_ACT=>NULL() WRIVER_ACT=>NULL() @@ -922,28 +977,48 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) !call MPI_allgatherv ( & ! route%qsflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & ! qsflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) + ! MPI_COMM_WORLD, mpierr) if(mapl_am_I_root())then !open(88,file="../river/river_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") !open(89,file="../river/stream_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - open(90,file="../river/river_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - !open(91,file="../river/stream_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(90,file="../river/river_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + !open(91,file="../river/stream_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") do i=1,n_catg !write(88,*)wriver_global(i) !write(89,*)wstream_global(i) write(90,*)qoutflow_global(i) !write(91,*)qsflow_global(i) enddo + !close(88) + !close(89) close(90) - !close(88);close(89);close(90)!;close(91) + !close(91) !print *, "output river storage is: ",sum(wriver_global)/1.e9 - !print *, "output stream storage is: ",sum(wstream_global)/1.e9 - endif + !print *, "output stream storage is: ",sum(wstream_global)/1.e9 + endif + + if(use_res==.True.)then + allocate(qres_global(n_catg)) + call MPI_allgatherv ( & + res%qres_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + qres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(92,file="../river/res_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(92,*)qres_global(i) + enddo + close(92) + endif + deallocate(qres_global) + endif + deallocate(wriver_global,wstream_global,qoutflow_global,qsflow_global) route%wriver_acc = 0. route%wstream_acc = 0. route%qoutflow_acc = 0. route%qsflow_acc = 0. + res%qres_acc = 0. endif !restart @@ -962,15 +1037,33 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) write(mon_s,'(I2.2)')MM_next write(day_s,'(I2.2)')DD_next open(88,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - open(89,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(89,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") do i=1,n_catg write(88,*)wriver_global(i) write(89,*)wstream_global(i) enddo close(88);close(89) print *, "saved river storage is: ",sum(wriver_global)/1.e9 - print *, "saved stream storage is: ",sum(wstream_global)/1.e9 + print *, "saved stream storage is: ",sum(wstream_global)/1.e9 endif + + if(use_res==.True.)then + allocate(wres_global(n_catg)) + call MPI_allgatherv ( & + res%Wr_res, route%scounts_cat(mype+1) ,MPI_REAL, & + wres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(90,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(90,*)wres_global(i) + enddo + close(90) + print *, "saved reservoir storage is: ",sum(wres_global)/1.e9 + endif + deallocate(wres_global) + endif + deallocate(wriver_global,wstream_global) endif @@ -1023,16 +1116,13 @@ subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_AC allocate(QFLOW_SINK(ntiles),QFLOW_SINK_GLOBAL(n_catg),WTOT_BEFORE_GLOBAL(n_catg),WTOT_AFTER_GLOBAL(n_catg)) allocate(runoff_save_m3(nt_local),runoff_global_m3(nt_global),ERROR(ntiles),ERROR_GLOBAL(n_catg)) - - - WTOT_AFTER=WRIVER_ACT+WSTREAM_ACT + WTOT_AFTER=WRIVER_ACT+WSTREAM_ACT+route%reservoir%Wr_res ERROR = WTOT_AFTER - (WTOT_BEFORE + RUNOFF_ACT*route_dt + QINFLOW_LOCAL*route_dt - QOUTFLOW_ACT*route_dt) - where(QOUTFLOW_ACT>0.) UNBALANCE = abs(ERROR)/(QOUTFLOW_ACT*route_dt) - where(QOUTFLOW_ACT<=0.) UNBALANCE = 0. - call MPI_allgatherv ( & - UNBALANCE, route%scounts_cat(mype+1) ,MPI_REAL, & - UNBALANCE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + !UNBALANCE = abs(ERROR) + !call MPI_allgatherv ( & + ! UNBALANCE, route%scounts_cat(mype+1) ,MPI_REAL, & + ! UNBALANCE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) QFLOW_SINK=0. do i=1,ntiles if(route%downid(i)==-1)then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 new file mode 100644 index 000000000..9e42c2d7e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 @@ -0,0 +1,331 @@ +module reservoir + + +implicit none +private +public :: res_init, res_cal + +!----Reservoir module constants---------- +integer,parameter :: nres=7250 +integer,parameter :: nlake=3917 + +real, parameter :: fac_elec_a = 0.30 ! Coefficient for hydropower calculation +real, parameter :: fac_elec_b = 2.00 ! Exponent for hydropower calculation +real, parameter :: fac_irr_a = 0.01 ! Coefficient for irrigation calculation (arid areas) +real, parameter :: fac_irr_b = 3.00 ! Scaling factor for irrigation (arid areas) +real, parameter :: fac_sup_a = 0.03 ! Coefficient for water supply calculation +real, parameter :: fac_sup_b = 2.00 ! Exponent for water supply calculation +real, parameter :: fac_other_a = 0.20 ! Coefficient for other reservoir types +real, parameter :: fac_other_b = 2.00 ! Exponent for other reservoir types +integer, parameter :: fac_fld = 1 ! Flood control parameter + +real, parameter :: fac_a_slake = 0.003 ! Factor for small lakes +real, parameter :: fac_b_slake = 0.40 ! Exponent for small lakes +real, parameter :: fac_a_llake = 0.01 ! Factor for large lakes +real, parameter :: fac_b_llake = 0.60 ! Exponent for large lakes +real, parameter :: thr_wid_lake = 1.e5 ! Threshold lake width (in m) + +!real, parameter :: dt = 86400. ! Time step in seconds (1 day) +real, parameter :: rho = 1.e3 ! Water density (kg/m^3) + +!----------------------------------------- + +contains + +!------------------------------------------ +! Initialization subroutine for reservoirs +subroutine res_init(input_dir,nall,nc,minCatch,maxCatch,use_res,active_res,type_res,cap_res,fld_res,Qfld_thres,cat2res,wid_res) + character(len=500),intent(in) :: input_dir + ! Define the number of reservoirs (nres) and the number of catchments (nc) + integer,intent(in) :: nall,nc,minCatch,maxCatch + ! Logical variable to check if reservoirs are used + logical,intent(in) :: use_res + ! Input/output arrays for reservoir attributes: active reservoirs, types, capacities, etc. + integer,intent(inout),pointer :: active_res(:),type_res(:),fld_res(:),cat2res(:) + real,intent(inout),pointer :: cap_res(:),Qfld_thres(:) + real,intent(inout),pointer :: wid_res(:) + + ! Internal arrays for various reservoir-related data + integer,allocatable,dimension(:) :: flag_grand,catid_grand,elec_grand,fld_grand,supply_grand,irr_grand,realuse_grand + integer,allocatable,dimension(:) :: nav_grand,rec_grand,other_grand + integer,allocatable,dimension(:) :: type_res_all,cat2res_all + real,allocatable,dimension(:) :: cap_grand,area_max_res,Qavg_grand,ai_grand,area_grand,power_grand,area_res + real,allocatable,dimension(:,:) :: Wres_tar + real,pointer :: buff_global(:)=>NULL(),area_all(:)=>NULL() + integer,pointer :: fld_all(:)=>NULL() !buff_global_int(:)=>NULL() + real :: value_max + + integer,allocatable,dimension(:) :: flag_lake,catid_lake + real,allocatable,dimension(:) :: area_lake + + ! Define the flood threshold variable and a counter variable + character(len=2) :: fld_thres + integer :: i,cid,rid + +!----------reservoir module-------------- + ! Allocate memory for each array + allocate(flag_grand(nres),catid_grand(nres),active_res(nc),Qfld_thres(nc)) + allocate(elec_grand(nres),type_res(nc),type_res_all(nall),cap_grand(nres),cap_res(nc),area_grand(nres)) + allocate(area_res(nc),area_max_res(nall)) + allocate(fld_grand(nres),fld_res(nc),supply_grand(nres)) + allocate(irr_grand(nres)) + allocate(cat2res(nc),cat2res_all(nall)) + allocate(nav_grand(nres),rec_grand(nres)) + allocate(other_grand(nres)) + allocate(wid_res(nc)) + allocate(realuse_grand(nres)) + + allocate(flag_lake(nlake),catid_lake(nlake),area_lake(nlake)) + + ! Open reservoir-related data files and read the corresponding arrays + open(77,file=trim(input_dir)//"/catid_dam_corr_aca_grand5000.txt",status="old",action="read") + read(77,*)catid_grand;close(77) + open(77,file=trim(input_dir)//"/flag_all_res.txt",status="old",action="read") + read(77,*)flag_grand;close(77) + open(77,file=trim(input_dir)//"/cap_max_grand.txt",status="old",action="read") + read(77,*)cap_grand;close(77) + cap_grand=cap_grand*1.e6! Convert capacity from million cubic meters (MCM) to m3 + open(77,file=trim(input_dir)//"/hydroelec_grand.txt",status="old",action="read") + read(77,*)elec_grand;close(77) + open(77,file=trim(input_dir)//"/fldmainsec_grand.txt",status="old",action="read") + read(77,*)fld_grand;close(77) + write(fld_thres,'(I2.2)')fac_fld + + open(77,file=trim(input_dir)//"/watersupply_grand.txt",status="old",action="read") + read(77,*)supply_grand;close(77) + open(77,file=trim(input_dir)//"/irr_grand.txt",status="old",action="read") + read(77,*)irr_grand;close(77) + open(77,file=trim(input_dir)//"/nav_grand.txt",status="old",action="read") + read(77,*)nav_grand;close(77) + open(77,file=trim(input_dir)//"/rec_grand.txt",status="old",action="read") + read(77,*)rec_grand;close(77) + open(77,file=trim(input_dir)//"/other_grand.txt",status="old",action="read") + read(77,*)other_grand;close(77) + open(77,file=trim(input_dir)//"/area_skm_grand.txt",status="old",action="read") + read(77,*)area_grand;close(77) + area_grand=area_grand*1.e6 ! Convert area from square kilometers (km2) to square meters (m2) + + allocate(buff_global(nall)) + open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt");read(77,*)buff_global;close(77) + Qfld_thres=buff_global(minCatch:maxCatch) + deallocate(buff_global) + + !lake input + open(77, file = trim(input_dir)//"/lake_outlet_flag_valid_2097.txt") + read(77, *) flag_lake;close(77) + open(77, file = trim(input_dir)//"/lake_outlet_catid.txt") + read(77, *) catid_lake;close(77) + open(77, file = trim(input_dir)//"/lake_outlet_lakearea.txt") + read(77, *) area_lake;close(77) ! km^2 + area_lake=area_lake*1.e6 + + ! Set initial reservoir ID mapping + cat2res_all=0 + do i=1,nres + if(flag_grand(i)==1)then + cid=catid_grand(i) + cat2res_all(cid)=i ! Link reservoirs with catchments: multiple reservoirs in a catchment share attributes that can be accessed via cat2res + endif + enddo + + ! Initialize reservoir properties + cap_res = 0.0 ! Set reservoir capacity to zero + area_res = 0.0 ! Set reservoir area to zero + area_max_res = 0.0 ! Set max reservoir area to zero + type_res_all = 0 ! Set reservoir type to zero + fld_res = 0 ! Set flood status to zero + active_res = 0 ! Set active reservoirs to zero + realuse_grand = 0 ! Initialize real use for each reservoir to zero + + ! Loop over all reservoirs + allocate(buff_global(nall),fld_all(nall),area_all(nall)) + buff_global=0. + area_all=0. + fld_all=0 + do i = 1, nres + if(flag_grand(i) == 1) then ! If the reservoir is flagged as active + cid = catid_grand(i) ! Get the catchment ID for the reservoir + buff_global(cid) = buff_global(cid) + cap_grand(i) ! Sum up the capacities for reservoirs in the same catchment + area_all(cid) = area_all(cid) + area_grand(i) ! Sum up the areas for reservoirs in the same catchment + !Qavg_res(cid) = Qavg_grand(i) ! Assign average flow rate to the catchment + if(fld_grand(i) == 1) fld_all(cid) = 1 ! Mark the catchment if it has flood control + endif + enddo + cap_res=buff_global(minCatch:maxCatch) + value_max=huge(value_max) + where(cap_res==0.) cap_res=value_max + !area_res=buff_global2(minCatch:maxCatch) + fld_res=fld_all(minCatch:maxCatch) + deallocate(buff_global) + + ! Assign reservoir type 6 (Other use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(other_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 6 + cat2res_all(cid) = i ! Map the catchment to the reservoir + area_max_res(cid) = area_grand(i) ! Update the maximum area for the catchment + endif + endif + enddo + + ! Assign reservoir type 5 (Recreational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(rec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 5 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 4 (Navigational use) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(nav_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 4 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 3 (Water supply) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(supply_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 3 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 2 (Electricity generation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(elec_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 2 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Assign reservoir type 1 (Irrigation) to the largest reservoir in a catchment + do i = 1, nres + if(flag_grand(i) == 1) then + cid = catid_grand(i) + if(irr_grand(i) == 1 .and. area_grand(i) >= area_max_res(cid)) then + type_res_all(cid) = 1 + cat2res_all(cid) = i + area_max_res(cid) = area_grand(i) + endif + endif + enddo + + ! Set up natural lakes + do i = 1, nlake + if(flag_lake(i) == 1 .and. catid_lake(i) > 0) then + cid = catid_lake(i) + if(type_res_all(cid)==0.and.fld_all(cid)==0)then + type_res_all(cid) = -1 !for lake + cat2res_all(cid) = i + area_all(cid) = area_lake(i) + endif + endif + enddo + + type_res=type_res_all(minCatch:maxCatch) + cat2res=cat2res_all(minCatch:maxCatch) + area_res=area_all(minCatch:maxCatch) + ! Compute reservoir width from area (square root of the area) + wid_res = sqrt(area_res)!m + + ! Mark active reservoirs based on type or flood control status + do i = 1, nc + if(type_res(i) /= 0 .or. fld_res(i) == 1) then + active_res(i) = 1 + endif + enddo + + ! Deactivate reservoirs if the use_res flag is set to False + if(use_res == .False.) active_res = 0 + + deallocate(flag_grand,catid_grand,elec_grand,type_res_all,cap_grand,area_grand) + deallocate(area_res,area_max_res,fld_grand,supply_grand,irr_grand) + deallocate(cat2res_all,nav_grand,rec_grand,other_grand,realuse_grand) + deallocate(flag_lake,catid_lake,area_lake,area_all,fld_all) + +end subroutine res_init + +!----------------------- +! Reservoir calculation subroutine +subroutine res_cal(active_res,Qout,type_res,cat2res,Q_res,wid_res,fld_res,Wr_res,Qfld_thres,cap_res,dt) + integer, intent(in) :: active_res, type_res, cat2res, fld_res + real, intent(in) :: Qout, wid_res, Qfld_thres, cap_res + real, intent(inout) :: Q_res, Wr_res + real, intent(in) :: dt + + integer :: rid ! Reservoir ID + real :: Qin_res, coe, irrfac, alp_res ! Variables for inflow, coefficients, and factors + + ! If the reservoir is active + if (active_res == 1) then + + ! Determine the inflow to the reservoir + Qin_res = Qout ! Inflow from river + + ! Irrigation reservoir + if (type_res == 1) then + alp_res = fac_irr_a * ((1.0 / (wid_res / 1.e3)) ** fac_irr_b) / 3600.0 ! irrigation coefficient + + ! Hydropower reservoir + else if (type_res == 2) then + alp_res = fac_elec_a * ((1.0 / (wid_res / 1.e3)) ** fac_elec_b) / 3600.0 ! Hydropower coefficient + + ! Water supply reservoir + else if (type_res == 3) then + alp_res = fac_sup_a * ((1.0 / (wid_res / 1.e3)) ** fac_sup_b) / 3600.0 ! Supply coefficient + + ! Other reservoir types + else if (type_res == 4 .or. type_res == 5 .or. type_res == 6 .or. type_res == 0) then + alp_res = fac_other_a * ((1.0 / (wid_res / 1.e3)) ** fac_other_b) / 3600.0 ! Generic reservoir coefficient + + ! Natural lake + else if (type_res == -1) then + ! Determine lake type based on area and calculate alpha + if (wid_res >= thr_wid_lake) then + alp_res = fac_a_llake * ( (1. / (wid_res / 1.e3)) ** fac_b_llake ) / 3600. + else + alp_res = fac_a_slake * ( (1./ (wid_res / 1.e3)) ** fac_b_slake ) / 3600. + endif + + endif + + Q_res = alp_res * Wr_res + + ! Ensure outflow is within reasonable bounds + Q_res = max(0.0, Q_res) ! Ensure non-negative outflow + Q_res = min(Q_res, Wr_res / dt + Qin_res) ! Limit outflow to prevent exceeding inflow and storage + if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control + Wr_res = Wr_res + dt * (Qin_res - Q_res) ! Update water storage in the reservoir + Wr_res = max(0.0, Wr_res) ! Ensure non-negative storage + + ! If the storage exceeds capacity, adjust outflow and storage + if (Wr_res > cap_res) then + Q_res = Q_res + (Wr_res - cap_res) / dt ! Adjust outflow for overflow + Wr_res = cap_res ! Limit storage to reservoir capacity + endif + + endif + +end subroutine res_cal + +end module reservoir \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 index 922a17e14..6f1d93b00 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 @@ -157,7 +157,7 @@ SUBROUTINE RIVER_ROUTING_HYD ( & real, parameter :: small = 1.e-20 - real, parameter :: fac_kstr = 0.025 ! Factor for local stream scaling + real, parameter :: fac_kstr = 0.01 ! Factor for local stream scaling real, parameter :: M = 0.45 ! Parameter in hydraulic geometry formula real, parameter :: mm = 0.35 ! Parameter in hydraulic geometry formula real, parameter :: rho = 1000. @@ -213,6 +213,7 @@ SUBROUTINE RIVER_ROUTING_HYD ( & Wr0 = Wr/rho !kg -> m3 Qs = Qs/rho !kg/s -> m3/s Qout = Qout/rho !kg/s -> m3/s + RETURN From ebe52872d6aab0481fb24675cb92bacf7eefe226 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Wed, 19 Mar 2025 16:15:13 -0400 Subject: [PATCH 15/27] temporarily disable flood control for dams --- .../offline/interp_M36toPfaf.f90 | 2 +- .../GEOSroute_GridComp/offline/ncdioMod.f90 | 2355 ----------------- .../GEOSroute_GridComp/offline/res_mod.f90 | 10 +- .../offline/river_io_mod.f90 | 13 +- .../GEOSroute_GridComp/offline/river_read.f90 | 219 ++ .../GEOSroute_GridComp/offline/rwncMod.f90 | 516 ---- .../GEOSroute_GridComp/reservoir.F90 | 6 +- 7 files changed, 235 insertions(+), 2886 deletions(-) delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/ncdioMod.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_read.f90 delete mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/rwncMod.f90 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 index e3b831370..b1cd63d88 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/interp_M36toPfaf.f90 @@ -1,7 +1,7 @@ module interp use omp_lib ! Use OpenMP library for parallel processing -use rwncfile ! Use custom module for reading NetCDF files +use river_read ! Use custom module for reading NetCDF files implicit none private diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/ncdioMod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/ncdioMod.f90 deleted file mode 100644 index 94b50af1a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/ncdioMod.f90 +++ /dev/null @@ -1,2355 +0,0 @@ - -module ncdio - use netcdf -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: ncdioMod -! -! !DESCRIPTION: -! Generic interfaces to write fields to netcdf files -! -! !USES: -! -! !PUBLIC TYPES: - implicit none - include 'netcdf.inc' ! - save - public :: check_ret ! checks return status of netcdf calls - public :: check_var ! determine if variable is on netcdf file - public :: check_dim ! validity check on dimension - public :: ncd_defvar -! -! !REVISION HISTORY: -! -!EOP -! -! !PRIVATE METHODS: -! - interface ncd_iolocal - module procedure ncd_iolocal_int_1d - module procedure ncd_iolocal_real_1d - module procedure ncd_iolocal_double_1d - module procedure ncd_iolocal_int_2d - module procedure ncd_iolocal_real_2d - module procedure ncd_iolocal_double_2d - end interface - - interface ncd_ioglobal - module procedure ncd_ioglobal_int_var - module procedure ncd_ioglobal_real_var - module procedure ncd_ioglobal_double_var - module procedure ncd_ioglobal_int_1d - module procedure ncd_ioglobal_real_1d - module procedure ncd_ioglobal_double_1d - module procedure ncd_ioglobal_byte_2d - module procedure ncd_ioglobal_short_2d - module procedure ncd_ioglobal_int_2d - module procedure ncd_ioglobal_long_2d - module procedure ncd_ioglobal_real_2d - module procedure ncd_ioglobal_double_2d - module procedure ncd_ioglobal_int_3d - module procedure ncd_ioglobal_short_3d - module procedure ncd_ioglobal_real_3d - module procedure ncd_ioglobal_double_3d - end interface - - private :: endrun - logical, public, parameter :: nc_masterproc = .true. ! proc 0 logical for printing msgs - -!----------------------------------------------------------------------- - -contains - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: check_dim -! -! !INTERFACE: - subroutine check_dim(ncid, dimname, value) -! -! !DESCRIPTION: -! Validity check on dimension -! !ARGUMENTS: - implicit none - integer, intent(in) :: ncid - character(len=*), intent(in) :: dimname - integer, intent(in) :: value -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: dimid, dimlen ! temporaries -!----------------------------------------------------------------------- - - call check_ret(nf_inq_dimid (ncid, trim(dimname), dimid), 'check_dim') - call check_ret(nf_inq_dimlen (ncid, dimid, dimlen), 'check_dim') - if (dimlen /= value) then - write (6,*) 'CHECK_DIM error: mismatch of input dimension ',dimlen, & - ' with expected value ',value,' for variable ',trim(dimname) - call endrun() - end if - - end subroutine check_dim - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: check_var -! -! !INTERFACE: - subroutine check_var(ncid, varname, varid, readvar) -! !DESCRIPTION: -! Check if variable is on netcdf file -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: ncid - character(len=*), intent(in) :: varname - integer, intent(out) :: varid - logical, intent(out) :: readvar -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: ret ! return value -!----------------------------------------------------------------------- - - readvar = .true. - if (nc_masterproc) then - ret = nf_inq_varid (ncid, varname, varid) - if (ret/=NF_NOERR) then - write(6,*)'CHECK_VAR: variable ',trim(varname),' is not on initial dataset' - readvar = .false. - end if - end if - end subroutine check_var - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: check_ret -! -! !INTERFACE: - subroutine check_ret(ret, calling) -! !DESCRIPTION: -! Check return status from netcdf call -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: ret - character(len=*) :: calling -! -! !REVISION HISTORY: -! -!EOP -!----------------------------------------------------------------------- - - if (ret /= NF_NOERR) then - write(6,*)'netcdf error from ',trim(calling) - call endrun(nf_strerror(ret)) - end if - - end subroutine check_ret - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_defvar -! -! !INTERFACE: - subroutine ncd_defvar(ncid, varname, xtype, & - dim1name, dim2name, dim3name, dim4name, dim5name, & - long_name, units, cell_method, missing_value, fill_value, & - imissing_value, ifill_value) -! !DESCRIPTION: -! Define a netcdf variable -! -! !ARGUMENTS: - implicit none - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - integer , intent(in) :: xtype ! external type - character(len=*), intent(in), optional :: dim1name ! dimension name - character(len=*), intent(in), optional :: dim2name ! dimension name - character(len=*), intent(in), optional :: dim3name ! dimension name - character(len=*), intent(in), optional :: dim4name ! dimension name - character(len=*), intent(in), optional :: dim5name ! dimension name - character(len=*), intent(in), optional :: long_name ! attribute - character(len=*), intent(in), optional :: units ! attribute - character(len=*), intent(in), optional :: cell_method ! attribute - real , intent(in), optional :: missing_value ! attribute for real - real , intent(in), optional :: fill_value ! attribute for real - integer , intent(in), optional :: imissing_value ! attribute for int - integer , intent(in), optional :: ifill_value ! attribute for int -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: n ! indices - integer :: ndims ! dimension counter - integer :: dimid(5) ! dimension ids - integer :: varid ! variable id - integer :: itmp ! temporary - character(len=256) :: str ! temporary - character(len=32) :: subname='NCD_DEFVAR_REAL' ! subroutine name -!----------------------------------------------------------------------- - - if (.not. nc_masterproc) return - - ! Determine dimension ids for variable - - dimid(:) = 0 - ndims=0 - if (present(dim1name)) then - ndims=ndims+1 - call check_ret(nf_inq_dimid(ncid, dim1name, dimid(ndims)), subname) - end if - if (present(dim2name)) then - ndims=ndims+1 - call check_ret(nf_inq_dimid(ncid, dim2name, dimid(ndims)), subname) - end if - if (present(dim3name)) then - ndims=ndims+1 - call check_ret(nf_inq_dimid(ncid, dim3name, dimid(ndims)), subname) - end if - if (present(dim4name)) then - ndims=ndims+1 - call check_ret(nf_inq_dimid(ncid, dim4name, dimid(ndims)), subname) - end if - if (present(dim5name)) then - ndims=ndims+1 - call check_ret(nf_inq_dimid(ncid, dim5name, dimid(ndims)), subname) - end if - - - ! Define variable - - if (present(dim1name) .or. present(dim2name) .or. present(dim3name) .or. & - present(dim4name) .or. present(dim5name)) then - call check_ret(nf_def_var(ncid, trim(varname), xtype, ndims, dimid(1:ndims), varid), subname) - else - call check_ret(nf_def_var(ncid, varname, xtype, 0, 0, varid), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - if (present(cell_method)) then - str = 'time: ' // trim(cell_method) - call check_ret(nf_put_att_text(ncid, varid, 'cell_method', len_trim(str), trim(str)), subname) - end if - if (present(fill_value)) then - call check_ret(nf_put_att_real(ncid, varid, '_FillValue', xtype, 1, fill_value), subname) - end if - if (present(missing_value)) then - call check_ret(nf_put_att_real(ncid, varid, 'missing_value', xtype, 1, missing_value), subname) - end if - if (present(ifill_value)) then - call check_ret(nf_put_att_int(ncid, varid, '_FillValue', xtype, 1, ifill_value), subname) - end if - if (present(imissing_value)) then - call check_ret(nf_put_att_int(ncid, varid, 'missing_value', xtype, 1, imissing_value), subname) - end if - - end subroutine ncd_defvar - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_iolocal_int_1d -! -! !INTERFACE: - - subroutine ncd_iolocal_int_1d(varname, data, flag, ncid, & - lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & - long_name, units, readvar) -! !DESCRIPTION: -! I/O for 1d int field -! -! !USES: -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - integer , intent(inout) :: data(:) ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - integer , optional, intent(in) :: lb_lon ! start for longitude - integer , optional, intent(in) :: lb_lat ! start for latitute sizes - integer , optional, intent(in) :: lb_lvl ! start for level size - integer , optional, intent(in) :: lb_t ! start for time size - integer , optional, intent(in) :: ub_lon ! start for longitude - integer , optional, intent(in) :: ub_lat ! start for latitute sizes - integer , optional, intent(in) :: ub_lvl ! start for level size - integer , optional, intent(in) :: ub_t ! start for time size - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! variable id - integer :: ndim ! dimension counter - integer :: start(4) ! starting indices for netcdf field - integer :: count(4) ! count values for netcdf field - character(len=32) :: inq_name ! inquid variable name - character(len=8) :: inq_xtype ! inquid variable type - integer :: inq_ndims ! inquid variable dimention - integer :: inq_dimids(4) ! inquid variable dimention id - character(len=255) :: inq_natts ! inquid variable attachment - character(len=32) :: subname='NCD_IOLOCAL_INT_1D' ! subroutine name - logical :: varpresent ! if true, variable is on tape -!----------------------------------------------------------------------- - - ! Write field as 1d field - if (flag == 'write') then - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - ! Write 1d field - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_put_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if ! end of if-nc_masterproc block - ! Read field as 1d field - else if (flag == 'read') then - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - !read data - call check_ret(nf_get_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - else - call endrun('the varibal does not difined!',subname) - end if - end if - if (present(readvar)) readvar = varpresent - end if - - end subroutine ncd_iolocal_int_1d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_iolocal_real_1d -! -! !INTERFACE: - subroutine ncd_iolocal_real_1d(varname, data, flag, ncid, & - lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & - long_name, units, readvar) -! !DESCRIPTION: -! I/O for 1d int field -! -! !USES: -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - real, intent(inout) :: data(:) ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - integer , optional, intent(in) :: lb_lon ! start for longitude - integer , optional, intent(in) :: lb_lat ! start for latitute sizes - integer , optional, intent(in) :: lb_lvl ! start for level size - integer , optional, intent(in) :: lb_t ! start for time size - integer , optional, intent(in) :: ub_lon ! start for longitude - integer , optional, intent(in) :: ub_lat ! start for latitute sizes - integer , optional, intent(in) :: ub_lvl ! start for level size - integer , optional, intent(in) :: ub_t ! start for time size - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! variable id - integer :: ndim ! dimension counter - integer :: start(4) ! starting indices for netcdf field - integer :: count(4) ! count values for netcdf field - character(len=32) :: inq_name ! inquid variable name - character(len=8) :: inq_xtype ! inquid variable type - integer :: inq_ndims ! inquid variable dimention - integer :: inq_dimids(4) ! inquid variable dimention id - character(len=255) :: inq_natts ! inquid variable attachment - character(len=32) :: subname='NCD_IOLOCAL_REAL_1D' ! subroutine name - logical :: varpresent ! if true, variable is on tape -!----------------------------------------------------------------------- - - ! Write field as 1d field - if (flag == 'write') then - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - ! Write 1d field - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_put_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if ! end of if-nc_masterproc block - ! Read field as 1d field - else if (flag == 'read') then - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - !read data - call check_ret(nf_get_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - else - call endrun('the varibal does not difined!',subname) - end if - end if - if (present(readvar)) readvar = varpresent - end if - - end subroutine ncd_iolocal_real_1d -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_iolocal_real_1d -! -! !INTERFACE: - subroutine ncd_iolocal_double_1d(varname, data, flag, ncid, & - lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & - long_name, units, readvar) -! !DESCRIPTION: -! I/O for 1d int field -! -! !USES: -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - real*8, intent(inout) :: data(:) ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - integer , optional, intent(in) :: lb_lon ! start for longitude - integer , optional, intent(in) :: lb_lat ! start for latitute sizes - integer , optional, intent(in) :: lb_lvl ! start for level size - integer , optional, intent(in) :: lb_t ! start for time size - integer , optional, intent(in) :: ub_lon ! start for longitude - integer , optional, intent(in) :: ub_lat ! start for latitute sizes - integer , optional, intent(in) :: ub_lvl ! start for level size - integer , optional, intent(in) :: ub_t ! start for time size - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! variable id - integer :: ndim ! dimension counter - integer :: start(4) ! starting indices for netcdf field - integer :: count(4) ! count values for netcdf field - character(len=32) :: inq_name ! inquid variable name - character(len=8) :: inq_xtype ! inquid variable type - integer :: inq_ndims ! inquid variable dimention - integer :: inq_dimids(4) ! inquid variable dimention id - character(len=255) :: inq_natts ! inquid variable attachment - character(len=32) :: subname='NCD_IOLOCAL_REAL_1D' ! subroutine name - logical :: varpresent ! if true, variable is on tape -!----------------------------------------------------------------------- - - ! Write field as 1d field - if (flag == 'write') then - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - ! Write 1d field - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_put_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if ! end of if-nc_masterproc block - ! Read field as 1d field - else if (flag == 'read') then - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - !read data - call check_ret(nf_get_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - else - call endrun('the varibal does not difined!',subname) - end if - end if - if (present(readvar)) readvar = varpresent - end if - - end subroutine ncd_iolocal_double_1d -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_iolocal_int_2d -! -! !INTERFACE: - subroutine ncd_iolocal_int_2d(varname, data, flag, ncid, & - lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & - long_name, units, readvar) -! !DESCRIPTION: -! I/O for 2d real field -! -! !USES: -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - integer , intent(inout) :: data(:,:) ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - integer , optional, intent(in) :: lb_lon ! start for longitude - integer , optional, intent(in) :: lb_lat ! start for latitute sizes - integer , optional, intent(in) :: lb_lvl ! start for level size - integer , optional, intent(in) :: lb_t ! start for time size - integer , optional, intent(in) :: ub_lon ! start for longitude - integer , optional, intent(in) :: ub_lat ! start for latitute sizes - integer , optional, intent(in) :: ub_lvl ! start for level size - integer , optional, intent(in) :: ub_t ! start for time size - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! variable id - integer :: ndim ! dimension counter - integer :: start(4) ! starting indices for netcdf field - integer :: count(4) ! count values for netcdf field - character(len=32) :: inq_name ! inquid variable name - character(len=8) :: inq_xtype ! inquid variable type - integer :: inq_ndims ! inquid variable dimention - integer :: inq_dimids(4) ! inquid variable dimention id - character(len=255) :: inq_natts ! inquid variable attachment - character(len=32) :: subname='NCD_IOLOCAL_INT_2D' ! subroutine name - logical :: varpresent ! if true, variable is on tape -!----------------------------------------------------------------------- - - ! Write field as 2d field - if (flag == 'write') then - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - ! Write 2d field - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_put_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if ! end of if-nc_masterproc block - ! Read field as 1d field - else if (flag == 'read') then - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_get_vara_int(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - else - call endrun('the varibal does not difined!',subname) - end if - end if - if (present(readvar)) readvar = varpresent - end if - - end subroutine ncd_iolocal_int_2d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_iolocal_real_2d -! -! !INTERFACE: - subroutine ncd_iolocal_real_2d(varname, data, flag, ncid, & - lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & - long_name, units, readvar) -! !DESCRIPTION: -! I/O for 2d real field -! -! !USES: -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - real, intent(inout) :: data(:,:) ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - integer , optional, intent(in) :: lb_lon ! start for longitude - integer , optional, intent(in) :: lb_lat ! start for latitute sizes - integer , optional, intent(in) :: lb_lvl ! start for level size - integer , optional, intent(in) :: lb_t ! start for time size - integer , optional, intent(in) :: ub_lon ! start for longitude - integer , optional, intent(in) :: ub_lat ! start for latitute sizes - integer , optional, intent(in) :: ub_lvl ! start for level size - integer , optional, intent(in) :: ub_t ! start for time size - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! variable id - integer :: ndim ! dimension counter - integer :: start(4) ! starting indices for netcdf field - integer :: count(4) ! count values for netcdf field - character(len=32) :: inq_name ! inquid variable name - character(len=8) :: inq_xtype ! inquid variable type - integer :: inq_ndims ! inquid variable dimention - integer :: inq_dimids(4) ! inquid variable dimention id - character(len=255) :: inq_natts ! inquid variable attachment - character(len=32) :: subname='NCD_IOLOCAL_REAL_2D' ! subroutine name - logical :: varpresent ! if true, variable is on tape -!----------------------------------------------------------------------- - - ! Write field as 2d field - if (flag == 'write') then - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - ! Write 2d field - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_put_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if ! end of if-nc_masterproc block - ! Read field as 1d field - else if (flag == 'read') then - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_get_vara_real(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - else - call endrun('the varibal does not difined!',subname) - end if - end if - if (present(readvar)) readvar = varpresent - end if - - end subroutine ncd_iolocal_real_2d - - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_iolocal_real_2d -! -! !INTERFACE: - subroutine ncd_iolocal_double_2d(varname, data, flag, ncid, & - lb_lon, lb_lat, lb_lvl, lb_t, ub_lon, ub_lat, ub_lvl, ub_t, & - long_name, units, readvar) -! !DESCRIPTION: -! I/O for 2d real field -! -! !USES: -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - real*8, intent(inout) :: data(:,:) ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - integer , optional, intent(in) :: lb_lon ! start for longitude - integer , optional, intent(in) :: lb_lat ! start for latitute sizes - integer , optional, intent(in) :: lb_lvl ! start for level size - integer , optional, intent(in) :: lb_t ! start for time size - integer , optional, intent(in) :: ub_lon ! start for longitude - integer , optional, intent(in) :: ub_lat ! start for latitute sizes - integer , optional, intent(in) :: ub_lvl ! start for level size - integer , optional, intent(in) :: ub_t ! start for time size - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! variable id - integer :: ndim ! dimension counter - integer :: start(4) ! starting indices for netcdf field - integer :: count(4) ! count values for netcdf field - character(len=32) :: inq_name ! inquid variable name - character(len=8) :: inq_xtype ! inquid variable type - integer :: inq_ndims ! inquid variable dimention - integer :: inq_dimids(4) ! inquid variable dimention id - character(len=255) :: inq_natts ! inquid variable attachment - character(len=32) :: subname='NCD_IOLOCAL_REAL_2D' ! subroutine name - logical :: varpresent ! if true, variable is on tape -!----------------------------------------------------------------------- - - ! Write field as 2d field - if (flag == 'write') then - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - ! Write 2d field - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_put_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if ! end of if-nc_masterproc block - ! Read field as 1d field - else if (flag == 'read') then - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - ndim=0 - count=1 - if (present(lb_lon) .and. present(ub_lon)) then - ndim=ndim+1 - start(ndim)=lb_lon - count(ndim)=ub_lon-lb_lon+1 - else if(present(lb_lon) .neqv. present(ub_lon))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lat)) then - ndim=ndim+1 - start(ndim)=lb_lat - count(ndim)=ub_lat-lb_lat+1 - else if(present(lb_lat) .neqv. present(ub_lat))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_lvl)) then - ndim=ndim+1 - start(ndim)=lb_lvl - count(ndim)=ub_lvl-lb_lvl+1 - else if(present(lb_lvl) .neqv. present(ub_lvl))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - if (present(lb_t)) then - ndim=ndim+1 - start(ndim)=lb_t - count(ndim)=ub_t-lb_t+1 - else if(present(lb_t) .neqv. present(lb_t))then - call endrun('must specify the low and up boundary at the same time!',subname) - endif - - if ((.not. present(lb_lon)) .and. (.not. present(lb_lat)) .and. & - (.not. present(lb_lvl)) .and. (.not. present(lb_t))) then - call endrun('must specify one dimention!',subname) - endif - - call check_ret(nf_get_vara_double(ncid, varid, start(1:ndim), count(1:ndim), data), subname) - else - call endrun('the varibal does not difined!',subname) - end if - end if - if (present(readvar)) readvar = varpresent - end if - - end subroutine ncd_iolocal_double_2d - - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_int_var -! -! !INTERFACE: - subroutine ncd_ioglobal_int_var(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! I/O of integer variable -! - -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - integer , intent(inout) :: data ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - integer , optional, intent(in) :: nt ! time sample index - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: ier ! error status - integer :: dimid(1) ! dimension id - integer :: start(1), count(1) ! output bounds - integer :: varid ! variable id - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_INT_VAR' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = nt; count(1) = 1 - call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_int(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_int_var - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_var -! -! !INTERFACE: - subroutine ncd_ioglobal_real_var(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! I/O of real variable -! - -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - real , intent(inout) :: data ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: ier ! error status - integer :: dimid(1) ! dimension id - integer :: start(1), count(1) ! output bounds - integer :: varid ! variable id - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_VAR' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = nt; count(1) = 1 - call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_real(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_real(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_real_var - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_var -! -! !INTERFACE: - subroutine ncd_ioglobal_double_var(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! I/O of real variable -! - -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: varname ! variable name - real*8 , intent(inout) :: data ! local decomposition data - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: ier ! error status - integer :: dimid(1) ! dimension id - integer :: start(1), count(1) ! output bounds - integer :: varid ! variable id - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_VAR' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = nt; count(1) = 1 - call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_double(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_double(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_double_var - -!---------------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_int_1d -! -! !INTERFACE: - subroutine ncd_ioglobal_int_1d(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! Master I/O for 1d integer data -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - integer , intent(inout) :: data(:) ! local decomposition data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: dimid(2), ndims ! dimension ids - integer :: start(2), count(2) ! output bounds - integer :: ier ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_INT_1D' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data) - start(2) = nt; count(2) = 1 - call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_int(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_int_1d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_1d -! -! !INTERFACE: - subroutine ncd_ioglobal_real_1d(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! Master I/O for 1d real data -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - real , intent(inout) :: data(:) ! local decomposition input data - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: ier ! error code - integer :: dimid(2), ndims ! dimension ids - integer :: start(2), count(2) ! output bounds - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_1D' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data) - start(2) = nt; count(2) = 1 - call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) - else -! call check_ret(nf_put_var_real(ncid, varid, data), subname) -call check_ret(nf_put_var_real(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_real(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_real_1d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_1d -! -! !INTERFACE: - subroutine ncd_ioglobal_double_1d(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! Master I/O for 1d real data -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - real*8 , intent(inout) :: data(:) ! local decomposition input data - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: ier ! error code - integer :: dimid(2), ndims ! dimension ids - integer :: start(2), count(2) ! output bounds - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_1D' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data) - start(2) = nt; count(2) = 1 - call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) - else -! call check_ret(nf_put_var_double(ncid, varid, data), subname) -call check_ret(nf_put_var_double(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_double(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_double_1d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_int_2d -! -! !INTERFACE: - subroutine ncd_ioglobal_int_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 2d integer array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - integer , intent(inout) :: data(:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: dimid(3), ndims ! dimension ids - integer :: start(3), count(3) ! output bounds - integer :: ier ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_2D_INT_IO' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = nt; count(3) = 1 - call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_int(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_int_2d - -!----------------------------------------------------------------------- - -!BOP -! -! !IROUTINE: ncd_ioglobal_int_2d -! -! !INTERFACE: - subroutine ncd_ioglobal_long_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 2d integer array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - integer*8 , intent(inout) :: data(:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: dimid(3), ndims ! dimension ids - integer :: start(3), count(3) ! output bounds - integer :: ier ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_2D_INT_IO' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = nt; count(3) = 1 - call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_int(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_long_2d - -!----------------------------------------------------------------------- - -!BOP -! -! !IROUTINE: ncd_ioglobal_byte_2d -! -! !INTERFACE: - subroutine ncd_ioglobal_byte_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 2d integer array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - byte, intent(inout) :: data(:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: dimid(3), ndims ! dimension ids - integer :: start(3), count(3) ! output bounds - integer :: ier ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_2D_INT1_IO' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = nt; count(3) = 1 - call check_ret(nf_put_vara_int1(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int1(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_int1(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_byte_2d -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_short_2d -! -! !INTERFACE: - subroutine ncd_ioglobal_short_2d(varname, data, flag, ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 2d integer array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - integer*2, intent(inout) :: data(:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: dimid(3), ndims ! dimension ids - integer :: start(3), count(3) ! output bounds - integer :: ier ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_2D_INT2_IO' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = nt; count(3) = 1 - call check_ret(nf_put_vara_int2(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int2(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_int2(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_short_2d -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_2d -! -! !INTERFACE: - subroutine ncd_ioglobal_real_2d(varname, data, flag, & - ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 2d real array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - real , intent(inout) :: data(:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: ier ! error code - integer :: dimid(3), ndims ! dimension ids - integer :: start(3), count(3) ! output bounds - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_2D' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = nt; count(3) = 1 -! call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) -call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_real(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_real(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_real_2d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_2d -! -! !INTERFACE: - subroutine ncd_ioglobal_double_2d(varname, data, flag, & - ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 2d real array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - real*8 , intent(inout) :: data(:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: ier ! error code - integer :: dimid(3), ndims ! dimension ids - integer :: start(3), count(3) ! output bounds - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_2D' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = nt; count(3) = 1 -! call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) -call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_double(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - call check_ret(nf_get_var_double(ncid, varid, data), subname) - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_double_2d -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_short_3d -! -! !INTERFACE: - subroutine ncd_ioglobal_short_3d(varname, data, flag, & - ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 3d integer array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - integer*2 , intent(inout) :: data(:,:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: dimid(4), ndims ! dimension ids - integer :: start(4), count(4) ! output bounds - integer :: ier ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_3D_INT2_IO' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_put_vara_int2(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int2(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_get_vara_int2(ncid, varid, start, count, data), subname) - else - call check_ret(nf_get_var_int2(ncid, varid, data), subname) - end if - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_short_3d -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_int_3d -! -! !INTERFACE: - subroutine ncd_ioglobal_int_3d(varname, data, flag, & - ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 3d integer array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - integer , intent(inout) :: data(:,:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: dimid(4), ndims ! dimension ids - integer :: start(4), count(4) ! output bounds - integer :: ier ! error code - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_3D_INT_IO' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_put_vara_int(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_int(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_get_vara_int(ncid, varid, start, count, data), subname) - else - call check_ret(nf_get_var_int(ncid, varid, data), subname) - end if - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_int_3d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_3d -! -! !INTERFACE: - subroutine ncd_ioglobal_real_3d(varname, data, flag, & - ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 3d real array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - real, intent(inout) :: data(:,:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: ier ! error code - integer :: dimid(4), ndims ! dimension ids - integer :: start(4), count(4) ! output bounds - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_3D' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_put_vara_real(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_real(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_get_vara_real(ncid, varid, start, count, data), subname) - else - call check_ret(nf_get_var_real(ncid, varid, data), subname) - end if - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_real_3d - -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ncd_ioglobal_real_3d -! -! !INTERFACE: - subroutine ncd_ioglobal_double_3d(varname, data, flag, & - ncid, long_name, units, nt, readvar) -! !DESCRIPTION: -! netcdf I/O of global 3d real array -! -! !ARGUMENTS: - implicit none - character(len=*), intent(in) :: flag ! 'read' or 'write' - integer , intent(in) :: ncid ! input unit - character(len=*), intent(in) :: varname ! variable name - real*8, intent(inout) :: data(:,:,:) ! local decomposition input data - character(len=*), optional, intent(in) :: long_name ! variable long name - character(len=*), optional, intent(in) :: units ! variable units - logical , optional, intent(out):: readvar ! true => variable is on initial dataset (read only) - integer , optional, intent(in) :: nt ! time sample index -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer :: varid ! netCDF variable id - integer :: ier ! error code - integer :: dimid(4), ndims ! dimension ids - integer :: start(4), count(4) ! output bounds - logical :: varpresent ! if true, variable is on tape - character(len=32) :: subname='NCD_IOGLOBAL_REAL_3D' ! subroutine name -!----------------------------------------------------------------------- - - if (flag == 'write') then - - if (nc_masterproc) then - call check_ret(nf_inq_varid(ncid, varname, varid), subname) - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_put_vara_double(ncid, varid, start, count, data), subname) - else - call check_ret(nf_put_var_double(ncid, varid, data), subname) - end if - if (present(long_name)) then - call check_ret(nf_put_att_text(ncid, varid, 'long_name', len_trim(long_name), trim(long_name)), subname) - end if - if (present(units)) then - call check_ret(nf_put_att_text(ncid, varid, 'units', len_trim(units), trim(units)), subname) - end if - end if - - else if (flag == 'read') then - - if (nc_masterproc) then - call check_var(ncid, varname, varid, varpresent) - if (varpresent) then - if (present(nt)) then - start(1) = 1; count(1) = size(data, dim=1) - start(2) = 1; count(2) = size(data, dim=2) - start(3) = 1; count(3) = size(data, dim=3) - start(4) = nt; count(4) = 1 - call check_ret(nf_get_vara_double(ncid, varid, start, count, data), subname) - else - call check_ret(nf_get_var_double(ncid, varid, data), subname) - end if - else - call endrun('the varibal does not difined!',subname) - endif - end if - if (present(readvar)) readvar = varpresent - - end if - - end subroutine ncd_ioglobal_double_3d - -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: endrun -! -! !INTERFACE: -subroutine endrun(msg,subname) -! -! !DESCRIPTION: -! Abort the model for abnormal termination - implicit none -! !ARGUMENTS: - character(len=*), intent(in), optional :: msg ! string to be printed - character(len=*), intent(in), optional :: subname ! subname - - if (present (subname)) then - write(6,*) 'ERROR in subroutine :', trim(subname) - end if - - if (present (msg)) then - write(6,*)'ENDRUN:', msg - else - write(6,*) 'ENDRUN: called without a message string' - end if - - stop -end subroutine endrun - -end module ncdio - - - - - - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 index f3aed2c77..864065a10 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 @@ -1,6 +1,6 @@ module reservoir -use rwncfile +use river_read implicit none private @@ -85,9 +85,9 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c open(77,file=trim(input_dir)//"/fldmainsec_grand.txt") read(77,*)fld_grand write(fld_thres,'(I2.2)')fac_fld - open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt") - read(77,*)Qfld_thres ! Read flood thresholds in cubic meters per second (m3/s) - Qfld_thres=Qfld_thres*rho ! Convert threshold from cubic meters per second to kilograms per second (kg/s) + !open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt") + !read(77,*)Qfld_thres ! Read flood thresholds in cubic meters per second (m3/s) + Qfld_thres=0.D0!Qfld_thres*rho ! Convert threshold from cubic meters per second to kilograms per second (kg/s) open(77,file=trim(input_dir)//"/watersupply_grand.txt") read(77,*)supply_grand open(77,file=trim(input_dir)//"/irr_grand.txt") @@ -295,7 +295,7 @@ subroutine res_cal(active_res,active_lake,Qout,Q_lake,type_res,cat2res,Q_res,wid ! Ensure outflow is within reasonable bounds Q_res = max(0.D0, Q_res) ! Ensure non-negative outflow Q_res = min(Q_res, Wr_res / dt + Qin_res) ! Limit outflow to prevent exceeding inflow and storage - if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control + !if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control Wr_res = Wr_res + dt * (Qin_res - Q_res) ! Update water storage in the reservoir Wr_res = max(0.D0, Wr_res) ! Ensure non-negative storage diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 index d8472d8fe..ef83a668d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_io_mod.f90 @@ -1,7 +1,7 @@ module river_io use interp -use rwncfile +use river_read implicit none private @@ -9,7 +9,8 @@ module river_io public :: read_input,read_restart,read_runoff,write_output real*8, parameter :: rho = 1.D3 ! Water density in kg/m^3 -character(len=500) :: input_dir="/discover/nobackup/yzeng3/work/river_routing_model_offline/input/" ! Directory for input files +character(len=500) :: input_dir="/discover/nobackup/yzeng3/data/river_input/" ! Directory for input files +character(len=500) :: restart_dir="/discover/nobackup/yzeng3/data/river_restart/" character(len=500) :: output_dir="/discover/nobackup/yzeng3/river_output/" ! Directory for output files character(len=500) :: runoff_dir="/discover/nobackup/yzeng3/GEOldas_output/" ! Directory for runoff files @@ -109,18 +110,18 @@ subroutine read_restart(iter,is_coldstart,ny,nc,days_acc_year,days_acc_noleap,da ! If first iteration or cold start, read initial data if(iter==1.or.is_coldstart)then ! Read initial water storage data from files for cold start - open(77,file=trim(input_dir)//"/Pfaf_Ws_Kv_M0.10_mm0.40_20170330_OL7000.txt") + open(77,file=trim(restart_dir)//"/Pfaf_Ws_Kv_M0.10_mm0.40_20170330_OL7000.txt") read(77,*)Ws ! Read soil water storage (Ws) - open(77,file=trim(input_dir)//"/Pfaf_Wr_Kv_M0.10_mm0.40_20170330_OL7000.txt") + open(77,file=trim(restart_dir)//"/Pfaf_Wr_Kv_M0.10_mm0.40_20170330_OL7000.txt") read(77,*)Wr ! Read routing water storage (Wr) !----reservoir module------- - open(77,file=trim(input_dir)//"/Pfaf_Wr_res_Kv_M0.10_mm0.40_20170330_OL7000.txt") + open(77,file=trim(restart_dir)//"/Pfaf_Wr_res_Kv_M0.10_mm0.40_20170330_OL7000.txt") read(77,*)Wr_res ! Read reservoir water storage (Wr_res) !----lake module------------ - open(77,file=trim(input_dir)//"/Pfaf_Wr_lake_Kv_M0.10_mm0.40_20170330_OL7000.txt") + open(77,file=trim(restart_dir)//"/Pfaf_Wr_lake_Kv_M0.10_mm0.40_20170330_OL7000.txt") read(77,*)Wr_lake ! Read lake water storage (Wr_lake) ! Set cold start flag to False after initialization diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_read.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_read.f90 new file mode 100755 index 000000000..c8774b93a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/river_read.f90 @@ -0,0 +1,219 @@ +module river_read + + implicit none + include 'netcdf.inc' + + public :: read_ncfile_int1d + public :: read_ncfile_real1d + public :: read_ncfile_double1d + + public :: read_ncfile_int2d + public :: read_ncfile_int3d + public :: read_ncfile_real2d + public :: read_ncfile_real3d + public :: read_ncfile_double2d + public :: read_ncfile_double3d + + contains +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + integer, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real*8, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + integer, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double2d + + + subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real*8, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double3d +!------------------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: check_ret +! +! !INTERFACE: + subroutine check_ret(ret, calling) +! !DESCRIPTION: +! Check return status from netcdf call +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: ret + character(len=*) :: calling +! +! !REVISION HISTORY: +! +!EOP +!----------------------------------------------------------------------- + + if (ret /= NF_NOERR) then + write(6,*)'netcdf error from ',trim(calling) + call endrun(nf_strerror(ret)) + end if + + end subroutine check_ret +!----------------------------------------------------------------------- +!BOP +! !IROUTINE: endrun +! +! !INTERFACE: +subroutine endrun(msg,subname) +! +! !DESCRIPTION: +! Abort the model for abnormal termination + implicit none +! !ARGUMENTS: + character(len=*), intent(in), optional :: msg ! string to be printed + character(len=*), intent(in), optional :: subname ! subname + + if (present (subname)) then + write(6,*) 'ERROR in subroutine :', trim(subname) + end if + + if (present (msg)) then + write(6,*)'ENDRUN:', msg + else + write(6,*) 'ENDRUN: called without a message string' + end if + + stop +end subroutine endrun + +!----------------------------------------------------------------------- + +end module river_read + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/rwncMod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/rwncMod.f90 deleted file mode 100644 index 3b076e14a..000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/rwncMod.f90 +++ /dev/null @@ -1,516 +0,0 @@ -module rwncfile - - use ncdio - implicit none - - public :: read_ncfile_int1d - public :: read_ncfile_real1d - public :: read_ncfile_double1d - - public :: read_ncfile_int2d - public :: read_ncfile_int3d - public :: read_ncfile_real2d - public :: read_ncfile_real3d - public :: read_ncfile_double2d - public :: read_ncfile_double3d - - public :: write_ncfile_int2d - public :: write_ncfile_real2d - public :: write_ncfile_double2d - - public :: create_ncfile_byte2d - public :: create_ncfile_short2d - public :: create_ncfile_short3d - public :: create_ncfile_int3d - public :: create_ncfile_int2d - - public :: create_ncfile_long2d - public :: create_ncfile_real2d - public :: create_ncfile_real3d - public :: create_ncfile_double2d - - contains -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_int1d(filename,varname,var,n) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: n - integer, intent(inout) :: var(n) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_int(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_int1d -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_real1d(filename,varname,var,n) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: n - real, intent(inout) :: var(n) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_real(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_real1d -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_double1d(filename,varname,var,n) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: n - real*8, intent(inout) :: var(n) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_double(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_double1d -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_int2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - integer, intent(inout) :: var(nlon,nlat) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_int(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_int2d -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - integer, intent(inout) :: var(nlon,nlat,nlev) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_int(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_int3d -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_real2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real, intent(inout) :: var(nlon,nlat) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_real(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_real2d -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - real, intent(inout) :: var(nlon,nlat,nlev) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_real(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_real3d -!------------------------------------------------------------------------------------------ - subroutine read_ncfile_double2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real*8, intent(inout) :: var(nlon,nlat) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_double(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_double2d - - - subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - real*8, intent(inout) :: var(nlon,nlat,nlev) - - character(len=4) :: subname="read" - integer :: ncid, varid - - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) - call check_ret(nf_get_var_double(ncid,varid,var),subname) - call check_ret(nf_close(ncid), subname) - - end subroutine read_ncfile_double3d -!------------------------------------------------------------------------------------------ - subroutine write_ncfile_int2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - integer, intent(inout) :: var(nlon,nlat) - - character(len=4) :: subname="write" - integer :: ncid, varid, omode - - call check_ret(nf_open(filename, nf_write, ncid), subname) - call check_ret(nf_set_fill(ncid, nf_nofill, omode), subname) - call ncd_ioglobal(varname=varname, data=var, ncid=ncid, flag='write') - call check_ret(nf_sync(ncid), subname) - call check_ret(nf_close(ncid), subname) - end subroutine write_ncfile_int2d -!------------------------------------------------------------------------------------------ - subroutine write_ncfile_real2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real, intent(inout) :: var(nlon,nlat) - - character(len=4) :: subname="write" - integer :: ncid, varid, omode - - call check_ret(nf_open(filename, nf_write, ncid), subname) - call check_ret(nf_set_fill(ncid, nf_nofill, omode), subname) - call ncd_ioglobal(varname=varname, data=var, ncid=ncid, flag='write') - call check_ret(nf_sync(ncid), subname) - call check_ret(nf_close(ncid), subname) - end subroutine write_ncfile_real2d -!------------------------------------------------------------------------------------------ - subroutine write_ncfile_double2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real*8, intent(inout) :: var(nlon,nlat) - - character(len=4) :: subname="write" - integer :: ncid, varid, omode - - call check_ret(nf_open(filename, nf_write, ncid), subname) - call check_ret(nf_set_fill(ncid, nf_nofill, omode), subname) - call ncd_ioglobal(varname=varname, data=var, ncid=ncid, flag='write') - call check_ret(nf_sync(ncid), subname) - call check_ret(nf_close(ncid), subname) - end subroutine write_ncfile_double2d -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_int2d(filename,varname,var,lon,lat,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - integer, intent(inout) :: var(nlon,nlat) - real*8, intent(in) :: lon(nlon),lat(nlat) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat) - - lon1=lon - lat1=lat - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_int, dim1name='lon', & - dim2name='lat', long_name=varname, units='unitless', fill_value=-9999.) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_int2d - - subroutine create_ncfile_long2d(filename,varname,var,lon,lat,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - integer*8, intent(inout) :: var(nlon,nlat) - real*8, intent(in) :: lon(nlon),lat(nlat) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat) - - lon1=lon - lat1=lat - call check_ret(nf_create(trim(filename), NF_NETCDF4, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon',& - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat',& - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_int64, dim1name='lon',& - dim2name='lat', long_name=varname, units='unitless',fill_value=-9999.) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_long2d - -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_byte2d(filename,varname,var,lon,lat,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - byte, intent(inout) :: var(nlon,nlat) - real*8, intent(in) :: lon(nlon),lat(nlat) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat) - - lon1=lon - lat1=lat - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_byte, dim1name='lon', & - dim2name='lat', long_name=varname, units='unitless',fill_value=-128. ) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_byte2d - -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_short2d(filename,varname,var,lon,lat,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - integer*2, intent(inout) :: var(nlon,nlat) - real*8, intent(in) :: lon(nlon),lat(nlat) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat) - - lon1=lon - lat1=lat - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_short, dim1name='lon', & - dim2name='lat', long_name=varname, units='unitless',fill_value=-9999. ) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_short2d - - -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_real2d(filename,varname,var,lon,lat,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real, intent(inout) :: var(nlon,nlat) - real*8, intent(in) :: lon(nlon),lat(nlat) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat) - - lon1=lon - lat1=lat - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_float, dim1name='lon', & - dim2name='lat', long_name=varname, units='unitless', fill_value=-9999.) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_real2d - -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_short3d(filename,varname,var,lon,lat,lev,nlon,nlat,nlev) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - integer*2, intent(inout) :: var(nlon,nlat,nlev) - real*8, intent(in) :: lon(nlon),lat(nlat),lev(nlev) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat), lev1(nlev) - - lon1=lon - lat1=lat - lev1=lev - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call check_ret(nf_def_dim(ncid,'lev',nlev, dimid), subname) - - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname='lev', xtype=nf_double, dim2name='lev', & - long_name='level', units='unitless') - - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_short, dim1name='lon', & - dim2name='lat', dim3name='lev', long_name=varname, units='unitless', fill_value=-9999.) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lev', data=lev1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_short3d -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_int3d(filename,varname,var,lon,lat,lev,nlon,nlat,nlev) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - integer, intent(inout) :: var(nlon,nlat,nlev) - real*8, intent(in) :: lon(nlon),lat(nlat),lev(nlev) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat), lev1(nlev) - - lon1=lon - lat1=lat - lev1=lev - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call check_ret(nf_def_dim(ncid,'lev',nlev, dimid), subname) - - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname='lev', xtype=nf_double, dim2name='lev', & - long_name='level', units='unitless') - - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_int, dim1name='lon', & - dim2name='lat', dim3name='lev', long_name=varname, units='unitless', fill_value=-9999.) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lev', data=lev1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_int3d -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_real3d(filename,varname,var,lon,lat,lev,nlon,nlat,nlev) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - real, intent(inout) :: var(nlon,nlat,nlev) - real*8, intent(in) :: lon(nlon),lat(nlat),lev(nlev) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat), lev1(nlev) - - lon1=lon - lat1=lat - lev1=lev - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call check_ret(nf_def_dim(ncid,'lev',nlev, dimid), subname) - - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname='lev', xtype=nf_double, dim2name='lev', & - long_name='level', units='unitless') - - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_float, dim1name='lon', & - dim2name='lat', dim3name='lev', long_name=varname, units='unitless', fill_value=-9999.) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lev', data=lev1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_real3d - -!------------------------------------------------------------------------------------------ - subroutine create_ncfile_double2d(filename,varname,var,lon,lat,nlon,nlat) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real*8, intent(inout) :: var(nlon,nlat) - real*8, intent(in) :: lon(nlon),lat(nlat) - - character(len=4) :: subname="create" - integer :: ncid, varid, dimid - real*8 :: lon1(nlon), lat1(nlat) - - lon1=lon - lat1=lat - call check_ret(nf_create(trim(filename), nf_clobber, ncid), subname) - call check_ret(nf_def_dim(ncid,'lon',nlon, dimid), subname) - call check_ret(nf_def_dim(ncid,'lat',nlat, dimid), subname) - call ncd_defvar(ncid=ncid, varname='lon', xtype=nf_double, dim1name='lon', & - long_name='longtitude', units='degrees_east') - call ncd_defvar(ncid=ncid, varname='lat', xtype=nf_double, dim2name='lat', & - long_name='latitude', units='degrees_north') - call ncd_defvar(ncid=ncid, varname=varname, xtype=nf_double, dim1name='lon', & - dim2name='lat', long_name=varname, units='unitless', fill_value=-9999.) - call check_ret(nf_enddef(ncid), subname) - call ncd_ioglobal(varname='lon', data=lon1, flag='write',ncid=ncid) - call ncd_ioglobal(varname='lat', data=lat1, flag='write',ncid=ncid) - call ncd_ioglobal(varname=varname, data=var, flag='write',ncid=ncid) - call check_ret(nf_close(ncid), subname) - end subroutine create_ncfile_double2d -!------------------------------------------------------------------------------------------ -end module rwncfile - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 index 9e42c2d7e..3dbf867ba 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 @@ -106,8 +106,8 @@ subroutine res_init(input_dir,nall,nc,minCatch,maxCatch,use_res,active_res,type_ area_grand=area_grand*1.e6 ! Convert area from square kilometers (km2) to square meters (m2) allocate(buff_global(nall)) - open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt");read(77,*)buff_global;close(77) - Qfld_thres=buff_global(minCatch:maxCatch) + !open(77,file=trim(input_dir)//"/Pfaf_flood_qr_thres"//trim(fld_thres)//".txt");read(77,*)buff_global;close(77) + Qfld_thres=0.!buff_global(minCatch:maxCatch) deallocate(buff_global) !lake input @@ -314,7 +314,7 @@ subroutine res_cal(active_res,Qout,type_res,cat2res,Q_res,wid_res,fld_res,Wr_res ! Ensure outflow is within reasonable bounds Q_res = max(0.0, Q_res) ! Ensure non-negative outflow Q_res = min(Q_res, Wr_res / dt + Qin_res) ! Limit outflow to prevent exceeding inflow and storage - if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control + !if (fld_res == 1) Q_res = min(Q_res, Qfld_thres) ! Limit outflow for flood control Wr_res = Wr_res + dt * (Qin_res - Q_res) ! Update water storage in the reservoir Wr_res = max(0.0, Wr_res) ! Ensure non-negative storage From a81bceac4c3b49c268b78c8e6ec75052212bb190 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Thu, 20 Mar 2025 13:42:55 -0400 Subject: [PATCH 16/27] preprocessing for routing model added --- .../Utils/Raster/preproc/routing_model/build | 18 + .../routing_model/get_K_model_calik.f90 | 89 ++ .../preproc/routing_model/get_Pfaf_file.f90 | 196 ++++ .../preproc/routing_model/get_Qr_clmt.f90 | 130 +++ .../preproc/routing_model/get_area_M09.f90 | 84 ++ .../preproc/routing_model/get_area_M36.f90 | 84 ++ .../preproc/routing_model/get_dam_data.py | 331 +++++++ .../preproc/routing_model/get_isub_M09.f90 | 39 + .../preproc/routing_model/get_isub_M36.f90 | 39 + .../routing_model/get_latloni_cellarea.py | 141 +++ .../routing_model/get_lonlat_bond_M09.f90 | 35 + .../routing_model/get_lonlat_bond_M36.f90 | 35 + .../routing_model/get_lonlati_maptile_M09.py | 66 ++ .../routing_model/get_lonlati_maptile_M36.py | 66 ++ .../get_num_sub_catchment_M09.f90 | 85 ++ .../get_num_sub_catchment_M36.f90 | 85 ++ .../routing_model/get_river_length.f90 | 248 +++++ .../preproc/routing_model/k_module_cali.f90 | 905 ++++++++++++++++++ .../routing_model/process_lake_data.py | 172 ++++ .../routing_model/read_input_TopoCat.f90 | 101 ++ .../preproc/routing_model/river_read.f90 | 219 +++++ .../Utils/Raster/preproc/routing_model/run.sh | 77 ++ 22 files changed, 3245 insertions(+) create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 create mode 100755 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run.sh diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build new file mode 100755 index 000000000..acf585ede --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build @@ -0,0 +1,18 @@ +#!/bin/bash + +if [ $# -lt 1 ]; then + echo "no f90 specified" + exit +fi + +string=$1 +array=(${string//./ }) + +FILENAME=${array[0]} + +NETCDF_PATH=/usr/local/other/GEOSpyD/23.5.2-0_py3.11/2023-11-02 +LD_LIBRARY_PATH=${NETCDF_PATH}/lib:$LD_LIBRARY_PATH + +ifort -qopenmp river_read.f90 k_module_cali.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 new file mode 100755 index 000000000..3cd73aefc --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 @@ -0,0 +1,89 @@ +program main + + use k_module + + implicit none + + integer, parameter :: nl = 3352492 + integer, parameter :: nlat = 10800, nlon = 21600 + integer, parameter :: nc = 291284 + + ! Declare variables + integer, allocatable :: lati(:), loni(:) + real, allocatable :: data(:, :) ! 2D data array + integer,allocatable :: catid_full(:),catid(:) + real,allocatable, dimension(:) :: vel, dis + integer, allocatable :: nv(:),flag_gageii(:) + real,allocatable :: Qclmt_full(:),slp_full(:),KKobs_full(:),KImodel_full(:) + real,allocatable :: Qclmt(:),slp(:),KKobs(:),KImodel(:) + real,allocatable :: KImodel_all(:) + real,allocatable :: lats_full(:), lons_full(:) + real*8,allocatable :: MU_axis(:),slp_axis(:),clmt_axis(:),p_axis(:) + + real :: mm=0.35, MU=0.45, exp_slp=0.2, exp_clmt=-0.2 !MU ~(-0.6) + !real :: mm=0.4, MU=0.1, exp_slp=0.5, exp_clmt=0.2 + real :: fac_str=1. + + integer :: nt,ns,np,i,j,k,p,count + real :: ccr(10,10,10),rms(10,10,10) + !real :: ccr(20,10),rms(20,10) + real :: ccrp, rmsp + + + call read_usgs_data(nl, data) + call process_usgs_data(nl, ns, data, nv, nt, vel, dis) + !stop + call find_nearest_coords(ns, nlat, nlon, lats_full, lons_full, lati, loni) + + allocate(MU_axis(10),slp_axis(10),clmt_axis(10)) + + ccr=-9999. + rms=-9999. + count=0 + + do k=1,10 + MU_axis(k)=(k-1)*0.05 + enddo + do i=1,10 + slp_axis(i)=(i-1)*0.1 + enddo + do j=1,10 + clmt_axis(j)=(j-1)*0.2-0.8 + enddo + + !do k=1,10 + !do i=1,10 + !do j=1,10 + + count=count+1 + + !MU=MU_axis(k) + !exp_slp=slp_axis(i) + !exp_clmt=clmt_axis(j) + + + print *,"count=",count + print *,"M=",MU,", exp_slp=",exp_slp,", exp_clmt=",exp_clmt + + call get_station_inf(ns, nc, nlat, nlon, lati, loni, catid_full, Qclmt_full, slp_full, KImodel_all,exp_slp,exp_clmt,fac_str) + call get_valide_stations_gageii(ns,nc,catid_full,flag_gageii) + call regression(nt,vel,dis,nv,ns,Qclmt_full,slp_full,KKobs_full,KImodel_full,exp_slp,exp_clmt,mm,MU) + call filter_station(nc,ns,np,lats_full,lons_full,Qclmt_full,slp_full,catid_full,KKobs_full,KImodel_full,Qclmt,slp,catid,KKobs,KImodel,flag_gageii) + !call cal_Kmodel(ns,np,nc,MU,exp_slp,exp_clmt,Qclmt,slp,KKobs,KImodel,KImodel_all,catid,catid_full,ccr(k,i,j),rms(k,i,j)) + call cal_Kmodel(ns,np,nc,MU,exp_slp,exp_clmt,Qclmt,slp,KKobs,KImodel,KImodel_all,catid,catid_full,ccrp,rmsp) + + print *,"ccr=",ccrp + print *,"rms=",rmsp + + !enddo + !enddo + !enddo + + + + !call create_ncfile_real3d("ccr_clmtxslpxMU_10x10x10_mm0p35.nc","data",ccr,MU_axis,slp_axis,clmt_axis,10,10,10) + !call create_ncfile_real3d("rms_clmtxslpxMU_10x10x10_mm0p35.nc","data",rms,MU_axis,slp_axis,clmt_axis,10,10,10) + + + +end program main \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 new file mode 100644 index 000000000..247d209f1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 @@ -0,0 +1,196 @@ +program main + + implicit none + + integer,parameter :: nc = 291284, nupmax=34 + + integer,allocatable,dimension(:) :: downid,finalid + real*8,allocatable,dimension(:) :: pfaf + integer,allocatable,dimension(:,:) :: pfaf_digit,upstream + integer*8,allocatable,dimension(:) :: res + integer,allocatable,dimension(:) :: pfaf_last,pfaf_msk,code,behind + integer,allocatable,dimension(:) :: first,last,nup,nts,nts_old + real,allocatable,dimension(:) :: pfaf_area,pfaf_acar,pfaf_acar_old + + + integer :: i,j,jj,k,p,down,cur,idx,num,ok,samed,did,nmax + integer :: fulli(12),fullj(12) + real :: val(5) + + character(len=500) :: file_path="input/Pfafcatch-routing.dat" !/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/topo/v1/SRTM-TopoData/Pfafcatch-routing.dat + +! Get downstream catchment and final destination ID for each catchment, and determine whether it directs to an ocean or inland lake. +! downid=Pfafstetter index of catchment just downstream +! finalid=Pfafstetter index of catchment at outlet point +! pfaf= Pfafstetter number for catchment +! pfaf_digit= The 12 digits in a Pfafstetter number, separated +! pfaf_last= The index of the last nonzero digit in a Pfafstetter number (counting from the left) +! pfaf_msk =1 for non-sink catchments, 2 for sink catchments with endpoints in ocean, =3 for sink catchments with endpoints in interior lake +! last= The index of the last digit in a Pfafstetter number after removing any 11..000 tail. +! first= The index of the last zero (but not the zero at the very end). However, if there are no zeroes until the end, first =2 (the second index, since the first index indicates the continent). + + !if (command_argument_count() /= 1) then + ! print *, "no found" + ! stop + !endif + !call get_command_argument(1, file_path) + + open(77,file=file_path, form="formatted", status="old") + read(77,*)num + + allocate(downid(nc),finalid(nc),pfaf(nc),pfaf_digit(nc,12),res(nc),pfaf_last(nc),pfaf_msk(nc),pfaf_area(nc)) + allocate(first(nc),last(nc)) + + do i=1,nc + read(77,*)idx,pfaf(i),val(1:5),pfaf_area(i) + enddo + +! Separate Pfafstetter number into individual digits + res=int8(pfaf) + pfaf_digit(:,1)=res/(int8(10)**int8(11)) + do i=2,12 + res=res-int8(10)**int8(13-i)*int8(pfaf_digit(:,i-1)) + pfaf_digit(:,i)=res/(int8(10)**int8(12-i)) + enddo + +! Determine positions of last nonzero digit (pfaf_last) and the last digit that鈥檚 neither 0 nor 1 (at the end) + first=2 + last=2 + do i=1,nc + do j=12,1,-1 + if(pfaf_digit(i,j)/=0)then + pfaf_last(i)=j + do k=0,j-1 + if(pfaf_digit(i,j-k)/=1)then + last(i)=j-k + exit + endif + enddo + exit + endif + enddo + enddo + do i=1,nc + if(last(i)<=1) last(i)=2 + enddo + +! Determine position of final zero that has some nonzero digits after it + do i=1,nc + do j=last(i),2,-1 + if(pfaf_digit(i,j)==0)then + first(i)=j + exit + endif + enddo + enddo + + do i=1,nc + + if(first(i)>last(i)-1)then + downid(i)=-1 + else + + allocate(code(1:last(i)-first(i))) + code=pfaf_digit(i,first(i):last(i)-1) + if(any(code==2).or.any(code==4).or.any(code==6).or.any(code==8))then + ! If all digits (after the first) are odd, the Pfafstetter logic implies that the catchment will be on the coast. + fulli=pfaf_digit(i,:) + do j=i-1,1,-1 ! Test each catchment to see if it lies just downstream of catchment i + ok=1 + fullj=pfaf_digit(j,:) + samed=0 + do k=1,min(pfaf_last(i),pfaf_last(j)) ! Determine the index (samed) up to which the Pfaf numbers of catchment I and j match + if(fulli(k)==fullj(k))then + samed=samed+1 + else + exit + endif + enddo ! end k loop + if(samed+1<=pfaf_last(j))then + ! Check that none of catchment j鈥檚 indices (after samed) are even, which would imply a downstream branching off from the river on which catchment i lies. + allocate(behind(1:pfaf_last(j)-samed)) + behind=fullj(samed+1:pfaf_last(j)) + if(any(mod(behind,2)==0)) ok=0 + deallocate(behind) + else + ok=0 + endif + if(ok==1)then + downid(i)=j + exit + endif + enddo ! end j loop + else + downid(i)=-1 + endif + deallocate(code) + + endif ! end i loop + + + enddo + + + open(88,file="output/downstream_1D_new_noadj.txt") + do i=1,nc + write(88,*)downid(i) + enddo + + open(88,file="output/Pfaf_area.txt") + do i=1,nc + write(88,*)pfaf_area(i) + enddo + + allocate(upstream(nupmax,nc),nup(nc)) + nup=0 + upstream=-1 + do i=1,nc + did=downid(i) + if(did>=1)then + nup(did)=nup(did)+1 + upstream(nup(did),did)=i + end if + enddo + open(88,file="output/upstream_1D.txt") + do i=1,nc + write(88,'(34(I8))')upstream(:,i) + enddo + open(88,file="output/Pfaf_upnum.txt") + do i=1,nc + write(88,*)nup(i) + enddo + + allocate(nts(nc),pfaf_acar(nc)) + nts=-9999 + do i=1,nc + k=0 + cur=i + do while(downid(cur)/=-1) + k=k+1 + cur=downid(cur) + enddo + nts(i)=k + enddo + open(88,file="output/Pfaf_tosink.txt") + do i=1,nc + write(88,*)nts(i) + enddo + + nmax=maxval(nts) + pfaf_acar=pfaf_area + do j=nmax,1,-1 + do i=1,nc + if(nts(i)==j)then + did=downid(i) + pfaf_acar(did)=pfaf_acar(did)+pfaf_acar(i) + endif + enddo + enddo + open(88,file="temp/Pfaf_acar.txt") + do i=1,nc + write(88,*)pfaf_acar(i) + enddo + + + +end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 new file mode 100644 index 000000000..129fb3575 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 @@ -0,0 +1,130 @@ +program main + + use omp_lib + use river_read + implicit none + + integer,parameter :: nlat=1624,nlon=3856,nc=291284,nupmax=34 + character(len=500) :: filename="input/SMAPL4_OL7000_runoff_mean_2016_2023.nc" + real,allocatable :: runoff(:,:),qrunf(:),temp(:,:),qri(:),qin(:) + integer,allocatable :: nts(:),downid(:),upstream(:,:) + + integer :: i,j,nmax,did + + allocate(runoff(nlon,nlat),qrunf(nc),temp(nlon,nlat)) + call read_ncfile_real2d(trim(filename),"mean_runoff_flux",runoff,nlon,nlat) + where(runoff==-9999.)runoff=0. + temp=runoff(:,nlat:1:-1) + runoff=temp + runoff=runoff*86400. !mm/d + qrunf=M09_to_cat(runoff,nlon,nlat,nc) !kg/s + qrunf=qrunf/1.e3 !m3/s + open(88,file="output/Pfaf_qstr.txt") + do i=1,nc + write(88,*)qrunf(i) + enddo + + allocate(nts(nc),downid(nc),qri(nc)) + open(77,file="output/Pfaf_tosink.txt") + read(77,*)nts + open(77,file="output/downstream_1D_new_noadj.txt") + read(77,*)downid + + nmax=maxval(nts) + qri=qrunf + do j=nmax,1,-1 + do i=1,nc + if(nts(i)==j)then + did=downid(i) + qri(did)=qri(did)+qri(i) + endif + enddo + enddo + open(88,file="output/Pfaf_qri.txt") + do i=1,nc + write(88,*)qri(i) + enddo + + allocate(upstream(nupmax,nc),qin(nc)) + open(77,file="output/upstream_1D.txt") + read(77,*)upstream + qin=-9999. + where(upstream(1,:)/=-1)qin=qri-qrunf + where(upstream(1,:)==-1)qin=qrunf/2. + open(88,file="output/Pfaf_qin.txt") + do i=1,nc + write(88,*)qin(i) + enddo + +contains +!------------------------------------------------------------------------------ +! This function maps runoff data from M09 resolution to catchments (cat) +function M09_to_cat(runoff,nlon,nlat,ncat) result(Qrunf) + + integer,intent(in) :: nlon,nlat,ncat ! Input: number of longitude, latitude, and catchments + real,intent(in) :: runoff(nlon,nlat) ! Input: runoff array of size (nlon, nlat) + real :: Qrunf(ncat) ! Output: runoff mapped to catchments + + real,parameter :: small=1.e-12 ! Small value to avoid division by zero + + integer,parameter :: nmax=458 ! Maximum number of sub-areas per catchment + integer,parameter :: nc=291284 ! Total number of catchments + + real,allocatable,dimension(:,:) :: subarea,frac ! Arrays for sub-area and fractions + integer,allocatable,dimension(:,:) :: subx,suby ! Arrays for x and y coordinates of sub-areas + real,allocatable,dimension(:) :: tot,runfC,fracA ! Arrays for total area, calculated runoff, and fraction + integer,allocatable,dimension(:) :: nsub ! Array for number of sub-areas per catchment + + integer :: i,j,sx,sy ! Loop variables and coordinates for sub-areas + + ! Allocate memory for arrays + allocate(nsub(nc),subarea(nmax,nc),subx(nmax,nc),suby(nmax,nc),tot(nc)) + + ! Read sub-area data from text files + open(77,file="output/Pfaf_nsub_M09.txt"); read(77,*)nsub + open(77,file="output/Pfaf_asub_M09.txt"); read(77,*)subarea + open(77,file="output/Pfaf_xsub_M09.txt"); read(77,*)subx + open(77,file="output/Pfaf_ysub_M09.txt"); read(77,*)suby + open(77,file="output/Pfaf_area.txt"); read(77,*)tot + + ! Allocate memory for fraction array + allocate(frac(nmax,nc)) + + ! Compute fraction of each sub-area relative to the total catchment area + do i=1,nc + frac(:,i)=subarea(:,i)/tot(i) + enddo + + ! Allocate memory for runoff and fraction arrays + allocate(runfC(nc),fracA(nc)) + runfC=0. ! Initialize runoff array to zero + fracA=0. ! Initialize fraction array to zero + + !$OMP PARALLEL default(shared) private(i,j,sx,sy) ! Start OpenMP parallel region + !$OMP DO + ! Loop over all catchments and sub-areas + do i=1,nc + do j=1,nsub(i) + sy=suby(j,i) ! Get y-coordinate of the sub-area + sx=subx(j,i) ! Get x-coordinate of the sub-area + ! Check for valid fraction and runoff values + if(frac(j,i)>0..and.runoff(sx,sy)<1.e14.and.runoff(sx,sy)>=0.)then + runfC(i)=runfC(i)+frac(j,i)*runoff(sx,sy) ! Accumulate runoff for the catchment + fracA(i)=fracA(i)+frac(j,i) ! Accumulate fraction + endif + enddo + enddo + !$OMP END DO + !$OMP END PARALLEL ! End OpenMP parallel region + + ! Convert to kg/s by multiplying by area (in m虏) and dividing by time (in seconds) + Qrunf=runfC*(tot*1.e6)/86400. + + ! Deallocate arrays to free memory + deallocate(subarea,subx,suby,tot,frac,& + runfC,fracA,nsub) + +end function M09_to_cat +!------------------------------------------------------------------------------ + +end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 new file mode 100755 index 000000000..ffdf70c01 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 @@ -0,0 +1,84 @@ +program main + +use river_read +implicit none + +integer,parameter :: nmax=458 +integer,parameter :: nc=291284 +integer,parameter :: nlon=21600 +integer,parameter :: nlat=10800 +integer,parameter :: nlat36=1624,nlon36=3856 +integer,parameter :: nt_global=1684725 + +integer :: id,xi,yi,i,j,flag,subi,x_m36,y_m36,it +integer :: nsub(nc) +integer,allocatable :: xsub(:,:),ysub(:,:),subi_global(:,:) +real,allocatable :: asub(:,:) + +real*8,allocatable :: lon(:),lat(:) +integer,allocatable :: loni(:),lati(:) +integer,allocatable :: catchind(:,:),map_tile(:,:) +real,allocatable :: cellarea(:,:),area_m36(:,:),area_tile(:) +real*8,allocatable :: lat36(:),lon36(:) + + +!allocate(subi_global(nmax,nc)) +!open(77,file="Pfaf_isub_M36.txt",status="old",action="read"); read(77,*)subi_global; close(77) +!open(90,file="subi.txt",action="write") +!do i=1,nc +! write(90,'(150(i7))')subi_global(:,i) +!end do +!print *,"successful" +!stop + +allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) +allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) +allocate(lon(nlon),lat(nlat)) +allocate(loni(nlon),lati(nlat)) + + +call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) +call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) +call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) +call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) +cellarea=cellarea/1.e6 + + +open(10,file="temp/lati_1m_M09.txt") +read(10,*)lati +open(11,file="temp/loni_1m_M09.txt") +read(11,*)loni + + +allocate(area_m36(nlon36,nlat36)) +area_m36=0. +do xi=1,nlon + do yi=1,nlat + if(catchind(xi,yi)>=1)then + x_m36=loni(xi) + y_m36=lati(yi) + area_m36(x_m36,y_m36)=area_m36(x_m36,y_m36)+cellarea(xi,yi) + endif + enddo +enddo + +allocate(map_tile(nlon36,nlat36)) +call read_ncfile_int2d("temp/map_tile_M09.nc","data",map_tile,nlon36,nlat36) +allocate(area_tile(nt_global)) +area_tile=-9999. +do i=1,nlon36 + do j=1,nlat36 + it=map_tile(i,j) + if(it>0)then + area_tile(it)=area_m36(i,j) + endif + enddo +enddo + +open(88,file="output/area_M09_1d.txt") +do i=1,nt_global + write(88,*)area_tile(i) +enddo + + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 new file mode 100755 index 000000000..27e1f05f1 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 @@ -0,0 +1,84 @@ +program main + +use river_read +implicit none + +integer,parameter :: nmax=150 +integer,parameter :: nc=291284 +integer,parameter :: nlon=21600 +integer,parameter :: nlat=10800 +integer,parameter :: nlat36=406,nlon36=964 +integer,parameter :: nt_global=112573 + +integer :: id,xi,yi,i,j,flag,subi,x_m36,y_m36,it +integer :: nsub(nc) +integer,allocatable :: xsub(:,:),ysub(:,:),subi_global(:,:) +real,allocatable :: asub(:,:) + +real*8,allocatable :: lon(:),lat(:) +integer,allocatable :: loni(:),lati(:) +integer,allocatable :: catchind(:,:),map_tile(:,:) +real,allocatable :: cellarea(:,:),area_m36(:,:),area_tile(:) +real*8,allocatable :: lat36(:),lon36(:) + + +!allocate(subi_global(nmax,nc)) +!open(77,file="Pfaf_isub_M36.txt",status="old",action="read"); read(77,*)subi_global; close(77) +!open(90,file="subi.txt",action="write") +!do i=1,nc +! write(90,'(150(i7))')subi_global(:,i) +!end do +!print *,"successful" +!stop + +allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) +allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) +allocate(lon(nlon),lat(nlat)) +allocate(loni(nlon),lati(nlat)) + + +call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) +call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) +call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) +call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) +cellarea=cellarea/1.e6 + + +open(10,file="temp/lati_1m_M36.txt") +read(10,*)lati +open(11,file="temp/loni_1m_M36.txt") +read(11,*)loni + + +allocate(area_m36(nlon36,nlat36)) +area_m36=0. +do xi=1,nlon + do yi=1,nlat + if(catchind(xi,yi)>=1)then + x_m36=loni(xi) + y_m36=lati(yi) + area_m36(x_m36,y_m36)=area_m36(x_m36,y_m36)+cellarea(xi,yi) + endif + enddo +enddo + +allocate(map_tile(nlon36,nlat36)) +call read_ncfile_int2d("temp/map_tile_M36.nc","data",map_tile,nlon36,nlat36) +allocate(area_tile(nt_global)) +area_tile=-9999. +do i=1,nlon36 + do j=1,nlat36 + it=map_tile(i,j) + if(it>0)then + area_tile(it)=area_m36(i,j) + endif + enddo +enddo + +open(88,file="output/area_M36_1d.txt") +do i=1,nt_global + write(88,*)area_tile(i) +enddo + + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py new file mode 100755 index 000000000..6cab4cafb --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py @@ -0,0 +1,331 @@ +import numpy as np +from netCDF4 import Dataset +import os +import glob + +# Function to find the nearest index in a coordinate array +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +if __name__ == '__main__': + +#----get dam lat lon ind---- + # Parameter settings + ns = 7250 #nr + nlat = 10800 + nlon = 21600 + + # Read data from ASCII files; each file contains one number per line. + lats = np.loadtxt("input/lat_dam_grand.txt", dtype=np.float64, max_rows=ns) + lons = np.loadtxt("input/lon_dam_grand.txt", dtype=np.float64, max_rows=ns) + lat1m = np.loadtxt("input/lat_1m.txt", dtype=np.float64, max_rows=nlat) + lon1m = np.loadtxt("input/lon_1m.txt", dtype=np.float64, max_rows=nlon) + + # For each target coordinate, find the nearest index in the reference array. + lati = ind_nearest_coord(lats, lat1m) + loni = ind_nearest_coord(lons, lon1m) + + # Since NCL uses 1-based indexing, add 1 when writing the results. + #np.savetxt("data/lati_dam_PR.txt", lati, fmt='%d') + #np.savetxt("data/loni_dam_PR.txt", loni, fmt='%d') + + +#----get dam cat ind---- + # Read the NetCDF file + nc_file = "input/CatchIndex.nc" + with Dataset(nc_file, 'r') as nc: + # Read the integer 2D variable "data" + # We assume that the data is stored with shape (nlon, nlat) + catchind = nc.variables["data"][:] + # If catchind is a masked array, fill masked values with -9999 + if np.ma.is_masked(catchind): + catchind = catchind.filled(-9999) + # Read ASCII files containing indices for latitude and longitude. + # It is assumed that the files contain one integer per line and use 1-based indexing. + #lati = np.loadtxt("data/lati_dam.txt", dtype=int) # shape: (ns,) + #loni = np.loadtxt("data/loni_dam.txt", dtype=int) # shape: (ns,) + + # Initialize the array to store the output catchment ID values + catid = np.empty(ns, dtype=int) + + # Loop over each index (Fortran indices start at 1, so we subtract 1 for 0-based indexing in Python) + for i in range(ns): + # For each index, retrieve the value from catchind using (loni, lati) as indices. + # Subtract 1 from the read indices to convert from 1-based to 0-based indexing. + catid[i] = catchind[ lati[i], loni[i] ] + + # Write the output catid array to an ASCII file with one number per line. + #np.savetxt("data/catid_dam_PR.txt", catid, fmt='%d') + +#----get dam drainage area-- + # Define the number of catchments and the total number of entries in the full dataset + nc = 291284 + + # Alternative file (commented out in the original NCL script): + # catid = np.loadtxt("data/catid_dam_corr_aca_grand5000.txt", dtype=int, max_rows=ns) + + # Read full dataset for acar and area from ASCII files + acar_all = np.loadtxt("temp/Pfaf_acar.txt", dtype=float, max_rows=nc) + area_all = np.loadtxt("output/Pfaf_area.txt", dtype=float, max_rows=nc) + + # Initialize arrays to store the selected values for each catchment + acar = np.empty(ns, dtype=float) + area = np.empty(ns, dtype=float) + + # Loop over each catchment index and assign values based on catid + for i in range(ns): + cid = catid[i] + if cid != -9999: + # Subtract 1 from cid to convert 1-based index (from ASCII file) to 0-based index for Python + acar[i] = acar_all[cid - 1] + area[i] = area_all[cid - 1] + else: + acar[i] = -9999.0 + area[i] = -9999.0 + + # Write the output arrays to ASCII files, one number per line + #np.savetxt("data/catch_aca_model_PR.txt", acar, fmt="%.6f") + #np.savetxt("data/catch_area_model_PR.txt", area, fmt="%.6f") + +#----look for uncorrect station------ + thres = 5000.0 + # Read data from ASCII files + grand = np.loadtxt("input/catch_aca_grand.txt", dtype=float, max_rows=ns) + + # Initialize lists to store error information + id_error = [] + + # Loop over each catchment index + for i in range(ns): + if grand[i] > thres: + if acar[i] < 0.8 * grand[i]: + # Append error information; add 1 to i for 1-based indexing + id_error.append(i + 1) + + # Get the number of errors found + ne = len(id_error) + + # Write the error IDs to an ASCII file, one number per line + #np.savetxt("data/id_error_aca_grand5000_PR.txt", np.array(id_error), fmt='%d') + +#----get corrected catid for above station-------------------- + + # Read error arrays and the full catid array from ASCII files. + # It is assumed that the files contain one number per line. + catid_error = np.loadtxt("input/newcatid_error_aca_grand5000.txt", dtype=int, max_rows=ne) + + # Loop over each error index and update catid_all. + # Note: We subtract 1 from resid_error values to convert from 1-based to 0-based indexing. + for i in range(ne): + rid = id_error[i] + catid[rid - 1] = catid_error[i] + + # Write the updated catid_all array to an ASCII file. + #np.savetxt("data/catid_dam_corr_aca_grand5000_noman_PR.txt", catid, fmt='%d') + +#----get dam drainage area after correction-------------------- + # Initialize arrays to store the selected acar and area values for each catchment + acar = np.empty(ns, dtype=float) + area = np.empty(ns, dtype=float) + + # Loop over each catchment index + for i in range(ns): + cid = catid[i] + if cid != -9999: + # Adjust for 1-based indexing: subtract 1 when accessing the full dataset arrays + acar[i] = acar_all[cid - 1] + area[i] = area_all[cid - 1] + else: + acar[i] = -9999.0 + area[i] = -9999.0 + + # Write the output arrays to ASCII files with one number per line + #np.savetxt("data/catch_aca_model_corr_aca_grand5000_PR.txt", acar, fmt="%.6f") + #np.savetxt("data/catch_area_model_corr_aca_grand5000_PR.txt", area, fmt="%.6f") + +#----look for uncorrect station------ + # Define threshold and total number of catchments + thres = 5000.0 + + # The following files are read for completeness, though not used in the logic below. + #area = np.loadtxt("data/catch_area_model_corr_aca_grand5000.txt", dtype=float, max_rows=ns) + model = acar + # Instead of preallocating an array with a fixed size (np in NCL), + # we use a list to collect error indices. + id_error = [] + + # Loop over each catchment index + for i in range(ns): + # Check if the model value is greater than the threshold and grand is less than 80% of model + if model[i] > thres: + if grand[i] < 0.8 * model[i]: + # Append 1-based index (i+1) to the error list + id_error.append(i + 1) + + ne = len(id_error) + + # Write the error indices to an ASCII file (one number per line) + #np.savetxt("data/id_error_aca_model5000_PR.txt", np.array(id_error), fmt='%d') + +#----create flag for stations------ + + # Define manual adjustment arrays (1D arrays) + resid_man = np.array([5179, 289, 7070], dtype=int) + catid_man = np.array([46616, 142851, 199281], dtype=int) + nman = resid_man.size + + # Update specific indices in catid_all with manual adjustments. + # Convert from 1-based indexing (in NCL) to 0-based indexing (in Python) + for i in range(nman): + catid[resid_man[i] - 1] = catid_man[i] + + # Write the updated catid_all to an ASCII file + np.savetxt("output/catid_dam_corr_aca_grand5000.txt", catid, fmt='%d') + + # Read flag_error and id_error arrays from ASCII files + flag_error = np.loadtxt("input/flag_model5000.txt", dtype=int, max_rows=ne) + #id_error = np.loadtxt("data/id_error_aca_model5000.txt", dtype=int, max_rows=ne) + + # Initialize flag_all array with ones (default flag value) + flag_all = np.ones(ns, dtype=int) + + # For each error entry, update flag_all at the specified index. + # Adjust id from 1-based to 0-based indexing. + for i in range(ne): + id_val = id_error[i] + flag_all[id_val - 1] = flag_error[i] + + # Read the catchment area data from ASCII files + #aca_grand = np.loadtxt("data/catch_aca_grand.txt", dtype=float, max_rows=ns) + #aca_model = np.loadtxt("data/catch_aca_model_corr_aca_grand5000.txt", dtype=float, max_rows=ns) + + # Update flag_all based on conditions related to aca_grand and aca_model. + # If aca_grand is less than 1.e3 and also less than 0.5 times aca_model, set flag to 0. + for i in range(ns): + if grand[i] < 1.e3: + if grand[i] < 0.5 * acar[i]: + flag_all[i] = 0 + + # If aca_model is negative, set flag_all to 0 for that catchment. + for i in range(ns): + if acar[i] < 0.: + flag_all[i] = 0 + + # Write the final flag_all array to an ASCII file. + np.savetxt("output/flag_all_res.txt", flag_all, fmt='%d') + +#----get dam main use--------------- + # Define category strings and corresponding output tags + use_string = ["Irrigation", "Hydroelectricity", "Water supply", "Navigation", "Recreation"] + use_out = ["irr", "hydroelec", "watersupply", "nav", "rec"] + nu = len(use_string) + + # Read the main use data as strings from the ASCII file (one entry per line) + with open("input/main_use_grand.txt", "r") as f: + use = [line.strip() for line in f] + if len(use) != ns: + print(f"Warning: expected {ns} lines, but got {len(use)} lines.") + + # For each category in use_string, create a flag array and output the result + for j in range(nu): + # Initialize the flag array with zeros + flag = np.zeros(ns, dtype=int) + # Set flag to 1 where the use value matches the current category + for i in range(ns): + if use[i] == use_string[j]: + flag[i] = 1 + + # Print the sum of the flag array (i.e., the count of matched entries) + # print(np.sum(flag)) + + # Write the flag array to an ASCII file, one number per line + out_filename = os.path.join("output", use_out[j] + "_grand.txt") + np.savetxt(out_filename, flag, fmt='%d') +#----flood use-------------------- + # Read the use_irr strings from the ASCII file (one entry per line) + with open("input/flood_use_grand.txt", "r") as f: + use_irr = [line.strip() for line in f] + + # Initialize the flag array with zeros + flag = np.zeros(ns, dtype=int) + + # Loop over each entry and set flag to 1 if the entry is not "NA" + for i in range(ns): + if use_irr[i] != "NA": + flag[i] = 1 + + # Print the sum of the flag array (i.e., count of non-"NA" entries) + #print(np.sum(flag)) + + # Write the flag array to an ASCII file, one number per line + np.savetxt("output/fldmainsec_grand.txt", flag, fmt='%d') + +#----other use-------------------- + use_out = "other" + + # Read the main use data from the ASCII file (assumed one entry per line) + with open("input/main_use_grand.txt", "r") as f: + use = [line.strip() for line in f] + if len(use) != ns: + print(f"Warning: expected {ns} entries, but got {len(use)} entries.") + + # Initialize the flag array with zeros + flag = np.zeros(ns, dtype=int) + + # Loop over each entry and set flag to 1 if the entry matches the specified categories + for i in range(ns): + if use[i] == "Fisheries" or use[i] == "NA" or use[i] == "Other": + flag[i] = 1 + + # Print the sum of the flag array (i.e., count of matching entries) + #print(np.sum(flag)) + + # Write the flag array to an ASCII file, one number per line + np.savetxt("output/" + use_out + "_grand.txt", flag, fmt='%d') + +#----flood threshold------------- +if 1 == 0: + + thres_per = 1.0 + + nday = 1827 + day_start = 276 + day_end = 2102 + + # List files matching the pattern (assumed to be sorted in the same order as ls) + files = sorted(glob.glob("/Volumes/PASSPORT5T/work/river/river_OL7000_Kv/*Qr*.txt")) + nd = len(files) + #print(nd) + + # Initialize data_ori array with shape (nc, nday) + data_ori = np.empty((nc, nday), dtype=float) + + # Loop over each day from day_start to day_end (inclusive) + for i in range(day_start, day_end + 1): + if i % 10 == 0: + print(i) + # Read nc float values from file corresponding to day i and assign to the proper column + data_ori[:, i - day_start] = np.loadtxt(files[i], dtype=float, max_rows=nc) + + # Sort each row (daily values for each grid cell) in descending order + # Note: Sorting along axis=1 (the day dimension) + data_sorted = np.sort(data_ori, axis=1)[:, ::-1] + + # Calculate threshold index based on thres_per percentage of days + # For example, with thres_per=1, idx_thres becomes int(1/100 * 1827) = 18 + idx_thres = int(thres_per / 100.0 * nday) + #print(idx_thres) + + # For each grid cell (each row), select the value at rank idx_thres-1 (i.e. the 18th highest value) + output_data = data_sorted[:, idx_thres - 1] + + # Construct output filename and write the output_data to an ASCII file + filename = "output/Pfaf_flood_qr_thres0" + str(int(thres_per)) + ".txt" + np.savetxt(filename, output_data, fmt="%.6f") diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 new file mode 100755 index 000000000..82ee4a4fe --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 @@ -0,0 +1,39 @@ +program main + +use river_read ! Use custom module for reading NetCDF files +implicit none + +integer,parameter :: nlat=1624,nlon=3856 +integer,parameter :: nmax=458 ! Maximum number of sub-areas per catchment +integer,parameter :: nc=291284 ! Total number of catchments + +integer,allocatable :: map_tile(:,:),subx(:,:),suby(:,:),subi(:,:) + +integer :: i,x,y,j,it + +allocate(map_tile(nlon,nlat)) +call read_ncfile_int2d("temp/map_tile_M09.nc", "data", map_tile, nlon, nlat) +allocate(subx(nmax,nc),suby(nmax,nc),subi(nmax,nc)) +open(77,file="output/Pfaf_xsub_M09.txt"); read(77,*)subx +open(77,file="output/Pfaf_ysub_M09.txt"); read(77,*)suby +subi=0 +do i=1,nc + do j=1,nmax + x=subx(j,i) + y=suby(j,i) + if(x/=0)then + if(y==0)stop + subi(j,i)=map_tile(x,y) + endif + enddo +enddo + +open(88,file="output/Pfaf_isub_M09.txt") +do i=1,nc + write(88,'(150(i8))') subi(:,i) +enddo + + + + +end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 new file mode 100755 index 000000000..a96e9fa23 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 @@ -0,0 +1,39 @@ +program main + +use river_read ! Use custom module for reading NetCDF files +implicit none + +integer,parameter :: nlat=406,nlon=964 +integer,parameter :: nmax=150 ! Maximum number of sub-areas per catchment +integer,parameter :: nc=291284 ! Total number of catchments + +integer,allocatable :: map_tile(:,:),subx(:,:),suby(:,:),subi(:,:) + +integer :: i,x,y,j,it + +allocate(map_tile(nlon,nlat)) +call read_ncfile_int2d("temp/map_tile_M36.nc", "data", map_tile, nlon, nlat) +allocate(subx(nmax,nc),suby(nmax,nc),subi(nmax,nc)) +open(77,file="output/Pfaf_xsub_M36.txt"); read(77,*)subx +open(77,file="output/Pfaf_ysub_M36.txt"); read(77,*)suby +subi=0 +do i=1,nc + do j=1,nmax + x=subx(j,i) + y=suby(j,i) + if(x/=0)then + if(y==0)stop + subi(j,i)=map_tile(x,y) + endif + enddo +enddo + +open(88,file="output/Pfaf_isub_M36.txt") +do i=1,nc + write(88,'(150(i7))') subi(:,i) +enddo + + + + +end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py new file mode 100755 index 000000000..9fc5d4b5c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py @@ -0,0 +1,141 @@ +import numpy as np +import os +from netCDF4 import Dataset + +# Define file paths +lat36_file = "input/lat_M36.txt" +lon36_file = "input/lon_M36.txt" +lat1m_file = "input/lat_1m.txt" +lon1m_file = "input/lon_1m.txt" +lat09_file = "input/lat_M09.txt" +lon09_file = "input/lon_M09.txt" +lati36_output_file = "temp/lati_1m_M36.txt" +loni36_output_file = "temp/loni_1m_M36.txt" +lati09_output_file = "temp/lati_1m_M09.txt" +loni09_output_file = "temp/loni_1m_M09.txt" +cellarea_output_file = "temp/cellarea.nc" + +# Grid dimensions +nlat36, nlon36 = 406, 964 +nlat1m, nlon1m = 10800, 21600 +nlat09, nlon09 = 1624, 3856 + +# Read data +lat36 = np.loadtxt(lat36_file, dtype=float, max_rows=nlat36) +lon36 = np.loadtxt(lon36_file, dtype=float, max_rows=nlon36) +lat1m = np.loadtxt(lat1m_file, dtype=float, max_rows=nlat1m) +lon1m = np.loadtxt(lon1m_file, dtype=float, max_rows=nlon1m) +lat09 = np.loadtxt(lat09_file, dtype=float, max_rows=nlat09) +lon09 = np.loadtxt(lon09_file, dtype=float, max_rows=nlon09) + +# Define nearest coordinate function +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +# Find nearest coordinates +lati36 = ind_nearest_coord(lat1m, lat36) +loni36 = ind_nearest_coord(lon1m, lon36) +lati09 = ind_nearest_coord(lat1m, lat09) +loni09 = ind_nearest_coord(lon1m, lon09) + +# Save indices to files (1-based index) +np.savetxt(lati36_output_file, lati36 + 1, fmt='%d') +np.savetxt(loni36_output_file, loni36 + 1, fmt='%d') +np.savetxt(lati09_output_file, lati09 + 1, fmt='%d') +np.savetxt(loni09_output_file, loni09 + 1, fmt='%d') + +# Compute global grid cell area +def area_global_rectilinear_grid(lat, lon, rearth=6371.22): + """ + Calculate the approximate area of each grid cell on a global rectilinear grid. + + Parameters: + lat : numpy.ndarray + Array of latitude values (degrees). + lon : numpy.ndarray + Array of longitude values (degrees). + rearth : float + Earth radius in kilometers. Default is 6371.22 km. + + Returns: + area_grid : numpy.ndarray + 2D array representing the area of each grid cell (km^2). + """ + # Convert degrees to radians + rad = np.pi / 180.0 + rr = rearth * rad + + # Longitude spacing (constant across latitudes) + dlon = rr * (lon[1] - lon[0]) # Assuming uniform spacing in longitude + + # Compute longitude spacing at each latitude (dx) + dx = dlon * np.cos(lat * rad) + + # Handle rounding issues at poles + dx[0] = 0.0 if lat[0] < -89.9999 else dx[0] + dx[-1] = 0.0 if lat[-1] > 89.9999 else dx[-1] + + # Latitude spacing (dy), can be variable + dy = np.zeros_like(lat) + dy[0] = (lat[1] - lat[0]) * rr + dy[1:-1] = (lat[2:] - lat[:-2]) * rr / 2.0 + dy[-1] = (lat[-1] - lat[-2]) * rr + + # Area per latitude band + area_lat = dx * dy + + # Extend latitude areas to all longitudes + area_grid = np.outer(area_lat, np.ones(len(lon))) + + # Total area of all grid cells + area_total = np.sum(area_grid) + + # Total surface area of the sphere + area_sphere = 4.0 * np.pi * (rearth ** 2) + + # Add metadata as a dictionary + metadata = { + "long_name": "area of each grid cell", + "units": "km^2", + "area_total": area_total, + "area_lat": area_lat, + "rearth": rearth, + "area_sphere": area_sphere, + "area_ratio": area_total / area_sphere + } + + return area_grid, metadata + +# Calculate and save cell area +area, metadata = area_global_rectilinear_grid(lat1m, lon1m) +area *= 1.e6 # Convert to m虏 + +# Remove existing file and write new cell area to NetCDF +if os.path.exists(cellarea_output_file): + os.remove(cellarea_output_file) + +with Dataset(cellarea_output_file, "w", format="NETCDF4") as fout: + # Create dimensions + fout.createDimension("lat", nlat1m) + fout.createDimension("lon", nlon1m) + + # Create variables for lat and lon + lat_var = fout.createVariable("lat", "f4", ("lat",)) + lon_var = fout.createVariable("lon", "f4", ("lon",)) + lat_var[:] = lat1m + lon_var[:] = lon1m + # Assign units attribute to lat and lon + lat_var.units = "degrees_north" + lon_var.units = "degrees_east" + + # Create the area variable + area_var = fout.createVariable("data", "f8", ("lat", "lon")) + area_var[:] = area + area_var.units = "m2" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 new file mode 100755 index 000000000..f11340f06 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 @@ -0,0 +1,35 @@ +program main + +implicit none +integer,parameter :: nt=1684725 + +integer,allocatable,dimension(:) :: id, catid +real,allocatable,dimension(:) :: lon_left,lon_right,lat_bottom,lat_top + +integer :: i,ntot + +allocate(id(nt),catid(nt),lon_left(nt),lon_right(nt),lat_bottom(nt),lat_top(nt)) +open(77,file="input/catchment_M09.def") +read(77,*)ntot +do i=1,nt + read(77,*)id(i),catid(i),lon_left(i),lon_right(i),lat_bottom(i),lat_top(i) +enddo + +open(88,file="temp/lon_left_M09.txt") +do i=1,nt + write(88,*)lon_left(i) +enddo +open(88,file="temp/lon_right_M09.txt") +do i=1,nt + write(88,*)lon_right(i) +enddo +open(88,file="temp/lat_bottom_M09.txt") +do i=1,nt + write(88,*)lat_bottom(i) +enddo +open(88,file="temp/lat_upper_M09.txt") +do i=1,nt + write(88,*)lat_top(i) +enddo + +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 new file mode 100755 index 000000000..2bc7a9592 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 @@ -0,0 +1,35 @@ +program main + +implicit none +integer,parameter :: nt=112573 + +integer,allocatable,dimension(:) :: id, catid +real,allocatable,dimension(:) :: lon_left,lon_right,lat_bottom,lat_top + +integer :: i,ntot + +allocate(id(nt),catid(nt),lon_left(nt),lon_right(nt),lat_bottom(nt),lat_top(nt)) +open(77,file="input/catchment_M36.def") +read(77,*)ntot +do i=1,nt + read(77,*)id(i),catid(i),lon_left(i),lon_right(i),lat_bottom(i),lat_top(i) +enddo + +open(88,file="temp/lon_left_M36.txt") +do i=1,nt + write(88,*)lon_left(i) +enddo +open(88,file="temp/lon_right_M36.txt") +do i=1,nt + write(88,*)lon_right(i) +enddo +open(88,file="temp/lat_bottom_M36.txt") +do i=1,nt + write(88,*)lat_bottom(i) +enddo +open(88,file="temp/lat_upper_M36.txt") +do i=1,nt + write(88,*)lat_top(i) +enddo + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py new file mode 100755 index 000000000..94fa5c040 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py @@ -0,0 +1,66 @@ +import numpy as np +from netCDF4 import Dataset +import os + +# Load data +nt = 1684725 +nlat = 1624 +nlon = 3856 +nc = 291284 + +# Read input data from text files +lat_bot = np.loadtxt("temp/lat_bottom_M09.txt", dtype=float) +lat_up = np.loadtxt("temp/lat_upper_M09.txt", dtype=float) +lon_left = np.loadtxt("temp/lon_left_M09.txt", dtype=float) +lon_right = np.loadtxt("temp/lon_right_M09.txt", dtype=float) + +# Calculate the center latitudes and longitudes +latc = (lat_bot + lat_up) / 2.0 +lonc = (lon_left + lon_right) / 2.0 + +# Read latitudes and longitudes for the grid +lat36m = np.loadtxt("input/lat_M09.txt", dtype=float) +lon36m = np.loadtxt("input/lon_M09.txt", dtype=float) + +# Find the nearest coordinates +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +lati = ind_nearest_coord(latc, lat36m) +loni = ind_nearest_coord(lonc, lon36m) + +# Save the indices to files (1-based index) +np.savetxt("temp/lati_tile_M09.txt", lati + 1, fmt='%d') +np.savetxt("temp/loni_tile_M09.txt", loni + 1, fmt='%d') + +# Initialize the map_tile array +map_tile = np.full((nlat, nlon), -9999, dtype=int) + +# Fill the map_tile with data +for i in range(nt): + map_tile[lati[i], loni[i]] = i + 1 + +# Remove the existing file if it exists +if os.path.exists("temp/map_tile_M09.nc"): + os.remove("temp/map_tile_M09.nc") + +# Create a NetCDF file and write the data +with Dataset("temp/map_tile_M09.nc", "w", format="NETCDF4") as fout: + # Create dimensions + fout.createDimension("lat", nlat) + fout.createDimension("lon", nlon) + + # Create variable to store the map_tile data with fill_value set during creation + map_tile_var = fout.createVariable("data", "i4", ("lat", "lon"), fill_value=-9999) + map_tile_var[:] = map_tile + +# Print a sample of the map_tile data +#print(map_tile[62, 10]) # Corresponds to map_tile(63-1, 11-1) in NCL (1-based to 0-based) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py new file mode 100755 index 000000000..112e8572f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py @@ -0,0 +1,66 @@ +import numpy as np +from netCDF4 import Dataset +import os + +# Load data +nt = 112573 +nlat = 406 +nlon = 964 +nc = 291284 + +# Read input data from text files +lat_bot = np.loadtxt("temp/lat_bottom_M36.txt", dtype=float) +lat_up = np.loadtxt("temp/lat_upper_M36.txt", dtype=float) +lon_left = np.loadtxt("temp/lon_left_M36.txt", dtype=float) +lon_right = np.loadtxt("temp/lon_right_M36.txt", dtype=float) + +# Calculate the center latitudes and longitudes +latc = (lat_bot + lat_up) / 2.0 +lonc = (lon_left + lon_right) / 2.0 + +# Read latitudes and longitudes for the grid +lat36m = np.loadtxt("input/lat_M36.txt", dtype=float) +lon36m = np.loadtxt("input/lon_M36.txt", dtype=float) + +# Find the nearest coordinates +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +lati = ind_nearest_coord(latc, lat36m) +loni = ind_nearest_coord(lonc, lon36m) + +# Save the indices to files (1-based index) +np.savetxt("temp/lati_tile_M36.txt", lati + 1, fmt='%d') +np.savetxt("temp/loni_tile_M36.txt", loni + 1, fmt='%d') + +# Initialize the map_tile array +map_tile = np.full((nlat, nlon), -9999, dtype=int) + +# Fill the map_tile with data +for i in range(nt): + map_tile[lati[i], loni[i]] = i + 1 + +# Remove the existing file if it exists +if os.path.exists("temp/map_tile_M36.nc"): + os.remove("temp/map_tile_M36.nc") + +# Create a NetCDF file and write the data +with Dataset("temp/map_tile_M36.nc", "w", format="NETCDF4") as fout: + # Create dimensions + fout.createDimension("lat", nlat) + fout.createDimension("lon", nlon) + + # Create variable to store the map_tile data with fill_value set during creation + map_tile_var = fout.createVariable("data", "i4", ("lat", "lon"), fill_value=-9999) + map_tile_var[:] = map_tile + +# Print a sample of the map_tile data +#print(map_tile[62, 10]) # Corresponds to map_tile(63-1, 11-1) in NCL (1-based to 0-based) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 new file mode 100755 index 000000000..d7714859b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 @@ -0,0 +1,85 @@ +program main + +use river_read +implicit none + +integer,parameter :: nmax=458 +integer,parameter :: nc=291284 +integer,parameter :: nlon=21600 +integer,parameter :: nlat=10800 + +integer :: id,xi,yi,i,flag,subi +integer :: nsub(nc) +integer,allocatable :: xsub(:,:),ysub(:,:) +real,allocatable :: asub(:,:) + +real*8,allocatable :: lon(:),lat(:) +integer,allocatable :: loni(:),lati(:) +integer,allocatable :: catchind(:,:) +real,allocatable :: cellarea(:,:) + +allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) +allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) +allocate(lon(nlon),lat(nlat)) +allocate(loni(nlon),lati(nlat)) + + +call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) +call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) +call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) +call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) +cellarea=cellarea/1.e6 + + +open(10,file="temp/lati_1m_M09.txt") +read(10,*)lati +open(11,file="temp/loni_1m_M09.txt") +read(11,*)loni + +nsub=0 +xsub=0 +ysub=0 +asub=0. +do xi=1,nlon + do yi=1,nlat + if(catchind(xi,yi)>=1)then + + id=catchind(xi,yi) + flag=0 + if(nsub(id)>=1)then + do i=1,nsub(id) + if(loni(xi)==xsub(i,id).and.lati(yi)==ysub(i,id))then + flag=1 + asub(i,id)=asub(i,id)+cellarea(xi,yi) + exit + endif + enddo + endif + if(flag==0)then + nsub(id)=nsub(id)+1 + xsub(nsub(id),id)=loni(xi) + ysub(nsub(id),id)=lati(yi) + asub(nsub(id),id)=cellarea(xi,yi) + endif + + endif + enddo +enddo + +open(50,file="output/Pfaf_nsub_M09.txt") +open(51,file="output/Pfaf_xsub_M09.txt") +open(52,file="output/Pfaf_ysub_M09.txt") +open(53,file="output/Pfaf_asub_M09.txt") +do i=1,nc + write(50,*)nsub(i) + write(51,'(458(1x,i4))')xsub(:,i) + write(52,'(458(1x,i4))')ysub(:,i) + write(53,'(458(1x,f10.4))')asub(:,i) +enddo + +print *,maxval(nsub) +print *,maxloc(nsub) + + + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 new file mode 100755 index 000000000..c5495381e --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 @@ -0,0 +1,85 @@ +program main + +use river_read +implicit none + +integer,parameter :: nmax=150 +integer,parameter :: nc=291284 +integer,parameter :: nlon=21600 +integer,parameter :: nlat=10800 + +integer :: id,xi,yi,i,flag,subi +integer :: nsub(nc) +integer,allocatable :: xsub(:,:),ysub(:,:),subi_global(:,:) +real,allocatable :: asub(:,:) + +real*8,allocatable :: lon(:),lat(:) +integer,allocatable :: loni(:),lati(:) +integer,allocatable :: catchind(:,:) +real,allocatable :: cellarea(:,:) + +allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) +allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) +allocate(lon(nlon),lat(nlat)) +allocate(loni(nlon),lati(nlat)) + + +call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) +call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) +call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) +call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) +cellarea=cellarea/1.e6 + + +open(10,file="temp/lati_1m_M36.txt") +read(10,*)lati +open(11,file="temp/loni_1m_M36.txt") +read(11,*)loni + +nsub=0 +xsub=0 +ysub=0 +asub=0. +do xi=1,nlon + do yi=1,nlat + if(catchind(xi,yi)>=1)then + + id=catchind(xi,yi) + flag=0 + if(nsub(id)>=1)then + do i=1,nsub(id) + if(loni(xi)==xsub(i,id).and.lati(yi)==ysub(i,id))then + flag=1 + asub(i,id)=asub(i,id)+cellarea(xi,yi) + exit + endif + enddo + endif + if(flag==0)then + nsub(id)=nsub(id)+1 + xsub(nsub(id),id)=loni(xi) + ysub(nsub(id),id)=lati(yi) + asub(nsub(id),id)=cellarea(xi,yi) + endif + + endif + enddo +enddo + +open(50,file="output/Pfaf_nsub_M36.txt") +open(51,file="output/Pfaf_xsub_M36.txt") +open(52,file="output/Pfaf_ysub_M36.txt") +open(53,file="output/Pfaf_asub_M36.txt") +do i=1,nc + write(50,*)nsub(i) + write(51,'(150(1x,i3))')xsub(:,i) + write(52,'(150(1x,i3))')ysub(:,i) + write(53,'(150(1x,f10.4))')asub(:,i) +enddo + +print *,maxval(nsub) +print *,maxloc(nsub) + + + +end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 new file mode 100755 index 000000000..d7a761f6f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 @@ -0,0 +1,248 @@ +program main + +use river_read +implicit none + +integer :: nc=291284 +real :: cur_avg=1.4 +real :: cur_min=0.5 +real :: cur_max=5. + +integer,parameter :: nlon=21600 +integer,parameter :: nlat=10800 +real*8,allocatable :: lon(:),lat(:) +real,allocatable :: ldn1m(:,:),elev1m(:,:) +integer,allocatable :: catid(:,:),flag_slp(:) + +integer,parameter :: nlonh=86400 +integer,parameter :: nlath=33600 +real*8,allocatable :: lonh(:),lath(:) +real,allocatable :: ldnh(:,:),elev_15s(:,:) + +real,allocatable,dimension(:) :: lon_dn,lat_dn,lon_up,lat_up,dist_ref,dist_ref2,ldn_min,ldn_max,riv_len,str_len,slp +real,allocatable,dimension(:) :: lon_min,lon_max,lat_min,lat_max,area,elevdiff_ref,elevdiff +integer,allocatable,dimension(:) :: xi_min,yi_min,xi_max,yi_max +integer,allocatable,dimension(:) :: downid + + + +integer xi,yi +integer :: num,i,j,cid,did,k +integer :: data1,data12 +real*8 :: data2 +real :: data7,data9,data10 +real :: elev_temp + +!----------------------------------------------------------------------- +!Regrid LDN from HydroSHEDS + +allocate(ldn1m(nlon,nlat),catid(nlon,nlat)) +allocate(lon(nlon),lat(nlat)) +call read_ncfile_double1d("input/SRTM_PfafData.nc","longitude",lon,nlon) +call read_ncfile_double1d("input/SRTM_PfafData.nc","latitude",lat,nlat) +call read_ncfile_int2d("input/SRTM_PfafData.nc","CatchIndex",catid,nlon,nlat) +ldn1m=-1. +where(catid==-9999) ldn1m=-9999. + +allocate(ldnh(nlonh,nlath)) +call read_ncfile_real2d("input/hyd_glo_ldn_15s.nc","Band1",ldnh,nlonh,nlath) +where(ldnh.lt.4.e9) ldnh=ldnh/1.e3 !m -> km + +do xi=1,nlon + do yi=2041,10440 + if(ldn1m(xi,yi).ne.-9999.)then + ldn1m(xi,yi)=minval(ldnh(4*xi-3:4*xi,4*yi-3-8160:4*yi-8160)) + if(ldn1m(xi,yi).gt.4.e9)ldn1m(xi,yi)=-1. + end if + enddo +enddo +print *,maxval(ldn1m) + +allocate(ldn_min(nc),ldn_max(nc),xi_min(nc),yi_min(nc),xi_max(nc),yi_max(nc)) +ldn_min=1.e20 +ldn_max=-9999. +xi_min=-9999;yi_min=-9999;xi_max=-9999;yi_max=-9999 +do i=1,nlon + do j=1,nlat + if(catid(i,j)>=1)then + cid=catid(i,j) + if(ldn1m(i,j)>0. .and. ldn1m(i,j)0. .and. ldn1m(i,j)>ldn_max(cid))then + ldn_max(cid)=ldn1m(i,j) + xi_max(cid)=i + yi_max(cid)=j + endif + endif + enddo +enddo +where(ldn_min==1.e20)ldn_min=-9999 + +!open(88,file="xi_yi_min.txt") +!do i=1,nc +! write(88,*)xi_min(i),yi_min(i) +!enddo + + +allocate(elev_15s(nlonh,nlath),elev1m(nlon,nlat)) +call read_ncfile_real2d("input/hyd_glo_dem_15s.nc","Band1",elev_15s,nlonh,nlath) +where(elev_15s>30000.)elev_15s=0. +elev1m=0. +do xi=1,nlon + do yi=2041,10440 + elev1m(xi,yi)=sum(elev_15s(4*xi-3:4*xi,4*yi-3-8160:4*yi-8160))/16. + enddo +enddo + +!call create_ncfile_real2d("elev_1m.nc","data",elev1m,lon,lat,nlon,nlat) + +deallocate(ldnh,elev_15s) +!----------------------------------------------------------------------- +!Get reference distance + +open(77,file="input/Pfafcatch-routing.dat", form="formatted", status="old") +read(77,*)num +allocate(lon_dn(nc),lat_dn(nc),lon_up(nc),lat_up(nc),dist_ref(nc),dist_ref2(nc)) +allocate(lon_min(nc),lon_max(nc),lat_min(nc),lat_max(nc),area(nc),elevdiff_ref(nc),elevdiff(nc)) + +do i=1,nc + read(77,*)data1,data2,lon_min(i),lon_max(i),lat_min(i),lat_max(i),data7,area(i),data9,data10,elevdiff_ref(i),data12,lon_dn(i),lat_dn(i),lon_up(i),lat_up(i) +enddo + +do i=1,nc + dist_ref(i)=spherical_distance(lon_dn(i), lat_dn(i), lon_up(i), lat_up(i)) + dist_ref2(i)=spherical_distance(lon_min(i), lat_min(i), lon_max(i), lat_max(i)) +enddo +where(dist_ref>dist_ref2.or.dist_ref==0.)dist_ref=0.5*dist_ref2 + + +!-------------------------------------------------------------------- +! Get intial guess of river length +allocate(riv_len(nc),downid(nc),flag_slp(nc)) +open(77,file="output/downstream_1D_new_noadj.txt") +read(77,*)downid + +!open(88,file="temp/xi_yi_min.txt") +!do i=1,nc +! write(88,*)xi_min(i),yi_min(i) +!enddo +!open(88,file="temp/xi_yi_max.txt") +!do i=1,nc +! write(88,*)xi_max(i),yi_max(i) +!enddo + + +flag_slp=1 + +riv_len=-9999. +elevdiff=-9999. +do i=1,nc + if(downid(i)>=1)then + did=downid(i) + if(.not. (riv_len(did)>=cur_min*dist_ref(did).and.riv_len(did)<=cur_max*dist_ref(did)) )then + riv_len(did)=ldn_min(i)-ldn_min(did) + if(xi_min(i)>0.and.xi_min(did)>0)then + elevdiff(did)=max(0.,elev1m(xi_min(i),yi_min(i)) - elev1m(xi_min(did),yi_min(did))) + flag_slp(did)=1 + else + elevdiff(did)=elevdiff_ref(did) + flag_slp(did)=0 + endif + else if(flag_slp(did)==0.or.elevdiff(did)==0.)then + riv_len(did)=ldn_min(i)-ldn_min(did) + if(xi_min(i)>0.and.xi_min(did)>0)then + elevdiff(did)=max(0.,elev1m(xi_min(i),yi_min(i)) - elev1m(xi_min(did),yi_min(did))) + flag_slp(did)=1 + else + elevdiff(did)=elevdiff_ref(did) + flag_slp(did)=0 + endif + endif + endif +enddo + +do i=1,nc + if(riv_len(i)==-9999.)then + riv_len(i)=(ldn_max(i)-ldn_min(i))*0.5 + if(xi_min(i)>0)then + elevdiff(i)=max(0.,0.5*elev1m(xi_max(i),yi_max(i)) - 0.5*elev1m(xi_min(i),yi_min(i)) ) + else + elevdiff(i)=elevdiff_ref(i) + flag_slp(did)=0 + endif + endif +enddo + +k=0 +do i=1,nc + if(.not. (riv_len(i)>=cur_min*dist_ref(i).and.riv_len(i)<=cur_max*dist_ref(i)) )then + riv_len(i)=cur_avg*dist_ref(i) + elevdiff(i)=elevdiff_ref(i) + flag_slp(i)=0 + k=k+1 + endif +enddo +open(88,file="output/Pfaf_lriv_PR.txt") +do i=1,nc + write(88,*) riv_len(i) +enddo + + + +!-------------------------------------------------------------------- +! Calculate the length scale of local streams +allocate(str_len(nc)) +str_len=area/riv_len/4.*cur_avg +open(88,file="output/Pfaf_lstr_PR.txt") +do i=1,nc + write(88,*) str_len(i) +enddo +!-------------------------------------------------------------------- +! Calculate the Catchment slope +allocate(slp(nc)) +slp=elevdiff*1.e-3/riv_len +where(slp.lt.1.e-5) flag_slp=0 +where(slp.lt.1.e-5) slp=1.e-5 +print *,sum(flag_slp) +open(88,file="temp/Pfaf_slope.txt") +do i=1,nc + write(88,*) slp(i) +enddo +print *,minval(slp) +open(88,file="temp/Pfaf_slope_flag.txt") +do i=1,nc + write(88,*)flag_slp(i) +enddo + +!-------------------------------------------------------------------- +contains + +function spherical_distance(lon_dn, lat_dn, lon_up, lat_up) result(distance) + implicit none + ! Declare variables + real, intent(in) :: lon_dn, lat_dn ! Input coordinates (downstream point) + real, intent(in) :: lon_up, lat_up ! Input coordinates (upstream point) + real :: distance ! Output distance (in kilometers) + real :: R, dlon, dlat, a, c ! Intermediate variables + + ! Radius of the Earth in kilometers + R = 6371.0 + + ! Convert degrees to radians + dlon = (lon_up - lon_dn) * (acos(-1.0) / 180.0) + dlat = (lat_up - lat_dn) * (acos(-1.0) / 180.0) + + ! Haversine formula + a = sin(dlat / 2.0)**2 + cos(lat_dn * (acos(-1.0) / 180.0)) * & + cos(lat_up * (acos(-1.0) / 180.0)) * sin(dlon / 2.0)**2 + c = 2.0 * atan2(sqrt(a), sqrt(1.0 - a)) + + ! Distance calculation + distance = R * c + +end function spherical_distance + +end program \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 new file mode 100755 index 000000000..c316f57ff --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 @@ -0,0 +1,905 @@ +module k_module + + use river_read + + implicit none + private + public :: read_usgs_data, process_usgs_data, find_nearest_coords, get_station_inf, regression + public :: filter_station, cal_Kmodel, get_valide_stations_gageii + +contains +!------------------------------------------------------------ + subroutine read_usgs_data(nl, data) + ! Subroutine to read USGS velocity and discharge data and store it in a 2D array + integer, intent(in) :: nl + real, allocatable, intent(out) :: data(:,:) + + character(len=100) :: var(2) + character(len=256) :: filename + character(len=100) :: line + character(len=100) :: x(100) + + integer :: i, j, l, io, k + integer, allocatable :: nv(:) + + !---------- Define the data types to be read ---------- + var = (/ "velocity", "discharge" /) + + ! Allocate the data array + allocate(data(nl, 2)) + + ! Loop over velocity and discharge files + do l = 1, 2 + filename = "input/" // trim(var(l)) // ".txt" + open(unit=77, file=trim(filename), status='old') + + ! Allocate temporary array for counting valid numbers per line + allocate(nv(nl)) + + ! Read each line from the file + do k = 1, nl + read(77, '(A)', iostat=io) line + if (io /= 0) then + print *, "Error reading line ", k, " from file: ", trim(filename) + exit + endif + + ! Read tokens from the line and store in array x + do i = 1, 100 + read(line, *, iostat=io) (x(j), j=1, i) + if (io == -1) then + exit + endif + end do + + ! Count the number of valid values in the line + nv(k) = i - 1 + + ! If valid data exists, read the first value into the data array + if (nv(k) >= 1) then + read(x(1), *, iostat=io) data(k, l) + else + data(k, l) = -9999 ! Assign missing value if no data is available + end if + end do + + ! Deallocate the temporary array for valid number counts + deallocate(nv) + + ! Close the file + close(77) + end do + end subroutine read_usgs_data + +!------------------------------------------------------------ + subroutine process_usgs_data(nl, ns, data, nv, nt, vel, dis) + integer, intent(in) :: nl + integer, intent(out) :: ns + real, intent(inout),allocatable :: data(:,:) + real, allocatable, intent(out) :: vel(:), dis(:) + integer, allocatable,intent(out) :: nv(:) + integer,intent(out) :: nt + + character(len=20), allocatable :: id(:) + integer, allocatable :: nu(:) + character(len=20), allocatable :: idu(:) + integer :: i, k, ii + + ! Allocate arrays + allocate(id(nl)) + + + ! Read IDs from the file + open(unit=11, file="input/USGSID.txt", status="old") + read(11, *) id + close(11) + + ! Convert velocity from ft/s to m/s and discharge from ft^3/s to m^3/s + !data(:,1) = data(:,1) * 0.3048 ! Convert ft/s to m/s + !data(:,2) = data(:,2) * 0.0283168 ! Convert ft^3/s to m^3/s + + ! Initialize arrays + k = 1 + ! Process ID and count occurrences of unique IDs + do i = 2, nl + if (.not.(trim(id(i)) == trim(id(i-1)))) then + k = k + 1 + end if + end do + !print *, 'Number of unique IDs:', k + ns=k + allocate(nu(ns),nv(ns)) + allocate(idu(ns)) + ! Initialize arrays + nu(1) = 1 + idu(1) = id(1) + k = 1 + ! Process ID and count occurrences of unique IDs + do i = 2, nl + if (trim(id(i)) == trim(id(i-1))) then + nu(k) = nu(k) + 1 + else + k = k + 1 + nu(k) = 1 + idu(k) = id(i) + end if + end do + + ! Write idu to file (IDs without commas) + open(unit=13, file="temp/id_for_site.txt") + do i = 1, ns + write(13, '(A)') trim(idu(i))//"," + !write(13, '(A)') trim(idu(i)) + end do + close(13) + open(unit=13, file="temp/id_for_site_nocomma.txt") + do i = 1, ns + write(13, '(A)') trim(idu(i)) + !write(13, '(A)') trim(idu(i)) + end do + close(13) + + ! Initialize variables + nv = 0 + nv(1) = 1 + k = 1 + ii = 0 + k = k - 1 + ! Assuming nm is defined and idA, vel, dis are allocated and filled + ! Loop through the elements + do i = 2, nl + if (id(i) == id(i - 1)) then + k = k + 1 + if (data(i,1) <= 0.0) then + k = k - 1 + else if (data(i,2) <= 0.0) then + k = k - 1 + end if + else + nv(ii + 1) = k + k = 1 + ii = ii + 1 + if (data(i,1) <= 0.0) then + k = k - 1 + else if (data(i,2) <= 0.0) then + k = k - 1 + end if + end if + end do + nv(ii + 1) = k + !print *,"number valid records",sum(nv) + + nt=sum(nv) + allocate(vel(nt),dis(nt)) + k=0 + do i=1,nl + if(data(i,1)>0..and.data(i,2)>0.)then + k=k+1 + vel(k)=data(i,1) + dis(k)=data(i,2) + endif + enddo + !open(unit=13, file="All_vel_trim.txt") + !do i = 1, k + ! write(13, *) vel(i) + !end do + !open(unit=13, file="All_dis_trim.txt") + !do i = 1, k + ! write(13, *) dis(i) + !end do + + + ! Deallocate arrays + deallocate(id) + deallocate(nu) + deallocate(idu) + deallocate(data) + + end subroutine process_usgs_data + + +!------------------------------------------------------------ + + ! Subroutine to find the nearest latitude and longitude for each station + subroutine find_nearest_coords(ns, nlat, nlon, lats, lons, lati, loni) + integer, intent(in) :: ns, nlat, nlon + real,allocatable,intent(inout) :: lats(:), lons(:) + integer, allocatable, intent(out) :: lati(:), loni(:) + + real, allocatable :: lat1m(:), lon1m(:) + real :: min_dist_lat, min_dist_lon, dist + integer :: i, j, idx_min_lat, idx_min_lon + + ! Allocate arrays for lat/lon data + allocate(lati(ns), loni(ns)) + allocate(lats(ns), lons(ns)) + allocate(lat1m(nlat), lon1m(nlon)) + + !---- Read latitudes and longitudes for sites ---- + open(unit=10, file="input/lat_for_site_200.txt", status='old') + do i = 1, ns + read(10, *) lats(i) + end do + close(10) + + open(unit=11, file="input/lon_for_site_200.txt", status='old') + do i = 1, ns + read(11, *) lons(i) + end do + close(11) + + !---- Read 1-minute resolution lat/lon grid ---- + open(unit=12, file="input/lat_1m.txt", status='old') + do i = 1, nlat + read(12, *) lat1m(i) + end do + close(12) + + open(unit=13, file="input/lon_1m.txt", status='old') + do i = 1, nlon + read(13, *) lon1m(i) + end do + close(13) + + !---- Find nearest coordinates for each station ---- + do i = 1, ns + ! Initialize minimum distance + min_dist_lat = 1.0e20 + min_dist_lon = 1.0e20 + idx_min_lat = -1 + idx_min_lon = -1 + + ! Find nearest latitude + do j = 1, nlat + dist = abs(lats(i) - lat1m(j)) + if (dist < min_dist_lat) then + min_dist_lat = dist + idx_min_lat = j + end if + end do + lati(i) = idx_min_lat + + ! Find nearest longitude + do j = 1, nlon + dist = abs(lons(i) - lon1m(j)) + if (dist < min_dist_lon) then + min_dist_lon = dist + idx_min_lon = j + end if + end do + loni(i) = idx_min_lon + end do + + !---- Write output files with Fortran indexing (1-based) ---- + !open(unit=14, file="USGS_data/lati_for_site_200.txt", status='replace') + !do i = 1, ns + ! write(14, *) lati(i) + !end do + !close(14) + + !open(unit=15, file="USGS_data/loni_for_site_200.txt", status='replace') + !do i = 1, ns + ! write(15, *) loni(i) + !end do + !close(15) + + ! Deallocate arrays + deallocate(lat1m) + deallocate(lon1m) + end subroutine find_nearest_coords +!------------------------------------------------------------ + subroutine get_station_inf(ns, nc, nlat, nlon, lati, loni, catid, Qclmt, slp, KImodel_all,exp_slp,exp_clmt,fac_str) + integer, intent(in) :: ns, nc, nlat, nlon + integer, intent(in) :: lati(nlon), loni(nlon) + integer, allocatable, intent(out) :: catid(:) + real,allocatable,intent(out) :: Qclmt(:),slp(:) + real,allocatable,intent(out) :: KImodel_all(:) + real,intent(in) :: exp_slp,exp_clmt,fac_str + + integer,allocatable :: catchind(:,:) + real,allocatable,dimension(:) :: Qclmt_all,slp_all,Kstr_all,Qstr_all + integer :: i + + allocate(catchind(nlon,nlat),catid(ns)) + allocate(Qclmt_all(nc),slp_all(nc)) + allocate(Qclmt(ns),slp(ns)) + allocate(KImodel_all(nc),Kstr_all(nc),Qstr_all(nc)) + + call read_ncfile_int2d("input/SRTM_PfafData.nc","CatchIndex",catchind,nlon,nlat) + + do i=1,ns + catid(i)=catchind(loni(i),lati(i)) + end do + + open(88,file="temp/catid_for_site_200.txt") + do i=1,ns + write(88,*)catid(i) + end do + + open(77,file="output/Pfaf_qri.txt") + read(77,*)Qclmt_all + where(Qclmt_all<1.e-8) Qclmt_all=1.e-8 + open(77,file="temp/Pfaf_slope.txt") + read(77,*)slp_all + open(77,file="output/Pfaf_qstr.txt") + read(77,*)Qstr_all + where(Qstr_all<1.e-8) Qstr_all=1.e-8 + + do i=1,ns + if(catid(i)/=-9999)then + Qclmt(i)=Qclmt_all(catid(i)) + slp(i)=slp_all(catid(i)) + else + Qclmt(i)=-9999 + slp(i)=-9999 + endif + enddo + + KImodel_all = (Qclmt_all**(exp_clmt)) * (slp_all**(exp_slp)) + + Kstr_all = fac_str * (Qstr_all**(exp_clmt)) * (slp_all**(exp_slp)) + + open(88,file="output/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt") + do i=1,nc + write(88,*)Kstr_all(i) + enddo + + + !open(88,file="USGS_data/qri_for_site_200.txt") + !do i=1,ns + ! write(88,*)Qclmt(i) + !end do + !open(88,file="USGS_data/slp_for_site_200.txt") + !do i=1,ns + ! write(88,*)slp(i) + !end do + + + deallocate(catchind,Qclmt_all,slp_all,Kstr_all,Qstr_all) + + end subroutine get_station_inf +!------------------------------------------------------------ + subroutine get_valide_stations_gageii(ns,nc,catid_sta,flag_thres) + integer,intent(in) :: ns,nc + integer,intent(in) :: catid_sta(ns) + integer,allocatable,intent(out) :: flag_thres(:) + + + integer, parameter :: nga = 9067 + integer, parameter :: nv = 5704 + real, parameter :: thr_sel = 0.3 + + real,dimension(:),allocatable :: acar_pfaf + + integer :: i, j, k, cid + character(len=20) :: id_gages(nga) + character(len=20) :: id_sta(ns) + integer :: flag_gageii(ns) + real :: acar_gages(nga) + real :: acar_gages_sta(ns),acar_sta(ns) + character(len=20) :: line + integer :: ios + + allocate(flag_thres(ns)) + + ! Initialize acar_6156 array with missing value + acar_sta = -9999.0 + k = 0 + + ! Read id_gages from file + open(unit=10, file="input/id_gagesii.txt", status="old", action="read") + do j = 1, nga + read(10,'(A)', iostat=ios) id_gages(j) + if (ios /= 0) then + print *, "Error reading id_gagesii.txt" + stop + end if + end do + close(10) + + ! Read id_6156 from file + open(unit=11, file="temp/id_for_site_nocomma.txt", status="old", action="read") + do i = 1, ns + read(11,'(A)', iostat=ios) id_sta(i) + if (ios /= 0) then + print *, "Error reading id_for_site_nocomma.txt" + stop + end if + end do + close(11) + + ! Read acar_gages from file + open(unit=12, file="input/acar_gagesii.txt", status="old", action="read") + do j = 1, nga + read(12,*, iostat=ios) acar_gages(j) + if (ios /= 0) then + print *, "Error reading acar_gagesii.txt" + stop + end if + end do + close(12) + + flag_gageii = 0 + ! Compare id_sta and id_gages, and update acar_sta if there's a match + do i = 1, ns + do j = 1, nga + if (trim(id_gages(j)) == trim(id_sta(i))) then + acar_gages_sta(i) = acar_gages(j) + flag_gageii(i) = 1 + k = k + 1 + exit ! Exit inner loop if match is found + end if + end do + end do + + print *, "Number of matches:", sum(flag_gageii) + + allocate(acar_pfaf(nc)) + open(77,file="temp/Pfaf_acar.txt") + read(77,*)acar_pfaf + + do i = 1, ns + if(catid_sta(i)/=-9999)then + cid = catid_sta(i) + acar_sta(i) = acar_pfaf(cid) + else + acar_sta(i) = -9999. + end if + end do + + + flag_thres = 0 + do i = 1, ns + if(flag_gageii(i)==1 .and. catid_sta(i)/=-9999)then + if(acar_sta(i).ge.(1.-thr_sel)*acar_gages_sta(i) .and. acar_sta(i).le.(1.+thr_sel)*acar_gages_sta(i))then + flag_thres(i) = 1 + endif + endif + end do + + print *,"Number of valid:", sum(flag_thres) + + deallocate(acar_pfaf) + !open(88,file="flag_thr03_7065.txt") + !do i = 1,ns + ! write(88,*)flag_thres(i) + !enddo + + end subroutine get_valide_stations_gageii +!------------------------------------------------------------ + subroutine regression(nt,vel_ori,dis_ori,nv,ns,Qclmt,slp,KKobs,KImodel,exp_slp,exp_clmt,mm,MU) + integer,intent(in) :: nt, ns + real,intent(inout),allocatable :: vel_ori(:), dis_ori(:) + integer,intent(in) :: nv(ns) + real,intent(inout),allocatable :: Qclmt(:),slp(:) + real,intent(out),allocatable :: KKobs(:),KImodel(:) + real,intent(in) :: exp_slp,exp_clmt,mm,MU + + real,allocatable,dimension(:) :: x,y,yest + + integer :: thres=100 + integer :: i,j + real :: k(ns),cdtm(ns),med + integer :: acc(ns) + real,allocatable :: vel(:), dis(:) + + allocate(vel(nt),dis(nt)) + vel=vel_ori*0.3048 !m/s + dis=dis_ori*0.0283168 !m3/s + + acc(1)=nv(1) + do i=2,ns + acc(i)=acc(i-1)+nv(i) + end do + !open(88,file="USGS_data/acc_noMISSING_200.txt") + !do i=1,ns + ! write(88,*)acc(i) + !end do + !print *,"5.1" + do i=1,ns + if(nv(i)>=thres)then + allocate( x(nv(i)), y(nv(i)), yest(nv(i))) + x=dis( acc(i)-nv(i)+1:acc(i) )**mm + y=vel( acc(i)-nv(i)+1:acc(i) ) + k(i)=sum(x*y)/sum(x*x) + yest=k(i)*x + cdtm(i)=cal_cdtm(y,yest) + deallocate(x,y,yest) + else + k(i)=-9999. + cdtm(i)=-9999. + endif + enddo + med=median(cdtm) + + where(cdtm<0.5)k=-9999. + !print *,"mm=",mm,",cdtm_med=",med,",stop now!" + + !print *,"5.2" + allocate(KKobs(ns)) + do i=1,ns + if(k(i)/=-9999.and.Qclmt(i)/=-9999.)then + KKobs(i)=k(i)/(Qclmt(i)**(MU-mm)) + else + KKobs(i)=-9999. + endif + end do + + !open(88,file="KKobs_mm0p40_MU0p10_7065.txt") + !do i=1,ns + ! write(88,*)KKobs(i) + !enddo + + !print *,"mm=",mm,",cdtm_med=",med,",stop now!" + !stop + + !open(88,file="USGS_data/KKobs_200.txt") + !do i=1,ns + ! write(88,*)KKobs(i) + !end do + + allocate(KImodel(ns)) + KImodel = (Qclmt**(exp_clmt)) * (slp**(exp_slp)) + + deallocate(vel,dis) + !deallocate(vel_ori,dis_ori) + + end subroutine regression +!------------------------------------------------------------ + subroutine filter_station(nc,ns,np,lats_full,lons_full,Qclmt_full,slp_full,catid_full,KKobs_full,KImodel_full,Qclmt,slp,catid,KKobs,KImodel,flag_gageii) + integer,intent(in) :: ns,nc + integer,intent(out) :: np + real,intent(inout),allocatable :: lats_full(:),lons_full(:),Qclmt_full(:),slp_full(:),KKobs_full(:),KImodel_full(:) + real,intent(out),allocatable :: Qclmt(:),slp(:),KKobs(:),KImodel(:) + integer,intent(inout),allocatable :: catid_full(:) + integer,intent(out),allocatable :: catid(:) + integer,intent(inout),allocatable :: flag_gageii(:) + + integer,allocatable :: flag_slp(:) + real,allocatable :: lats(:),lons(:) + integer :: i,k + integer,allocatable :: flag_7065(:) + + + allocate(flag_slp(nc)) + open(77,file="temp/Pfaf_slope_flag.txt") + read(77,*)flag_slp + + allocate(flag_7065(ns)) + flag_7065=0 + + !open(77,file="flag_thr03_7065.txt") + !read(77,*)flag_gageii + + k=0 + do i=1,ns + if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_slp(catid_full(i))==1.and.flag_gageii(i)==1)then +! if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_gageii(i)==1)then + k=k+1 + endif + enddo + np=k + print *,"number of valid stations: ",np + !stop + allocate(Qclmt(np),slp(np),catid(np),KKobs(np),KImodel(np)) + allocate(lats(np),lons(np)) + k=0 + do i=1,ns + if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_slp(catid_full(i))==1.and.flag_gageii(i)==1)then +! if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_gageii(i)==1)then + k=k+1 + Qclmt(k)=Qclmt_full(i) + slp(k)=slp_full(i) + KKobs(k)=KKobs_full(i) + KImodel(k)=KImodel_full(i) + catid(k)=catid_full(i) + lats(k)=lats_full(i) + lons(k)=lons_full(i) + flag_7065(i)=1 + endif + enddo + !open(88,file="flag_7065_stations_1265.txt") + !do i=1,ns + ! write(88,*)flag_7065(i) + !enddo + !stop + !open(88,file="lats_stations.txt") + !do i=1,np + ! write(88,*)lats(i) + !enddo + !open(88,file="lons_stations.txt") + !do i=1,np + ! write(88,*)lons(i) + !enddo + + deallocate(Qclmt_full,slp_full,KKobs_full,KImodel_full,flag_slp,flag_gageii,lats,lons) + + end subroutine filter_station +!------------------------------------------------------------ + subroutine cal_Kmodel(ns,np,nc,MU,exp_slp,exp_clmt,Qclmt,slp,KKobs,KImodel,KImodel_all,catid,catid_full,ccr,rms) + integer,intent(in) :: ns,np,nc + real,intent(in) :: MU,exp_slp,exp_clmt + real,intent(inout),allocatable :: Qclmt(:),slp(:),KKobs(:),KImodel(:) + real,intent(inout),allocatable :: KImodel_all(:) + integer,intent(inout),allocatable :: catid(:),catid_full(:) + real,intent(inout) :: ccr,rms + + real,allocatable :: KKobs_sort(:), KImodel_sort(:), KKmodel_full(:) + real, allocatable, dimension(:) :: dis,sca,Kv,KKmodel + integer,allocatable,dimension(:) :: gear + + character(len=50) :: MU_s,exp_slp_s,exp_clmt_s + + integer :: bulk,i,lev + real :: Kper(11),KMper(11),rat(11),dis_full(11) + + write(MU_s,'(f4.2)')MU + write(exp_slp_s,'(f4.2)')exp_slp + if(exp_clmt>=0.)then + write(exp_clmt_s,'(f4.2)')exp_clmt + else + write(exp_clmt_s,'(f4.2)') -1.*exp_clmt + exp_clmt_s="n"//trim(exp_clmt_s) + endif + + allocate(KKobs_sort(np),KImodel_sort(np)) + call sort(np,KKobs,KKobs_sort) + call sort(np,KImodel,KImodel_sort) + + bulk=np/10 + Kper(1)=KKobs_sort(1) + KMper(1)=KImodel_sort(1) + do i=2,10 + Kper(i)=KKobs_sort(bulk*(i-1)) + KMper(i)=KImodel_sort(bulk*(i-1)) + enddo + Kper(11)=KKobs_sort(np) + KMper(11)=KImodel_sort(np) + rat=Kper/KMper + + !open(88,file="rat_Kper2KMper.txt") + !do i=1,11 + ! write(88,*)rat(i) + !enddo + !close(88) + !exit + + allocate(gear(nc),dis(nc),sca(nc),Kv(nc)) + + gear=12 + dis=-9999. + do i=1,nc + do lev=1,11 + if(KImodel_all(i)<=KMper(lev))then + gear(i)=lev + dis(i)=KMper(lev)-KImodel_all(i) + exit + endif + end do + enddo + + dis_full(1)=KMper(1) + do i=2,11 + dis_full(i)=KMper(i)-KMper(i-1) + enddo + + do i=1,nc + if(gear(i)==1)then + sca(i)=rat(1) + elseif(gear(i)==12)then + sca(i)=rat(11) + else + sca(i)= ( rat(gear(i)-1)*dis(i) + rat(gear(i))*(dis_full(gear(i))-dis(i)) ) / dis_full(gear(i)) + endif + Kv(i)=KImodel_all(i)*sca(i) + enddo + + open(88,file="output/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt") +! open(88,file="Pfaf_Kv_PR_0p4_0p1_0p5_0p2.txt") + do i=1,nc + write(88,*)Kv(i) + enddo + + allocate(KKmodel_full(ns)) + do i=1,ns + if(catid_full(i)/=-9999)then + KKmodel_full(i)=Kv(catid_full(i)) + else + KKmodel_full(i)=-9999. + endif + enddo + + !open(88,file="KKmodel_7065/KKmodel_7065_"//trim(MU_s)//"_"//trim(exp_slp_s)//"_"//trim(exp_clmt_s)//".txt") + !do i=1,ns + ! write(88,*)KKmodel_full(i) + !enddo + + allocate(KKmodel(np)) + do i=1,np + KKmodel(i)=Kv(catid(i)) + enddo + + ccr=cal_ccr(KKobs,KKmodel) + rms=cal_rms(KKobs,KKmodel,np) + + + !open(88,file="KKobs_stations.txt") + !do i=1,np + ! write(88,*)KKobs(i) + !enddo + !print *,ccr + + + deallocate(KKobs_sort,KImodel_sort) + deallocate(KImodel_all,gear,dis,sca,Kv) + deallocate(Qclmt,slp,KKobs,KImodel,catid,KKmodel,catid_full,KKmodel_full) + end subroutine cal_Kmodel + + subroutine sort(np, data, data_sort) + integer, intent(in) :: np ! The size of the array + real, intent(in) :: data(np) ! Input array to be sorted + real, intent(out) :: data_sort(np) ! Output sorted array + integer :: i, j + real :: temp + + ! Copy input array to output array + data_sort = data + + ! Perform a bubble sort (simple sorting algorithm) + do i = 1, np-1 + do j = 1, np-i + if (data_sort(j) > data_sort(j+1)) then + ! Swap the elements + temp = data_sort(j) + data_sort(j) = data_sort(j+1) + data_sort(j+1) = temp + end if + end do + end do + end subroutine sort + + function cal_ccr(y, yest) result(ccr) + real, intent(in) :: y(:) + real, intent(in) :: yest(:) + real :: ccr + real :: mean_y, mean_yest + real :: sum_y, sum_yest + real :: sum_num, sum_den_y, sum_den_yest + integer :: n + integer :: i + + n = size(y) + if (n /= size(yest)) then + print *, "Error: Arrays must have the same length" + ccr = 0.0 + return + endif + + ! Calculate means + sum_y = sum(y) + sum_yest = sum(yest) + mean_y = sum_y / n + mean_yest = sum_yest / n + + ! Calculate numerator and denominators for correlation coefficient + sum_num = 0.0 + sum_den_y = 0.0 + sum_den_yest = 0.0 + do i = 1, n + sum_num = sum_num + (y(i) - mean_y) * (yest(i) - mean_yest) + sum_den_y = sum_den_y + (y(i) - mean_y) ** 2 + sum_den_yest = sum_den_yest + (yest(i) - mean_yest) ** 2 + end do + + ! Calculate correlation coefficient + if (sum_den_y == 0.0 .or. sum_den_yest == 0.0) then + print *, "Error: Zero variance in input arrays" + ccr = 0.0 + else + ccr = sum_num / sqrt(sum_den_y * sum_den_yest) + end if + + end function cal_ccr + + function cal_rms(k_obs,k_model, n) result(rms) + implicit none + integer, intent(in) :: n + real, intent(in) :: k_obs(n),k_model(n) + real :: rms + real :: sum_sq_diff + integer :: i + + sum_sq_diff = 0.0 + + do i = 1, n + sum_sq_diff = sum_sq_diff + ((k_model(i) - k_obs(i)) / k_obs(i))**2 + end do + + rms = sqrt(sum_sq_diff / n) +end function cal_rms + + function cal_cdtm(y, yest) result(dtmc) + real, intent(in) :: y(:) + real, intent(in) :: yest(:) + real :: dtmc + real :: ss_tot, ss_res + real :: mean_y + integer :: n, i + + n = size(y) + if (n /= size(yest)) then + print *, "Error: Arrays must have the same length" + dtmc = 0.0 + return + endif + + ! Calculate mean of y + mean_y = sum(y) / n + + ! Calculate total sum of squares (SS_tot) + ss_tot = sum((y - mean_y)**2) + + ! Calculate residual sum of squares (SS_res) + ss_res = sum((y - yest)**2) + + ! Calculate coefficient of determination (R^2) + if (ss_tot == 0.0) then + print *, "Error: Zero total sum of squares" + dtmc = 0.0 + else + dtmc = 1.0 - (ss_res / ss_tot) + endif + + end function cal_cdtm + +function median(data) result(med) + implicit none + real, intent(in) :: data(:) + real :: med + real :: sorted_data(size(data)) + integer :: n_valid + integer :: i + + n_valid = 0 + do i = 1, size(data) + if (data(i) /= -9999.0) then + n_valid = n_valid + 1 + sorted_data(n_valid) = data(i) + end if + end do + + if (n_valid == 0) then + med = -9999.0 + return + end if + + call sort2(sorted_data(1:n_valid)) + + if (mod(n_valid, 2) == 0) then + med = (sorted_data(n_valid/2) + sorted_data(n_valid/2 + 1)) / 2.0 + else + med = sorted_data((n_valid + 1) / 2) + end if + +end function median + +subroutine sort2(arr) + implicit none + real, intent(inout) :: arr(:) + integer :: i, j + real :: temp + + do i = 2, size(arr) + temp = arr(i) + j = i - 1 + do while (j >= 1 .and. arr(j) > temp) + arr(j + 1) = arr(j) + j = j - 1 + end do + arr(j + 1) = temp + end do +end subroutine sort2 + +!------------------------------------------------------------ + +end module k_module \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py new file mode 100755 index 000000000..2c70619ef --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py @@ -0,0 +1,172 @@ +import numpy as np +from netCDF4 import Dataset + +# Define constants +nlat = 10800 +nlon = 21600 + +# Read data from files +lats = np.loadtxt("temp/outlet_lat.txt", dtype=float) # Latitude of outlets +lons = np.loadtxt("temp/outlet_lon.txt", dtype=float) # Longitude of outlets +lat1m = np.loadtxt("input/lat_1m.txt", dtype=float) # Latitude grid +lon1m = np.loadtxt("input/lon_1m.txt", dtype=float) # Longitude grid + +# Function to find the nearest index in a coordinate array +def ind_nearest_coord(coord_array1, coord_array2): + """ + Find the index of the nearest value in coord_array2 for each value in coord_array1. + """ + indices = [] + for coord in coord_array1: + index = np.argmin(np.abs(coord_array2 - coord)) + indices.append(index) + return np.array(indices) + +# Find nearest indices for latitudes and longitudes +lati = ind_nearest_coord(lats, lat1m)+1 +loni = ind_nearest_coord(lons, lon1m)+1 + +#------------------------------------------------------------------------------------------------------ +ns = 3917 + +# Allocate array +catchind = np.zeros((nlat, nlon), dtype=int) + +# Read NetCDF file +def read_ncfile_int2d(filepath, varname, shape): + # Open the NetCDF file and read the specified variable + with Dataset(filepath, 'r') as nc: + data = nc.variables[varname][:].reshape(shape) + # Check for missing values and replace them with a default value + fill_value = nc.variables[varname]._FillValue if hasattr(nc.variables[varname], '_FillValue') else None + if fill_value is not None: + data = np.where(data == fill_value, -9999, data) # Replace missing values with 0 + return data + +catchind = read_ncfile_int2d("input/CatchIndex.nc", "data", (nlat, nlon)) + +# Calculate catid +catid = np.zeros(ns, dtype=int) +for i in range(ns): + # Ensure indices are within bounds + if 0 < loni[i] <= nlon and 0 < lati[i] <= nlat: + catid[i] = catchind[lati[i] - 1, loni[i] - 1] # Adjust for 0-based indexing in Python + else: + catid[i] = -1 # Assign a default value for out-of-bounds indices + +#------------------------------------------------------------------------------------------------------ +# Constants +nall = 291284 +nv = 1782 +nv3 = 2097 + +# Read input data +aca_all = np.loadtxt("temp/Pfaf_acar.txt") + +# Initialize aca_model array +aca_model = np.full(ns, -9999.0) + +# Map aca_model using catid +for i in range(ns): + if catid[i] != -9999: + cid = catid[i] + aca_model[i] = aca_all[cid - 1] + +# Read observation data +aca_obs = np.loadtxt("temp/outlet_lakeacaOBS.txt") +outid_INCON = np.zeros(nv, dtype=int) + +# Filter inconsistent data +k = 0 +for i in range(ns): + if not (0.7 * aca_model[i] <= aca_obs[i] <= 1.3 * aca_model[i]): + outid_INCON[k] = i + 1 + k += 1 + +#print(k) + +#------------------------------------------------------------------------------------------------------ +# Read tags +tag_INCON = np.loadtxt("input/outletINCON_catid_tag_from_excel.txt", dtype=int) + +# Update catid and aca_model based on tags +for i in range(nv): + oid = outid_INCON[i] + tag = tag_INCON[i] + if tag >= 1: + cid = tag + catid[oid - 1] = cid + aca_model[oid - 1] = aca_all[cid - 1] + else: + catid[oid - 1] = -9999 + aca_model[oid - 1] = -9999.0 + +# Compute flag_out +flag_out = np.where(aca_model != -9999, 1, 0) +#print(np.sum(flag_out)) + +#------------------------------------------------------------------------------------------------------ +# Read lakeid_out and compute absolute differences +lakeid_out = np.loadtxt("temp/outlet_lakeid.txt", dtype=int) +acaABSDIF_out = np.abs(aca_model - aca_obs) + +# Initialize collections +lakeid_collect = np.zeros(nv3, dtype=int) +outletid_collect = np.zeros(nv3, dtype=int) +acaABSDIF_collect = np.full(nv3, 1e10) +flag_2097_out = np.zeros(ns, dtype=int) +k = 0 + +# Collect valid outlets +for i in range(ns): + if flag_out[i] == 1: + lid = lakeid_out[i] + flag = 1 + if k >= 1: + for j in range(k): + if lid == lakeid_collect[j]: + flag = 0 + if acaABSDIF_out[i] < acaABSDIF_collect[j]: + flag_2097_out[outletid_collect[j]] = 0 + outletid_collect[j] = i + acaABSDIF_collect[j] = acaABSDIF_out[i] + flag_2097_out[i] = 1 + if flag == 1: + lakeid_collect[k] = lid + outletid_collect[k] = i + acaABSDIF_collect[k] = acaABSDIF_out[i] + flag_2097_out[i] = 1 + k += 1 + +#print(np.sum(flag_2097_out)) +np.savetxt("output/lake_outlet_flag_valid_2097.txt", flag_2097_out, fmt="%d") + +#------------------------------------------------------------------------------------------------------ +# Update catid with valid flags +catid = np.where(flag_2097_out == 0, -9999, catid) + +# Collect valid outlet IDs +outidV = np.zeros(nv3, dtype=int) +k = 0 +for i in range(ns): + if flag_2097_out[i] == 1: + outidV[k] = i + k += 1 + +outidV += 1 + +# Fix multi-outlet IDs +catid_outfix_2097 = np.loadtxt("input/outlet2097_catid_multiOut_fix.txt", dtype=int) +catid_outfix_out = np.full(ns, -9999, dtype=int) + +for i in range(nv3): + oid = outidV[i] + catid_outfix_out[oid - 1] = catid_outfix_2097[i] + +catid = np.where((catid_outfix_out != 0) & (catid_outfix_out != -9999), catid_outfix_out, catid) +np.savetxt("output/lake_outlet_catid.txt", catid, fmt="%d") + +# Final flag computation +#flag_final = np.where(catid > 0, 1, 0) +#print(np.sum(flag_final)) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 new file mode 100755 index 000000000..afdf7de03 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 @@ -0,0 +1,101 @@ +program main + + implicit none + + integer,parameter :: no=1459201 + integer,parameter :: nvl=3409 + integer,parameter :: nvo=3917 + integer,parameter :: nl=1426967 + + integer,allocatable,dimension(:) :: lakeid_out,outid_out,lakeid_lake,lakeid_outV,outid_outV + real,allocatable,dimension(:) :: lat_out,lon_out,lat_outV,lon_outV,& + lakeaca_lake,lakearea_lake,lakeaca_outV,lakearea_outV + + real,allocatable,dimension(:) :: area_lake, aca_lake + integer,allocatable,dimension(:) :: id_lake + character(len=256) :: area_lake_file, id_lake_file, aca_lake_file + integer :: i,j,k + + allocate(area_lake(nl),aca_lake(nl),id_lake(nl)) + ! Initialize file names + area_lake_file = "input/Lake_area.csv" + id_lake_file = "input/Hylak_id_lake.csv" + aca_lake_file = "input/Cat_a_lake.csv" + + ! Read input data (You can implement your own read procedure if needed) + open(77, file=area_lake_file, status="old") + read(77, *) area_lake + open(77, file=id_lake_file, status="old") + read(77, *) id_lake + open(77, file=aca_lake_file, status="old") + read(77, *) aca_lake + + ! Allocate arrays for filtered data + allocate(lakearea_lake(nvl)) + allocate(lakeid_lake(nvl)) + allocate(lakeaca_lake(nvl)) + + k = 0 + ! Filter lakes with area >= 50 + do i = 1, nl + if (area_lake(i) .ge. 50.0) then + k = k + 1 + lakearea_lake(k) = area_lake(i) + lakeid_lake(k) = id_lake(i) + lakeaca_lake(k) = aca_lake(i) + end if + end do +!------------------------------------------------------------------------------------- + + allocate(lakeid_out(no),outid_out(no),lat_out(no),lon_out(no)) + allocate(lakeid_outV(nvo),outid_outV(nvo),lat_outV(nvo),lon_outV(nvo),lakeaca_outV(nvo),lakearea_outV(nvo)) + + open(77,file="input/Hylak_id_outlet.csv") + read(77,*)lakeid_out + open(77,file="input/Outlet_id.csv") + read(77,*)outid_out + open(77,file="input/Outlet_lat.csv") + read(77,*)lat_out + open(77,file="input/Outlet_lon.csv") + read(77,*)lon_out + + k=0 + do i=1,no + do j=1,nvl + if(lakeid_out(i)==lakeid_lake(j))then + k=k+1 + outid_outV(k)=outid_out(i) + lat_outV(k)=lat_out(i) + lon_outV(k)=lon_out(i) + lakeid_outV(k)=lakeid_lake(j) + lakeaca_outV(k)=lakeaca_lake(j) + lakearea_outV(k)=lakearea_lake(j) + endif + enddo + enddo + + !print *,k + + open(88,file="temp/outlet_lat.txt")! + do i=1,nvo + write(88,*)lat_outV(i) + enddo + open(88,file="temp/outlet_lon.txt")! + do i=1,nvo + write(88,*)lon_outV(i) + enddo + open(88,file="temp/outlet_lakeid.txt")! + do i=1,nvo + write(88,*)lakeid_outV(i) + enddo + open(88,file="temp/outlet_lakeacaOBS.txt")! + do i=1,nvo + write(88,*)lakeaca_outV(i) + enddo + open(88,file="output/lake_outlet_lakearea.txt")! + do i=1,nvo + write(88,*)lakearea_outV(i) + enddo + + +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 new file mode 100755 index 000000000..c8774b93a --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 @@ -0,0 +1,219 @@ +module river_read + + implicit none + include 'netcdf.inc' + + public :: read_ncfile_int1d + public :: read_ncfile_real1d + public :: read_ncfile_double1d + + public :: read_ncfile_int2d + public :: read_ncfile_int3d + public :: read_ncfile_real2d + public :: read_ncfile_real3d + public :: read_ncfile_double2d + public :: read_ncfile_double3d + + contains +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + integer, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double1d(filename,varname,var,n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real*8, intent(inout) :: var(n) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double1d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + integer, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_int(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_int3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real2d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_real(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_real3d +!------------------------------------------------------------------------------------------ + subroutine read_ncfile_double2d(filename,varname,var,nlon,nlat) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double2d + + + subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: nlon, nlat, nlev + real*8, intent(inout) :: var(nlon,nlat,nlev) + + character(len=4) :: subname="read" + integer :: ncid, varid + + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_get_var_double(ncid,varid,var),subname) + call check_ret(nf_close(ncid), subname) + + end subroutine read_ncfile_double3d +!------------------------------------------------------------------------------------------ +!BOP +! +! !IROUTINE: check_ret +! +! !INTERFACE: + subroutine check_ret(ret, calling) +! !DESCRIPTION: +! Check return status from netcdf call +! +! !ARGUMENTS: + implicit none + integer, intent(in) :: ret + character(len=*) :: calling +! +! !REVISION HISTORY: +! +!EOP +!----------------------------------------------------------------------- + + if (ret /= NF_NOERR) then + write(6,*)'netcdf error from ',trim(calling) + call endrun(nf_strerror(ret)) + end if + + end subroutine check_ret +!----------------------------------------------------------------------- +!BOP +! !IROUTINE: endrun +! +! !INTERFACE: +subroutine endrun(msg,subname) +! +! !DESCRIPTION: +! Abort the model for abnormal termination + implicit none +! !ARGUMENTS: + character(len=*), intent(in), optional :: msg ! string to be printed + character(len=*), intent(in), optional :: subname ! subname + + if (present (subname)) then + write(6,*) 'ERROR in subroutine :', trim(subname) + end if + + if (present (msg)) then + write(6,*)'ENDRUN:', msg + else + write(6,*) 'ENDRUN: called without a message string' + end if + + stop +end subroutine endrun + +!----------------------------------------------------------------------- + +end module river_read + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run.sh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run.sh new file mode 100755 index 000000000..00fc9a3cb --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run.sh @@ -0,0 +1,77 @@ +#!/bin/bash +set -e + + +#---copy some files---- +cp input/area_skm_grand.txt output/ +cp input/cap_max_grand.txt output/ + +#---river-------------- +echo get_Pfaf_file.f90 +./build get_Pfaf_file.f90 +./get_Pfaf_file.out + +echo get_latloni_cellarea.py +python3 get_latloni_cellarea.py + +echo get_num_sub_catchment_M09.f90 +./build get_num_sub_catchment_M09.f90 +./get_num_sub_catchment_M09.out + +echo get_num_sub_catchment_M36.f90 +./build get_num_sub_catchment_M36.f90 +./get_num_sub_catchment_M36.out + +echo get_lonlat_bond_M09.f90 +./build get_lonlat_bond_M09.f90 +./get_lonlat_bond_M09.out + +echo get_lonlat_bond_M36.f90 +./build get_lonlat_bond_M36.f90 +./get_lonlat_bond_M36.out + +echo get_lonlati_maptile_M09.py +python3 get_lonlati_maptile_M09.py +echo get_lonlati_maptile_M36.py +python3 get_lonlati_maptile_M36.py + +echo get_isub_M09.f90 +./build get_isub_M09.f90 +./get_isub_M09.out + +echo get_isub_M36.f90 +./build get_isub_M36.f90 +./get_isub_M36.out + +echo get_area_M09.f90 +./build get_area_M09.f90 +./get_area_M09.out + +echo get_area_M36.f90 +./build get_area_M36.f90 +./get_area_M36.out + +echo get_Qr_clmt.f90 +./build get_Qr_clmt.f90 +./get_Qr_clmt.out + +echo get_river_length.f90 +./build get_river_length.f90 +./get_river_length.out + +echo get_K_model_calik.f90 +./build get_K_model_calik.f90 +./get_K_model_calik.out + +#--------reservoir----------- +echo get_dam_data.py +python3 get_dam_data.py + +#--------lake---------------- +echo read_input_TopoCat.f90 +./build read_input_TopoCat.f90 +./read_input_TopoCat.out + +echo process_lake_data.py +python3 process_lake_data.py + From 0c5d77903111bdbe9e125ded2e4ab66a9acc99fd Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Thu, 8 May 2025 12:44:36 -0400 Subject: [PATCH 17/27] code clean up, and comment&documents added --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 55 +- .../GEOSroute_GridComp/reservoir.F90 | 35 +- .../GEOSroute_GridComp/routing_model.F90 | 61 +- .../Utils/Raster/preproc/routing_model/build | 2 +- .../Raster/preproc/routing_model/constant.f90 | 39 + .../routing_model/get_K_model_calik.f90 | 171 ++- .../preproc/routing_model/get_Pfaf_file.f90 | 314 ++--- .../preproc/routing_model/get_Qr_clmt.f90 | 292 ++-- .../preproc/routing_model/get_area_M09.f90 | 155 ++- .../preproc/routing_model/get_area_M36.f90 | 160 ++- .../preproc/routing_model/get_dam_data.py | 188 +-- .../preproc/routing_model/get_isub_M09.f90 | 62 +- .../preproc/routing_model/get_isub_M36.f90 | 62 +- .../routing_model/get_latloni_cellarea.py | 12 +- .../routing_model/get_lonlat_bond_M09.f90 | 87 +- .../routing_model/get_lonlat_bond_M36.f90 | 84 +- .../routing_model/get_lonlati_maptile_M09.py | 12 +- .../routing_model/get_lonlati_maptile_M36.py | 8 +- .../get_num_sub_catchment_M09.f90 | 178 +-- .../get_num_sub_catchment_M36.f90 | 168 ++- .../routing_model/get_river_length.f90 | 398 +++--- .../preproc/routing_model/k_module_cali.f90 | 1194 +++++++++-------- .../routing_model/process_lake_data.py | 19 +- .../routing_model/read_input_TopoCat.f90 | 170 ++- .../Raster/preproc/routing_model/readme.txt | 165 +++ .../preproc/routing_model/river_read.f90 | 166 +-- .../routing_model/run_routing_preproc.py | 176 +++ 27 files changed, 2574 insertions(+), 1859 deletions(-) create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/constant.f90 create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/readme.txt create mode 100644 GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run_routing_preproc.py diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 2697658c0..53041911d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -42,7 +42,7 @@ module GEOS_RouteGridCompMod private - type RES_STATE + type RES_STATE !reserver related variables integer, pointer :: active_res(:) integer, pointer :: active_up(:,:) real, pointer :: Wr_res(:) !m3 @@ -55,7 +55,7 @@ module GEOS_RouteGridCompMod real, pointer :: qres_acc(:) end type RES_STATE - type T_RROUTE_STATE + type T_RROUTE_STATE !routing related variables private type (ESMF_RouteHandle) :: routeHandle type (ESMF_Field) :: field @@ -200,10 +200,6 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, RUN2, RC=STATUS ) VERIFY_(STATUS) -!------------------------------------------------------------ -! Set generic final method -!------------------------------------------------------------ - ! ----------------------------------------------------------- ! Get the configuration @@ -400,13 +396,12 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%mype = mype allocate(ims(1:ndes)) - ! define minCatch, maxCatch + ! define catchment space for this processor call MAPL_DecomposeDim ( n_catg,ims,ndes ) ! ims(mype+1) gives the size of my partition ! myPE is 0-based! beforeMe = sum(ims(1:mype)) minCatch = beforeMe + 1 maxCatch = beforeMe + ims(myPe+1) - ! get LocStream call MAPL_Get(MAPL, LocStream = locstream, RC=status) VERIFY_(STATUS) @@ -415,7 +410,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) tileGrid=tilegrid, nt_global=nt_global, RC=status) VERIFY_(STATUS) route%nt_global = nt_global - + ! Determine the resolution if(nt_global==112573)then resname="M36" nmax=150 @@ -429,23 +424,22 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) endif endif ! exchange Pfaf across PEs - call MAPL_LocStreamGet(locstream, TILEAREA = tile_area_src, LOCAL_ID=local_id, RC=status) VERIFY_(STATUS) nt_local=size(tile_area_src,1) route%nt_local=nt_local - ntiles = maxCatch-minCatch+1 allocate(arbSeq_pf(maxCatch-minCatch+1)) - arbSeq_pf = [(i, i = minCatch, maxCatch)] - - ! redist pfaf (NOTE: me might need a second routehandle for integers) - + arbSeq_pf = [(i, i = minCatch, maxCatch)] route%pfaf => arbSeq_pf route%ntiles = ntiles route%minCatch = minCatch route%maxCatch = maxCatch - ! Read sub-area data from text files + + + + + ! Read sub-catchment data allocate(nsub_global(N_CatG),subarea_global(nmax,N_CatG)) open(77,file=trim(inputdir)//"/Pfaf_nsub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)nsub_global; close(77) open(77,file=trim(inputdir)//"/Pfaf_asub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)subarea_global; close(77) @@ -464,7 +458,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%subi => subi deallocate(subi_global) - + ! Set variables used in MPI allocate(scounts(ndes),scounts_global(ndes),rdispls_global(ndes)) scounts=0 scounts(mype+1)=nt_local @@ -493,6 +487,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%runoff_save => runoff_save route%runoff_save=0. + ! Read tile area data allocate(tile_area_local(nt_local),tile_area_global(nt_global)) open(77,file=trim(inputdir)//"/area_"//trim(resname)//"_1d.txt",status="old",action="read");read(77,*)tile_area_global;close(77) tile_area_local=tile_area_global(rdispls_global(mype+1)+1:rdispls_global(mype+1)+nt_local)*1.e6 !km2->m2 @@ -512,6 +507,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) enddo route%areacat=>areacat + ! Read river network-realated data allocate(lengsc_global(n_catg),lengsc(ntiles)) open(77,file=trim(inputdir)//"/Pfaf_lriv_PR.txt",status="old",action="read");read(77,*)lengsc_global;close(77) lengsc=lengsc_global(minCatch:maxCatch)*1.e3 !km->m @@ -530,6 +526,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%upid=>upid deallocate(upid_global) + ! Read restart data call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) write(yr_s,'(I4.4)')YY @@ -606,6 +603,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%wriver=>wriver route%reservoir%Wr_res=>wres + ! accumulated variables for output allocate(route%wriver_acc(ntiles),route%wstream_acc(ntiles),route%qoutflow_acc(ntiles),route%qsflow_acc(ntiles),route%reservoir%qres_acc(ntiles)) route%wriver_acc=0. route%wstream_acc=0. @@ -613,7 +611,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%qsflow_acc=0. route%reservoir%qres_acc=0. - !input for geometry hydraulic + !Read input specially for geometry hydraulic (not required by linear model) allocate(buff_global(n_catg),route%lstr(ntiles)) open(77,file=trim(inputdir)//"/Pfaf_lstr_PR.txt",status="old",action="read");read(77,*)buff_global;close(77) route%lstr=buff_global(minCatch:maxCatch)*1.e3 !km->m @@ -644,6 +642,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%qstr_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) + !Initial reservoir module res => route%reservoir call res_init(inputdir,n_catg,ntiles,minCatch,maxCatch,use_res,res%active_res,res%type_res,res%cap_res,res%fld_res,res%Qfld_thres,res%cat2res,res%wid_res) if(mapl_am_I_root()) print *,"reservoir init success" @@ -850,8 +849,10 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) N_CYC = ROUTE_DT/HEARTBEAT RUN_MODEL : if (ThisCycle == N_CYC) then + !accumulates runoff runoff_save = runoff_save + RUNOFF_SRC0/real (N_CYC) + !Gets time used for output and restart call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) call ESMF_ClockGetNextTime(clock, nextTime=nextTime, rc=status) @@ -860,12 +861,14 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) write(mon_s,'(I2.2)')MM write(day_s,'(I2.2)')DD + !Collect runoff from all processors allocate(runoff_global(nt_global)) call MPI_allgatherv ( & runoff_save, route%scounts_global(mype+1) ,MPI_REAL, & runoff_global, route%scounts_global, route%rdispls_global,MPI_REAL, & MPI_COMM_WORLD, mpierr) + !Distribute runoff from tile space to catchment space if(FirstTime.and.mapl_am_I_root()) print *,"nmax=",nmax allocate(RUNOFF_ACT(ntiles)) RUNOFF_ACT=0. @@ -881,7 +884,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) deallocate(runoff_global) - + ! Prepares to conduct routing model allocate (AREACAT_ACT (ntiles)) allocate (LENGSC_ACT (ntiles)) allocate (QSFLOW_ACT (ntiles)) @@ -908,7 +911,8 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) route%qstr_clmt, route%qri_clmt, route%qin_clmt, & route%K, route%Kstr, & WSTREAM_ACT,WRIVER_ACT, & - QSFLOW_ACT,QOUTFLOW_ACT) + QSFLOW_ACT,QOUTFLOW_ACT) + ! Call reservoir module do i=1,ntiles call res_cal(res%active_res(i),QOUTFLOW_ACT(i),res%type_res(i),res%cat2res(i),& QRES_ACT(i),res%wid_res(i),res%fld_res(i),res%Wr_res(i),res%Qfld_thres(i),res%cap_res(i),real(route_dt)) @@ -916,13 +920,14 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) QOUT_CAT = QOUTFLOW_ACT where(res%active_res==1) QOUT_CAT=QRES_ACT - + ! Collects dishcarge (routing model output) from all processors allocate(QOUTFLOW_GLOBAL(n_catg)) call MPI_allgatherv ( & QOUT_CAT, route%scounts_cat(mype+1) ,MPI_REAL, & QOUTFLOW_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & MPI_COMM_WORLD, mpierr) + ! Linking discharge as inflow to downstream catchment to adjust river storage allocate(QINFLOW_LOCAL(ntiles)) QINFLOW_LOCAL=0. do i=1,nTiles @@ -937,8 +942,10 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) enddo enddo - call check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUT_CAT,FirstTime,yr_s,mon_s) + ! Check balance if needed + !call check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUT_CAT,FirstTime,yr_s,mon_s) + ! Update accumulated variables for output if(FirstTime) nstep_per_day = 86400/route_dt route%wriver_acc = route%wriver_acc + WRIVER_ACT/real(nstep_per_day) route%wstream_acc = route%wstream_acc + WSTREAM_ACT/real(nstep_per_day) @@ -954,7 +961,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) runoff_save = 0. ThisCycle = 1 - ! output + ! output variables !if(mapl_am_I_root())print *, "nstep_per_day=",nstep_per_day if(mapl_am_I_root())print *, "Current time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS, ", next MM_next:",MM_next if(FirstTime)then @@ -1021,7 +1028,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) res%qres_acc = 0. endif - !restart + !write restart if(MM_next/=MM)then allocate(wriver_global(n_catg),wstream_global(n_catg)) call MPI_allgatherv ( & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 index 3dbf867ba..2cbb0ccba 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 @@ -6,27 +6,26 @@ module reservoir public :: res_init, res_cal !----Reservoir module constants---------- -integer,parameter :: nres=7250 -integer,parameter :: nlake=3917 - -real, parameter :: fac_elec_a = 0.30 ! Coefficient for hydropower calculation -real, parameter :: fac_elec_b = 2.00 ! Exponent for hydropower calculation -real, parameter :: fac_irr_a = 0.01 ! Coefficient for irrigation calculation (arid areas) -real, parameter :: fac_irr_b = 3.00 ! Scaling factor for irrigation (arid areas) -real, parameter :: fac_sup_a = 0.03 ! Coefficient for water supply calculation -real, parameter :: fac_sup_b = 2.00 ! Exponent for water supply calculation -real, parameter :: fac_other_a = 0.20 ! Coefficient for other reservoir types -real, parameter :: fac_other_b = 2.00 ! Exponent for other reservoir types +integer,parameter :: nres=7250 +integer,parameter :: nlake=3917 + +real, parameter :: fac_elec_a = 0.30 ! Coefficient for hydropower calculation +real, parameter :: fac_elec_b = 2.00 ! Exponent for hydropower calculation +real, parameter :: fac_irr_a = 0.01 ! Coefficient for irrigation calculation (arid areas) +real, parameter :: fac_irr_b = 3.00 ! Scaling factor for irrigation (arid areas) +real, parameter :: fac_sup_a = 0.03 ! Coefficient for water supply calculation +real, parameter :: fac_sup_b = 2.00 ! Exponent for water supply calculation +real, parameter :: fac_other_a = 0.20 ! Coefficient for other reservoir types +real, parameter :: fac_other_b = 2.00 ! Exponent for other reservoir types integer, parameter :: fac_fld = 1 ! Flood control parameter -real, parameter :: fac_a_slake = 0.003 ! Factor for small lakes -real, parameter :: fac_b_slake = 0.40 ! Exponent for small lakes -real, parameter :: fac_a_llake = 0.01 ! Factor for large lakes -real, parameter :: fac_b_llake = 0.60 ! Exponent for large lakes -real, parameter :: thr_wid_lake = 1.e5 ! Threshold lake width (in m) +real, parameter :: fac_a_slake = 0.003 ! Factor for small lakes +real, parameter :: fac_b_slake = 0.40 ! Exponent for small lakes +real, parameter :: fac_a_llake = 0.01 ! Factor for large lakes +real, parameter :: fac_b_llake = 0.60 ! Exponent for large lakes +real, parameter :: thr_wid_lake = 1.e5 ! Threshold lake width (in m) -!real, parameter :: dt = 86400. ! Time step in seconds (1 day) -real, parameter :: rho = 1.e3 ! Water density (kg/m^3) +real, parameter :: rho = 1.e3 ! Water density (kg/m^3) !----------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 index 6f1d93b00..d89164d30 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/routing_model.F90 @@ -8,8 +8,24 @@ MODULE routing_model CONTAINS - ! ------------------------------------------------------------------------ + ! Routing Model Input Parameters + ! ------------------------------ + !**** NCAT = NUMBER OF CATCHMENTS IN THE STUDY DOMAIN + !**** RUNCATCH = RUNOFF PRODUCED BY LAND SURFACE MODEL IN THE CATCHMENT [m^3/s] + !**** AREACAT = AREA OF CATCHMENT [km^2] + !**** LENGSC = LENGTHSCALE OF CATCHMENT FOR RIVER CALCULATION [km] + ! Note: We assume LENGSC for stream to river calculation as AREACAT/LENGSC + + ! Routing Model Prognostics + ! ------------------------- + !**** WSTREAM = AMOUNT OF WATER IN "LOCAL STREAM" [m^3] + !**** WRIVER = AMOUNT OF WATER IN RIVER [m^3] + + ! Routing Model Diagnostics + ! ------------------------- + !**** QSFLOW = TRANSFER OF MOISTURE FROM STREAM VARIABLE TO RIVER VARIABLE [m^3/s] + !**** QOUTFLOW = TRANSFER OF RIVER WATER TO THE DOWNSTREAM CATCHMENT [m^3/s] SUBROUTINE RIVER_ROUTING_LIN ( & NCAT, & @@ -31,26 +47,6 @@ SUBROUTINE RIVER_ROUTING_LIN ( & INTEGER :: N,I,J REAL :: COEFF, LS, COEFF1, COEFF2,ROFF - ! Routing Model Input Parameters - ! ------------------------------ - !**** NCAT = NUMBER OF CATCHMENTS IN THE STUDY DOMAIN - !**** RUNCATCH = RUNOFF PRODUCED BY LAND SURFACE MODEL IN THE CATCHMENT [m3/s] - !**** AREACAT = AREA OF CATCHMENT [km^2] - !**** LENGSC = LENGTHSCALE OF CATCHMENT FOR RIVER CALCULATION [km] - ! Note: We assume LENGSC for stream to river calculation as AREACAT/LENGSC - - ! Routing Model Prognostics - ! ------------------------- - !**** WSTREAM = AMOUNT OF WATER IN "LOCAL STREAM" [m^3] - !**** WRIVER = AMOUNT OF WATER IN RIVER [m^3] - - ! Routing Model Diagnostics - ! ------------------------- - !**** QSFLOW = TRANSFER OF MOISTURE FROM STREAM VARIABLE TO RIVER VARIABLE [m^3/s] - !**** QINFLOW = TRANSFER OF RIVER WATER FROM UPSTREAM CATCHMENTS [m^3/s] - i.e. sum of - ! QOUTFLOWs from all upstream catchments. This is computed outside this subroutine - !**** QOUTFLOW = TRANSFER OF RIVER WATER TO THE DOWNSTREAM CATCHMENT [m^3/s] - QSFLOW = 0. QOUTFLOW = 0. @@ -137,6 +133,27 @@ RECURSIVE SUBROUTINE SEARCH_DNST (K, NCAT_G, DNST, Pfaf_all, DNST_OUT) END SUBROUTINE SEARCH_DNST ! ------------------------------------------------------------------------------------------------------- + ! Routing Model Input Parameters + ! ------------------------------ + !**** NCAT = NUMBER OF CATCHMENTS IN THE STUDY DOMAIN + !**** Qrunf0 = RUNOFF PRODUCED BY LAND SURFACE MODEL IN THE CATCHMENT [m^3/s] + !**** llc_ori = MAIN RIVER LENGTH SCALE [m] + !**** lstr = LOCAL STREAMS LENGTH SCALE [m] + !**** qstr_clmt0= CLIMATOLOGY RUNOFF [m^3/s] + !**** qri_clmt0 = CLIMATOLOGY DISCHAR [m^3/s] + !**** qin_clmt0 = CLIMATOLOGY INFLOW [m^3/s] + !**** K = K PARAMETER FOR MAIN RIVER + !**** Kstr0 = K PARAMETER FOR LOCAL STREAM [m^3/s] + + ! Routing Model Prognostics + ! ------------------------- + !**** Ws0 = AMOUNT OF WATER IN "LOCAL STREAM" [m^3] + !**** Wr0 = AMOUNT OF WATER IN RIVER [m^3] + + ! Routing Model Diagnostics + ! ------------------------- + !**** QS = TRANSFER OF MOISTURE FROM STREAM VARIABLE TO RIVER VARIABLE [m^3/s] + !**** QOUT = TRANSFER OF RIVER WATER TO THE DOWNSTREAM CATCHMENT [m^3/s] SUBROUTINE RIVER_ROUTING_HYD ( & NCAT, & @@ -181,7 +198,7 @@ SUBROUTINE RIVER_ROUTING_HYD ( & Kstr = fac_kstr * Kstr0 dt = ROUTE_DT - ! Calculate llc (length of river channel) + ! Adjust llc (length of river channel) nume = qri_clmt**(2.-M) - qin_clmt**(2.-M) ! Numerator for the llc calculation deno = (2.-M) * (qri_clmt - qin_clmt) * (qri_clmt**(1.-M)) ! Denominator for the llc calculation where(abs(deno) > small) llc = llc_ori * (nume / deno) ! Compute llc where denominator is not too small diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build index acf585ede..b9e64540e 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build @@ -13,6 +13,6 @@ FILENAME=${array[0]} NETCDF_PATH=/usr/local/other/GEOSpyD/23.5.2-0_py3.11/2023-11-02 LD_LIBRARY_PATH=${NETCDF_PATH}/lib:$LD_LIBRARY_PATH -ifort -qopenmp river_read.f90 k_module_cali.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out +ifort -qopenmp constant.f90 river_read.f90 k_module_cali.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/constant.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/constant.f90 new file mode 100644 index 000000000..f46edc201 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/constant.f90 @@ -0,0 +1,39 @@ +module constant +!module for constants used in the river routing pre-processing package + + implicit none + public + + ! Define constant parameters + integer,parameter :: nmax09=458 ! Maximum number of sub-catchments per catchment for M09 + integer,parameter :: nmax36=150 ! Maximum number of sub-catchments per catchment for M36 + integer,parameter :: nc=291284 ! Total number of catchments + integer,parameter :: nlon=21600 ! Number of longitude grid points in the original grid + integer,parameter :: nlat=10800 ! Number of latitude grid points in the original grid + integer,parameter :: nlat09=1624, nlon09=3856 ! Dimensions for the M09 grid + integer,parameter :: nlat36=406, nlon36=964 ! Dimensions for the aggregated M36 grid + integer,parameter :: nt_global09=1684725 ! Total number of global tiles for area mapping for M09 + integer,parameter :: nt_global36=112573 ! Total number of global tiles for area mapping for M36 + ! Define grid dimensions for 15-second resolution data (HydroSHEDS high-res grid) + integer,parameter :: nlonh = 86400 + integer,parameter :: nlath = 33600 + + integer,parameter :: nl_USGS = 3352492 ! Total number of USGS data records + integer,parameter :: nt09=1684725, nt36=112573 !Total number of catchment gridcell in M09 and M36 + integer,parameter :: nupmax = 34 ! Maximum number of upstream catchments to record + + !river curve parameters + real,parameter :: cur_avg = 1.4 + real,parameter :: cur_min = 0.5 + real,parameter :: cur_max = 5.0 + + integer,parameter :: nga = 9067 ! Number of GAGE-II records + + !lake input parameters: + integer,parameter :: no = 1459201 ! Total number of outlet records in the outlet files + integer,parameter :: nvl = 3409 ! Number of lakes that pass the filtering criteria (area >= 50) + integer,parameter :: nvo = 3917 ! Number of outlet records after matching with lakes + integer,parameter :: nl_lake = 1426967 ! Total number of lake records in the input files + + +end module constant \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 index 3cd73aefc..6570fc17c 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_K_model_calik.f90 @@ -1,89 +1,124 @@ program main +!Main purpose: Calculates the K parameter used in the river routing model. - use k_module - + use k_module ! Import custom module "k_module" which contains necessary subroutines and functions + use constant, only: nl=>nl_USGS,nlat,nlon,nc implicit none - integer, parameter :: nl = 3352492 - integer, parameter :: nlat = 10800, nlon = 21600 - integer, parameter :: nc = 291284 - - ! Declare variables - integer, allocatable :: lati(:), loni(:) - real, allocatable :: data(:, :) ! 2D data array - integer,allocatable :: catid_full(:),catid(:) - real,allocatable, dimension(:) :: vel, dis - integer, allocatable :: nv(:),flag_gageii(:) - real,allocatable :: Qclmt_full(:),slp_full(:),KKobs_full(:),KImodel_full(:) - real,allocatable :: Qclmt(:),slp(:),KKobs(:),KImodel(:) - real,allocatable :: KImodel_all(:) - real,allocatable :: lats_full(:), lons_full(:) - real*8,allocatable :: MU_axis(:),slp_axis(:),clmt_axis(:),p_axis(:) - - real :: mm=0.35, MU=0.45, exp_slp=0.2, exp_clmt=-0.2 !MU ~(-0.6) - !real :: mm=0.4, MU=0.1, exp_slp=0.5, exp_clmt=0.2 - real :: fac_str=1. - - integer :: nt,ns,np,i,j,k,p,count - real :: ccr(10,10,10),rms(10,10,10) - !real :: ccr(20,10),rms(20,10) - real :: ccrp, rmsp + ! Declare variables and allocatable arrays + integer, allocatable :: lati(:), loni(:) ! Arrays to store grid indices (latitude and longitude) for stations + real, allocatable :: data(:, :) ! 2D data array to store USGS data + integer, allocatable :: catid_full(:), catid(:) ! Arrays to store full and filtered catchment ids for stations + real, allocatable, dimension(:) :: vel, dis ! Arrays to store velocity and distance data from the USGS dataset + integer, allocatable :: nv(:), flag_gageii(:) ! Arrays for number of values per station and GAGE-II validation flags + real, allocatable :: Qclmt_full(:), slp_full(:), KKobs_full(:), KImodel_full(:) + ! climatology discharge (Qclmt), slope (slp), observed K factor (KKobs), and initial appromaxtion of modeled K factor (KImodel) + real, allocatable :: Qclmt(:), slp(:), KKobs(:), KImodel(:) + ! Arrays for filtered parameters after station selection + real, allocatable :: KImodel_all(:) ! Array to store all modeled K values from the dataset + real, allocatable :: lats_full(:), lons_full(:) ! Arrays to store the full latitude and longitude values for the grid + real*8, allocatable :: MU_axis(:), slp_axis(:), clmt_axis(:), p_axis(:) + ! Arrays for parameter axes: M factor (MU), slope exponent (slp_axis), runoff exponent (clmt_axis), and an additional parameter axis (p_axis) + + ! Set model parameters and scaling factors + real :: mm = 0.35, MU = 0.45, exp_slp = 0.2, exp_clmt = -0.2 ! Base model parameters (mm, MU, and exponents for slope and climatology discharge) + !real :: mm=0.4, MU=0.1, exp_slp=0.5, exp_clmt=0.2 ! Alternative parameter set (commented out) + real :: fac_str = 1. ! Scaling factor for stream K + + ! Declare additional integer and real variables for looping and statistical calculations + integer :: nt, ns, np, i, j, k, p, count + real :: ccr(10,10,10), rms(10,10,10) ! 3D arrays to hold correlation coefficients and RMS errors over a parameter space + !real :: ccr(20,10), rms(20,10) ! Alternative array dimensions (commented out) + real :: ccrp, rmsp ! Variables to store computed correlation coefficient and RMS error for a given parameter set - - call read_usgs_data(nl, data) - call process_usgs_data(nl, ns, data, nv, nt, vel, dis) - !stop - call find_nearest_coords(ns, nlat, nlon, lats_full, lons_full, lati, loni) - - allocate(MU_axis(10),slp_axis(10),clmt_axis(10)) - - ccr=-9999. - rms=-9999. - count=0 - - do k=1,10 - MU_axis(k)=(k-1)*0.05 + character(len=900) :: file_vel + character(len=900) :: file_dis + character(len=900) :: file_usid + character(len=900) :: file_lats + character(len=900) :: file_lons + character(len=900) :: file_lat1m + character(len=900) :: file_lon1m + character(len=900) :: file_pfafmap + character(len=900) :: file_gage_id + character(len=900) :: file_gage_acar + + if (command_argument_count() /= 10) then + print *, "no appropriate files found" + stop + endif + call get_command_argument(1, file_vel) + call get_command_argument(2, file_dis) + call get_command_argument(3, file_usid) + call get_command_argument(4, file_lats) + call get_command_argument(5, file_lons) + call get_command_argument(6, file_lat1m) + call get_command_argument(7, file_lon1m) + call get_command_argument(8, file_pfafmap) + call get_command_argument(9, file_gage_id) + call get_command_argument(10, file_gage_acar) + + ! Read USGS data and process it + call read_usgs_data(file_vel, file_dis, nl, data) ! Read USGS data (nl records) into the 2D array "data" + call process_usgs_data(file_usid, nl, ns, data, nv, nt, vel, dis) + ! Process the USGS data to extract the number of stations (ns), velocity, distance + + ! Determine the nearest grid coordinates for each station based on the full grid latitude and longitude arrays + call find_nearest_coords(file_lats, file_lons, file_lat1m, file_lon1m, ns, nlat, nlon, lats_full, lons_full, lati, loni) + + ! Allocate arrays for parameter axes (each with 10 discrete values) + allocate(MU_axis(10), slp_axis(10), clmt_axis(10)) + ! Initialize the correlation and RMS error arrays with a default invalid value + ccr = -9999. + rms = -9999. + count = 0 + ! Set up the parameter axis for MU (M factor): values from 0 to 0.45 in increments of 0.05 + do k = 1, 10 + MU_axis(k) = (k - 1) * 0.05 enddo - do i=1,10 - slp_axis(i)=(i-1)*0.1 + ! Set up the parameter axis for slope exponent: values from 0 to 0.9 in increments of 0.1 + do i = 1, 10 + slp_axis(i) = (i - 1) * 0.1 enddo - do j=1,10 - clmt_axis(j)=(j-1)*0.2-0.8 + ! Set up the parameter axis for climate exponent: values from -0.8 to 1.2 in increments of 0.2 + do j = 1, 10 + clmt_axis(j) = (j - 1) * 0.2 - 0.8 enddo !do k=1,10 !do i=1,10 !do j=1,10 - count=count+1 - - !MU=MU_axis(k) - !exp_slp=slp_axis(i) - !exp_clmt=clmt_axis(j) - - - print *,"count=",count - print *,"M=",MU,", exp_slp=",exp_slp,", exp_clmt=",exp_clmt - - call get_station_inf(ns, nc, nlat, nlon, lati, loni, catid_full, Qclmt_full, slp_full, KImodel_all,exp_slp,exp_clmt,fac_str) - call get_valide_stations_gageii(ns,nc,catid_full,flag_gageii) - call regression(nt,vel,dis,nv,ns,Qclmt_full,slp_full,KKobs_full,KImodel_full,exp_slp,exp_clmt,mm,MU) - call filter_station(nc,ns,np,lats_full,lons_full,Qclmt_full,slp_full,catid_full,KKobs_full,KImodel_full,Qclmt,slp,catid,KKobs,KImodel,flag_gageii) - !call cal_Kmodel(ns,np,nc,MU,exp_slp,exp_clmt,Qclmt,slp,KKobs,KImodel,KImodel_all,catid,catid_full,ccr(k,i,j),rms(k,i,j)) - call cal_Kmodel(ns,np,nc,MU,exp_slp,exp_clmt,Qclmt,slp,KKobs,KImodel,KImodel_all,catid,catid_full,ccrp,rmsp) + ! count = count + 1 ! Increment the count of parameter combinations (currently only one iteration) + + !MU = MU_axis(k) + !exp_slp = slp_axis(i) + !exp_clmt = clmt_axis(j) + +! print *, "count=", count + print *, "M=", MU, ", exp_slp=", exp_slp, ", exp_clmt=", exp_clmt + + ! Retrieve station information and associated parameter data based on grid indices and model parameters + call get_station_inf(file_pfafmap, ns, nc, nlat, nlon, lati, loni, catid_full, Qclmt_full, slp_full, KImodel_all, exp_slp, exp_clmt, fac_str) + ! filtering stations using the GAGE-II dataset criteria + call get_valide_stations_gageii(file_gage_id, file_gage_acar, ns, nc, catid_full, flag_gageii) + ! Perform regression analysis using the USGS data + call regression(nt, vel, dis, nv, ns, Qclmt_full, slp_full, KKobs_full, KImodel_full, exp_slp, exp_clmt, mm, MU) + ! Filter stations based on predefined criteria + call filter_station(nc, ns, np, lats_full, lons_full, Qclmt_full, slp_full, catid_full, KKobs_full, KImodel_full, Qclmt, slp, catid, KKobs, KImodel, flag_gageii) + ! Calculate the modeled K parameter for each station + !call cal_Kmodel(ns, np, nc, MU, exp_slp, exp_clmt, Qclmt, slp, KKobs, KImodel, KImodel_all, catid, catid_full, ccr(k,i,j), rms(k,i,j)) + call cal_Kmodel(ns, np, nc, MU, exp_slp, exp_clmt, Qclmt, slp, KKobs, KImodel, KImodel_all, catid, catid_full, ccrp, rmsp) - print *,"ccr=",ccrp - print *,"rms=",rmsp + ! Print the computed correlation coefficient and RMS error + print *, "ccr=", ccrp + print *, "rms=", rmsp !enddo !enddo !enddo - - - !call create_ncfile_real3d("ccr_clmtxslpxMU_10x10x10_mm0p35.nc","data",ccr,MU_axis,slp_axis,clmt_axis,10,10,10) - !call create_ncfile_real3d("rms_clmtxslpxMU_10x10x10_mm0p35.nc","data",rms,MU_axis,slp_axis,clmt_axis,10,10,10) - - + ! The following calls would write the 3D parameter space results to NetCDF files (currently commented out) + !call create_ncfile_real3d("ccr_clmtxslpxMU_10x10x10_mm0p35.nc", "data", ccr, MU_axis, slp_axis, clmt_axis, 10, 10, 10) + !call create_ncfile_real3d("rms_clmtxslpxMU_10x10x10_mm0p35.nc", "data", rms, MU_axis, slp_axis, clmt_axis, 10, 10, 10) end program main \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 index 247d209f1..69200c82b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Pfaf_file.f90 @@ -1,196 +1,206 @@ program main +!main purpose: Reads the Pfafstetter code dataset and generates files for the connectivity of catchments in the routing network. + + use constant, only: nc, nupmax implicit none - - integer,parameter :: nc = 291284, nupmax=34 - integer,allocatable,dimension(:) :: downid,finalid - real*8,allocatable,dimension(:) :: pfaf - integer,allocatable,dimension(:,:) :: pfaf_digit,upstream - integer*8,allocatable,dimension(:) :: res - integer,allocatable,dimension(:) :: pfaf_last,pfaf_msk,code,behind - integer,allocatable,dimension(:) :: first,last,nup,nts,nts_old - real,allocatable,dimension(:) :: pfaf_area,pfaf_acar,pfaf_acar_old + ! Declare allocatable arrays for routing and Pfafstetter information: + integer, allocatable, dimension(:) :: downid, finalid + real*8, allocatable, dimension(:) :: pfaf ! Pfafstetter number for each catchment + integer, allocatable, dimension(:,:) :: pfaf_digit, upstream + integer*8, allocatable, dimension(:) :: res ! Temporary storage for digit extraction + integer, allocatable, dimension(:) :: pfaf_last, pfaf_msk, code, behind + integer, allocatable, dimension(:) :: first, last, nup, nts, nts_old + real, allocatable, dimension(:) :: pfaf_area, pfaf_acar, pfaf_acar_old - - integer :: i,j,jj,k,p,down,cur,idx,num,ok,samed,did,nmax - integer :: fulli(12),fullj(12) - real :: val(5) + ! Declare loop and temporary variables: + integer :: i, j, jj, k, p, down, cur, idx, num, ok, samed, did, nmax + integer :: fulli(12), fullj(12) + real :: val(5) - character(len=500) :: file_path="input/Pfafcatch-routing.dat" !/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/topo/v1/SRTM-TopoData/Pfafcatch-routing.dat - -! Get downstream catchment and final destination ID for each catchment, and determine whether it directs to an ocean or inland lake. -! downid=Pfafstetter index of catchment just downstream -! finalid=Pfafstetter index of catchment at outlet point -! pfaf= Pfafstetter number for catchment -! pfaf_digit= The 12 digits in a Pfafstetter number, separated -! pfaf_last= The index of the last nonzero digit in a Pfafstetter number (counting from the left) -! pfaf_msk =1 for non-sink catchments, 2 for sink catchments with endpoints in ocean, =3 for sink catchments with endpoints in interior lake -! last= The index of the last digit in a Pfafstetter number after removing any 11..000 tail. -! first= The index of the last zero (but not the zero at the very end). However, if there are no zeroes until the end, first =2 (the second index, since the first index indicates the continent). + ! Define file path for input routing data: + character(len=900) :: file_path !"input/Pfafcatch-routing.dat" - !if (command_argument_count() /= 1) then - ! print *, "no found" - ! stop - !endif - !call get_command_argument(1, file_path) + if (command_argument_count() /= 1) then + print *, "no found" + stop + endif + call get_command_argument(1, file_path) - open(77,file=file_path, form="formatted", status="old") - read(77,*)num + !--------------------------------------------------------------------------- + ! Read routing data from the input file: + open(77, file=trim(file_path), form="formatted", status="old") + read(77, *) num - allocate(downid(nc),finalid(nc),pfaf(nc),pfaf_digit(nc,12),res(nc),pfaf_last(nc),pfaf_msk(nc),pfaf_area(nc)) - allocate(first(nc),last(nc)) + ! Allocate arrays based on the total number of catchments (nc): + allocate(downid(nc), finalid(nc), pfaf(nc), pfaf_digit(nc,12), res(nc), & + pfaf_last(nc), pfaf_msk(nc), pfaf_area(nc)) + allocate(first(nc), last(nc)) - do i=1,nc - read(77,*)idx,pfaf(i),val(1:5),pfaf_area(i) - enddo + do i = 1, nc + read(77, *) idx, pfaf(i), val(1:5), pfaf_area(i) + end do -! Separate Pfafstetter number into individual digits - res=int8(pfaf) - pfaf_digit(:,1)=res/(int8(10)**int8(11)) - do i=2,12 - res=res-int8(10)**int8(13-i)*int8(pfaf_digit(:,i-1)) - pfaf_digit(:,i)=res/(int8(10)**int8(12-i)) - enddo + !--------------------------------------------------------------------------- + ! Separate the Pfafstetter number into its 12 individual digits. + res = int8(pfaf) ! Convert Pfafstetter numbers to 64-bit integers + pfaf_digit(:,1) = res / (int8(10) ** int8(11)) + do i = 2, 12 + res = res - int8(10) ** int8(13-i) * int8(pfaf_digit(:, i-1)) + pfaf_digit(:, i) = res / (int8(10) ** int8(12-i)) + end do -! Determine positions of last nonzero digit (pfaf_last) and the last digit that鈥檚 neither 0 nor 1 (at the end) - first=2 - last=2 - do i=1,nc - do j=12,1,-1 - if(pfaf_digit(i,j)/=0)then - pfaf_last(i)=j - do k=0,j-1 - if(pfaf_digit(i,j-k)/=1)then - last(i)=j-k + !--------------------------------------------------------------------------- + ! Determine the positions of the last nonzero digit (pfaf_last) + ! and the position of the last digit that is not 1 (stored in 'last'). + first = 2 ! Initialize 'first' to 2 by default + last = 2 ! Initialize 'last' to 2 by default + do i = 1, nc + do j = 12, 1, -1 + if (pfaf_digit(i, j) /= 0) then + pfaf_last(i) = j + do k = 0, j-1 + if (pfaf_digit(i, j-k) /= 1) then + last(i) = j - k exit endif - enddo + end do exit endif - enddo - enddo - do i=1,nc - if(last(i)<=1) last(i)=2 - enddo + end do + end do + do i = 1, nc + if (last(i) <= 1) last(i) = 2 + end do -! Determine position of final zero that has some nonzero digits after it - do i=1,nc - do j=last(i),2,-1 - if(pfaf_digit(i,j)==0)then - first(i)=j + !--------------------------------------------------------------------------- + ! Determine the position of the final zero that has nonzero digits after it. + do i = 1, nc + do j = last(i), 2, -1 + if (pfaf_digit(i, j) == 0) then + first(i) = j exit endif - enddo - enddo + end do + end do - do i=1,nc + !--------------------------------------------------------------------------- + ! Determine the immediate downstream catchment for each catchment. + do i = 1, nc - if(first(i)>last(i)-1)then - downid(i)=-1 + if (first(i) > last(i) - 1) then + ! No valid downstream digit exists; mark as terminal (sink) + downid(i) = -1 else - allocate(code(1:last(i)-first(i))) - code=pfaf_digit(i,first(i):last(i)-1) - if(any(code==2).or.any(code==4).or.any(code==6).or.any(code==8))then - ! If all digits (after the first) are odd, the Pfafstetter logic implies that the catchment will be on the coast. - fulli=pfaf_digit(i,:) - do j=i-1,1,-1 ! Test each catchment to see if it lies just downstream of catchment i - ok=1 - fullj=pfaf_digit(j,:) - samed=0 - do k=1,min(pfaf_last(i),pfaf_last(j)) ! Determine the index (samed) up to which the Pfaf numbers of catchment I and j match - if(fulli(k)==fullj(k))then - samed=samed+1 + allocate(code(1 : last(i) - first(i))) + code = pfaf_digit(i, first(i) : last(i)-1) + if (any(code == 2) .or. any(code == 4) .or. any(code == 6) .or. any(code == 8)) then + ! If any digit in the extracted part is even, then the catchment is non-coastal. + fulli = pfaf_digit(i, :) + do j = i-1, 1, -1 ! Loop backward to find a catchment just downstream of catchment i + ok = 1 + fullj = pfaf_digit(j, :) + samed = 0 + do k = 1, min(pfaf_last(i), pfaf_last(j)) + if (fulli(k) == fullj(k)) then + samed = samed + 1 else exit endif - enddo ! end k loop - if(samed+1<=pfaf_last(j))then - ! Check that none of catchment j鈥檚 indices (after samed) are even, which would imply a downstream branching off from the river on which catchment i lies. - allocate(behind(1:pfaf_last(j)-samed)) - behind=fullj(samed+1:pfaf_last(j)) - if(any(mod(behind,2)==0)) ok=0 + end do ! End of k loop: number of matching leading digits stored in 'samed' + if (samed + 1 <= pfaf_last(j)) then + ! Check that none of catchment j's remaining digits (after the common part) + ! are even, which would indicate a branching downstream. + allocate(behind(1 : pfaf_last(j) - samed)) + behind = fullj(samed+1 : pfaf_last(j)) + if (any(mod(behind, 2) == 0)) ok = 0 deallocate(behind) else - ok=0 + ok = 0 endif - if(ok==1)then - downid(i)=j + if (ok == 1) then + downid(i) = j ! Found the immediate downstream catchment for catchment i exit endif - enddo ! end j loop + end do ! End of j loop else - downid(i)=-1 + downid(i) = -1 ! If extracted digits are not even, mark as sink (or coastal) endif deallocate(code) - endif ! end i loop + endif ! End if for determining downstream catchment for catchment i - - enddo - + end do - open(88,file="output/downstream_1D_new_noadj.txt") - do i=1,nc - write(88,*)downid(i) - enddo + !--------------------------------------------------------------------------- + ! Write the downstream catchment IDs to an output file: + open(88, file="output/downstream_1D_new_noadj.txt") + do i = 1, nc + write(88, *) downid(i) + end do - open(88,file="output/Pfaf_area.txt") - do i=1,nc - write(88,*)pfaf_area(i) - enddo + ! Write catchment areas to an output file: + open(88, file="output/Pfaf_area.txt") + do i = 1, nc + write(88, *) pfaf_area(i) + end do - allocate(upstream(nupmax,nc),nup(nc)) - nup=0 - upstream=-1 - do i=1,nc - did=downid(i) - if(did>=1)then - nup(did)=nup(did)+1 - upstream(nup(did),did)=i + !--------------------------------------------------------------------------- + ! Build an upstream connectivity matrix: + allocate(upstream(nupmax, nc), nup(nc)) + nup = 0 + upstream = -1 + do i = 1, nc + did = downid(i) + if (did >= 1) then + nup(did) = nup(did) + 1 + upstream(nup(did), did) = i end if - enddo - open(88,file="output/upstream_1D.txt") - do i=1,nc - write(88,'(34(I8))')upstream(:,i) - enddo - open(88,file="output/Pfaf_upnum.txt") - do i=1,nc - write(88,*)nup(i) - enddo + end do + open(88, file="output/upstream_1D.txt") + do i = 1, nc + write(88, '(34(I8))') upstream(:, i) + end do + open(88, file="output/Pfaf_upnum.txt") + do i = 1, nc + write(88, *) nup(i) + end do - allocate(nts(nc),pfaf_acar(nc)) - nts=-9999 - do i=1,nc - k=0 - cur=i - do while(downid(cur)/=-1) - k=k+1 - cur=downid(cur) - enddo - nts(i)=k - enddo - open(88,file="output/Pfaf_tosink.txt") - do i=1,nc - write(88,*)nts(i) - enddo + !--------------------------------------------------------------------------- + ! Calculate the number of steps (nts) from each catchment to the sink: + allocate(nts(nc), pfaf_acar(nc)) + nts = -9999 + do i = 1, nc + k = 0 + cur = i + do while (downid(cur) /= -1) + k = k + 1 + cur = downid(cur) + end do + nts(i) = k + end do + open(88, file="output/Pfaf_tosink.txt") + do i = 1, nc + write(88, *) nts(i) + end do - nmax=maxval(nts) - pfaf_acar=pfaf_area - do j=nmax,1,-1 - do i=1,nc - if(nts(i)==j)then - did=downid(i) - pfaf_acar(did)=pfaf_acar(did)+pfaf_acar(i) - endif - enddo - enddo - open(88,file="temp/Pfaf_acar.txt") - do i=1,nc - write(88,*)pfaf_acar(i) - enddo + !--------------------------------------------------------------------------- + ! Aggregate catchment areas along the flow network: + nmax = maxval(nts) + pfaf_acar = pfaf_area + do j = nmax, 1, -1 + do i = 1, nc + if (nts(i) == j) then + did = downid(i) + pfaf_acar(did) = pfaf_acar(did) + pfaf_acar(i) + endif + end do + end do + open(88, file="temp/Pfaf_acar.txt") + do i = 1, nc + write(88, *) pfaf_acar(i) + end do - - end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 index 129fb3575..853429c74 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_Qr_clmt.f90 @@ -1,130 +1,184 @@ program main +!Main purpose: Reads SMAP L4 runoff data (2016鈥2023) from a NetCDF file and computes the climatological mean discharge for each catchment. use omp_lib use river_read + use constant, only : nlat=>nlat09, nlon=>nlon09, nc, nupmax + implicit none - integer,parameter :: nlat=1624,nlon=3856,nc=291284,nupmax=34 - character(len=500) :: filename="input/SMAPL4_OL7000_runoff_mean_2016_2023.nc" - real,allocatable :: runoff(:,:),qrunf(:),temp(:,:),qri(:),qin(:) - integer,allocatable :: nts(:),downid(:),upstream(:,:) + ! Define variables: + real, allocatable :: runoff(:,:), qrunf(:), temp(:,:), qri(:), qin(:) + integer, allocatable :: nts(:), downid(:), upstream(:,:) + integer :: i, j, nmax, did - integer :: i,j,nmax,did - - allocate(runoff(nlon,nlat),qrunf(nc),temp(nlon,nlat)) - call read_ncfile_real2d(trim(filename),"mean_runoff_flux",runoff,nlon,nlat) - where(runoff==-9999.)runoff=0. - temp=runoff(:,nlat:1:-1) - runoff=temp - runoff=runoff*86400. !mm/d - qrunf=M09_to_cat(runoff,nlon,nlat,nc) !kg/s - qrunf=qrunf/1.e3 !m3/s - open(88,file="output/Pfaf_qstr.txt") - do i=1,nc - write(88,*)qrunf(i) - enddo - - allocate(nts(nc),downid(nc),qri(nc)) - open(77,file="output/Pfaf_tosink.txt") - read(77,*)nts - open(77,file="output/downstream_1D_new_noadj.txt") - read(77,*)downid - - nmax=maxval(nts) - qri=qrunf - do j=nmax,1,-1 - do i=1,nc - if(nts(i)==j)then - did=downid(i) - qri(did)=qri(did)+qri(i) - endif - enddo - enddo - open(88,file="output/Pfaf_qri.txt") - do i=1,nc - write(88,*)qri(i) - enddo - - allocate(upstream(nupmax,nc),qin(nc)) - open(77,file="output/upstream_1D.txt") - read(77,*)upstream - qin=-9999. - where(upstream(1,:)/=-1)qin=qri-qrunf - where(upstream(1,:)==-1)qin=qrunf/2. - open(88,file="output/Pfaf_qin.txt") - do i=1,nc - write(88,*)qin(i) - enddo + character(len=900) :: file_path !"input/SMAPL4_OL7000_runoff_mean_2016_2023.nc" -contains -!------------------------------------------------------------------------------ -! This function maps runoff data from M09 resolution to catchments (cat) -function M09_to_cat(runoff,nlon,nlat,ncat) result(Qrunf) - - integer,intent(in) :: nlon,nlat,ncat ! Input: number of longitude, latitude, and catchments - real,intent(in) :: runoff(nlon,nlat) ! Input: runoff array of size (nlon, nlat) - real :: Qrunf(ncat) ! Output: runoff mapped to catchments - - real,parameter :: small=1.e-12 ! Small value to avoid division by zero - - integer,parameter :: nmax=458 ! Maximum number of sub-areas per catchment - integer,parameter :: nc=291284 ! Total number of catchments - - real,allocatable,dimension(:,:) :: subarea,frac ! Arrays for sub-area and fractions - integer,allocatable,dimension(:,:) :: subx,suby ! Arrays for x and y coordinates of sub-areas - real,allocatable,dimension(:) :: tot,runfC,fracA ! Arrays for total area, calculated runoff, and fraction - integer,allocatable,dimension(:) :: nsub ! Array for number of sub-areas per catchment - - integer :: i,j,sx,sy ! Loop variables and coordinates for sub-areas - - ! Allocate memory for arrays - allocate(nsub(nc),subarea(nmax,nc),subx(nmax,nc),suby(nmax,nc),tot(nc)) - - ! Read sub-area data from text files - open(77,file="output/Pfaf_nsub_M09.txt"); read(77,*)nsub - open(77,file="output/Pfaf_asub_M09.txt"); read(77,*)subarea - open(77,file="output/Pfaf_xsub_M09.txt"); read(77,*)subx - open(77,file="output/Pfaf_ysub_M09.txt"); read(77,*)suby - open(77,file="output/Pfaf_area.txt"); read(77,*)tot - - ! Allocate memory for fraction array - allocate(frac(nmax,nc)) - - ! Compute fraction of each sub-area relative to the total catchment area - do i=1,nc - frac(:,i)=subarea(:,i)/tot(i) - enddo - - ! Allocate memory for runoff and fraction arrays - allocate(runfC(nc),fracA(nc)) - runfC=0. ! Initialize runoff array to zero - fracA=0. ! Initialize fraction array to zero - - !$OMP PARALLEL default(shared) private(i,j,sx,sy) ! Start OpenMP parallel region - !$OMP DO - ! Loop over all catchments and sub-areas - do i=1,nc - do j=1,nsub(i) - sy=suby(j,i) ! Get y-coordinate of the sub-area - sx=subx(j,i) ! Get x-coordinate of the sub-area - ! Check for valid fraction and runoff values - if(frac(j,i)>0..and.runoff(sx,sy)<1.e14.and.runoff(sx,sy)>=0.)then - runfC(i)=runfC(i)+frac(j,i)*runoff(sx,sy) ! Accumulate runoff for the catchment - fracA(i)=fracA(i)+frac(j,i) ! Accumulate fraction - endif - enddo - enddo - !$OMP END DO - !$OMP END PARALLEL ! End OpenMP parallel region + if (command_argument_count() /= 1) then + print *, "no found" + stop + endif + call get_command_argument(1, file_path) - ! Convert to kg/s by multiplying by area (in m虏) and dividing by time (in seconds) - Qrunf=runfC*(tot*1.e6)/86400. - - ! Deallocate arrays to free memory - deallocate(subarea,subx,suby,tot,frac,& - runfC,fracA,nsub) - -end function M09_to_cat -!------------------------------------------------------------------------------ + ! Allocate arrays for runoff (grid), catchment runoff, and a temporary grid array: + allocate(runoff(nlon, nlat), qrunf(nc), temp(nlon, nlat)) + + ! Read the "mean_runoff_flux" variable from the NetCDF file: + call read_ncfile_real2d(trim(file_path), "mean_runoff_flux", runoff, nlon, nlat) + ! Replace missing values (-9999) with 0: + where(runoff == -9999.) runoff = 0. + + ! Flip the grid vertically (reverse the latitude order) and assign back to runoff: + temp = runoff(:, nlat:1:-1) + runoff = temp + + ! Convert runoff from [mm/s] to [mm/d] + runoff = runoff * 86400. + + ! Map runoff from the M09 grid to catchments using the function M09_to_cat. + ! The result is in kg/s; then convert to m^3/s by dividing by 1.e3. + qrunf = M09_to_cat(runoff, nlon, nlat, nc) ! kg/s + qrunf = qrunf / 1.e3 ! m^3/s + + ! Write catchment runoff (qrunf): + open(88, file="output/Pfaf_qstr.txt") + do i = 1, nc + write(88, *) qrunf(i) + end do + + ! Allocate arrays for "steps to sink" (nts), downstream id (downid) and aggregated runoff (qri): + allocate(nts(nc), downid(nc), qri(nc)) + ! Read the number of steps to sink for each catchment from file: + open(77, file="output/Pfaf_tosink.txt") + read(77, *) nts + ! Read the downstream connectivity (immediate downstream catchment id) from file: + open(77, file="output/downstream_1D_new_noadj.txt") + read(77, *) downid + + ! Get the maximum number of steps among all catchments: + nmax = maxval(nts) + ! Initialize qri with the catchment runoff values: + qri = qrunf + ! Aggregate runoff upstream: For each catchment with a given number of steps j, + ! add its runoff to its downstream catchment. + do j = nmax, 1, -1 + do i = 1, nc + if (nts(i) == j) then + did = downid(i) + qri(did) = qri(did) + qri(i) + endif + end do + end do + + ! Write the aggregated runoff (qri) to file "Pfaf_qri.txt": + open(88, file="output/Pfaf_qri.txt") + do i = 1, nc + write(88, *) qri(i) + end do + + ! Allocate arrays for upstream connectivity and inlet discharge (qin): + allocate(upstream(nupmax, nc), qin(nc)) + ! Read upstream connectivity information from file "upstream_1D.txt": + open(77, file="output/upstream_1D.txt") + read(77, *) upstream + ! Initialize qin to -9999: + qin = -9999. + ! For catchments that have upstream connectivity (upstream(1,:) /= -1), + ! set qin as the difference between outlet discharge (qri) and runoff (qrunf); + ! for catchments with no upstream (upstream(1,:) == -1), set qin to half of direct runoff. + where(upstream(1,:) /= -1) qin = qri - qrunf + where(upstream(1,:) == -1) qin = qrunf / 2. + + ! Write the inlet discharge (qin): + open(88, file="output/Pfaf_qin.txt") + do i = 1, nc + write(88, *) qin(i) + end do +contains + !------------------------------------------------------------------------------ + ! Function: M09_to_cat + ! Purpose : Maps runoff data from the M09 grid resolution to catchments using + ! sub-area information. It aggregates runoff from sub-areas weighted by + ! their area fractions. + ! + ! Input: + ! runoff - Runoff array of size (nlon, nlat) [in mm/d] + ! nlon - Number of longitude grid cells. + ! nlat - Number of latitude grid cells. + ! ncat - Number of catchments. + ! + ! Output: + ! Qrunf - Runoff mapped to catchments (in kg/s, then converted to m^3/s). + !------------------------------------------------------------------------------ + function M09_to_cat(runoff, nlon, nlat, ncat) result(Qrunf) + integer, intent(in) :: nlon, nlat, ncat ! Grid dimensions and number of catchments + real, intent(in) :: runoff(nlon, nlat) ! Input runoff array at grid resolution + real :: Qrunf(ncat) ! Output catchment runoff array + + real, parameter :: small = 1.e-12 + + ! Define sub-area parameters (same as in the M09 dataset) + integer, parameter :: nmax = 458 ! Maximum number of sub-areas per catchment + integer, parameter :: nc = 291284 ! Total number of catchments + + ! Declare allocatable arrays to hold sub-area data: + real, allocatable, dimension(:,:) :: subarea, frac ! subarea: area of each sub-area, frac: fraction of total + integer, allocatable, dimension(:,:) :: subx, suby ! Coordinates of sub-areas in the grid + real, allocatable, dimension(:) :: tot, runfC, fracA ! tot: total catchment area; runfC: aggregated runoff; fracA: fraction sum + integer, allocatable, dimension(:) :: nsub ! nsub: number of sub-areas per catchment + + integer :: i, j, sx, sy ! Loop counters and sub-area grid coordinates + + ! Allocate arrays for sub-area information and total area: + allocate(nsub(nc), subarea(nmax, nc), subx(nmax, nc), suby(nmax, nc), tot(nc)) + + ! Read sub-area data from text files: + open(77, file="output/Pfaf_nsub_M09.txt"); read(77, *) nsub + open(77, file="output/Pfaf_asub_M09.txt"); read(77, *) subarea + open(77, file="output/Pfaf_xsub_M09.txt"); read(77, *) subx + open(77, file="output/Pfaf_ysub_M09.txt"); read(77, *) suby + open(77, file="output/Pfaf_area.txt"); read(77, *) tot + + ! Allocate fraction array (fraction of sub-area relative to total catchment area) + allocate(frac(nmax, nc)) + + ! Compute the fraction for each sub-area: + do i = 1, nc + frac(:, i) = subarea(:, i) / tot(i) + end do + + ! Allocate arrays to accumulate runoff and fraction sums per catchment: + allocate(runfC(nc), fracA(nc)) + runfC = 0. ! Initialize aggregated runoff for each catchment to zero + fracA = 0. ! Initialize fraction accumulation to zero + + !$OMP PARALLEL default(shared) private(i,j,sx,sy) + !$OMP DO + ! Loop over all catchments and their sub-areas: + do i = 1, nc + do j = 1, nsub(i) + sy = suby(j, i) ! Get y-coordinate of the sub-area + sx = subx(j, i) ! Get x-coordinate of the sub-area + ! Only consider valid sub-areas (non-zero fraction and valid runoff values) + if (frac(j, i) > 0. .and. runoff(sx, sy) < 1.e14 .and. runoff(sx, sy) >= 0.) then + runfC(i) = runfC(i) + frac(j, i) * runoff(sx, sy) + fracA(i) = fracA(i) + frac(j, i) + endif + end do + end do + !$OMP END DO + !$OMP END PARALLEL + + ! Convert aggregated runoff to kg/s by multiplying by total catchment area (in m虏) + ! and dividing by the number of seconds per day (86400): + Qrunf = runfC * (tot * 1.e6) / 86400. + + ! Deallocate allocated arrays to free memory: + deallocate(subarea, subx, suby, tot, frac, & + runfC, fracA, nsub) + + end function M09_to_cat + !------------------------------------------------------------------------------ + end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 index ffdf70c01..38f055179 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M09.f90 @@ -1,84 +1,103 @@ program main +!Main purpose: Gets the area for each catchment-tile for M09 grid. use river_read -implicit none +use constant, only: nmax=>nmax09,nc,nlon,nlat,nlat09,nlon09,nt_global=>nt_global09 -integer,parameter :: nmax=458 -integer,parameter :: nc=291284 -integer,parameter :: nlon=21600 -integer,parameter :: nlat=10800 -integer,parameter :: nlat36=1624,nlon36=3856 -integer,parameter :: nt_global=1684725 - -integer :: id,xi,yi,i,j,flag,subi,x_m36,y_m36,it -integer :: nsub(nc) -integer,allocatable :: xsub(:,:),ysub(:,:),subi_global(:,:) -real,allocatable :: asub(:,:) - -real*8,allocatable :: lon(:),lat(:) -integer,allocatable :: loni(:),lati(:) -integer,allocatable :: catchind(:,:),map_tile(:,:) -real,allocatable :: cellarea(:,:),area_m36(:,:),area_tile(:) -real*8,allocatable :: lat36(:),lon36(:) - - -!allocate(subi_global(nmax,nc)) -!open(77,file="Pfaf_isub_M36.txt",status="old",action="read"); read(77,*)subi_global; close(77) -!open(90,file="subi.txt",action="write") -!do i=1,nc -! write(90,'(150(i7))')subi_global(:,i) -!end do -!print *,"successful" -!stop - -allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) -allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) -allocate(lon(nlon),lat(nlat)) -allocate(loni(nlon),lati(nlat)) - - -call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) -call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) -call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) -call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) -cellarea=cellarea/1.e6 - - -open(10,file="temp/lati_1m_M09.txt") -read(10,*)lati -open(11,file="temp/loni_1m_M09.txt") -read(11,*)loni - - -allocate(area_m36(nlon36,nlat36)) -area_m36=0. -do xi=1,nlon - do yi=1,nlat - if(catchind(xi,yi)>=1)then - x_m36=loni(xi) - y_m36=lati(yi) - area_m36(x_m36,y_m36)=area_m36(x_m36,y_m36)+cellarea(xi,yi) +implicit none +! Require explicit declaration of all variables + +! Declare variables for indices, flags, and temporary storage +integer :: id, xi, yi, i, j, flag, subi, x_m09, y_m09, it +! Allocatable arrays to hold sub-catchment coordinate indices and global sub-catchment information +integer,allocatable :: xsub(:,:), ysub(:,:), subi_global(:,:) + +! Allocatable array to store sub-catchment area data +real,allocatable :: asub(:,:) + +! Allocatable double precision arrays for storing longitude and latitude values from file +real*8,allocatable :: lon(:), lat(:) +! Allocatable integer arrays for mapping longitude and latitude indices +integer,allocatable :: loni(:), lati(:) +! 2D arrays: catchind holds catchment index for each grid cell; map_tile maps M09 grid cells to global indices +integer,allocatable :: catchind(:,:), map_tile(:,:) +! Arrays for cell areas from the original grid, aggregated area on the M grid, and area per global tile +real,allocatable :: cellarea(:,:), area_m09(:,:), area_tile(:) + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays for sub-catchment data +! Allocate 2D arrays with dimensions (nmax, nc) for sub-catchment coordinate indices and areas +allocate(xsub(nmax,nc), ysub(nmax,nc), asub(nmax,nc)) + +! Allocate arrays for the catchment index grid and cell area data +allocate(catchind(nlon,nlat), cellarea(nlon,nlat)) +! Allocate 1D arrays for longitude and latitude values +allocate(lon(nlon), lat(nlat)) +! Allocate arrays for integer mappings of longitude and latitude indices +allocate(loni(nlon), lati(nlat)) + +! Read longitude and latitude data from the NetCDF file +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +! Read 2D catchment index data from the same file +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +! Read cell area data +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +! Scale cell area values (from m^2 to km^2) +cellarea = cellarea/1.e6 + +! Read mapping indices from text files for the M09 grid conversion +! Read integer latitude indices mapping for each original grid +open(10, file="temp/lati_1m_M09.txt") +read(10, *) lati +! Read integer longitude indices mapping for each original grid +open(11, file="temp/loni_1m_M09.txt") +read(11, *) loni + +! Allocate and initialize the aggregated area array for the M09 grid +allocate(area_m09(nlon09, nlat09)) +area_m09 = 0. +! Loop over the original grid and accumulate cell areas into the M09 grid using mapping indices +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi,yi) >= 1) then + x_m09 = loni(xi) + y_m09 = lati(yi) + ! For grid cells with a valid catchment index, add their cell area to the corresponding M09 grid cell + area_m09(x_m09, y_m09) = area_m09(x_m09, y_m09) + cellarea(xi,yi) endif enddo enddo -allocate(map_tile(nlon36,nlat36)) -call read_ncfile_int2d("temp/map_tile_M09.nc","data",map_tile,nlon36,nlat36) +! Allocate the map_tile array and read its data from a NetCDF file +allocate(map_tile(nlon09, nlat09)) +call read_ncfile_int2d("temp/map_tile_M09.nc", "data", map_tile, nlon09, nlat09) +! Allocate the global area array to hold area data for each tile allocate(area_tile(nt_global)) -area_tile=-9999. -do i=1,nlon36 - do j=1,nlat36 - it=map_tile(i,j) - if(it>0)then - area_tile(it)=area_m36(i,j) +area_tile = -9999. + +! Map the aggregated M09 grid areas to the global tile indices using the map_tile array +do i = 1, nlon09 + do j = 1, nlat09 + it = map_tile(i, j) + if (it > 0) then + area_tile(it) = area_m09(i, j) endif enddo enddo -open(88,file="output/area_M09_1d.txt") -do i=1,nt_global - write(88,*)area_tile(i) +! Write the global tile area data to an output text file +open(88, file="output/area_M09_1d.txt") +do i = 1, nt_global + write(88, *) area_tile(i) enddo - end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 index 27e1f05f1..3b0394e50 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_area_M36.f90 @@ -1,84 +1,104 @@ program main +!Main purpose: Gets the area for each catchment-tile for M36 grid. -use river_read -implicit none - -integer,parameter :: nmax=150 -integer,parameter :: nc=291284 -integer,parameter :: nlon=21600 -integer,parameter :: nlat=10800 -integer,parameter :: nlat36=406,nlon36=964 -integer,parameter :: nt_global=112573 - -integer :: id,xi,yi,i,j,flag,subi,x_m36,y_m36,it -integer :: nsub(nc) -integer,allocatable :: xsub(:,:),ysub(:,:),subi_global(:,:) -real,allocatable :: asub(:,:) - -real*8,allocatable :: lon(:),lat(:) -integer,allocatable :: loni(:),lati(:) -integer,allocatable :: catchind(:,:),map_tile(:,:) -real,allocatable :: cellarea(:,:),area_m36(:,:),area_tile(:) -real*8,allocatable :: lat36(:),lon36(:) - - -!allocate(subi_global(nmax,nc)) -!open(77,file="Pfaf_isub_M36.txt",status="old",action="read"); read(77,*)subi_global; close(77) -!open(90,file="subi.txt",action="write") -!do i=1,nc -! write(90,'(150(i7))')subi_global(:,i) -!end do -!print *,"successful" -!stop - -allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) -allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) -allocate(lon(nlon),lat(nlat)) -allocate(loni(nlon),lati(nlat)) +use river_read ! Use the module "river_read" to access functions for reading NetCDF files +use constant, only: nmax=>nmax36,nc,nlon,nlat,nlat36,nlon36,nt_global=>nt_global36 - -call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) -call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) -call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) -call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) -cellarea=cellarea/1.e6 - - -open(10,file="temp/lati_1m_M36.txt") -read(10,*)lati -open(11,file="temp/loni_1m_M36.txt") -read(11,*)loni - - -allocate(area_m36(nlon36,nlat36)) -area_m36=0. -do xi=1,nlon - do yi=1,nlat - if(catchind(xi,yi)>=1)then - x_m36=loni(xi) - y_m36=lati(yi) - area_m36(x_m36,y_m36)=area_m36(x_m36,y_m36)+cellarea(xi,yi) +implicit none +! Require explicit declaration of all variables + +! Declare variables for indices and temporary storage +integer :: id, xi, yi, i, j, flag, subi, x_m36, y_m36, it + +! Declare allocatable arrays for sub-catchment information +integer,allocatable :: xsub(:,:), ysub(:,:), subi_global(:,:) +! Arrays for storing sub-catchment coordinate indices and sub-catchment areas +real,allocatable :: asub(:,:) + +! Declare arrays for grid and mapping information +! Arrays for longitude and latitude values from the NetCDF file +real*8,allocatable :: lon(:), lat(:) +! Arrays for integer mappings of longitude and latitude indices +integer,allocatable :: loni(:), lati(:) +! 2D arrays: "catchind" holds catchment index for each original grid cell; "map_tile" maps aggregated grid cells to global indices +integer,allocatable :: catchind(:,:), map_tile(:,:) +! "cellarea" holds the area of each grid cell; "area_m36" is the aggregated area on the M36 grid; +! "area_tile" will store the area for each global tile based on the aggregated grid +real,allocatable :: cellarea(:,:), area_m36(:,:), area_tile(:) + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays for sub-catchment information with dimensions (nmax, nc) +allocate(xsub(nmax,nc), ysub(nmax,nc), asub(nmax,nc)) +! Allocate arrays for the original grid: catchment indices and cell areas +allocate(catchind(nlon,nlat), cellarea(nlon,nlat)) +! Allocate arrays for longitude and latitude values +allocate(lon(nlon), lat(nlat)) +! Allocate arrays for the mapping of longitude and latitude indices +allocate(loni(nlon), lati(nlat)) + +! Read longitude and latitude data from the NetCDF file +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +! Read the 2D catchment index data +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +! Read the cell area data +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +! Convert cell areas (from m^2 to km^2) by scaling with 1.e6 +cellarea = cellarea / 1.e6 + +! Open text files to read the mapping indices for the aggregated grid (M36) +! Read the latitude mapping: converts original latitude indices to M36 grid indices +open(10, file="temp/lati_1m_M36.txt") +read(10, *) lati +! Read the longitude mapping: converts original longitude indices to M36 grid indices +open(11, file="temp/loni_1m_M36.txt") +read(11, *) loni + +! Allocate and initialize the aggregated area array for the M36 grid +allocate(area_m36(nlon36, nlat36)) +area_m36 = 0. +! Loop over each grid cell in the original grid +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi,yi) >= 1) then + ! For cells that belong to a catchment (valid catchment index) + x_m36 = loni(xi) + y_m36 = lati(yi) + ! Accumulate the cell area into the corresponding aggregated grid cell + area_m36(x_m36, y_m36) = area_m36(x_m36, y_m36) + cellarea(xi,yi) endif enddo enddo -allocate(map_tile(nlon36,nlat36)) -call read_ncfile_int2d("temp/map_tile_M36.nc","data",map_tile,nlon36,nlat36) +! Allocate the map_tile array and read its data from a NetCDF file +allocate(map_tile(nlon36, nlat36)) +call read_ncfile_int2d("temp/map_tile_M36.nc", "data", map_tile, nlon36, nlat36) +! Allocate the global area array to hold the area for each global tile allocate(area_tile(nt_global)) -area_tile=-9999. -do i=1,nlon36 - do j=1,nlat36 - it=map_tile(i,j) - if(it>0)then - area_tile(it)=area_m36(i,j) +area_tile = -9999. + +! Map the aggregated grid areas to the global tile indices using the map_tile mapping +do i = 1, nlon36 + do j = 1, nlat36 + it = map_tile(i, j) + if (it > 0) then + area_tile(it) = area_m36(i, j) endif enddo enddo -open(88,file="output/area_M36_1d.txt") -do i=1,nt_global - write(88,*)area_tile(i) +! Write the global tile area data to an output text file +open(88, file="output/area_M36_1d.txt") +do i = 1, nt_global + write(88, *) area_tile(i) enddo - -end +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py index 6cab4cafb..d89a3cc8c 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_dam_data.py @@ -1,8 +1,11 @@ +import sys import numpy as np from netCDF4 import Dataset import os import glob +#Main purpose: Processes reservoir (dam) data: reads dam locations and usage information from GRanD database. + # Function to find the nearest index in a coordinate array def ind_nearest_coord(coord_array1, coord_array2): """ @@ -16,62 +19,44 @@ def ind_nearest_coord(coord_array1, coord_array2): if __name__ == '__main__': -#----get dam lat lon ind---- + file_latdam, file_londam, file_lat1m, file_lon1m, file_catmap, file_acadam, file_damcat_manfix, file_dam_manflag, file_dam_use, file_flood = sys.argv[1:11] # Parameter settings ns = 7250 #nr nlat = 10800 nlon = 21600 + nc = 291284 + thres = 5000.0 + +#----get dam lat lon ind---- - # Read data from ASCII files; each file contains one number per line. - lats = np.loadtxt("input/lat_dam_grand.txt", dtype=np.float64, max_rows=ns) - lons = np.loadtxt("input/lon_dam_grand.txt", dtype=np.float64, max_rows=ns) - lat1m = np.loadtxt("input/lat_1m.txt", dtype=np.float64, max_rows=nlat) - lon1m = np.loadtxt("input/lon_1m.txt", dtype=np.float64, max_rows=nlon) + # Read data from ASCII files + lats = np.loadtxt(file_latdam, dtype=np.float64, max_rows=ns) + lons = np.loadtxt(file_londam, dtype=np.float64, max_rows=ns) + lat1m = np.loadtxt(file_lat1m, dtype=np.float64, max_rows=nlat) + lon1m = np.loadtxt(file_lon1m, dtype=np.float64, max_rows=nlon) # For each target coordinate, find the nearest index in the reference array. lati = ind_nearest_coord(lats, lat1m) loni = ind_nearest_coord(lons, lon1m) - # Since NCL uses 1-based indexing, add 1 when writing the results. - #np.savetxt("data/lati_dam_PR.txt", lati, fmt='%d') - #np.savetxt("data/loni_dam_PR.txt", loni, fmt='%d') - - -#----get dam cat ind---- - # Read the NetCDF file - nc_file = "input/CatchIndex.nc" - with Dataset(nc_file, 'r') as nc: - # Read the integer 2D variable "data" - # We assume that the data is stored with shape (nlon, nlat) - catchind = nc.variables["data"][:] - # If catchind is a masked array, fill masked values with -9999 +#----get dam catchemnt indices---- + # Read the catchment indices file + nc_file = file_catmap + with Dataset(nc_file, 'r') as ncf: + catchind = ncf.variables["CatchIndex"][:] if np.ma.is_masked(catchind): catchind = catchind.filled(-9999) - # Read ASCII files containing indices for latitude and longitude. - # It is assumed that the files contain one integer per line and use 1-based indexing. - #lati = np.loadtxt("data/lati_dam.txt", dtype=int) # shape: (ns,) - #loni = np.loadtxt("data/loni_dam.txt", dtype=int) # shape: (ns,) # Initialize the array to store the output catchment ID values catid = np.empty(ns, dtype=int) - # Loop over each index (Fortran indices start at 1, so we subtract 1 for 0-based indexing in Python) + # Loop over each index for i in range(ns): - # For each index, retrieve the value from catchind using (loni, lati) as indices. - # Subtract 1 from the read indices to convert from 1-based to 0-based indexing. + # For each index, retrieve the value from catchind. catid[i] = catchind[ lati[i], loni[i] ] - # Write the output catid array to an ASCII file with one number per line. - #np.savetxt("data/catid_dam_PR.txt", catid, fmt='%d') - #----get dam drainage area-- - # Define the number of catchments and the total number of entries in the full dataset - nc = 291284 - - # Alternative file (commented out in the original NCL script): - # catid = np.loadtxt("data/catid_dam_corr_aca_grand5000.txt", dtype=int, max_rows=ns) - - # Read full dataset for acar and area from ASCII files + # Read full dataset for acar(drainage area) and catchment area from ASCII files acar_all = np.loadtxt("temp/Pfaf_acar.txt", dtype=float, max_rows=nc) area_all = np.loadtxt("output/Pfaf_area.txt", dtype=float, max_rows=nc) @@ -83,27 +68,23 @@ def ind_nearest_coord(coord_array1, coord_array2): for i in range(ns): cid = catid[i] if cid != -9999: - # Subtract 1 from cid to convert 1-based index (from ASCII file) to 0-based index for Python + # Subtract 1 from cid to convert 1-based index to 0-based index for Python acar[i] = acar_all[cid - 1] area[i] = area_all[cid - 1] else: acar[i] = -9999.0 area[i] = -9999.0 - # Write the output arrays to ASCII files, one number per line - #np.savetxt("data/catch_aca_model_PR.txt", acar, fmt="%.6f") - #np.savetxt("data/catch_area_model_PR.txt", area, fmt="%.6f") - -#----look for uncorrect station------ - thres = 5000.0 - # Read data from ASCII files - grand = np.loadtxt("input/catch_aca_grand.txt", dtype=float, max_rows=ns) +#----look for station: model drainage area is too small------ + # Read drainage area from GRAND database + grand = np.loadtxt(file_acadam, dtype=float, max_rows=ns) # Initialize lists to store error information id_error = [] # Loop over each catchment index for i in range(ns): + # At here only care about large-scale dams if grand[i] > thres: if acar[i] < 0.8 * grand[i]: # Append error information; add 1 to i for 1-based indexing @@ -112,25 +93,17 @@ def ind_nearest_coord(coord_array1, coord_array2): # Get the number of errors found ne = len(id_error) - # Write the error IDs to an ASCII file, one number per line - #np.savetxt("data/id_error_aca_grand5000_PR.txt", np.array(id_error), fmt='%d') - #----get corrected catid for above station-------------------- + # Read manually corrected catid array from ASCII files. + catid_error = np.loadtxt(file_damcat_manfix, dtype=int, max_rows=ne) - # Read error arrays and the full catid array from ASCII files. - # It is assumed that the files contain one number per line. - catid_error = np.loadtxt("input/newcatid_error_aca_grand5000.txt", dtype=int, max_rows=ne) - - # Loop over each error index and update catid_all. + # Loop over each error index and update catid. # Note: We subtract 1 from resid_error values to convert from 1-based to 0-based indexing. for i in range(ne): rid = id_error[i] catid[rid - 1] = catid_error[i] - # Write the updated catid_all array to an ASCII file. - #np.savetxt("data/catid_dam_corr_aca_grand5000_noman_PR.txt", catid, fmt='%d') - -#----get dam drainage area after correction-------------------- +#----get dam drainage area with corrected catid-------------------- # Initialize arrays to store the selected acar and area values for each catchment acar = np.empty(ns, dtype=float) area = np.empty(ns, dtype=float) @@ -146,18 +119,8 @@ def ind_nearest_coord(coord_array1, coord_array2): acar[i] = -9999.0 area[i] = -9999.0 - # Write the output arrays to ASCII files with one number per line - #np.savetxt("data/catch_aca_model_corr_aca_grand5000_PR.txt", acar, fmt="%.6f") - #np.savetxt("data/catch_area_model_corr_aca_grand5000_PR.txt", area, fmt="%.6f") - -#----look for uncorrect station------ - # Define threshold and total number of catchments - thres = 5000.0 - - # The following files are read for completeness, though not used in the logic below. - #area = np.loadtxt("data/catch_area_model_corr_aca_grand5000.txt", dtype=float, max_rows=ns) +#----look for station: model drainage area is too large------ model = acar - # Instead of preallocating an array with a fixed size (np in NCL), # we use a list to collect error indices. id_error = [] @@ -170,28 +133,23 @@ def ind_nearest_coord(coord_array1, coord_array2): id_error.append(i + 1) ne = len(id_error) - - # Write the error indices to an ASCII file (one number per line) - #np.savetxt("data/id_error_aca_model5000_PR.txt", np.array(id_error), fmt='%d') -#----create flag for stations------ +#----create flag for all dams------ - # Define manual adjustment arrays (1D arrays) + # Three more manual adjustment dams resid_man = np.array([5179, 289, 7070], dtype=int) catid_man = np.array([46616, 142851, 199281], dtype=int) nman = resid_man.size # Update specific indices in catid_all with manual adjustments. - # Convert from 1-based indexing (in NCL) to 0-based indexing (in Python) for i in range(nman): catid[resid_man[i] - 1] = catid_man[i] # Write the updated catid_all to an ASCII file np.savetxt("output/catid_dam_corr_aca_grand5000.txt", catid, fmt='%d') - # Read flag_error and id_error arrays from ASCII files - flag_error = np.loadtxt("input/flag_model5000.txt", dtype=int, max_rows=ne) - #id_error = np.loadtxt("data/id_error_aca_model5000.txt", dtype=int, max_rows=ne) + # Read dams flag (whether we still need it in the model) for the above uncorrect dams from a manually checked flag file + flag_error = np.loadtxt(file_dam_manflag, dtype=int, max_rows=ne) # Initialize flag_all array with ones (default flag value) flag_all = np.ones(ns, dtype=int) @@ -202,18 +160,13 @@ def ind_nearest_coord(coord_array1, coord_array2): id_val = id_error[i] flag_all[id_val - 1] = flag_error[i] - # Read the catchment area data from ASCII files - #aca_grand = np.loadtxt("data/catch_aca_grand.txt", dtype=float, max_rows=ns) - #aca_model = np.loadtxt("data/catch_aca_model_corr_aca_grand5000.txt", dtype=float, max_rows=ns) - - # Update flag_all based on conditions related to aca_grand and aca_model. - # If aca_grand is less than 1.e3 and also less than 0.5 times aca_model, set flag to 0. + # If drainage area in GRAND is small and also less than 0.5 times model drainage area, we do not need the dam. for i in range(ns): if grand[i] < 1.e3: if grand[i] < 0.5 * acar[i]: flag_all[i] = 0 - # If aca_model is negative, set flag_all to 0 for that catchment. + # If model drainage area is negative, set flag_all to 0 for that dam. for i in range(ns): if acar[i] < 0.: flag_all[i] = 0 @@ -227,30 +180,26 @@ def ind_nearest_coord(coord_array1, coord_array2): use_out = ["irr", "hydroelec", "watersupply", "nav", "rec"] nu = len(use_string) - # Read the main use data as strings from the ASCII file (one entry per line) - with open("input/main_use_grand.txt", "r") as f: + # Read the main use data as strings from the GRAND file + with open(file_dam_use, "r") as f: use = [line.strip() for line in f] if len(use) != ns: print(f"Warning: expected {ns} lines, but got {len(use)} lines.") # For each category in use_string, create a flag array and output the result for j in range(nu): - # Initialize the flag array with zeros flag = np.zeros(ns, dtype=int) # Set flag to 1 where the use value matches the current category for i in range(ns): if use[i] == use_string[j]: flag[i] = 1 - # Print the sum of the flag array (i.e., the count of matched entries) - # print(np.sum(flag)) - - # Write the flag array to an ASCII file, one number per line + # Write the flag array out_filename = os.path.join("output", use_out[j] + "_grand.txt") np.savetxt(out_filename, flag, fmt='%d') #----flood use-------------------- - # Read the use_irr strings from the ASCII file (one entry per line) - with open("input/flood_use_grand.txt", "r") as f: + # Read the use_irr strings from the GRAND file + with open(file_flood, "r") as f: use_irr = [line.strip() for line in f] # Initialize the flag array with zeros @@ -261,17 +210,14 @@ def ind_nearest_coord(coord_array1, coord_array2): if use_irr[i] != "NA": flag[i] = 1 - # Print the sum of the flag array (i.e., count of non-"NA" entries) - #print(np.sum(flag)) - - # Write the flag array to an ASCII file, one number per line + # Write the flag array np.savetxt("output/fldmainsec_grand.txt", flag, fmt='%d') #----other use-------------------- use_out = "other" - # Read the main use data from the ASCII file (assumed one entry per line) - with open("input/main_use_grand.txt", "r") as f: + # Read the main use data from the GRAND file + with open(file_dam_use, "r") as f: use = [line.strip() for line in f] if len(use) != ns: print(f"Warning: expected {ns} entries, but got {len(use)} entries.") @@ -284,48 +230,6 @@ def ind_nearest_coord(coord_array1, coord_array2): if use[i] == "Fisheries" or use[i] == "NA" or use[i] == "Other": flag[i] = 1 - # Print the sum of the flag array (i.e., count of matching entries) - #print(np.sum(flag)) - - # Write the flag array to an ASCII file, one number per line + # Write the flag array np.savetxt("output/" + use_out + "_grand.txt", flag, fmt='%d') -#----flood threshold------------- -if 1 == 0: - - thres_per = 1.0 - - nday = 1827 - day_start = 276 - day_end = 2102 - - # List files matching the pattern (assumed to be sorted in the same order as ls) - files = sorted(glob.glob("/Volumes/PASSPORT5T/work/river/river_OL7000_Kv/*Qr*.txt")) - nd = len(files) - #print(nd) - - # Initialize data_ori array with shape (nc, nday) - data_ori = np.empty((nc, nday), dtype=float) - - # Loop over each day from day_start to day_end (inclusive) - for i in range(day_start, day_end + 1): - if i % 10 == 0: - print(i) - # Read nc float values from file corresponding to day i and assign to the proper column - data_ori[:, i - day_start] = np.loadtxt(files[i], dtype=float, max_rows=nc) - - # Sort each row (daily values for each grid cell) in descending order - # Note: Sorting along axis=1 (the day dimension) - data_sorted = np.sort(data_ori, axis=1)[:, ::-1] - - # Calculate threshold index based on thres_per percentage of days - # For example, with thres_per=1, idx_thres becomes int(1/100 * 1827) = 18 - idx_thres = int(thres_per / 100.0 * nday) - #print(idx_thres) - - # For each grid cell (each row), select the value at rank idx_thres-1 (i.e. the 18th highest value) - output_data = data_sorted[:, idx_thres - 1] - - # Construct output filename and write the output_data to an ASCII file - filename = "output/Pfaf_flood_qr_thres0" + str(int(thres_per)) + ".txt" - np.savetxt(filename, output_data, fmt="%.6f") diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 index 82ee4a4fe..d82c6b791 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M09.f90 @@ -1,39 +1,55 @@ program main +!Main purpose: Assigns a catchment鈥恡ile index from maptile files to each sub-catchment for M09 grid. use river_read ! Use custom module for reading NetCDF files +use constant, only: nlat=>nlat09, nlon=>nlon09, nmax=>nmax09, nc implicit none -integer,parameter :: nlat=1624,nlon=3856 -integer,parameter :: nmax=458 ! Maximum number of sub-areas per catchment -integer,parameter :: nc=291284 ! Total number of catchments +! Declare allocatable arrays for grid mapping and sub-catchment indices +integer,allocatable :: map_tile(:,:), subx(:,:), suby(:,:), subi(:,:) -integer,allocatable :: map_tile(:,:),subx(:,:),suby(:,:),subi(:,:) - -integer :: i,x,y,j,it +! Declare integer variables for looping and temporary storage +integer :: i, x, y, j, it +! Allocate the map_tile array for the aggregated grid (M09) with dimensions (nlon, nlat) allocate(map_tile(nlon,nlat)) +! Read the mapping data from a NetCDF file into the map_tile array call read_ncfile_int2d("temp/map_tile_M09.nc", "data", map_tile, nlon, nlat) -allocate(subx(nmax,nc),suby(nmax,nc),subi(nmax,nc)) -open(77,file="output/Pfaf_xsub_M09.txt"); read(77,*)subx -open(77,file="output/Pfaf_ysub_M09.txt"); read(77,*)suby -subi=0 -do i=1,nc - do j=1,nmax - x=subx(j,i) - y=suby(j,i) - if(x/=0)then - if(y==0)stop - subi(j,i)=map_tile(x,y) + +! Allocate subx, suby, and subi arrays to store sub-catchment coordinate data and indices +allocate(subx(nmax,nc), suby(nmax,nc), subi(nmax,nc)) + +! Open and read the x-coordinates of sub-catchments from a text file into subx +open(77, file="output/Pfaf_xsub_M09.txt") +read(77, *) subx + +! Open and read the y-coordinates of sub-catchments from a text file into suby +open(77, file="output/Pfaf_ysub_M09.txt") +read(77, *) suby + +! Initialize the subi array to zero +subi = 0 + +! Loop over each catchment +do i = 1, nc + ! Loop over each possible sub-area within a catchment + do j = 1, nmax + x = subx(j, i) + y = suby(j, i) + ! If the x-coordinate is non-zero, then the sub-area exists + if (x /= 0) then + ! If x exists but y is zero, then there is an error and the program stops + if (y == 0) stop + ! Map the sub-area indices from the aggregated grid using the map_tile array + subi(j, i) = map_tile(x, y) endif enddo enddo -open(88,file="output/Pfaf_isub_M09.txt") -do i=1,nc - write(88,'(150(i8))') subi(:,i) +! Open an output file to write the computed sub-catchment tile indices +open(88, file="output/Pfaf_isub_M09.txt") +do i = 1, nc + write(88, '(150(i8))') subi(:, i) enddo - - - end program main diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 index a96e9fa23..637f116e7 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_isub_M36.f90 @@ -1,39 +1,53 @@ program main +!Main purpose: Assigns a catchment鈥恡ile index from maptile files to each sub-catchment for M36 grid. use river_read ! Use custom module for reading NetCDF files +use constant, only: nlat=>nlat36, nlon=>nlon36, nmax=>nmax36, nc implicit none -integer,parameter :: nlat=406,nlon=964 -integer,parameter :: nmax=150 ! Maximum number of sub-areas per catchment -integer,parameter :: nc=291284 ! Total number of catchments +! Declare allocatable arrays for grid mapping and sub-catchment indices +integer,allocatable :: map_tile(:,:), subx(:,:), suby(:,:), subi(:,:) -integer,allocatable :: map_tile(:,:),subx(:,:),suby(:,:),subi(:,:) +! Declare integer variables for loop indices and temporary storage +integer :: i, x, y, j, it -integer :: i,x,y,j,it - -allocate(map_tile(nlon,nlat)) +! Allocate the mapping array for the aggregated grid with dimensions (nlon, nlat) +allocate(map_tile(nlon, nlat)) +! Read mapping data from the NetCDF file into the map_tile array call read_ncfile_int2d("temp/map_tile_M36.nc", "data", map_tile, nlon, nlat) -allocate(subx(nmax,nc),suby(nmax,nc),subi(nmax,nc)) -open(77,file="output/Pfaf_xsub_M36.txt"); read(77,*)subx -open(77,file="output/Pfaf_ysub_M36.txt"); read(77,*)suby -subi=0 -do i=1,nc - do j=1,nmax - x=subx(j,i) - y=suby(j,i) - if(x/=0)then - if(y==0)stop - subi(j,i)=map_tile(x,y) + +! Allocate arrays to store sub-catchment x and y coordinates and their mapped indices +allocate(subx(nmax, nc), suby(nmax, nc), subi(nmax, nc)) + +! Open and read the sub-catchment x-coordinates from a text file into the subx array +open(77, file="output/Pfaf_xsub_M36.txt") +read(77, *) subx + +! Open and read the sub-catchment y-coordinates from a text file into the suby array +open(77, file="output/Pfaf_ysub_M36.txt") +read(77, *) suby + +! Initialize the sub-area index array to zero +subi = 0 + +! Loop over each catchment +do i = 1, nc + ! Loop over each potential sub-area within the current catchment + do j = 1, nmax + x = subx(j, i) ! Retrieve the x-coordinate for the sub-area + y = suby(j, i) ! Retrieve the y-coordinate for the sub-area + if (x /= 0) then ! Check if a valid sub-area exists (non-zero x-coordinate) + if (y == 0) stop ! If x is valid but y is zero, there is an error, so stop the program + subi(j, i) = map_tile(x, y) ! Map the sub-area coordinates to a global tile index using map_tile endif enddo enddo -open(88,file="output/Pfaf_isub_M36.txt") -do i=1,nc - write(88,'(150(i7))') subi(:,i) +! Open an output file to write the computed sub-catchment tile indices +open(88, file="output/Pfaf_isub_M36.txt") +do i = 1, nc + write(88, '(150(i7))') subi(:, i) enddo - - - end program main + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py index 9fc5d4b5c..790e12a8d 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_latloni_cellarea.py @@ -1,14 +1,12 @@ +import sys import numpy as np import os from netCDF4 import Dataset -# Define file paths -lat36_file = "input/lat_M36.txt" -lon36_file = "input/lon_M36.txt" -lat1m_file = "input/lat_1m.txt" -lon1m_file = "input/lon_1m.txt" -lat09_file = "input/lat_M09.txt" -lon09_file = "input/lon_M09.txt" +#Main purpose: Computes grid-cell index arrays and per-cell areas for 1-m high-res grid. + +lat36_file, lon36_file, lat09_file, lon09_file, lat1m_file, lon1m_file = sys.argv[1:7] + lati36_output_file = "temp/lati_1m_M36.txt" loni36_output_file = "temp/loni_1m_M36.txt" lati09_output_file = "temp/lati_1m_M09.txt" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 index f11340f06..bb0dc5c74 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M09.f90 @@ -1,35 +1,62 @@ program main +!Main purpose: Extracts the latitude/longitude boundaries of each catchment-tile from catchment definition files for M09 grid. + +use constant, only : nt=>nt09 implicit none -integer,parameter :: nt=1684725 - -integer,allocatable,dimension(:) :: id, catid -real,allocatable,dimension(:) :: lon_left,lon_right,lat_bottom,lat_top - -integer :: i,ntot - -allocate(id(nt),catid(nt),lon_left(nt),lon_right(nt),lat_bottom(nt),lat_top(nt)) -open(77,file="input/catchment_M09.def") -read(77,*)ntot -do i=1,nt - read(77,*)id(i),catid(i),lon_left(i),lon_right(i),lat_bottom(i),lat_top(i) -enddo - -open(88,file="temp/lon_left_M09.txt") -do i=1,nt - write(88,*)lon_left(i) -enddo -open(88,file="temp/lon_right_M09.txt") -do i=1,nt - write(88,*)lon_right(i) -enddo -open(88,file="temp/lat_bottom_M09.txt") -do i=1,nt - write(88,*)lat_bottom(i) -enddo -open(88,file="temp/lat_upper_M09.txt") -do i=1,nt - write(88,*)lat_top(i) -enddo + +! Declare allocatable arrays for catchment ID, parent catchment ID, +! and geographical boundaries (longitude and latitude extents) +integer, allocatable, dimension(:) :: id, catid +real, allocatable, dimension(:) :: lon_left, lon_right, lat_bottom, lat_top + +integer :: i, ntot ! Loop counter and total number of catchments read from file + +! Define file path for input routing data: +character(len=900) :: file_path !"input/catchment_M09.def" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays with size nt +allocate(id(nt), catid(nt), lon_left(nt), lon_right(nt), lat_bottom(nt), lat_top(nt)) + +! Open input file that contains catchment definitions +open(77, file=trim(file_path)) +! Read total number of catchments (ntot) from the file header +read(77, *) ntot + +! Loop over each catchment and read the definitions: +! id, catchment id, left and right longitudes, bottom and top latitudes +do i = 1, nt + read(77, *) id(i), catid(i), lon_left(i), lon_right(i), lat_bottom(i), lat_top(i) +end do + +! Write the left longitude values to a temporary output file +open(88, file="temp/lon_left_M09.txt") +do i = 1, nt + write(88, *) lon_left(i) +end do + +! Write the right longitude values to a temporary output file +open(88, file="temp/lon_right_M09.txt") +do i = 1, nt + write(88, *) lon_right(i) +end do + +! Write the bottom latitude values to a temporary output file +open(88, file="temp/lat_bottom_M09.txt") +do i = 1, nt + write(88, *) lat_bottom(i) +end do + +! Write the upper (top) latitude values to a temporary output file +open(88, file="temp/lat_upper_M09.txt") +do i = 1, nt + write(88, *) lat_top(i) +end do end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 index 2bc7a9592..a033bd133 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlat_bond_M36.f90 @@ -1,35 +1,59 @@ program main +!Main purpose: Extracts the latitude/longitude boundaries of each catchment-tile from catchment definition files for M36 grid. + +use constant, only : nt=>nt36 implicit none -integer,parameter :: nt=112573 - -integer,allocatable,dimension(:) :: id, catid -real,allocatable,dimension(:) :: lon_left,lon_right,lat_bottom,lat_top - -integer :: i,ntot - -allocate(id(nt),catid(nt),lon_left(nt),lon_right(nt),lat_bottom(nt),lat_top(nt)) -open(77,file="input/catchment_M36.def") -read(77,*)ntot -do i=1,nt - read(77,*)id(i),catid(i),lon_left(i),lon_right(i),lat_bottom(i),lat_top(i) -enddo - -open(88,file="temp/lon_left_M36.txt") -do i=1,nt - write(88,*)lon_left(i) -enddo -open(88,file="temp/lon_right_M36.txt") -do i=1,nt - write(88,*)lon_right(i) -enddo -open(88,file="temp/lat_bottom_M36.txt") -do i=1,nt - write(88,*)lat_bottom(i) -enddo -open(88,file="temp/lat_upper_M36.txt") -do i=1,nt - write(88,*)lat_top(i) -enddo + +! Declare allocatable arrays for catchment ID, parent catchment ID, and boundary coordinates +integer, allocatable, dimension(:) :: id, catid +real, allocatable, dimension(:) :: lon_left, lon_right, lat_bottom, lat_top + +integer :: i, ntot ! 'i' is the loop counter; 'ntot' holds the total number of catchments read from the file + +! Define file path for input routing data: +character(len=900) :: file_path !"input/catchment_M36.def" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays with size nt +allocate(id(nt), catid(nt), lon_left(nt), lon_right(nt), lat_bottom(nt), lat_top(nt)) + +! Open the catchment definition file for the M36 grid and read the total number of catchments (header) +open(77, file=trim(file_path)) +read(77, *) ntot + +! Loop over each catchment and read: id, catchment id, left/right longitudes, bottom/top latitudes +do i = 1, nt + read(77, *) id(i), catid(i), lon_left(i), lon_right(i), lat_bottom(i), lat_top(i) +end do + +! Write the left boundary longitudes to an output file +open(88, file="temp/lon_left_M36.txt") +do i = 1, nt + write(88, *) lon_left(i) +end do + +! Write the right boundary longitudes to an output file +open(88, file="temp/lon_right_M36.txt") +do i = 1, nt + write(88, *) lon_right(i) +end do + +! Write the bottom boundary latitudes to an output file +open(88, file="temp/lat_bottom_M36.txt") +do i = 1, nt + write(88, *) lat_bottom(i) +end do + +! Write the top boundary latitudes to an output file +open(88, file="temp/lat_upper_M36.txt") +do i = 1, nt + write(88, *) lat_top(i) +end do end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py index 94fa5c040..9ecf8396d 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M09.py @@ -1,6 +1,8 @@ +import sys import numpy as np from netCDF4 import Dataset import os +#Main purpose: Assigns a catchment鈥恡ile index from catchment definition files to each model grid cell for M09 grid. # Load data nt = 1684725 @@ -19,8 +21,10 @@ lonc = (lon_left + lon_right) / 2.0 # Read latitudes and longitudes for the grid -lat36m = np.loadtxt("input/lat_M09.txt", dtype=float) -lon36m = np.loadtxt("input/lon_M09.txt", dtype=float) +lat09_file, lon09_file = sys.argv[1:3] + +lat09m = np.loadtxt(lat09_file, dtype=float) +lon09m = np.loadtxt(lon09_file, dtype=float) # Find the nearest coordinates def ind_nearest_coord(coord_array1, coord_array2): @@ -33,8 +37,8 @@ def ind_nearest_coord(coord_array1, coord_array2): indices.append(index) return np.array(indices) -lati = ind_nearest_coord(latc, lat36m) -loni = ind_nearest_coord(lonc, lon36m) +lati = ind_nearest_coord(latc, lat09m) +loni = ind_nearest_coord(lonc, lon09m) # Save the indices to files (1-based index) np.savetxt("temp/lati_tile_M09.txt", lati + 1, fmt='%d') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py index 112e8572f..08b57572c 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_lonlati_maptile_M36.py @@ -1,6 +1,8 @@ +import sys import numpy as np from netCDF4 import Dataset import os +#Main purpose: Assigns a catchment鈥恡ile index from catchment definition files to each model grid cell for M36 grid. # Load data nt = 112573 @@ -19,8 +21,10 @@ lonc = (lon_left + lon_right) / 2.0 # Read latitudes and longitudes for the grid -lat36m = np.loadtxt("input/lat_M36.txt", dtype=float) -lon36m = np.loadtxt("input/lon_M36.txt", dtype=float) +lat36_file, lon36_file = sys.argv[1:3] + +lat36m = np.loadtxt(lat36_file, dtype=float) +lon36m = np.loadtxt(lon36_file, dtype=float) # Find the nearest coordinates def ind_nearest_coord(coord_array1, coord_array2): diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 index d7714859b..f1cc1be7c 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M09.f90 @@ -1,85 +1,113 @@ program main +!Main purpose: Assigns a catchment鈥恡ile index from catchment definition files to each model grid cell for M09 grid. use river_read +use constant, only : nmax=>nmax09, nc, nlon, nlat + implicit none -integer,parameter :: nmax=458 -integer,parameter :: nc=291284 -integer,parameter :: nlon=21600 -integer,parameter :: nlat=10800 - -integer :: id,xi,yi,i,flag,subi -integer :: nsub(nc) -integer,allocatable :: xsub(:,:),ysub(:,:) -real,allocatable :: asub(:,:) - -real*8,allocatable :: lon(:),lat(:) -integer,allocatable :: loni(:),lati(:) -integer,allocatable :: catchind(:,:) -real,allocatable :: cellarea(:,:) - -allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) -allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) -allocate(lon(nlon),lat(nlat)) -allocate(loni(nlon),lati(nlat)) - - -call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) -call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) -call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) -call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) -cellarea=cellarea/1.e6 - - -open(10,file="temp/lati_1m_M09.txt") -read(10,*)lati -open(11,file="temp/loni_1m_M09.txt") -read(11,*)loni - -nsub=0 -xsub=0 -ysub=0 -asub=0. -do xi=1,nlon - do yi=1,nlat - if(catchind(xi,yi)>=1)then - - id=catchind(xi,yi) - flag=0 - if(nsub(id)>=1)then - do i=1,nsub(id) - if(loni(xi)==xsub(i,id).and.lati(yi)==ysub(i,id))then - flag=1 - asub(i,id)=asub(i,id)+cellarea(xi,yi) - exit +! Variable declarations: +integer :: id, xi, yi, i, flag, subi +integer :: nsub(nc) ! Array storing the number of sub-areas for each catchment + +! Allocatable arrays for sub-catchment information: +integer, allocatable :: xsub(:,:), ysub(:,:) +real, allocatable :: asub(:,:) ! Aggregated area for each sub-catchment + +! Arrays for grid data and mapping: +real*8, allocatable :: lon(:), lat(:) ! Longitude and latitude arrays from NetCDF file +integer, allocatable :: loni(:), lati(:) ! Mapped integer indices from 1-minute resolution files +integer, allocatable :: catchind(:,:) ! 2D array of catchment indices for each grid cell +real, allocatable :: cellarea(:,:) ! 2D array of cell areas + + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays based on the defined dimensions: +allocate(xsub(nmax, nc), ysub(nmax, nc), asub(nmax, nc)) +allocate(catchind(nlon, nlat), cellarea(nlon, nlat)) +allocate(lon(nlon), lat(nlat)) +allocate(loni(nlon), lati(nlat)) + +! Read grid longitude, latitude, catchment index, and cell area data from NetCDF files: +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +cellarea = cellarea / 1.e6 ! Convert cell area units (from m^2 to km^2) + +! Read mapped grid indices for 1-minute resolution from text files: +open(10, file="temp/lati_1m_M09.txt") +read(10, *) lati +open(11, file="temp/loni_1m_M09.txt") +read(11, *) loni + +! Initialize aggregation arrays: +nsub = 0 ! Set number of sub-areas per catchment to zero +xsub = 0 ! Initialize x-coordinate array for sub-catchments to zero +ysub = 0 ! Initialize y-coordinate array for sub-catchments to zero +asub = 0. ! Initialize aggregated area values to zero + +! Loop over each 1m grid cell to accumulate cell areas into sub-catchments: +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi, yi) >= 1) then + ! The cell belongs to a catchment: + id = catchind(xi, yi) ! Retrieve the catchment id for the current cell + flag = 0 ! Reset flag; will be set to 1 if a matching sub-area is found + + ! Check if this catchment already has at least one sub-area: + if (nsub(id) >= 1) then + do i = 1, nsub(id) + ! If the mapped indices of the current cell match an existing sub-area: + if (loni(xi) == xsub(i, id) .and. lati(yi) == ysub(i, id)) then + flag = 1 + ! Accumulate the cell area into the existing sub-area: + asub(i, id) = asub(i, id) + cellarea(xi, yi) + exit ! Exit the loop once the match is found endif - enddo + end do endif - if(flag==0)then - nsub(id)=nsub(id)+1 - xsub(nsub(id),id)=loni(xi) - ysub(nsub(id),id)=lati(yi) - asub(nsub(id),id)=cellarea(xi,yi) + + ! If no matching sub-area was found, create a new sub-area for this catchment: + if (flag == 0) then + nsub(id) = nsub(id) + 1 + xsub(nsub(id), id) = loni(xi) + ysub(nsub(id), id) = lati(yi) + asub(nsub(id), id) = cellarea(xi, yi) endif endif - enddo -enddo - -open(50,file="output/Pfaf_nsub_M09.txt") -open(51,file="output/Pfaf_xsub_M09.txt") -open(52,file="output/Pfaf_ysub_M09.txt") -open(53,file="output/Pfaf_asub_M09.txt") -do i=1,nc - write(50,*)nsub(i) - write(51,'(458(1x,i4))')xsub(:,i) - write(52,'(458(1x,i4))')ysub(:,i) - write(53,'(458(1x,f10.4))')asub(:,i) -enddo - -print *,maxval(nsub) -print *,maxloc(nsub) - - - -end + end do +end do + +! Open output files to write the aggregated sub-catchment information: +open(50, file="output/Pfaf_nsub_M09.txt") +open(51, file="output/Pfaf_xsub_M09.txt") +open(52, file="output/Pfaf_ysub_M09.txt") +open(53, file="output/Pfaf_asub_M09.txt") + +! For each catchment, write: +! - Number of sub-areas +! - X indices of sub-areas (formatted in groups of 458 integers) +! - Y indices of sub-areas (formatted similarly) +! - Aggregated area values of sub-areas (formatted as floating-point numbers) +do i = 1, nc + write(50, *) nsub(i) + write(51, '(458(1x,i4))') xsub(:, i) + write(52, '(458(1x,i4))') ysub(:, i) + write(53, '(458(1x,f10.4))') asub(:, i) +end do + +! Print the maximum number of sub-areas found for any catchment and its location: +print *, maxval(nsub) +print *, maxloc(nsub) + +end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 index c5495381e..8a5725800 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_num_sub_catchment_M36.f90 @@ -1,85 +1,107 @@ program main +!Main purpose: Assigns a catchment鈥恡ile index from catchment definition files to each model grid cell for M36 grid. use river_read +use constant, only : nmax=>nmax36, nc, nlon, nlat + implicit none -integer,parameter :: nmax=150 -integer,parameter :: nc=291284 -integer,parameter :: nlon=21600 -integer,parameter :: nlat=10800 - -integer :: id,xi,yi,i,flag,subi -integer :: nsub(nc) -integer,allocatable :: xsub(:,:),ysub(:,:),subi_global(:,:) -real,allocatable :: asub(:,:) - -real*8,allocatable :: lon(:),lat(:) -integer,allocatable :: loni(:),lati(:) -integer,allocatable :: catchind(:,:) -real,allocatable :: cellarea(:,:) - -allocate(xsub(nmax,nc),ysub(nmax,nc),asub(nmax,nc)) -allocate(catchind(nlon,nlat),cellarea(nlon,nlat)) -allocate(lon(nlon),lat(nlat)) -allocate(loni(nlon),lati(nlat)) - - -call read_ncfile_double1d("input/CatchIndex.nc","lon",lon,nlon) -call read_ncfile_double1d("input/CatchIndex.nc","lat",lat,nlat) -call read_ncfile_int2d("input/CatchIndex.nc","data",catchind,nlon,nlat) -call read_ncfile_real2d("temp/cellarea.nc","data",cellarea,nlon,nlat) -cellarea=cellarea/1.e6 - - -open(10,file="temp/lati_1m_M36.txt") -read(10,*)lati -open(11,file="temp/loni_1m_M36.txt") -read(11,*)loni - -nsub=0 -xsub=0 -ysub=0 -asub=0. -do xi=1,nlon - do yi=1,nlat - if(catchind(xi,yi)>=1)then - - id=catchind(xi,yi) - flag=0 - if(nsub(id)>=1)then - do i=1,nsub(id) - if(loni(xi)==xsub(i,id).and.lati(yi)==ysub(i,id))then - flag=1 - asub(i,id)=asub(i,id)+cellarea(xi,yi) - exit + +! Variable declarations: +integer :: id, xi, yi, i, flag, subi +integer :: nsub(nc) ! Array to store the number of sub-areas for each catchment +integer, allocatable :: xsub(:,:), ysub(:,:), subi_global(:,:) +! xsub and ysub: 2D arrays to store mapped x and y indices for sub-catchments (not using subi_global in this code) +real, allocatable :: asub(:,:) ! 2D array to store aggregated area for each sub-catchment + +real*8, allocatable :: lon(:), lat(:) ! Arrays to hold longitude and latitude values from the NetCDF file +integer, allocatable :: loni(:), lati(:) +! loni and lati: Arrays holding mapping indices from 1-minute resolution data files +integer, allocatable :: catchind(:,:) ! 2D array holding catchment indices for each grid cell +real, allocatable :: cellarea(:,:) ! 2D array containing the area of each grid cell + +! Define file path for input routing data: +character(len=900) :: file_path !"input/CatchIndex.nc" + +if (command_argument_count() /= 1) then + print *, "no found" + stop +endif +call get_command_argument(1, file_path) + +! Allocate arrays with the specified dimensions: +allocate(xsub(nmax, nc), ysub(nmax, nc), asub(nmax, nc)) +allocate(catchind(nlon, nlat), cellarea(nlon, nlat)) +allocate(lon(nlon), lat(nlat)) +allocate(loni(nlon), lati(nlat)) + +! Read grid information from the NetCDF file "CatchIndex.nc": +call read_ncfile_double1d(trim(file_path), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_path), "latitude", lat, nlat) +call read_ncfile_int2d(trim(file_path), "CatchIndex", catchind, nlon, nlat) +! Read cell area data from the NetCDF file "cellarea.nc": +call read_ncfile_real2d("temp/cellarea.nc", "data", cellarea, nlon, nlat) +cellarea = cellarea / 1.e6 ! Convert cell area (e.g., from m^2 to km^2) + +! Read mapping indices for the 1-minute resolution grid from text files: +open(10, file="temp/lati_1m_M36.txt") +read(10, *) lati +open(11, file="temp/loni_1m_M36.txt") +read(11, *) loni + +! Initialize aggregation arrays to zero: +nsub = 0 +xsub = 0 +ysub = 0 +asub = 0. + +! Loop over all grid cells to aggregate cell areas by catchment and sub-area: +do xi = 1, nlon + do yi = 1, nlat + if (catchind(xi, yi) >= 1) then + ! The grid cell belongs to a catchment + id = catchind(xi, yi) ! Get the catchment id for the current cell + flag = 0 ! Reset flag to indicate whether a matching sub-area is found + + ! If the catchment already has one or more sub-areas, check for a matching sub-area: + if (nsub(id) >= 1) then + do i = 1, nsub(id) + if (loni(xi) == xsub(i, id) .and. lati(yi) == ysub(i, id)) then + flag = 1 + ! If a match is found, accumulate the cell area into the existing sub-area: + asub(i, id) = asub(i, id) + cellarea(xi, yi) + exit ! Exit the inner loop since a matching sub-area has been found endif - enddo + end do endif - if(flag==0)then - nsub(id)=nsub(id)+1 - xsub(nsub(id),id)=loni(xi) - ysub(nsub(id),id)=lati(yi) - asub(nsub(id),id)=cellarea(xi,yi) + + ! If no matching sub-area was found, create a new sub-area: + if (flag == 0) then + nsub(id) = nsub(id) + 1 + xsub(nsub(id), id) = loni(xi) + ysub(nsub(id), id) = lati(yi) + asub(nsub(id), id) = cellarea(xi, yi) endif endif - enddo -enddo - -open(50,file="output/Pfaf_nsub_M36.txt") -open(51,file="output/Pfaf_xsub_M36.txt") -open(52,file="output/Pfaf_ysub_M36.txt") -open(53,file="output/Pfaf_asub_M36.txt") -do i=1,nc - write(50,*)nsub(i) - write(51,'(150(1x,i3))')xsub(:,i) - write(52,'(150(1x,i3))')ysub(:,i) - write(53,'(150(1x,f10.4))')asub(:,i) -enddo - -print *,maxval(nsub) -print *,maxloc(nsub) - - + end do +end do + +! Open output files to write the aggregated sub-catchment information: +open(50, file="output/Pfaf_nsub_M36.txt") +open(51, file="output/Pfaf_xsub_M36.txt") +open(52, file="output/Pfaf_ysub_M36.txt") +open(53, file="output/Pfaf_asub_M36.txt") +! Loop over all catchments and write: +do i = 1, nc + write(50, *) nsub(i) ! Write the number of sub-areas for catchment i + write(51, '(150(1x,i3))') xsub(:, i) ! Write the x indices for all sub-areas (formatted as 3-digit integers) + write(52, '(150(1x,i3))') ysub(:, i) ! Write the y indices for all sub-areas (formatted as 3-digit integers) + write(53, '(150(1x,f10.4))') asub(:, i) ! Write the aggregated areas for all sub-areas (formatted as floating-point numbers) +end do + +! Print the maximum number of sub-areas found for any catchment and its location: +print *, maxval(nsub) +print *, maxloc(nsub) end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 index d7a761f6f..86945ee83 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/get_river_length.f90 @@ -1,248 +1,250 @@ program main +!Main purpose: Determines main river channel lengths for each catchment by using HydroSHEDS data of distance to sink. use river_read -implicit none - -integer :: nc=291284 -real :: cur_avg=1.4 -real :: cur_min=0.5 -real :: cur_max=5. - -integer,parameter :: nlon=21600 -integer,parameter :: nlat=10800 -real*8,allocatable :: lon(:),lat(:) -real,allocatable :: ldn1m(:,:),elev1m(:,:) -integer,allocatable :: catid(:,:),flag_slp(:) - -integer,parameter :: nlonh=86400 -integer,parameter :: nlath=33600 -real*8,allocatable :: lonh(:),lath(:) -real,allocatable :: ldnh(:,:),elev_15s(:,:) - -real,allocatable,dimension(:) :: lon_dn,lat_dn,lon_up,lat_up,dist_ref,dist_ref2,ldn_min,ldn_max,riv_len,str_len,slp -real,allocatable,dimension(:) :: lon_min,lon_max,lat_min,lat_max,area,elevdiff_ref,elevdiff -integer,allocatable,dimension(:) :: xi_min,yi_min,xi_max,yi_max -integer,allocatable,dimension(:) :: downid - +use constant, only : nc, nlon, nlat, nlonh, nlath, cur_avg, cur_min, cur_max +implicit none -integer xi,yi -integer :: num,i,j,cid,did,k -integer :: data1,data12 -real*8 :: data2 -real :: data7,data9,data10 -real :: elev_temp +real*8, allocatable :: lon(:), lat(:) +real, allocatable :: ldn1m(:,:), elev1m(:,:) +integer, allocatable :: catid(:,:), flag_slp(:) + +real*8, allocatable :: lonh(:), lath(:) +real, allocatable :: ldnh(:,:), elev_15s(:,:) + +! Declare arrays to hold routing and catchment characteristics: +real, allocatable, dimension(:) :: lon_dn, lat_dn, lon_up, lat_up, dist_ref, dist_ref2, ldn_min, ldn_max, riv_len, str_len, slp +real, allocatable, dimension(:) :: lon_min, lon_max, lat_min, lat_max, area, elevdiff_ref, elevdiff +integer, allocatable, dimension(:) :: xi_min, yi_min, xi_max, yi_max +integer, allocatable, dimension(:) :: downid + +! Loop indices and temporary variables +integer xi, yi +integer :: num, i, j, cid, did, k +integer :: data1, data12 +real*8 :: data2 +real :: data7, data9, data10 +real :: elev_temp + +character(len=100) :: file_pfafmap !input/SRTM_PfafData.nc +character(len=100) :: file_ldn !input/hyd_glo_ldn_15s.nc +character(len=100) :: file_hyelev !input/hyd_glo_dem_15s.nc +character(len=100) :: file_pfafrout !input/Pfafcatch-routing.dat + + if (command_argument_count() /= 4) then + print *, "no found" + stop + endif + call get_command_argument(1, file_pfafmap) + call get_command_argument(2, file_ldn) + call get_command_argument(3, file_hyelev) + call get_command_argument(4, file_pfafrout) !----------------------------------------------------------------------- -!Regrid LDN from HydroSHEDS - -allocate(ldn1m(nlon,nlat),catid(nlon,nlat)) -allocate(lon(nlon),lat(nlat)) -call read_ncfile_double1d("input/SRTM_PfafData.nc","longitude",lon,nlon) -call read_ncfile_double1d("input/SRTM_PfafData.nc","latitude",lat,nlat) -call read_ncfile_int2d("input/SRTM_PfafData.nc","CatchIndex",catid,nlon,nlat) -ldn1m=-1. -where(catid==-9999) ldn1m=-9999. - -allocate(ldnh(nlonh,nlath)) -call read_ncfile_real2d("input/hyd_glo_ldn_15s.nc","Band1",ldnh,nlonh,nlath) -where(ldnh.lt.4.e9) ldnh=ldnh/1.e3 !m -> km - -do xi=1,nlon - do yi=2041,10440 - if(ldn1m(xi,yi).ne.-9999.)then - ldn1m(xi,yi)=minval(ldnh(4*xi-3:4*xi,4*yi-3-8160:4*yi-8160)) - if(ldn1m(xi,yi).gt.4.e9)ldn1m(xi,yi)=-1. +! Regrid LDN (length to sink) from HydroSHEDS data + +allocate(ldn1m(nlon, nlat), catid(nlon, nlat)) +allocate(lon(nlon), lat(nlat)) +! Read longitude, latitude, and catchment index data from SRTM Pfaf data +call read_ncfile_double1d(trim(file_pfafmap), "longitude", lon, nlon) +call read_ncfile_double1d(trim(file_pfafmap), "latitude", lat, nlat) +call read_ncfile_int2d(trim(file_pfafmap), "CatchIndex", catid, nlon, nlat) +ldn1m = -1. +where(catid == -9999) ldn1m = -9999. + +! Allocate high-resolution LDN array and read data from HydroSHEDS 15s file +allocate(ldnh(nlonh, nlath)) +call read_ncfile_real2d(trim(file_ldn), "Band1", ldnh, nlonh, nlath) +where(ldnh.lt.4.e9) ldnh = ldnh / 1.e3 ! Convert from meters to kilometers + +! Regrid: For each grid cell in the M09 grid, assign the minimum LDN value from the corresponding high-res block. +do xi = 1, nlon + do yi = 2041, 10440 + if (ldn1m(xi, yi) .ne. -9999.) then + ldn1m(xi, yi) = minval(ldnh(4*xi-3:4*xi, 4*yi-3-8160:4*yi-8160)) + if (ldn1m(xi, yi) .gt. 4.e9) ldn1m(xi, yi) = -1. end if - enddo -enddo -print *,maxval(ldn1m) - -allocate(ldn_min(nc),ldn_max(nc),xi_min(nc),yi_min(nc),xi_max(nc),yi_max(nc)) -ldn_min=1.e20 -ldn_max=-9999. -xi_min=-9999;yi_min=-9999;xi_max=-9999;yi_max=-9999 -do i=1,nlon - do j=1,nlat - if(catid(i,j)>=1)then - cid=catid(i,j) - if(ldn1m(i,j)>0. .and. ldn1m(i,j)= 1) then + cid = catid(i, j) + if (ldn1m(i, j) > 0. .and. ldn1m(i, j) < ldn_min(cid)) then + ldn_min(cid) = ldn1m(i, j) + xi_min(cid) = i + yi_min(cid) = j endif - if(ldn1m(i,j)>0. .and. ldn1m(i,j)>ldn_max(cid))then - ldn_max(cid)=ldn1m(i,j) - xi_max(cid)=i - yi_max(cid)=j + if (ldn1m(i, j) > 0. .and. ldn1m(i, j) > ldn_max(cid)) then + ldn_max(cid) = ldn1m(i, j) + xi_max(cid) = i + yi_max(cid) = j endif endif - enddo -enddo -where(ldn_min==1.e20)ldn_min=-9999 - -!open(88,file="xi_yi_min.txt") -!do i=1,nc -! write(88,*)xi_min(i),yi_min(i) -!enddo + end do +end do +where(ldn_min == 1.e20) ldn_min = -9999 - -allocate(elev_15s(nlonh,nlath),elev1m(nlon,nlat)) -call read_ncfile_real2d("input/hyd_glo_dem_15s.nc","Band1",elev_15s,nlonh,nlath) -where(elev_15s>30000.)elev_15s=0. -elev1m=0. -do xi=1,nlon - do yi=2041,10440 - elev1m(xi,yi)=sum(elev_15s(4*xi-3:4*xi,4*yi-3-8160:4*yi-8160))/16. - enddo -enddo - -!call create_ncfile_real2d("elev_1m.nc","data",elev1m,lon,lat,nlon,nlat) - -deallocate(ldnh,elev_15s) !----------------------------------------------------------------------- -!Get reference distance - -open(77,file="input/Pfafcatch-routing.dat", form="formatted", status="old") -read(77,*)num -allocate(lon_dn(nc),lat_dn(nc),lon_up(nc),lat_up(nc),dist_ref(nc),dist_ref2(nc)) -allocate(lon_min(nc),lon_max(nc),lat_min(nc),lat_max(nc),area(nc),elevdiff_ref(nc),elevdiff(nc)) +! Compute elevation at 1-minute resolution from high-resolution DEM (15s) +allocate(elev_15s(nlonh, nlath), elev1m(nlon, nlat)) +call read_ncfile_real2d(trim(file_hyelev), "Band1", elev_15s, nlonh, nlath) +where(elev_15s > 30000.) elev_15s = 0. +elev1m = 0. +do xi = 1, nlon + do yi = 2041, 10440 + elev1m(xi, yi) = sum(elev_15s(4*xi-3:4*xi, 4*yi-3-8160:4*yi-8160)) / 16. + end do +end do + + +deallocate(ldnh, elev_15s) +!----------------------------------------------------------------------- +! Get reference distances using routing data -do i=1,nc - read(77,*)data1,data2,lon_min(i),lon_max(i),lat_min(i),lat_max(i),data7,area(i),data9,data10,elevdiff_ref(i),data12,lon_dn(i),lat_dn(i),lon_up(i),lat_up(i) -enddo +open(77, file=trim(file_pfafrout), form="formatted", status="old") +read(77, *) num +allocate(lon_dn(nc), lat_dn(nc), lon_up(nc), lat_up(nc), dist_ref(nc), dist_ref2(nc)) +allocate(lon_min(nc), lon_max(nc), lat_min(nc), lat_max(nc), area(nc), elevdiff_ref(nc), elevdiff(nc)) -do i=1,nc - dist_ref(i)=spherical_distance(lon_dn(i), lat_dn(i), lon_up(i), lat_up(i)) - dist_ref2(i)=spherical_distance(lon_min(i), lat_min(i), lon_max(i), lat_max(i)) -enddo -where(dist_ref>dist_ref2.or.dist_ref==0.)dist_ref=0.5*dist_ref2 +! Read routing and catchment geometry data from the Pfafcatch routing file +do i = 1, nc + read(77, *) data1, data2, lon_min(i), lon_max(i), lat_min(i), lat_max(i), data7, area(i), data9, data10, elevdiff_ref(i), data12, lon_dn(i), lat_dn(i), lon_up(i), lat_up(i) +end do +! Compute spherical distances reference +do i = 1, nc + dist_ref(i) = spherical_distance(lon_dn(i), lat_dn(i), lon_up(i), lat_up(i)) + dist_ref2(i) = spherical_distance(lon_min(i), lat_min(i), lon_max(i), lat_max(i)) +end do +where(dist_ref > dist_ref2 .or. dist_ref == 0.) dist_ref = 0.5 * dist_ref2 !-------------------------------------------------------------------- -! Get intial guess of river length -allocate(riv_len(nc),downid(nc),flag_slp(nc)) -open(77,file="output/downstream_1D_new_noadj.txt") -read(77,*)downid - -!open(88,file="temp/xi_yi_min.txt") -!do i=1,nc -! write(88,*)xi_min(i),yi_min(i) -!enddo -!open(88,file="temp/xi_yi_max.txt") -!do i=1,nc -! write(88,*)xi_max(i),yi_max(i) -!enddo - - -flag_slp=1 - -riv_len=-9999. -elevdiff=-9999. -do i=1,nc - if(downid(i)>=1)then - did=downid(i) - if(.not. (riv_len(did)>=cur_min*dist_ref(did).and.riv_len(did)<=cur_max*dist_ref(did)) )then - riv_len(did)=ldn_min(i)-ldn_min(did) - if(xi_min(i)>0.and.xi_min(did)>0)then - elevdiff(did)=max(0.,elev1m(xi_min(i),yi_min(i)) - elev1m(xi_min(did),yi_min(did))) - flag_slp(did)=1 +! Get initial guess of river length (riv_len) based on LDN differences and elevation differences + +allocate(riv_len(nc), downid(nc), flag_slp(nc)) +open(77, file="output/downstream_1D_new_noadj.txt") +read(77, *) downid + +flag_slp = 1 + +riv_len = -9999. +elevdiff = -9999. +do i = 1, nc + if (downid(i) >= 1) then + did = downid(i) + if (.not. (riv_len(did) >= cur_min * dist_ref(did) .and. riv_len(did) <= cur_max * dist_ref(did))) then + riv_len(did) = ldn_min(i) - ldn_min(did) + if (xi_min(i) > 0 .and. xi_min(did) > 0) then + elevdiff(did) = max(0., elev1m(xi_min(i), yi_min(i)) - elev1m(xi_min(did), yi_min(did))) + flag_slp(did) = 1 else - elevdiff(did)=elevdiff_ref(did) - flag_slp(did)=0 + elevdiff(did) = elevdiff_ref(did) + flag_slp(did) = 0 endif - else if(flag_slp(did)==0.or.elevdiff(did)==0.)then - riv_len(did)=ldn_min(i)-ldn_min(did) - if(xi_min(i)>0.and.xi_min(did)>0)then - elevdiff(did)=max(0.,elev1m(xi_min(i),yi_min(i)) - elev1m(xi_min(did),yi_min(did))) - flag_slp(did)=1 + else if (flag_slp(did) == 0 .or. elevdiff(did) == 0.) then + riv_len(did) = ldn_min(i) - ldn_min(did) + if (xi_min(i) > 0 .and. xi_min(did) > 0) then + elevdiff(did) = max(0., elev1m(xi_min(i), yi_min(i)) - elev1m(xi_min(did), yi_min(did))) + flag_slp(did) = 1 else - elevdiff(did)=elevdiff_ref(did) - flag_slp(did)=0 + elevdiff(did) = elevdiff_ref(did) + flag_slp(did) = 0 endif endif endif -enddo +end do -do i=1,nc - if(riv_len(i)==-9999.)then - riv_len(i)=(ldn_max(i)-ldn_min(i))*0.5 - if(xi_min(i)>0)then - elevdiff(i)=max(0.,0.5*elev1m(xi_max(i),yi_max(i)) - 0.5*elev1m(xi_min(i),yi_min(i)) ) +do i = 1, nc + if (riv_len(i) == -9999.) then + riv_len(i) = (ldn_max(i) - ldn_min(i)) * 0.5 + if (xi_min(i) > 0) then + elevdiff(i) = max(0., 0.5 * elev1m(xi_max(i), yi_max(i)) - 0.5 * elev1m(xi_min(i), yi_min(i))) else - elevdiff(i)=elevdiff_ref(i) - flag_slp(did)=0 + elevdiff(i) = elevdiff_ref(i) + flag_slp(i) = 0 endif endif -enddo - -k=0 -do i=1,nc - if(.not. (riv_len(i)>=cur_min*dist_ref(i).and.riv_len(i)<=cur_max*dist_ref(i)) )then - riv_len(i)=cur_avg*dist_ref(i) - elevdiff(i)=elevdiff_ref(i) - flag_slp(i)=0 - k=k+1 +end do + +k = 0 +do i = 1, nc + if (.not. (riv_len(i) >= cur_min * dist_ref(i) .and. riv_len(i) <= cur_max * dist_ref(i))) then + riv_len(i) = cur_avg * dist_ref(i) + elevdiff(i) = elevdiff_ref(i) + flag_slp(i) = 0 + k = k + 1 endif -enddo -open(88,file="output/Pfaf_lriv_PR.txt") -do i=1,nc - write(88,*) riv_len(i) -enddo - - +end do +open(88, file="output/Pfaf_lriv_PR.txt") +do i = 1, nc + write(88, *) riv_len(i) +end do !-------------------------------------------------------------------- -! Calculate the length scale of local streams +! Calculate the length scale of local streams based on catchment area and river length. allocate(str_len(nc)) -str_len=area/riv_len/4.*cur_avg -open(88,file="output/Pfaf_lstr_PR.txt") -do i=1,nc - write(88,*) str_len(i) -enddo +str_len = area / riv_len / 4. * cur_avg +open(88, file="output/Pfaf_lstr_PR.txt") +do i = 1, nc + write(88, *) str_len(i) +end do !-------------------------------------------------------------------- -! Calculate the Catchment slope +! Calculate the catchment slope from elevation difference and river length. allocate(slp(nc)) -slp=elevdiff*1.e-3/riv_len -where(slp.lt.1.e-5) flag_slp=0 -where(slp.lt.1.e-5) slp=1.e-5 -print *,sum(flag_slp) -open(88,file="temp/Pfaf_slope.txt") -do i=1,nc - write(88,*) slp(i) -enddo -print *,minval(slp) -open(88,file="temp/Pfaf_slope_flag.txt") -do i=1,nc - write(88,*)flag_slp(i) -enddo +slp = elevdiff * 1.e-3 / riv_len +where(slp.lt.1.e-5) flag_slp = 0 +where(slp.lt.1.e-5) slp = 1.e-5 +print *, sum(flag_slp) +open(88, file="temp/Pfaf_slope.txt") +do i = 1, nc + write(88, *) slp(i) +end do +print *, minval(slp) +open(88, file="temp/Pfaf_slope_flag.txt") +do i = 1, nc + write(88, *) flag_slp(i) +end do !-------------------------------------------------------------------- contains function spherical_distance(lon_dn, lat_dn, lon_up, lat_up) result(distance) implicit none - ! Declare variables - real, intent(in) :: lon_dn, lat_dn ! Input coordinates (downstream point) - real, intent(in) :: lon_up, lat_up ! Input coordinates (upstream point) - real :: distance ! Output distance (in kilometers) + !------------------------------------------------------------ + ! Function: spherical_distance + ! Purpose : Calculates the great-circle distance between two geographic + ! points using the Haversine formula. + ! + ! Input: + ! lon_dn, lat_dn - Longitude and latitude of the first point (degrees) + ! lon_up, lat_up - Longitude and latitude of the second point (degrees) + ! + ! Output: + ! distance - Great-circle distance between the two points (kilometers) + !------------------------------------------------------------ + real, intent(in) :: lon_dn, lat_dn ! Coordinates of downstream point + real, intent(in) :: lon_up, lat_up ! Coordinates of upstream point + real :: distance ! Computed distance (km) real :: R, dlon, dlat, a, c ! Intermediate variables - ! Radius of the Earth in kilometers - R = 6371.0 + R = 6371.0 ! Earth's radius in kilometers + dlon = (lon_up - lon_dn) * (acos(-1.0) / 180.0) ! Delta longitude (radians) + dlat = (lat_up - lat_dn) * (acos(-1.0) / 180.0) ! Delta latitude (radians) - ! Convert degrees to radians - dlon = (lon_up - lon_dn) * (acos(-1.0) / 180.0) - dlat = (lat_up - lat_dn) * (acos(-1.0) / 180.0) - - ! Haversine formula a = sin(dlat / 2.0)**2 + cos(lat_dn * (acos(-1.0) / 180.0)) * & cos(lat_up * (acos(-1.0) / 180.0)) * sin(dlon / 2.0)**2 c = 2.0 * atan2(sqrt(a), sqrt(1.0 - a)) - - ! Distance calculation distance = R * c end function spherical_distance -end program \ No newline at end of file +end program main \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 index c316f57ff..b8a178b30 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/k_module_cali.f90 @@ -1,7 +1,9 @@ module k_module +!module for K parameter calculations. use river_read - + use constant, only: nga + implicit none private public :: read_usgs_data, process_usgs_data, find_nearest_coords, get_station_inf, regression @@ -9,31 +11,45 @@ module k_module contains !------------------------------------------------------------ - subroutine read_usgs_data(nl, data) - ! Subroutine to read USGS velocity and discharge data and store it in a 2D array - integer, intent(in) :: nl + subroutine read_usgs_data(file_vel, file_dis, nl, data) + !------------------------------------------------------------ + ! Subroutine: read_usgs_data + ! Purpose : Reads USGS velocity and discharge data from text files + ! and stores the data in a 2D array. + ! + ! Input: + ! nl - Total number of records (lines) to read. + ! + ! Output: + ! data - 2D array (nl x 2) where column 1 contains velocity and + ! column 2 contains discharge. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_vel, file_dis + integer, intent(in) :: nl real, allocatable, intent(out) :: data(:,:) - character(len=100) :: var(2) - character(len=256) :: filename - character(len=100) :: line - character(len=100) :: x(100) + character(len=100) :: var(2) + character(len=900) :: filename + character(len=100) :: line + character(len=100) :: x(100) - integer :: i, j, l, io, k - integer, allocatable :: nv(:) + integer :: i, j, l, io, k + integer, allocatable :: nv(:) - !---------- Define the data types to be read ---------- + ! Define the variable names for the two data files var = (/ "velocity", "discharge" /) - ! Allocate the data array + ! Allocate the data array with nl rows and 2 columns allocate(data(nl, 2)) - ! Loop over velocity and discharge files + ! Loop over both "velocity" and "discharge" files do l = 1, 2 - filename = "input/" // trim(var(l)) // ".txt" + ! Construct the file name + if(l==1)filename = file_vel + if(l==2)filename = file_dis open(unit=77, file=trim(filename), status='old') - ! Allocate temporary array for counting valid numbers per line + ! Allocate a temporary array to count the number of valid tokens per line allocate(nv(nl)) ! Read each line from the file @@ -44,77 +60,87 @@ subroutine read_usgs_data(nl, data) exit endif - ! Read tokens from the line and store in array x + ! Read tokens from the line and store them in array x do i = 1, 100 - read(line, *, iostat=io) (x(j), j=1, i) + read(line, *, iostat=io) (x(j), j = 1, i) if (io == -1) then exit endif end do - ! Count the number of valid values in the line + ! Record the number of valid tokens read from this line nv(k) = i - 1 - ! If valid data exists, read the first value into the data array + ! If valid data is found, extract the first value for the data array; + ! otherwise assign a missing value (-9999) if (nv(k) >= 1) then read(x(1), *, iostat=io) data(k, l) else - data(k, l) = -9999 ! Assign missing value if no data is available + data(k, l) = -9999 end if end do - ! Deallocate the temporary array for valid number counts + ! Deallocate the temporary token count array deallocate(nv) - ! Close the file + ! Close the current file close(77) end do end subroutine read_usgs_data !------------------------------------------------------------ - subroutine process_usgs_data(nl, ns, data, nv, nt, vel, dis) - integer, intent(in) :: nl - integer, intent(out) :: ns - real, intent(inout),allocatable :: data(:,:) - real, allocatable, intent(out) :: vel(:), dis(:) - integer, allocatable,intent(out) :: nv(:) - integer,intent(out) :: nt - - character(len=20), allocatable :: id(:) - integer, allocatable :: nu(:) - character(len=20), allocatable :: idu(:) - integer :: i, k, ii - - ! Allocate arrays + subroutine process_usgs_data(file_usid, nl, ns, data, nv, nt, vel, dis) + !------------------------------------------------------------ + ! Subroutine: process_usgs_data + ! Purpose : Processes the raw USGS data by reading unique station IDs, + ! counting valid records per station. + ! + ! Input: + ! nl - Total number of records. + ! data - 2D array with raw velocity and discharge data. + ! + ! Output: + ! ns - Number of unique stations. + ! nv - Array with the count of valid records per station. + ! nt - Total number of valid records. + ! vel - Array of velocity values. + ! dis - Array of discharge values. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_usid + integer, intent(in) :: nl + integer, intent(out) :: ns + real, intent(inout), allocatable :: data(:,:) + real, allocatable, intent(out) :: vel(:), dis(:) + integer, allocatable, intent(out) :: nv(:) + integer, intent(out) :: nt + + character(len=20), allocatable :: id(:) + integer, allocatable :: nu(:) + character(len=20), allocatable :: idu(:) + integer :: i, k, ii + + ! Allocate array to hold station IDs for each record allocate(id(nl)) - - ! Read IDs from the file - open(unit=11, file="input/USGSID.txt", status="old") + ! Read station IDs from file "input/USGSID.txt" + open(unit=11, file=trim(file_usid), status="old") read(11, *) id close(11) - ! Convert velocity from ft/s to m/s and discharge from ft^3/s to m^3/s - !data(:,1) = data(:,1) * 0.3048 ! Convert ft/s to m/s - !data(:,2) = data(:,2) * 0.0283168 ! Convert ft^3/s to m^3/s - - ! Initialize arrays + ! Initialize station count and count unique IDs k = 1 - ! Process ID and count occurrences of unique IDs do i = 2, nl if (.not.(trim(id(i)) == trim(id(i-1)))) then k = k + 1 end if end do - !print *, 'Number of unique IDs:', k - ns=k - allocate(nu(ns),nv(ns)) + ns = k + allocate(nu(ns), nv(ns)) allocate(idu(ns)) - ! Initialize arrays + nu(1) = 1 idu(1) = id(1) k = 1 - ! Process ID and count occurrences of unique IDs do i = 2, nl if (trim(id(i)) == trim(id(i-1))) then nu(k) = nu(k) + 1 @@ -125,28 +151,24 @@ subroutine process_usgs_data(nl, ns, data, nv, nt, vel, dis) end if end do - ! Write idu to file (IDs without commas) + ! Write unique station IDs to files (with and without commas) open(unit=13, file="temp/id_for_site.txt") do i = 1, ns - write(13, '(A)') trim(idu(i))//"," - !write(13, '(A)') trim(idu(i)) + write(13, '(A)') trim(idu(i)) // "," end do close(13) open(unit=13, file="temp/id_for_site_nocomma.txt") do i = 1, ns write(13, '(A)') trim(idu(i)) - !write(13, '(A)') trim(idu(i)) end do close(13) - ! Initialize variables + ! Read record nv = 0 nv(1) = 1 k = 1 ii = 0 k = k - 1 - ! Assuming nm is defined and idA, vel, dis are allocated and filled - ! Loop through the elements do i = 2, nl if (id(i) == id(i - 1)) then k = k + 1 @@ -167,29 +189,18 @@ subroutine process_usgs_data(nl, ns, data, nv, nt, vel, dis) end if end do nv(ii + 1) = k - !print *,"number valid records",sum(nv) - - nt=sum(nv) - allocate(vel(nt),dis(nt)) - k=0 - do i=1,nl - if(data(i,1)>0..and.data(i,2)>0.)then - k=k+1 - vel(k)=data(i,1) - dis(k)=data(i,2) + nt = sum(nv) + allocate(vel(nt), dis(nt)) + k = 0 + do i = 1, nl + if (data(i,1) > 0.0 .and. data(i,2) > 0.0) then + k = k + 1 + vel(k) = data(i,1) + dis(k) = data(i,2) endif enddo - !open(unit=13, file="All_vel_trim.txt") - !do i = 1, k - ! write(13, *) vel(i) - !end do - !open(unit=13, file="All_dis_trim.txt") - !do i = 1, k - ! write(13, *) dis(i) - !end do - - ! Deallocate arrays + ! Deallocate temporary arrays deallocate(id) deallocate(nu) deallocate(idu) @@ -197,59 +208,75 @@ subroutine process_usgs_data(nl, ns, data, nv, nt, vel, dis) end subroutine process_usgs_data - !------------------------------------------------------------ - - ! Subroutine to find the nearest latitude and longitude for each station - subroutine find_nearest_coords(ns, nlat, nlon, lats, lons, lati, loni) - integer, intent(in) :: ns, nlat, nlon - real,allocatable,intent(inout) :: lats(:), lons(:) + subroutine find_nearest_coords(file_lats, file_lons, file_lat1m, file_lon1m, ns, nlat, nlon, lats, lons, lati, loni) + !------------------------------------------------------------ + ! Subroutine: find_nearest_coords + ! Purpose : For each station, finds the nearest grid point in a 1-minute + ! resolution grid and returns the corresponding indices. + ! + ! Input: + ! ns - Number of stations. + ! nlat - Number of latitude grid points in the high-resolution grid. + ! nlon - Number of longitude grid points in the high-resolution grid. + ! + ! In/Out: + ! lats, lons - Arrays to store the station latitude and longitude values. + ! + ! Output: + ! lati, loni - Arrays of indices corresponding to the nearest grid points. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_lats, file_lons, file_lat1m, file_lon1m + integer, intent(in) :: ns, nlat, nlon + real, allocatable, intent(inout) :: lats(:), lons(:) integer, allocatable, intent(out) :: lati(:), loni(:) + real, allocatable :: lat1m(:), lon1m(:) + real :: min_dist_lat, min_dist_lon, dist + integer :: i, j, idx_min_lat, idx_min_lon - real, allocatable :: lat1m(:), lon1m(:) - real :: min_dist_lat, min_dist_lon, dist - integer :: i, j, idx_min_lat, idx_min_lon - - ! Allocate arrays for lat/lon data + ! Allocate output arrays for grid indices for each station allocate(lati(ns), loni(ns)) + ! Allocate arrays for station coordinates allocate(lats(ns), lons(ns)) + ! Allocate arrays for 1-minute grid coordinates allocate(lat1m(nlat), lon1m(nlon)) - !---- Read latitudes and longitudes for sites ---- - open(unit=10, file="input/lat_for_site_200.txt", status='old') + ! Read station latitudes from file "input/lat_for_site_200.txt" + open(unit=10, file=trim(file_lats), status='old') do i = 1, ns read(10, *) lats(i) end do close(10) - open(unit=11, file="input/lon_for_site_200.txt", status='old') + ! Read station longitudes from file "input/lon_for_site_200.txt" + open(unit=11, file=trim(file_lons), status='old') do i = 1, ns read(11, *) lons(i) end do close(11) - !---- Read 1-minute resolution lat/lon grid ---- - open(unit=12, file="input/lat_1m.txt", status='old') + ! Read high-resolution latitude grid from file "input/lat_1m.txt" + open(unit=12, file=trim(file_lat1m), status='old') do i = 1, nlat read(12, *) lat1m(i) end do close(12) - open(unit=13, file="input/lon_1m.txt", status='old') + ! Read high-resolution longitude grid from file "input/lon_1m.txt" + open(unit=13, file=trim(file_lon1m), status='old') do i = 1, nlon read(13, *) lon1m(i) end do close(13) - !---- Find nearest coordinates for each station ---- + ! For each station, determine the nearest latitude and longitude indices do i = 1, ns - ! Initialize minimum distance min_dist_lat = 1.0e20 min_dist_lon = 1.0e20 idx_min_lat = -1 idx_min_lon = -1 - ! Find nearest latitude + ! Find nearest latitude index do j = 1, nlat dist = abs(lats(i) - lat1m(j)) if (dist < min_dist_lat) then @@ -259,7 +286,7 @@ subroutine find_nearest_coords(ns, nlat, nlon, lats, lons, lati, loni) end do lati(i) = idx_min_lat - ! Find nearest longitude + ! Find nearest longitude index do j = 1, nlon dist = abs(lons(i) - lon1m(j)) if (dist < min_dist_lon) then @@ -270,503 +297,569 @@ subroutine find_nearest_coords(ns, nlat, nlon, lats, lons, lati, loni) loni(i) = idx_min_lon end do - !---- Write output files with Fortran indexing (1-based) ---- - !open(unit=14, file="USGS_data/lati_for_site_200.txt", status='replace') - !do i = 1, ns - ! write(14, *) lati(i) - !end do - !close(14) - - !open(unit=15, file="USGS_data/loni_for_site_200.txt", status='replace') - !do i = 1, ns - ! write(15, *) loni(i) - !end do - !close(15) - - ! Deallocate arrays + ! Deallocate high-resolution grid arrays deallocate(lat1m) deallocate(lon1m) end subroutine find_nearest_coords !------------------------------------------------------------ - subroutine get_station_inf(ns, nc, nlat, nlon, lati, loni, catid, Qclmt, slp, KImodel_all,exp_slp,exp_clmt,fac_str) - integer, intent(in) :: ns, nc, nlat, nlon - integer, intent(in) :: lati(nlon), loni(nlon) + subroutine get_station_inf(file_pfafmap, ns, nc, nlat, nlon, lati, loni, catid, Qclmt, slp, KImodel_all, exp_slp, exp_clmt, fac_str) + !------------------------------------------------------------ + ! Subroutine: get_station_inf + ! Purpose : Retrieves station catchment information from a NetCDF file, + ! assigns climate runoff (Qclmt) and slope values for each station, + ! and computes modeled K values for all catchments. + ! + ! Input: + ! ns - Number of stations. + ! nc - Total number of catchments. + ! nlat, nlon - Dimensions of the grid. + ! lati, loni - Grid indices for each station. + ! exp_slp, exp_clmt - Exponents for slope and climatology discharge. + ! fac_str - Scaling factor for stream. + ! + ! Output: + ! catid - Array of catchment IDs for each station. + ! Qclmt - Array of climatology discharge values for stations. + ! slp - Array of slope values for stations. + ! KImodel_all - Array of modeled K values for all catchments. + !------------------------------------------------------------ + character(len=900),intent(in) :: file_pfafmap + integer, intent(in) :: ns, nc, nlat, nlon + integer, intent(in) :: lati(nlon), loni(nlon) integer, allocatable, intent(out) :: catid(:) - real,allocatable,intent(out) :: Qclmt(:),slp(:) - real,allocatable,intent(out) :: KImodel_all(:) - real,intent(in) :: exp_slp,exp_clmt,fac_str - - integer,allocatable :: catchind(:,:) - real,allocatable,dimension(:) :: Qclmt_all,slp_all,Kstr_all,Qstr_all - integer :: i - - allocate(catchind(nlon,nlat),catid(ns)) - allocate(Qclmt_all(nc),slp_all(nc)) - allocate(Qclmt(ns),slp(ns)) - allocate(KImodel_all(nc),Kstr_all(nc),Qstr_all(nc)) + real, allocatable, intent(out) :: Qclmt(:), slp(:) + real, allocatable, intent(out) :: KImodel_all(:) + real, intent(in) :: exp_slp, exp_clmt, fac_str + + integer, allocatable :: catchind(:,:) + real, allocatable, dimension(:) :: Qclmt_all, slp_all, Kstr_all, Qstr_all + integer :: i + + ! Allocate arrays for the catchment index and station outputs + allocate(catchind(nlon, nlat), catid(ns)) + allocate(Qclmt_all(nc), slp_all(nc)) + allocate(Qclmt(ns), slp(ns)) + allocate(KImodel_all(nc), Kstr_all(nc), Qstr_all(nc)) - call read_ncfile_int2d("input/SRTM_PfafData.nc","CatchIndex",catchind,nlon,nlat) + ! Read catchment index data from the NetCDF file "input/SRTM_PfafData.nc" + call read_ncfile_int2d(trim(file_pfafmap), "CatchIndex", catchind, nlon, nlat) - do i=1,ns - catid(i)=catchind(loni(i),lati(i)) + ! For each station, assign the catchment ID based on its grid location + do i = 1, ns + catid(i) = catchind(loni(i), lati(i)) end do - open(88,file="temp/catid_for_site_200.txt") - do i=1,ns - write(88,*)catid(i) + ! Write station catchment IDs to a temporary file + open(88, file="temp/catid_for_site_200.txt") + do i = 1, ns + write(88, *) catid(i) end do - - open(77,file="output/Pfaf_qri.txt") - read(77,*)Qclmt_all - where(Qclmt_all<1.e-8) Qclmt_all=1.e-8 - open(77,file="temp/Pfaf_slope.txt") - read(77,*)slp_all - open(77,file="output/Pfaf_qstr.txt") - read(77,*)Qstr_all - where(Qstr_all<1.e-8) Qstr_all=1.e-8 - - do i=1,ns - if(catid(i)/=-9999)then - Qclmt(i)=Qclmt_all(catid(i)) - slp(i)=slp_all(catid(i)) + close(88) + + ! Read climate runoff data from file "output/Pfaf_qri.txt" + open(77, file="output/Pfaf_qri.txt") + read(77, *) Qclmt_all + where(Qclmt_all < 1.e-8) Qclmt_all = 1.e-8 + ! Read slope data from file "temp/Pfaf_slope.txt" + open(77, file="temp/Pfaf_slope.txt") + read(77, *) slp_all + ! Read clmt discharge data from file "output/Pfaf_qstr.txt" + open(77, file="output/Pfaf_qstr.txt") + read(77, *) Qstr_all + where(Qstr_all < 1.e-8) Qstr_all = 1.e-8 + + ! For each station, assign Qclmt and slope using the catchment ID + do i = 1, ns + if (catid(i) /= -9999) then + Qclmt(i) = Qclmt_all(catid(i)) + slp(i) = slp_all(catid(i)) else - Qclmt(i)=-9999 - slp(i)=-9999 + Qclmt(i) = -9999 + slp(i) = -9999 endif - enddo + end do + ! Calculate modeled K values for all catchments KImodel_all = (Qclmt_all**(exp_clmt)) * (slp_all**(exp_slp)) + ! Calculate stream K values using the scaling factor Kstr_all = fac_str * (Qstr_all**(exp_clmt)) * (slp_all**(exp_slp)) - open(88,file="output/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt") - do i=1,nc - write(88,*)Kstr_all(i) - enddo + ! Write stream K values to an output file + open(88, file="output/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt") + do i = 1, nc + write(88, *) Kstr_all(i) + end do + close(88) - - !open(88,file="USGS_data/qri_for_site_200.txt") - !do i=1,ns - ! write(88,*)Qclmt(i) - !end do - !open(88,file="USGS_data/slp_for_site_200.txt") - !do i=1,ns - ! write(88,*)slp(i) - !end do - - - deallocate(catchind,Qclmt_all,slp_all,Kstr_all,Qstr_all) + ! Deallocate temporary arrays + deallocate(catchind, Qclmt_all, slp_all, Kstr_all, Qstr_all) end subroutine get_station_inf !------------------------------------------------------------ - subroutine get_valide_stations_gageii(ns,nc,catid_sta,flag_thres) - integer,intent(in) :: ns,nc - integer,intent(in) :: catid_sta(ns) - integer,allocatable,intent(out) :: flag_thres(:) - - - integer, parameter :: nga = 9067 - integer, parameter :: nv = 5704 - real, parameter :: thr_sel = 0.3 - - real,dimension(:),allocatable :: acar_pfaf - - integer :: i, j, k, cid - character(len=20) :: id_gages(nga) - character(len=20) :: id_sta(ns) - integer :: flag_gageii(ns) - real :: acar_gages(nga) - real :: acar_gages_sta(ns),acar_sta(ns) - character(len=20) :: line - integer :: ios - - allocate(flag_thres(ns)) - - ! Initialize acar_6156 array with missing value - acar_sta = -9999.0 - k = 0 + subroutine get_valide_stations_gageii(file_gage_id, file_gage_acar, ns, nc, catid_sta, flag_thres) + !------------------------------------------------------------ + ! Subroutine: get_valide_stations_gageii + ! Purpose : Compares station drainage area with GAGE-II dataset and applies an + ! area ratio threshold to determine valid stations. + ! + ! Input: + ! ns - Number of stations. + ! nc - Total number of catchments. + ! catid_sta - Array of catchment IDs for stations. + ! + ! Output: + ! flag_thres - Array indicating valid stations (1 for valid, 0 otherwise). + !------------------------------------------------------------ + character(len=900),intent(in) :: file_gage_id, file_gage_acar + integer, intent(in) :: ns, nc + integer, intent(in) :: catid_sta(ns) + integer, allocatable, intent(out) :: flag_thres(:) + + real :: thr_sel = 0.3 ! Threshold selection factor + + real, dimension(:), allocatable :: acar_pfaf + integer :: i, j, k, cid + character(len=20) :: id_gages(nga) + character(len=20) :: id_sta(ns) + integer :: flag_gageii(ns) + real :: acar_gages(nga) + real :: acar_gages_sta(ns), acar_sta(ns) + character(len=20) :: line + integer :: ios + + allocate(flag_thres(ns)) - ! Read id_gages from file - open(unit=10, file="input/id_gagesii.txt", status="old", action="read") - do j = 1, nga - read(10,'(A)', iostat=ios) id_gages(j) - if (ios /= 0) then - print *, "Error reading id_gagesii.txt" - stop - end if - end do - close(10) + ! Initialize station area ratios with a missing value + acar_sta = -9999.0 + k = 0 - ! Read id_6156 from file - open(unit=11, file="temp/id_for_site_nocomma.txt", status="old", action="read") - do i = 1, ns - read(11,'(A)', iostat=ios) id_sta(i) - if (ios /= 0) then - print *, "Error reading id_for_site_nocomma.txt" - stop - end if - end do - close(11) + ! Read GAGE-II station IDs from "input/id_gagesii.txt" + open(unit=10, file=trim(file_gage_id), status="old", action="read") + do j = 1, nga + read(10, '(A)', iostat=ios) id_gages(j) + if (ios /= 0) then + print *, "Error reading id_gagesii.txt" + stop + end if + end do + close(10) - ! Read acar_gages from file - open(unit=12, file="input/acar_gagesii.txt", status="old", action="read") - do j = 1, nga - read(12,*, iostat=ios) acar_gages(j) - if (ios /= 0) then - print *, "Error reading acar_gagesii.txt" - stop - end if - end do - close(12) + ! Read station IDs for the sites from "temp/id_for_site_nocomma.txt" + open(unit=11, file="temp/id_for_site_nocomma.txt", status="old", action="read") + do i = 1, ns + read(11, '(A)', iostat=ios) id_sta(i) + if (ios /= 0) then + print *, "Error reading id_for_site_nocomma.txt" + stop + end if + end do + close(11) - flag_gageii = 0 - ! Compare id_sta and id_gages, and update acar_sta if there's a match - do i = 1, ns + ! Read area ratios for GAGE-II stations from "input/acar_gagesii.txt" + open(unit=12, file=trim(file_gage_acar), status="old", action="read") do j = 1, nga - if (trim(id_gages(j)) == trim(id_sta(i))) then - acar_gages_sta(i) = acar_gages(j) - flag_gageii(i) = 1 - k = k + 1 - exit ! Exit inner loop if match is found + read(12, *, iostat=ios) acar_gages(j) + if (ios /= 0) then + print *, "Error reading acar_gagesii.txt" + stop end if end do - end do - - print *, "Number of matches:", sum(flag_gageii) + close(12) + + ! Initialize the GAGE-II flag array to zero (no match) + flag_gageii = 0 + ! Compare station IDs with GAGE-II IDs and mark matches + do i = 1, ns + do j = 1, nga + if (trim(id_gages(j)) == trim(id_sta(i))) then + acar_gages_sta(i) = acar_gages(j) + flag_gageii(i) = 1 + k = k + 1 + exit ! Exit loop after a match is found + end if + end do + end do - allocate(acar_pfaf(nc)) - open(77,file="temp/Pfaf_acar.txt") - read(77,*)acar_pfaf + print *, "Number of matches:", sum(flag_gageii) - do i = 1, ns - if(catid_sta(i)/=-9999)then - cid = catid_sta(i) - acar_sta(i) = acar_pfaf(cid) - else - acar_sta(i) = -9999. - end if - end do + allocate(acar_pfaf(nc)) + open(77, file="temp/Pfaf_acar.txt") + read(77, *) acar_pfaf + close(77) + ! For each station, assign the area ratio based on its catchment ID + do i = 1, ns + if (catid_sta(i) /= -9999) then + cid = catid_sta(i) + acar_sta(i) = acar_pfaf(cid) + else + acar_sta(i) = -9999. + end if + end do - flag_thres = 0 - do i = 1, ns - if(flag_gageii(i)==1 .and. catid_sta(i)/=-9999)then - if(acar_sta(i).ge.(1.-thr_sel)*acar_gages_sta(i) .and. acar_sta(i).le.(1.+thr_sel)*acar_gages_sta(i))then - flag_thres(i) = 1 + ! Apply threshold criteria to flag valid stations + flag_thres = 0 + do i = 1, ns + if (flag_gageii(i) == 1 .and. catid_sta(i) /= -9999) then + if (acar_sta(i) .ge. (1. - thr_sel) * acar_gages_sta(i) .and. & + acar_sta(i) .le. (1. + thr_sel) * acar_gages_sta(i)) then + flag_thres(i) = 1 + endif endif - endif - end do - - print *,"Number of valid:", sum(flag_thres) + end do - deallocate(acar_pfaf) - !open(88,file="flag_thr03_7065.txt") - !do i = 1,ns - ! write(88,*)flag_thres(i) - !enddo + print *, "Number of valid:", sum(flag_thres) + deallocate(acar_pfaf) end subroutine get_valide_stations_gageii !------------------------------------------------------------ - subroutine regression(nt,vel_ori,dis_ori,nv,ns,Qclmt,slp,KKobs,KImodel,exp_slp,exp_clmt,mm,MU) - integer,intent(in) :: nt, ns - real,intent(inout),allocatable :: vel_ori(:), dis_ori(:) - integer,intent(in) :: nv(ns) - real,intent(inout),allocatable :: Qclmt(:),slp(:) - real,intent(out),allocatable :: KKobs(:),KImodel(:) - real,intent(in) :: exp_slp,exp_clmt,mm,MU - - real,allocatable,dimension(:) :: x,y,yest - - integer :: thres=100 - integer :: i,j - real :: k(ns),cdtm(ns),med + subroutine regression(nt, vel_ori, dis_ori, nv, ns, Qclmt, slp, KKobs, KImodel, exp_slp, exp_clmt, mm, MU) + !------------------------------------------------------------ + ! Subroutine: regression + ! Purpose : For each station with sufficient valid records, performs a + ! regression between discharge and velocity to obtain a calibration + ! factor, and then computes the observed K value (KKobs) for that station. + ! + ! Input: + ! nt - Total number of valid records. + ! ns - Number of stations. + ! nv - Array containing the count of valid records per station. + ! vel_ori - Original velocity data (in ft/s, will be converted). + ! dis_ori - Original discharge data (in ft^3/s, will be converted). + ! Qclmt - Climatology discharge data for each station. + ! slp - Slope data for each station. + ! exp_slp, exp_clmt - Exponents for slope and climatology discharge. + ! mm, MU - Model parameters. + ! + ! Output: + ! KKobs - Array of observed K values for each station. + ! KImodel - Array of modeled K values (init guess) for each station. + !------------------------------------------------------------ + integer, intent(in) :: nt, ns + real, intent(inout), allocatable :: vel_ori(:), dis_ori(:) + integer, intent(in) :: nv(ns) + real, intent(inout), allocatable :: Qclmt(:), slp(:) + real, intent(out), allocatable :: KKobs(:), KImodel(:) + real, intent(in) :: exp_slp, exp_clmt, mm, MU + + real, allocatable, dimension(:) :: x, y, yest + integer :: thres = 100 + integer :: i, j + real :: k(ns), cdtm(ns), med integer :: acc(ns) - real,allocatable :: vel(:), dis(:) + real, allocatable :: vel(:), dis(:) - allocate(vel(nt),dis(nt)) - vel=vel_ori*0.3048 !m/s - dis=dis_ori*0.0283168 !m3/s - - acc(1)=nv(1) - do i=2,ns - acc(i)=acc(i-1)+nv(i) + ! Convert velocity from ft/s to m/s and discharge from ft^3/s to m^3/s + allocate(vel(nt), dis(nt)) + vel = vel_ori * 0.3048 + dis = dis_ori * 0.0283168 + + ! Calculate cumulative counts to index into the valid records for each station + acc(1) = nv(1) + do i = 2, ns + acc(i) = acc(i - 1) + nv(i) end do - !open(88,file="USGS_data/acc_noMISSING_200.txt") - !do i=1,ns - ! write(88,*)acc(i) - !end do - !print *,"5.1" - do i=1,ns - if(nv(i)>=thres)then - allocate( x(nv(i)), y(nv(i)), yest(nv(i))) - x=dis( acc(i)-nv(i)+1:acc(i) )**mm - y=vel( acc(i)-nv(i)+1:acc(i) ) - k(i)=sum(x*y)/sum(x*x) - yest=k(i)*x - cdtm(i)=cal_cdtm(y,yest) - deallocate(x,y,yest) + + ! For each station with enough valid records, perform regression + do i = 1, ns + if (nv(i) >= thres) then + allocate(x(nv(i)), y(nv(i)), yest(nv(i))) + x = dis(acc(i) - nv(i) + 1 : acc(i))**mm + y = vel(acc(i) - nv(i) + 1 : acc(i)) + k(i) = sum(x * y) / sum(x * x) + yest = k(i) * x + cdtm(i) = cal_cdtm(y, yest) + deallocate(x, y, yest) else - k(i)=-9999. - cdtm(i)=-9999. + k(i) = -9999. + cdtm(i) = -9999. endif - enddo - med=median(cdtm) + end do + med = median(cdtm) - where(cdtm<0.5)k=-9999. - !print *,"mm=",mm,",cdtm_med=",med,",stop now!" + ! Invalidate calibration factors for stations with low determination coefficient + where(cdtm < 0.5) k = -9999. - !print *,"5.2" allocate(KKobs(ns)) - do i=1,ns - if(k(i)/=-9999.and.Qclmt(i)/=-9999.)then - KKobs(i)=k(i)/(Qclmt(i)**(MU-mm)) + do i = 1, ns + if (k(i) /= -9999. .and. Qclmt(i) /= -9999.) then + KKobs(i) = k(i) / (Qclmt(i)**(MU - mm)) else - KKobs(i)=-9999. + KKobs(i) = -9999. endif end do - !open(88,file="KKobs_mm0p40_MU0p10_7065.txt") - !do i=1,ns - ! write(88,*)KKobs(i) - !enddo - - !print *,"mm=",mm,",cdtm_med=",med,",stop now!" - !stop - - !open(88,file="USGS_data/KKobs_200.txt") - !do i=1,ns - ! write(88,*)KKobs(i) - !end do - + ! Calculate modeled K values (init guess) using the provided exponents allocate(KImodel(ns)) KImodel = (Qclmt**(exp_clmt)) * (slp**(exp_slp)) - deallocate(vel,dis) - !deallocate(vel_ori,dis_ori) - + deallocate(vel, dis) end subroutine regression !------------------------------------------------------------ - subroutine filter_station(nc,ns,np,lats_full,lons_full,Qclmt_full,slp_full,catid_full,KKobs_full,KImodel_full,Qclmt,slp,catid,KKobs,KImodel,flag_gageii) - integer,intent(in) :: ns,nc - integer,intent(out) :: np - real,intent(inout),allocatable :: lats_full(:),lons_full(:),Qclmt_full(:),slp_full(:),KKobs_full(:),KImodel_full(:) - real,intent(out),allocatable :: Qclmt(:),slp(:),KKobs(:),KImodel(:) - integer,intent(inout),allocatable :: catid_full(:) - integer,intent(out),allocatable :: catid(:) - integer,intent(inout),allocatable :: flag_gageii(:) - - integer,allocatable :: flag_slp(:) - real,allocatable :: lats(:),lons(:) - integer :: i,k - integer,allocatable :: flag_7065(:) - - + subroutine filter_station(nc, ns, np, lats_full, lons_full, Qclmt_full, slp_full, catid_full, KKobs_full, KImodel_full, Qclmt, slp, catid, KKobs, KImodel, flag_gageii) + !------------------------------------------------------------ + ! Subroutine: filter_station + ! Purpose : Filters out stations that do not meet several criteria: + ! valid catchment ID, valid K values, minimum slope threshold, + ! and a positive GAGE-II flag. It then outputs the filtered data. + ! + ! Input: + ! nc - Total number of catchments. + ! ns - Number of stations. + ! lats_full, lons_full - Full arrays of station latitudes and longitudes. + ! Qclmt_full, slp_full - Full climatology discharge and slope data for stations. + ! catid_full - Full catchment ID array for stations. + ! KKobs_full, KImodel_full - Full observed and modeled K values (initial guess). + ! flag_gageii - GAGE-II validation flags. + ! + ! Output: + ! np - Number of stations that passed the filter. + ! Qclmt, slp, KKobs, KImodel - Filtered arrays for clmt discharge, slope, observed and modeled K (init guess). + ! catid - Filtered catchment IDs for the valid stations. + !------------------------------------------------------------ + integer, intent(in) :: ns, nc + integer, intent(out) :: np + real, intent(inout), allocatable :: lats_full(:), lons_full(:), Qclmt_full(:), slp_full(:), KKobs_full(:), KImodel_full(:) + real, intent(out), allocatable :: Qclmt(:), slp(:), KKobs(:), KImodel(:) + integer, intent(inout), allocatable :: catid_full(:) + integer, intent(out), allocatable :: catid(:) + integer, intent(inout), allocatable :: flag_gageii(:) + + integer, allocatable :: flag_slp(:) + real, allocatable :: lats(:), lons(:) + integer :: i, k + integer, allocatable :: flag_7065(:) + + ! Allocate and read slope flag data from file "temp/Pfaf_slope_flag.txt" allocate(flag_slp(nc)) - open(77,file="temp/Pfaf_slope_flag.txt") - read(77,*)flag_slp + open(77, file="temp/Pfaf_slope_flag.txt") + read(77, *) flag_slp allocate(flag_7065(ns)) - flag_7065=0 + flag_7065 = 0 - !open(77,file="flag_thr03_7065.txt") - !read(77,*)flag_gageii - - k=0 - do i=1,ns - if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_slp(catid_full(i))==1.and.flag_gageii(i)==1)then -! if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_gageii(i)==1)then - k=k+1 + k = 0 + ! Count stations that meet all filtering criteria + do i = 1, ns + if (catid_full(i) .ne. -9999 .and. KKobs_full(i) /= -9999. .and. & + slp_full(i) > 1.e-5 .and. flag_slp(catid_full(i)) == 1 .and. & + flag_gageii(i) == 1) then + k = k + 1 endif - enddo - np=k - print *,"number of valid stations: ",np - !stop - allocate(Qclmt(np),slp(np),catid(np),KKobs(np),KImodel(np)) - allocate(lats(np),lons(np)) - k=0 - do i=1,ns - if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_slp(catid_full(i))==1.and.flag_gageii(i)==1)then -! if(catid_full(i).ne.-9999.and.KKobs_full(i)/=-9999..and.slp_full(i)>1.e-5.and.flag_gageii(i)==1)then - k=k+1 - Qclmt(k)=Qclmt_full(i) - slp(k)=slp_full(i) - KKobs(k)=KKobs_full(i) - KImodel(k)=KImodel_full(i) - catid(k)=catid_full(i) - lats(k)=lats_full(i) - lons(k)=lons_full(i) - flag_7065(i)=1 + end do + np = k + print *, "number of valid stations: ", np + + ! Allocate filtered output arrays + allocate(Qclmt(np), slp(np), catid(np), KKobs(np), KImodel(np)) + allocate(lats(np), lons(np)) + k = 0 + do i = 1, ns + if (catid_full(i) .ne. -9999 .and. KKobs_full(i) /= -9999. .and. & + slp_full(i) > 1.e-5 .and. flag_slp(catid_full(i)) == 1 .and. & + flag_gageii(i) == 1) then + k = k + 1 + Qclmt(k) = Qclmt_full(i) + slp(k) = slp_full(i) + KKobs(k) = KKobs_full(i) + KImodel(k) = KImodel_full(i) + catid(k) = catid_full(i) + lats(k) = lats_full(i) + lons(k) = lons_full(i) + flag_7065(i) = 1 endif - enddo - !open(88,file="flag_7065_stations_1265.txt") - !do i=1,ns - ! write(88,*)flag_7065(i) - !enddo - !stop - !open(88,file="lats_stations.txt") - !do i=1,np - ! write(88,*)lats(i) - !enddo - !open(88,file="lons_stations.txt") - !do i=1,np - ! write(88,*)lons(i) - !enddo - - deallocate(Qclmt_full,slp_full,KKobs_full,KImodel_full,flag_slp,flag_gageii,lats,lons) + end do + + ! Deallocate temporary full arrays that are no longer needed + deallocate(Qclmt_full, slp_full, KKobs_full, KImodel_full, flag_slp, flag_gageii, lats, lons) end subroutine filter_station !------------------------------------------------------------ - subroutine cal_Kmodel(ns,np,nc,MU,exp_slp,exp_clmt,Qclmt,slp,KKobs,KImodel,KImodel_all,catid,catid_full,ccr,rms) - integer,intent(in) :: ns,np,nc - real,intent(in) :: MU,exp_slp,exp_clmt - real,intent(inout),allocatable :: Qclmt(:),slp(:),KKobs(:),KImodel(:) - real,intent(inout),allocatable :: KImodel_all(:) - integer,intent(inout),allocatable :: catid(:),catid_full(:) - real,intent(inout) :: ccr,rms + subroutine cal_Kmodel(ns, np, nc, MU, exp_slp, exp_clmt, Qclmt, slp, KKobs, KImodel, KImodel_all, catid, catid_full, ccr, rms) + !------------------------------------------------------------ + ! Subroutine: cal_Kmodel + ! Purpose : Calibrates the model by adjusting catchment K values with a scaling + ! factor computed from the percentiles of observed and modeled K values. + ! It then computes the correlation coefficient (ccr) and RMS error. + ! + ! Input/Output: + ! ns - Number of stations. + ! np - Number of valid stations. + ! nc - Total number of catchments. + ! MU, exp_slp, exp_clmt - Model parameters. + ! Qclmt, slp, KKobs, KImodel - Arrays for station data. + ! KImodel_all - Modeled K values for all catchments. + ! catid, catid_full - Filtered and full catchment ID arrays. + ! + ! Output: + ! ccr - Correlation coefficient between observed and calibrated K. + ! rms - RMS error between observed and calibrated K. + !------------------------------------------------------------ + integer, intent(in) :: ns, np, nc + real, intent(in) :: MU, exp_slp, exp_clmt + real, intent(inout), allocatable :: Qclmt(:), slp(:), KKobs(:), KImodel(:) + real, intent(inout), allocatable :: KImodel_all(:) + integer, intent(inout), allocatable :: catid(:), catid_full(:) + real, intent(inout) :: ccr, rms - real,allocatable :: KKobs_sort(:), KImodel_sort(:), KKmodel_full(:) - real, allocatable, dimension(:) :: dis,sca,Kv,KKmodel - integer,allocatable,dimension(:) :: gear + real, allocatable :: KKobs_sort(:), KImodel_sort(:), KKmodel_full(:) + real, allocatable, dimension(:) :: dis, sca, Kv, KKmodel + integer, allocatable, dimension(:) :: gear - character(len=50) :: MU_s,exp_slp_s,exp_clmt_s + character(len=50) :: MU_s, exp_slp_s, exp_clmt_s - integer :: bulk,i,lev - real :: Kper(11),KMper(11),rat(11),dis_full(11) + integer :: bulk, i, lev + real :: Kper(11), KMper(11), rat(11), dis_full(11) - write(MU_s,'(f4.2)')MU - write(exp_slp_s,'(f4.2)')exp_slp - if(exp_clmt>=0.)then - write(exp_clmt_s,'(f4.2)')exp_clmt + ! Format model parameters into strings for output naming purposes + write(MU_s, '(f4.2)') MU + write(exp_slp_s, '(f4.2)') exp_slp + if (exp_clmt >= 0.) then + write(exp_clmt_s, '(f4.2)') exp_clmt else - write(exp_clmt_s,'(f4.2)') -1.*exp_clmt - exp_clmt_s="n"//trim(exp_clmt_s) + write(exp_clmt_s, '(f4.2)') -1.*exp_clmt + exp_clmt_s = "n" // trim(exp_clmt_s) endif - allocate(KKobs_sort(np),KImodel_sort(np)) - call sort(np,KKobs,KKobs_sort) - call sort(np,KImodel,KImodel_sort) + ! Allocate arrays for sorted K values + allocate(KKobs_sort(np), KImodel_sort(np)) + call sort(np, KKobs, KKobs_sort) + call sort(np, KImodel, KImodel_sort) + + ! Compute percentile thresholds by dividing sorted arrays into 10 equal parts + bulk = np / 10 + Kper(1) = KKobs_sort(1) + KMper(1) = KImodel_sort(1) + do i = 2, 10 + Kper(i) = KKobs_sort(bulk * (i - 1)) + KMper(i) = KImodel_sort(bulk * (i - 1)) + end do + Kper(11) = KKobs_sort(np) + KMper(11) = KImodel_sort(np) + rat = Kper / KMper - bulk=np/10 - Kper(1)=KKobs_sort(1) - KMper(1)=KImodel_sort(1) - do i=2,10 - Kper(i)=KKobs_sort(bulk*(i-1)) - KMper(i)=KImodel_sort(bulk*(i-1)) - enddo - Kper(11)=KKobs_sort(np) - KMper(11)=KImodel_sort(np) - rat=Kper/KMper - - !open(88,file="rat_Kper2KMper.txt") - !do i=1,11 - ! write(88,*)rat(i) - !enddo - !close(88) - !exit - - allocate(gear(nc),dis(nc),sca(nc),Kv(nc)) + ! Allocate arrays for scaling calculations over all catchments + allocate(gear(nc), dis(nc), sca(nc), Kv(nc)) - gear=12 - dis=-9999. - do i=1,nc - do lev=1,11 - if(KImodel_all(i)<=KMper(lev))then - gear(i)=lev - dis(i)=KMper(lev)-KImodel_all(i) + ! Initialize gear to default (12) and compute distance to percentile thresholds + gear = 12 + dis = -9999. + do i = 1, nc + do lev = 1, 11 + if (KImodel_all(i) <= KMper(lev)) then + gear(i) = lev + dis(i) = KMper(lev) - KImodel_all(i) exit endif end do - enddo + end do - dis_full(1)=KMper(1) - do i=2,11 - dis_full(i)=KMper(i)-KMper(i-1) - enddo + ! Calculate differences between consecutive percentile thresholds + dis_full(1) = KMper(1) + do i = 2, 11 + dis_full(i) = KMper(i) - KMper(i - 1) + end do - do i=1,nc - if(gear(i)==1)then - sca(i)=rat(1) - elseif(gear(i)==12)then - sca(i)=rat(11) + ! Compute scaling factors for each catchment based on its percentile position + do i = 1, nc + if (gear(i) == 1) then + sca(i) = rat(1) + elseif (gear(i) == 12) then + sca(i) = rat(11) else - sca(i)= ( rat(gear(i)-1)*dis(i) + rat(gear(i))*(dis_full(gear(i))-dis(i)) ) / dis_full(gear(i)) + sca(i) = ( rat(gear(i)-1) * dis(i) + rat(gear(i)) * (dis_full(gear(i)) - dis(i)) ) / dis_full(gear(i)) endif - Kv(i)=KImodel_all(i)*sca(i) - enddo + Kv(i) = KImodel_all(i) * sca(i) + end do - open(88,file="output/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt") -! open(88,file="Pfaf_Kv_PR_0p4_0p1_0p5_0p2.txt") - do i=1,nc - write(88,*)Kv(i) - enddo + ! Write scaled K values for each catchment to an output file + open(88, file="output/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt") + do i = 1, nc + write(88, *) Kv(i) + end do + close(88) + ! For each station, assign the corresponding scaled K value from its catchment allocate(KKmodel_full(ns)) - do i=1,ns - if(catid_full(i)/=-9999)then - KKmodel_full(i)=Kv(catid_full(i)) + do i = 1, ns + if (catid_full(i) /= -9999) then + KKmodel_full(i) = Kv(catid_full(i)) else - KKmodel_full(i)=-9999. + KKmodel_full(i) = -9999. endif - enddo - - !open(88,file="KKmodel_7065/KKmodel_7065_"//trim(MU_s)//"_"//trim(exp_slp_s)//"_"//trim(exp_clmt_s)//".txt") - !do i=1,ns - ! write(88,*)KKmodel_full(i) - !enddo + end do + ! For filtered stations, extract the modeled K values allocate(KKmodel(np)) - do i=1,np - KKmodel(i)=Kv(catid(i)) - enddo - - ccr=cal_ccr(KKobs,KKmodel) - rms=cal_rms(KKobs,KKmodel,np) - - - !open(88,file="KKobs_stations.txt") - !do i=1,np - ! write(88,*)KKobs(i) - !enddo - !print *,ccr + do i = 1, np + KKmodel(i) = Kv(catid(i)) + end do + ! Compute correlation coefficient and RMS error between observed and modeled K values + ccr = cal_ccr(KKobs, KKmodel) + rms = cal_rms(KKobs, KKmodel, np) - deallocate(KKobs_sort,KImodel_sort) - deallocate(KImodel_all,gear,dis,sca,Kv) - deallocate(Qclmt,slp,KKobs,KImodel,catid,KKmodel,catid_full,KKmodel_full) + ! Deallocate temporary arrays and full data arrays + deallocate(KKobs_sort, KImodel_sort) + deallocate(KImodel_all, gear, dis, sca, Kv) + deallocate(Qclmt, slp, KKobs, KImodel, catid, KKmodel, catid_full, KKmodel_full) end subroutine cal_Kmodel subroutine sort(np, data, data_sort) - integer, intent(in) :: np ! The size of the array - real, intent(in) :: data(np) ! Input array to be sorted - real, intent(out) :: data_sort(np) ! Output sorted array - integer :: i, j - real :: temp - - ! Copy input array to output array + !------------------------------------------------------------ + ! Subroutine: sort + ! Purpose : Sorts an array of real numbers in ascending order using bubble sort. + ! + ! Input: + ! np - Number of elements in the array. + ! data - Input array to be sorted. + ! + ! Output: + ! data_sort - Sorted array. + !------------------------------------------------------------ + integer, intent(in) :: np ! Size of the array + real, intent(in) :: data(np) ! Input array + real, intent(out) :: data_sort(np) ! Output sorted array + integer :: i, j + real :: temp + + ! Copy the input array to the output array data_sort = data - ! Perform a bubble sort (simple sorting algorithm) - do i = 1, np-1 - do j = 1, np-i - if (data_sort(j) > data_sort(j+1)) then - ! Swap the elements + ! Bubble sort algorithm + do i = 1, np - 1 + do j = 1, np - i + if (data_sort(j) > data_sort(j + 1)) then temp = data_sort(j) - data_sort(j) = data_sort(j+1) - data_sort(j+1) = temp + data_sort(j) = data_sort(j + 1) + data_sort(j + 1) = temp end if end do end do end subroutine sort function cal_ccr(y, yest) result(ccr) + !------------------------------------------------------------ + ! Function: cal_ccr + ! Purpose : Calculates the correlation coefficient between observed and + ! estimated arrays. + ! + ! Input: + ! y - Observed data array. + ! yest - Estimated (modeled) data array. + ! + ! Output: + ! ccr - Correlation coefficient. + !------------------------------------------------------------ real, intent(in) :: y(:) real, intent(in) :: yest(:) - real :: ccr - real :: mean_y, mean_yest - real :: sum_y, sum_yest - real :: sum_num, sum_den_y, sum_den_yest - integer :: n - integer :: i + real :: ccr + real :: mean_y, mean_yest + real :: sum_y, sum_yest + real :: sum_num, sum_den_y, sum_den_yest + integer :: n + integer :: i n = size(y) if (n /= size(yest)) then @@ -775,23 +868,22 @@ function cal_ccr(y, yest) result(ccr) return endif - ! Calculate means + ! Compute means sum_y = sum(y) sum_yest = sum(yest) mean_y = sum_y / n mean_yest = sum_yest / n - ! Calculate numerator and denominators for correlation coefficient + ! Compute numerator and denominators for the correlation coefficient sum_num = 0.0 sum_den_y = 0.0 sum_den_yest = 0.0 do i = 1, n sum_num = sum_num + (y(i) - mean_y) * (yest(i) - mean_yest) - sum_den_y = sum_den_y + (y(i) - mean_y) ** 2 - sum_den_yest = sum_den_yest + (yest(i) - mean_yest) ** 2 + sum_den_y = sum_den_y + (y(i) - mean_y)**2 + sum_den_yest = sum_den_yest + (yest(i) - mean_yest)**2 end do - ! Calculate correlation coefficient if (sum_den_y == 0.0 .or. sum_den_yest == 0.0) then print *, "Error: Zero variance in input arrays" ccr = 0.0 @@ -801,30 +893,55 @@ function cal_ccr(y, yest) result(ccr) end function cal_ccr - function cal_rms(k_obs,k_model, n) result(rms) - implicit none - integer, intent(in) :: n - real, intent(in) :: k_obs(n),k_model(n) - real :: rms - real :: sum_sq_diff - integer :: i + function cal_rms(k_obs, k_model, n) result(rms) + !------------------------------------------------------------ + ! Function: cal_rms + ! Purpose : Calculates the relative root mean square error between observed + ! and modeled K values. + ! + ! Input: + ! k_obs - Observed K values array. + ! k_model - Modeled K values array. + ! n - Number of elements. + ! + ! Output: + ! rms - Relative RMS error. + !------------------------------------------------------------ + implicit none + integer, intent(in) :: n + real, intent(in) :: k_obs(n), k_model(n) + real :: rms + real :: sum_sq_diff + integer :: i - sum_sq_diff = 0.0 + sum_sq_diff = 0.0 - do i = 1, n - sum_sq_diff = sum_sq_diff + ((k_model(i) - k_obs(i)) / k_obs(i))**2 - end do + do i = 1, n + sum_sq_diff = sum_sq_diff + ((k_model(i) - k_obs(i)) / k_obs(i))**2 + end do - rms = sqrt(sum_sq_diff / n) -end function cal_rms + rms = sqrt(sum_sq_diff / n) + end function cal_rms function cal_cdtm(y, yest) result(dtmc) + !------------------------------------------------------------ + ! Function: cal_cdtm + ! Purpose : Computes the coefficient of determination (R^2) between observed + ! and estimated data. + ! + ! Input: + ! y - Observed data array. + ! yest - Estimated data array. + ! + ! Output: + ! dtmc - Coefficient of determination (R^2). + !------------------------------------------------------------ real, intent(in) :: y(:) real, intent(in) :: yest(:) - real :: dtmc - real :: ss_tot, ss_res - real :: mean_y - integer :: n, i + real :: dtmc + real :: ss_tot, ss_res + real :: mean_y + integer :: n, i n = size(y) if (n /= size(yest)) then @@ -833,16 +950,10 @@ function cal_cdtm(y, yest) result(dtmc) return endif - ! Calculate mean of y mean_y = sum(y) / n - - ! Calculate total sum of squares (SS_tot) ss_tot = sum((y - mean_y)**2) - - ! Calculate residual sum of squares (SS_res) ss_res = sum((y - yest)**2) - ! Calculate coefficient of determination (R^2) if (ss_tot == 0.0) then print *, "Error: Zero total sum of squares" dtmc = 0.0 @@ -852,13 +963,23 @@ function cal_cdtm(y, yest) result(dtmc) end function cal_cdtm -function median(data) result(med) + function median(data) result(med) + !------------------------------------------------------------ + ! Function: median + ! Purpose : Computes the median of an array, ignoring values equal to -9999.0. + ! + ! Input: + ! data - Array of real numbers. + ! + ! Output: + ! med - Median value. + !------------------------------------------------------------ implicit none real, intent(in) :: data(:) - real :: med - real :: sorted_data(size(data)) - integer :: n_valid - integer :: i + real :: med + real :: sorted_data(size(data)) + integer :: n_valid + integer :: i n_valid = 0 do i = 1, size(data) @@ -881,13 +1002,21 @@ function median(data) result(med) med = sorted_data((n_valid + 1) / 2) end if -end function median - -subroutine sort2(arr) + end function median + + subroutine sort2(arr) + !------------------------------------------------------------ + ! Subroutine: sort2 + ! Purpose : Sorts an array of real numbers in ascending order using + ! insertion sort. + ! + ! Input/Output: + ! arr - Array to be sorted. + !------------------------------------------------------------ implicit none real, intent(inout) :: arr(:) - integer :: i, j - real :: temp + integer :: i, j + real :: temp do i = 2, size(arr) temp = arr(i) @@ -898,8 +1027,7 @@ subroutine sort2(arr) end do arr(j + 1) = temp end do -end subroutine sort2 + end subroutine sort2 !------------------------------------------------------------ - end module k_module \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py index 2c70619ef..f5989e826 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/process_lake_data.py @@ -1,5 +1,9 @@ +import sys import numpy as np from netCDF4 import Dataset +#Main purpose: Processes lake data to be used in the river routing model. + +file_lat1m, file_lon1m, file_catmap, file_lake_mantag, file_lakecat_manfix = sys.argv[1:6] # Define constants nlat = 10800 @@ -8,8 +12,8 @@ # Read data from files lats = np.loadtxt("temp/outlet_lat.txt", dtype=float) # Latitude of outlets lons = np.loadtxt("temp/outlet_lon.txt", dtype=float) # Longitude of outlets -lat1m = np.loadtxt("input/lat_1m.txt", dtype=float) # Latitude grid -lon1m = np.loadtxt("input/lon_1m.txt", dtype=float) # Longitude grid +lat1m = np.loadtxt(file_lat1m, dtype=float) # Latitude grid +lon1m = np.loadtxt(file_lon1m, dtype=float) # Longitude grid # Function to find the nearest index in a coordinate array def ind_nearest_coord(coord_array1, coord_array2): @@ -43,7 +47,7 @@ def read_ncfile_int2d(filepath, varname, shape): data = np.where(data == fill_value, -9999, data) # Replace missing values with 0 return data -catchind = read_ncfile_int2d("input/CatchIndex.nc", "data", (nlat, nlon)) +catchind = read_ncfile_int2d(file_catmap, "CatchIndex", (nlat, nlon)) # Calculate catid catid = np.zeros(ns, dtype=int) @@ -87,7 +91,7 @@ def read_ncfile_int2d(filepath, varname, shape): #------------------------------------------------------------------------------------------------------ # Read tags -tag_INCON = np.loadtxt("input/outletINCON_catid_tag_from_excel.txt", dtype=int) +tag_INCON = np.loadtxt(file_lake_mantag, dtype=int) # Update catid and aca_model based on tags for i in range(nv): @@ -155,8 +159,8 @@ def read_ncfile_int2d(filepath, varname, shape): outidV += 1 -# Fix multi-outlet IDs -catid_outfix_2097 = np.loadtxt("input/outlet2097_catid_multiOut_fix.txt", dtype=int) +# Fix multiple outlets in same catchment +catid_outfix_2097 = np.loadtxt(file_lakecat_manfix, dtype=int) catid_outfix_out = np.full(ns, -9999, dtype=int) for i in range(nv3): @@ -166,7 +170,4 @@ def read_ncfile_int2d(filepath, varname, shape): catid = np.where((catid_outfix_out != 0) & (catid_outfix_out != -9999), catid_outfix_out, catid) np.savetxt("output/lake_outlet_catid.txt", catid, fmt="%d") -# Final flag computation -#flag_final = np.where(catid > 0, 1, 0) -#print(np.sum(flag_final)) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 index afdf7de03..4557eba84 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/read_input_TopoCat.f90 @@ -1,42 +1,64 @@ program main +!Main purpose: Reads lake and lake outlets information from Lake-TopoCat database. + +use constant, only : no, nvl, nvo, nl=>nl_lake implicit none - integer,parameter :: no=1459201 - integer,parameter :: nvl=3409 - integer,parameter :: nvo=3917 - integer,parameter :: nl=1426967 + ! Declare arrays for outlet and lake data: + integer, allocatable, dimension(:) :: lakeid_out, outid_out, lakeid_lake, lakeid_outV, outid_outV + real, allocatable, dimension(:) :: lat_out, lon_out, lat_outV, lon_outV, & + lakeaca_lake, lakearea_lake, lakeaca_outV, lakearea_outV + + ! Arrays for raw lake data: + real, allocatable, dimension(:) :: area_lake, aca_lake + integer, allocatable, dimension(:) :: id_lake + character(len=900) :: area_lake_file, id_lake_file, aca_lake_file + integer :: i, j, k - integer,allocatable,dimension(:) :: lakeid_out,outid_out,lakeid_lake,lakeid_outV,outid_outV - real,allocatable,dimension(:) :: lat_out,lon_out,lat_outV,lon_outV,& - lakeaca_lake,lakearea_lake,lakeaca_outV,lakearea_outV + character(len=900) :: file_lake_area + character(len=900) :: file_lake_id + character(len=900) :: file_lake_aca + character(len=900) :: file_lakeo_lakeid + character(len=900) :: file_lakeo_id + character(len=900) :: file_lakeo_lat + character(len=900) :: file_lakeo_lon - real,allocatable,dimension(:) :: area_lake, aca_lake - integer,allocatable,dimension(:) :: id_lake - character(len=256) :: area_lake_file, id_lake_file, aca_lake_file - integer :: i,j,k + if (command_argument_count() /= 7) then + print *, "no appropriate files found" + stop + endif + call get_command_argument(1, file_lake_area) + call get_command_argument(2, file_lake_id) + call get_command_argument(3, file_lake_aca) + call get_command_argument(4, file_lakeo_lakeid) + call get_command_argument(5, file_lakeo_id) + call get_command_argument(6, file_lakeo_lat) + call get_command_argument(7, file_lakeo_lon) - allocate(area_lake(nl),aca_lake(nl),id_lake(nl)) - ! Initialize file names - area_lake_file = "input/Lake_area.csv" - id_lake_file = "input/Hylak_id_lake.csv" - aca_lake_file = "input/Cat_a_lake.csv" + ! Allocate arrays for raw lake data (size nl): + allocate(area_lake(nl), aca_lake(nl), id_lake(nl)) + + ! Initialize file names for input lake data: + area_lake_file = file_lake_area + id_lake_file = file_lake_id + aca_lake_file = file_lake_aca - ! Read input data (You can implement your own read procedure if needed) - open(77, file=area_lake_file, status="old") + ! Read lake area, lake ID, and lake "aca" data from the input CSV files: + open(77, file=trim(area_lake_file), status="old") read(77, *) area_lake - open(77, file=id_lake_file, status="old") + open(77, file=trim(id_lake_file), status="old") read(77, *) id_lake - open(77, file=aca_lake_file, status="old") + open(77, file=trim(aca_lake_file), status="old") read(77, *) aca_lake - ! Allocate arrays for filtered data + ! Allocate arrays for filtered lake data (size nvl): allocate(lakearea_lake(nvl)) allocate(lakeid_lake(nvl)) allocate(lakeaca_lake(nvl)) k = 0 - ! Filter lakes with area >= 50 + ! Filter lakes: select only those with an area greater than or equal to 50. do i = 1, nl if (area_lake(i) .ge. 50.0) then k = k + 1 @@ -47,55 +69,61 @@ program main end do !------------------------------------------------------------------------------------- - allocate(lakeid_out(no),outid_out(no),lat_out(no),lon_out(no)) - allocate(lakeid_outV(nvo),outid_outV(nvo),lat_outV(nvo),lon_outV(nvo),lakeaca_outV(nvo),lakearea_outV(nvo)) - - open(77,file="input/Hylak_id_outlet.csv") - read(77,*)lakeid_out - open(77,file="input/Outlet_id.csv") - read(77,*)outid_out - open(77,file="input/Outlet_lat.csv") - read(77,*)lat_out - open(77,file="input/Outlet_lon.csv") - read(77,*)lon_out - - k=0 - do i=1,no - do j=1,nvl - if(lakeid_out(i)==lakeid_lake(j))then - k=k+1 - outid_outV(k)=outid_out(i) - lat_outV(k)=lat_out(i) - lon_outV(k)=lon_out(i) - lakeid_outV(k)=lakeid_lake(j) - lakeaca_outV(k)=lakeaca_lake(j) - lakearea_outV(k)=lakearea_lake(j) - endif - enddo - enddo - - !print *,k - - open(88,file="temp/outlet_lat.txt")! - do i=1,nvo - write(88,*)lat_outV(i) - enddo - open(88,file="temp/outlet_lon.txt")! - do i=1,nvo - write(88,*)lon_outV(i) - enddo - open(88,file="temp/outlet_lakeid.txt")! - do i=1,nvo - write(88,*)lakeid_outV(i) - enddo - open(88,file="temp/outlet_lakeacaOBS.txt")! - do i=1,nvo - write(88,*)lakeaca_outV(i) - enddo - open(88,file="output/lake_outlet_lakearea.txt")! - do i=1,nvo - write(88,*)lakearea_outV(i) - enddo + ! Allocate arrays for outlet data (raw arrays with size 'no'): + allocate(lakeid_out(no), outid_out(no), lat_out(no), lon_out(no)) + ! Allocate arrays for matched outlet data (size 'nvo'): + allocate(lakeid_outV(nvo), outid_outV(nvo), lat_outV(nvo), lon_outV(nvo), lakeaca_outV(nvo), lakearea_outV(nvo)) + + ! Read outlet data from CSV files: + open(77, file=trim(file_lakeo_lakeid)) + read(77, *) lakeid_out + open(77, file=trim(file_lakeo_id)) + read(77, *) outid_out + open(77, file=trim(file_lakeo_lat)) + read(77, *) lat_out + open(77, file=trim(file_lakeo_lon)) + read(77, *) lon_out + + ! Match outlet records to filtered lakes: + k = 0 + do i = 1, no + do j = 1, nvl + if (lakeid_out(i) == lakeid_lake(j)) then + k = k + 1 + outid_outV(k) = outid_out(i) + lat_outV(k) = lat_out(i) + lon_outV(k) = lon_out(i) + lakeid_outV(k) = lakeid_lake(j) + lakeaca_outV(k) = lakeaca_lake(j) + lakearea_outV(k) = lakearea_lake(j) + end if + end do + end do + + ! Write matched outlet data to output text files: + open(88, file="temp/outlet_lat.txt") + do i = 1, nvo + write(88, *) lat_outV(i) + end do + + open(88, file="temp/outlet_lon.txt") + do i = 1, nvo + write(88, *) lon_outV(i) + end do + + open(88, file="temp/outlet_lakeid.txt") + do i = 1, nvo + write(88, *) lakeid_outV(i) + end do + + open(88, file="temp/outlet_lakeacaOBS.txt") + do i = 1, nvo + write(88, *) lakeaca_outV(i) + end do + open(88, file="output/lake_outlet_lakearea.txt") + do i = 1, nvo + write(88, *) lakearea_outV(i) + end do end \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/readme.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/readme.txt new file mode 100644 index 000000000..947e08f81 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/readme.txt @@ -0,0 +1,165 @@ +v1 05/05/2025, Yujin Zeng + +The "preproc/routing_model" package is used for creating input data for the GEOS routing model. + +Usage: + 鈥 On NCCS/Discover: + 1. source g5_modules.sh + 2. python3 run_routing_preproc.py + 鈥 Off Discover: contact yujin.zeng@nasa.gov + +The tasks completed by each F90 or Python program are briefly described as follows: + +1. get_Pfaf_file.f90 + Reads the Pfafstetter code dataset and generates + files for the connectivity of catchments in the routing network. + +2. get_latloni_cellarea.py + Computes grid-cell index arrays and per-cell areas for 1-m high-res grid. + +3. get_num_sub_catchment_M09.f90 / get_num_sub_catchment_M36.f90 + Parses high-res map of catchment index to get the area and + coordinates (of model grid) of each sub-catchments within each main catchment. + +4. get_lonlat_bond_M09.f90 / get_lonlat_bond_M36.f90 + Extracts the latitude/longitude boundaries of each catchment-tile from + catchment definition files. + +5. get_lonlati_maptile_M09.py / get_lonlati_maptile_M36.py + Assigns a catchment鈥恡ile index from catchment definition files to each model grid cell. + +6. get_isub_M09.f90 / get_isub_M36.f90 + Assigns a catchment鈥恡ile index from maptile files to each sub-catchment. + +7. get_area_M09.f90 / get_area_M36.f90 + Gets the area for each catchment-tile. + +8. get_Qr_clmt.f90 + Reads SMAP L4 runoff data (2016鈥2023) from a NetCDF file and computes the climatological + mean discharge for each catchment. + +9. get_river_length.f90 + Determines main river channel lengths for each catchment by using HydroSHEDS + data of distance to sink. + +10. get_K_model_calik.f90 + Calculates the K parameter used in the river routing model. + +11. get_dam_data.py + Processes reservoir (dam) data: reads dam locations and usage information from GRanD database. + +12. read_input_TopoCat.f90 + Reads lake and lake outlets information from Lake-TopoCa database. + +13. process_lake_data.py + Processes lake data to be used in the river routing model. + +The explanations for the input files of this package can be found in the input directory. + +The outputs from this package, which are used as input to the river routing model, are listed as follows: + +downstream_1D_new_noadj.txt + Downstream catchment id for each catchment. + +Pfaf_area.txt + Catchment area (km^2) for each catchment. + +upstream_1D.txt + Upstream catchment id for each catchment. + +Pfaf_upnum.txt + Number of upstream catchments for each catchment. + +Pfaf_tosink.txt + Number of steps to final sink for each catchment. + +Pfaf_nsub_M09.txt / Pfaf_nsub_M36.txt + Count of sub鈥恈atchments contained within each catchment at M09 and M36 resolutions, respectively. + +Pfaf_xsub_M09.txt / Pfaf_xsub_M36.txt + X (longitude) coordinates in M09 and M36 grid for each sub-catchemnt within each catchment, respectively. + +Pfaf_ysub_M09.txt / Pfaf_ysub_M36.txt + Y (longitude) coordinates in M09 and M36 grid for each sub-catchemnt within each catchment, respectively. + +Pfaf_asub_M09.txt / Pfaf_asub_M36.txt + Area (km^2) of each sub鈥恈atchment within each catchment at M09 and M36 resolutions, respectively. + +Pfaf_isub_M09.txt / Pfaf_isub_M36.txt + Tile number (in the catchment definition file) of each sub鈥恈atchment within each catchment at M09 and M36 resolutions, respectively. + +area_M09_1d.txt / area_M36_1d.txt + Area (km^2) of each tile (in the catchment definition file) for M09 and M36 grid, respectively. + +Pfaf_qstr.txt + Climatological mean runoff (m^3 s-1) for each catchment. + +Pfaf_qri.txt + Climatological mean discharge (m^3 s-1) for each catchment. + +Pfaf_qin.txt + Climatological mean inflow (m^3 s-1) from upstream for each catchment. + +Pfaf_lriv_PR.txt + Main river length scale (km) for each catchment. + +Pfaf_lstr_PR.txt + Mean local stream length scale (km) for each catchment. + +Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt + Calculated K parameters for local streams in each catchment. + +Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt + Calculated K parameters for main rivers in each catchment. + +area_skm_grand.txt + Reservoir surface areas (km^2) for the GRanD dams. + +cap_max_grand.txt + Maximum storage capacities (10^6 m^3) for the GRanD dams. + +catid_dam_corr_aca_grand5000.txt + Catchment IDs for the GRanD dams. + +flag_all_res.txt + In-use flags for the GRanD dams. + +irr_grand.txt + Flags for irrigation use for the GRanD dams. + +hydroelec_grand.txt + Flags for hydroelectric use for the GRanD dams. + +watersupply_grand.txt + Flags for water-supply use for the GRanD dams. + +nav_grand.txt + Flags for navigation use for the GRanD dams. + +rec_grand.txt + Flags for recreational use for the GRanD dams. + +fldmainsec_grand.txt + Flags for flood鈥恈ontrol use for the GRanD dams. + +other_grand.txt + Flags for other use for the GRanD dams. + +lake_outlet_lakearea.txt + Lake surface area (km^2) for each lake represented in the model. + +lake_outlet_flag_valid_2097.txt + In-use flags for the lakes. + +lake_outlet_catid.txt + Catchment IDs for the lakes represented in the model. + + + + + + + + + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 index c8774b93a..1ed66ce0b 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/river_read.f90 @@ -1,4 +1,5 @@ module river_read +!module for reading river routing-related netcdf data implicit none include 'netcdf.inc' @@ -17,45 +18,45 @@ module river_read contains !------------------------------------------------------------------------------------------ subroutine read_ncfile_int1d(filename,varname,var,n) - character(len=*), intent(in) :: filename + character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: n - integer, intent(inout) :: var(n) + integer, intent(in) :: n + integer, intent(inout) :: var(n) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) call check_ret(nf_get_var_int(ncid,varid,var),subname) call check_ret(nf_close(ncid), subname) end subroutine read_ncfile_int1d !------------------------------------------------------------------------------------------ subroutine read_ncfile_real1d(filename,varname,var,n) - character(len=*), intent(in) :: filename + character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: n - real, intent(inout) :: var(n) + integer, intent(in) :: n + real, intent(inout) :: var(n) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) call check_ret(nf_get_var_real(ncid,varid,var),subname) call check_ret(nf_close(ncid), subname) end subroutine read_ncfile_real1d !------------------------------------------------------------------------------------------ subroutine read_ncfile_double1d(filename,varname,var,n) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: varname - integer, intent(in) :: n - real*8, intent(inout) :: var(n) + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + integer, intent(in) :: n + real*8, intent(inout) :: var(n) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid call check_ret(nf_open(filename,0,ncid),subname) call check_ret(nf_inq_varid(ncid,varname,varid),subname) @@ -65,13 +66,13 @@ subroutine read_ncfile_double1d(filename,varname,var,n) end subroutine read_ncfile_double1d !------------------------------------------------------------------------------------------ subroutine read_ncfile_int2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename + character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - integer, intent(inout) :: var(nlon,nlat) + integer, intent(in) :: nlon, nlat + integer, intent(inout) :: var(nlon,nlat) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid call check_ret(nf_open(filename,0,ncid),subname) call check_ret(nf_inq_varid(ncid,varname,varid),subname) @@ -83,11 +84,11 @@ end subroutine read_ncfile_int2d subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - integer, intent(inout) :: var(nlon,nlat,nlev) + integer, intent(in) :: nlon, nlat, nlev + integer, intent(inout) :: var(nlon,nlat,nlev) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid call check_ret(nf_open(filename,0,ncid),subname) call check_ret(nf_inq_varid(ncid,varname,varid),subname) @@ -97,16 +98,16 @@ subroutine read_ncfile_int3d(filename,varname,var,nlon,nlat,nlev) end subroutine read_ncfile_int3d !------------------------------------------------------------------------------------------ subroutine read_ncfile_real2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename + character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real, intent(inout) :: var(nlon,nlat) + integer, intent(in) :: nlon, nlat + real, intent(inout) :: var(nlon,nlat) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) call check_ret(nf_get_var_real(ncid,varid,var),subname) call check_ret(nf_close(ncid), subname) @@ -115,11 +116,11 @@ end subroutine read_ncfile_real2d subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - real, intent(inout) :: var(nlon,nlat,nlev) + integer, intent(in) :: nlon, nlat, nlev + real, intent(inout) :: var(nlon,nlat,nlev) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid call check_ret(nf_open(filename,0,ncid),subname) call check_ret(nf_inq_varid(ncid,varname,varid),subname) @@ -129,30 +130,29 @@ subroutine read_ncfile_real3d(filename,varname,var,nlon,nlat,nlev) end subroutine read_ncfile_real3d !------------------------------------------------------------------------------------------ subroutine read_ncfile_double2d(filename,varname,var,nlon,nlat) - character(len=*), intent(in) :: filename + character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat - real*8, intent(inout) :: var(nlon,nlat) + integer, intent(in) :: nlon, nlat + real*8, intent(inout) :: var(nlon,nlat) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid - call check_ret(nf_open(filename,0,ncid),subname) - call check_ret(nf_inq_varid(ncid,varname,varid),subname) + call check_ret(nf_open(filename,0,ncid),subname) + call check_ret(nf_inq_varid(ncid,varname,varid),subname) call check_ret(nf_get_var_double(ncid,varid,var),subname) call check_ret(nf_close(ncid), subname) end subroutine read_ncfile_double2d - - +!------------------------------------------------------------------------------------------ subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) character(len=*), intent(in) :: filename character(len=*), intent(in) :: varname - integer, intent(in) :: nlon, nlat, nlev - real*8, intent(inout) :: var(nlon,nlat,nlev) + integer, intent(in) :: nlon, nlat, nlev + real*8, intent(inout) :: var(nlon,nlat,nlev) - character(len=4) :: subname="read" - integer :: ncid, varid + character(len=4) :: subname="read" + integer :: ncid, varid call check_ret(nf_open(filename,0,ncid),subname) call check_ret(nf_inq_varid(ncid,varname,varid),subname) @@ -161,58 +161,32 @@ subroutine read_ncfile_double3d(filename,varname,var,nlon,nlat,nlev) end subroutine read_ncfile_double3d !------------------------------------------------------------------------------------------ -!BOP -! -! !IROUTINE: check_ret -! -! !INTERFACE: subroutine check_ret(ret, calling) -! !DESCRIPTION: -! Check return status from netcdf call -! -! !ARGUMENTS: - implicit none - integer, intent(in) :: ret - character(len=*) :: calling -! -! !REVISION HISTORY: -! -!EOP -!----------------------------------------------------------------------- - - if (ret /= NF_NOERR) then - write(6,*)'netcdf error from ',trim(calling) - call endrun(nf_strerror(ret)) - end if + integer, intent(in) :: ret + character(len=*) :: calling + if (ret /= NF_NOERR) then + write(6,*)'netcdf error from ',trim(calling) + call endrun(nf_strerror(ret)) + end if end subroutine check_ret !----------------------------------------------------------------------- -!BOP -! !IROUTINE: endrun -! -! !INTERFACE: -subroutine endrun(msg,subname) -! -! !DESCRIPTION: -! Abort the model for abnormal termination - implicit none -! !ARGUMENTS: - character(len=*), intent(in), optional :: msg ! string to be printed - character(len=*), intent(in), optional :: subname ! subname - - if (present (subname)) then + subroutine endrun(msg,subname) + character(len=*), intent(in), optional :: msg + character(len=*), intent(in), optional :: subname + + if (present (subname)) then write(6,*) 'ERROR in subroutine :', trim(subname) - end if + end if - if (present (msg)) then + if (present (msg)) then write(6,*)'ENDRUN:', msg - else + else write(6,*) 'ENDRUN: called without a message string' - end if - - stop -end subroutine endrun + end if + stop + end subroutine endrun !----------------------------------------------------------------------- end module river_read diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run_routing_preproc.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run_routing_preproc.py new file mode 100644 index 000000000..b334d4872 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/run_routing_preproc.py @@ -0,0 +1,176 @@ +#!/usr/bin/env python3 + +#source g5_modules before run to get the necessary env + +import os +import shutil +import subprocess +from pathlib import Path + +def run(cmd): + """Run a command and exit on failure.""" + print(f">>> {' '.join(cmd)}") + subprocess.run(cmd, check=True) + +def main(): + # ----------------------------- + # Define input and output paths + # ----------------------------- + +# Path to "bcs_shared" directory: + file_path = "/discover/nobackup/yzeng3/data/river_preproc_input/" # NCCS Discover + #file_path = "/nobackup/gmao_SIteam/ModelData/bcs_shared/" # NAS + + + file_pfafrout = file_path + "/Pfafcatch-routing.dat" + file_lat1m = file_path + "/lat_1m.txt" + file_lon1m = file_path + "/lon_1m.txt" + file_lat = {"M09": file_path + "/lat_M09.txt", + "M36": file_path + "/lat_M36.txt"} + file_lon = {"M09": file_path + "/lon_M09.txt", + "M36": file_path + "/lon_M36.txt"} + file_catdef = {"M09": file_path + "/catchment_M09.def", + "M36": file_path + "/catchment_M36.def"} + file_clmtrunf = file_path + "/SMAPL4_OL7000_runoff_mean_2016_2023.nc" + file_pfafmap = file_path + "/SRTM_PfafData.nc" + file_ldn = file_path + "/hyd_glo_ldn_15s.nc" + file_hyelev = file_path + "/hyd_glo_dem_15s.nc" + file_vel = file_path + "/velocity.txt" + file_dis = file_path + "/discharge.txt" + file_usid = file_path + "/USGSID.txt" + file_lats = file_path + "/lat_for_site.txt" + file_lons = file_path + "/lon_for_site.txt" + file_gage_id = file_path + "/id_gagesii.txt" + file_gage_acar = file_path + "/acar_gagesii.txt" + + file_latdam = file_path + "/lat_dam_grand.txt" + file_londam = file_path + "/lon_dam_grand.txt" + file_acadam = file_path + "/catch_acar_grand.txt" + file_damcat_manfix = file_path + "/catid_dam_manfix.txt" + file_dam_manflag = file_path + "/flag_dam_manfix.txt" + file_dam_use = file_path + "/main_use_grand.txt" + file_damflood = file_path + "/flood_use_grand.txt" + file_damarea = file_path + "/area_skm_grand.txt" + file_damcap = file_path + "/cap_max_grand.txt" + + file_lake_area = file_path + "/Lake_area.csv" + file_lake_id = file_path + "/Hylak_id_lake.csv" + file_lake_aca = file_path + "/acar_lake.csv" + file_lakeo_lakeid = file_path + "/Hylak_id_lakeout.csv" + file_lakeo_id = file_path + "/Outlet_id_lakeout.csv" + file_lakeo_lat = file_path + "/Outlet_lat_lakeout.csv" + file_lakeo_lon = file_path + "/Outlet_lon_lakeout.csv" + file_lake_mantag = file_path + "/catid_lake_manfix.txt" + file_lakecat_manfix = file_path + "/catid_lake_multout_manfix.txt" + + + lib_path = "/discover/nobackup/yzeng3/lib" + old_ld = os.environ.get("LD_LIBRARY_PATH", "") + os.environ["LD_LIBRARY_PATH"] = f"{lib_path}:{old_ld}" + + # ----------------------------- + # Ensure output and temp directory exists + # ----------------------------- + subprocess.run(["mkdir", "-p", "output"], check=True) + subprocess.run(["mkdir", "-p", "temp"], check=True) + + # ----------------------------- + # Copy dam area and capacity files + # ----------------------------- + shutil.copy(file_damarea, "output/") + shutil.copy(file_damcap, "output/") + + # ----------------------------- + # River processing section + # ----------------------------- + # Compile and run Pfafcatch routing generator + run(["./build", "get_Pfaf_file.f90"]) + run(["./get_Pfaf_file.out", file_pfafrout]) + + # Generate latitude/longitude indices and cell areas + run([ + "python3", "get_latloni_cellarea.py", + file_lat["M36"], file_lon["M36"], + file_lat["M09"], file_lon["M09"], + file_lat1m, file_lon1m, + ]) + + # Compute number of sub-catchments for M09 and M36 resolutions + for res in ("M09", "M36"): + run(["./build", f"get_num_sub_catchment_{res}.f90"]) + run([f"./get_num_sub_catchment_{res}.out", file_pfafmap]) + + # Build longitude-latitude boundary files for each resolution + for res in ("M09", "M36"): + run(["./build", f"get_lonlat_bond_{res}.f90"]) + run([f"./get_lonlat_bond_{res}.out", file_catdef[res]]) + + # Map tile longitude/latitude for M09 and M36 + for res in ("M09", "M36"): + run(["python3", f"get_lonlati_maptile_{res}.py", file_lat[res], file_lon[res]]) + # Build and run isub calculators for both resolutions + for res in ("M09", "M36"): + run(["./build", f"get_isub_{res}.f90"]) + run([f"./get_isub_{res}.out"]) + + # Calculate area of each catchment + for res in ("M09", "M36"): + run(["./build", f"get_area_{res}.f90"]) + run([f"./get_area_{res}.out", file_pfafmap]) + + # Compute climatological runoff + run(["./build", "get_Qr_clmt.f90"]) + run(["./get_Qr_clmt.out", file_clmtrunf]) + + # Determine river lengths + run(["./build", "get_river_length.f90"]) + run([ + "./get_river_length.out", + file_pfafmap, file_ldn, + file_hyelev, file_pfafrout + ]) + + # Calibrate K model using velocity and discharge data + run(["./build", "get_K_model_calik.f90"]) + run([ + "./get_K_model_calik.out", + file_vel, file_dis, file_usid, + file_lats, file_lons, + file_lat1m, file_lon1m, + file_pfafmap, + file_gage_id, file_gage_acar + ]) + + # ----------------------------- + # Reservoir (dam) processing + # ----------------------------- + run([ + "python3", "get_dam_data.py", + file_latdam, file_londam, + file_lat1m, file_lon1m, + file_pfafmap, file_acadam, + file_damcat_manfix, file_dam_manflag, + file_dam_use, file_damflood + ]) + + # ----------------------------- + # Lake processing section + # ----------------------------- + run(["./build", "read_input_TopoCat.f90"]) + run([ + "./read_input_TopoCat.out", + file_lake_area, file_lake_id, + file_lake_aca, + file_lakeo_lakeid, file_lakeo_id, + file_lakeo_lat, file_lakeo_lon + ]) + + run([ + "python3", "process_lake_data.py", + file_lat1m, file_lon1m, + file_pfafmap, + file_lake_mantag, file_lakecat_manfix + ]) + +if __name__ == "__main__": + main() \ No newline at end of file From 9a08d7b381679928adc0c6a44ad187ccbee578ba Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Thu, 8 May 2025 14:23:07 -0400 Subject: [PATCH 18/27] '==' changed to '.eqv.' --- .../GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 index 2cbb0ccba..e4a576865 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 @@ -255,7 +255,7 @@ subroutine res_init(input_dir,nall,nc,minCatch,maxCatch,use_res,active_res,type_ enddo ! Deactivate reservoirs if the use_res flag is set to False - if(use_res == .False.) active_res = 0 + if(use_res .eqv. .False.) active_res = 0 deallocate(flag_grand,catid_grand,elec_grand,type_res_all,cap_grand,area_grand) deallocate(area_res,area_max_res,fld_grand,supply_grand,irr_grand) From 32fe9551f9d3cb2f3919a5b3c1b3c35d1363fb72 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Fri, 9 May 2025 10:56:33 -0400 Subject: [PATCH 19/27] '.eqv.' replaces '==' --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 4 ++-- .../GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 | 2 +- .../GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 53041911d..6b9205889 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -1004,7 +1004,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) !print *, "output stream storage is: ",sum(wstream_global)/1.e9 endif - if(use_res==.True.)then + if(use_res .eqv. .True.)then allocate(qres_global(n_catg)) call MPI_allgatherv ( & res%qres_acc, route%scounts_cat(mype+1) ,MPI_REAL, & @@ -1054,7 +1054,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) print *, "saved stream storage is: ",sum(wstream_global)/1.e9 endif - if(use_res==.True.)then + if(use_res .eqv. .True.)then allocate(wres_global(n_catg)) call MPI_allgatherv ( & res%Wr_res, route%scounts_cat(mype+1) ,MPI_REAL, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 index 0aab6d316..176757772 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/lake_mod.f90 @@ -63,7 +63,7 @@ subroutine lake_init(input_dir, use_lake, nc, nlake, nres, active_res, active_la where (active_res == 1) active_lake = 0 ! If lakes are not being used, set active lakes to zero - if (use_lake == .False.) active_lake = 0 + if (use_lake .eqv. .False.) active_lake = 0 end subroutine lake_init diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 index 864065a10..77d066bbd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/offline/res_mod.f90 @@ -247,7 +247,7 @@ subroutine res_init(input_dir,nres,nc,use_res,active_res,Wr_res,Q_res,type_res,c ! Wres_tar = Wres_tar * 1.D6 * rho ! Convert from million cubic meters (MCM) to kilograms (kg) ! Deactivate reservoirs if the use_res flag is set to False - if(use_res == .False.) active_res = 0 + if(use_res .eqv. .False.) active_res = 0 end subroutine res_init From ef58210363133953792a83348e5c6e1a947febe3 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Wed, 21 May 2025 09:35:31 -0400 Subject: [PATCH 20/27] changed variable name NUM_CATCH -> NUM_CATCH_ENS for clarity (GEOS_LandGridComp.F90) --- .../GEOSland_GridComp/GEOS_LandGridComp.F90 | 28 +++++++++---------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 index 59910cdd6..86321eb76 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 @@ -45,7 +45,7 @@ module GEOS_LandGridCompMod integer :: VEGDYN - integer, allocatable :: CATCH(:), ROUTE (:), CATCHCN (:) + integer, allocatable :: CATCH(:), CATCHCN(:), ROUTE(:) integer :: LSM_CHOICE, RUN_ROUTE, DO_GOSWIM integer :: IGNI logical :: DO_FIRE_DANGER @@ -84,7 +84,7 @@ subroutine SetServices ( GC, RC ) character(len=ESMF_MAXSTR) :: GCName type(ESMF_Config) :: CF, SCF - integer :: NUM_CATCH + integer :: NUM_CATCH_ENS integer :: I character(len=ESMF_MAXSTR) :: TMP type(MAPL_MetaComp),pointer :: MAPL=>null() @@ -134,7 +134,7 @@ subroutine SetServices ( GC, RC ) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) VERIFY_(STATUS) - call ESMF_ConfigGetAttribute ( CF, NUM_CATCH, Label="NUM_CATCH_ENSEMBLES:", default=1, RC=STATUS) + call ESMF_ConfigGetAttribute ( CF, NUM_CATCH_ENS, Label="NUM_CATCH_ENSEMBLES:", default=1, RC=STATUS) VERIFY_(STATUS) !------------------------------------------------------------ @@ -163,13 +163,13 @@ subroutine SetServices ( GC, RC ) CASE (1) - allocate (CATCH(NUM_CATCH), stat=status) + allocate (CATCH(NUM_CATCH_ENS), stat=status) VERIFY_(STATUS) - if (NUM_CATCH == 1) then + if (NUM_CATCH_ENS == 1) then CATCH(1) = MAPL_AddChild(GC, NAME='CATCH'//trim(tmp), SS=CatchSetServices, RC=STATUS) VERIFY_(STATUS) else - do I = 1, NUM_CATCH + do I = 1, NUM_CATCH_ENS WRITE(TMP,'(I3.3)') I GCName = 'ens' // trim(TMP) // ':CATCH' CATCH(I) = MAPL_AddChild(GC, NAME=GCName, SS=CatchSetServices, RC=STATUS) @@ -179,13 +179,13 @@ subroutine SetServices ( GC, RC ) CASE (2,3) - allocate (CATCHCN(NUM_CATCH), stat=status) + allocate (CATCHCN(NUM_CATCH_ENS), stat=status) VERIFY_(STATUS) - if (NUM_CATCH == 1) then + if (NUM_CATCH_ENS == 1) then CATCHCN(1) = MAPL_AddChild(GC, NAME='CATCHCN'//trim(tmp), SS=CatchCNSetServices, RC=STATUS) VERIFY_(STATUS) else - do I = 1, NUM_CATCH + do I = 1, NUM_CATCH_ENS WRITE(TMP,'(I3.3)') I GCName = 'ens' // trim(TMP) // ':CATCHCN' CATCHCN(I) = MAPL_AddChild(GC, NAME=GCName, SS=CatchCNSetServices, RC=STATUS) @@ -195,14 +195,14 @@ subroutine SetServices ( GC, RC ) END SELECT - allocate (ROUTE(NUM_CATCH), stat=status) + allocate (ROUTE(NUM_CATCH_ENS), stat=status) VERIFY_(STATUS) IF(RUN_ROUTE == 1) THEN - if (NUM_CATCH == 1) then + if (NUM_CATCH_ENS == 1) then ROUTE(1) = MAPL_AddChild(GC, NAME='ROUTE', SS=RouteSetServices, RC=STATUS) VERIFY_(STATUS) else - do I = 1, NUM_CATCH + do I = 1, NUM_CATCH_ENS WRITE(TMP,'(I3.3)') I GCName = 'ens' // trim(TMP) // ':ROUTE' ROUTE(I) = MAPL_AddChild(GC, NAME=GCName, SS=RouteSetServices, RC=STATUS) @@ -1428,7 +1428,7 @@ subroutine SetServices ( GC, RC ) ! !CONNECTIONS: - DO I = 1, NUM_CATCH + DO I = 1, NUM_CATCH_ENS SELECT CASE (LSM_CHOICE) @@ -1500,7 +1500,7 @@ subroutine SetServices ( GC, RC ) ENDIF END SELECT END DO - + call MAPL_TimerAdd(GC, name="INITIALIZE" ,RC=STATUS) VERIFY_(STATUS) From 85af5a79c5a74b0e8768fd33ed95f6a354ffc67f Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Wed, 21 May 2025 14:04:22 -0400 Subject: [PATCH 21/27] avoid duplicate hard-coding of #Pfaf catchments; fixed indent, alignment (GEOS_RouteGridComp.F90) --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 839 +++++++++--------- 1 file changed, 421 insertions(+), 418 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 6b9205889..85ecd8f4e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -24,21 +24,18 @@ module GEOS_RouteGridCompMod use ESMF use MAPL_Mod use MAPL_ConstantsMod - use ROUTING_MODEL, ONLY: & - river_routing_lin, river_routing_hyd, ROUTE_DT - use reservoir -#if 0 - USE catch_constants, ONLY: & - N_CatG => N_Pfaf_Catchs -#endif + use ROUTING_MODEL, ONLY: river_routing_lin, river_routing_hyd, ROUTE_DT + use reservoir, ONLY: res_init, res_cal + use catch_constants, ONLY: N_CatG => CATCH_N_PFAFS + use, intrinsic :: iso_c_binding implicit none - integer, parameter :: N_CatG = 291284 - integer,parameter :: upmax=34 - character(len=500) :: inputdir="/discover/nobackup/yzeng3/data/river_input/" - logical,parameter :: use_res = .True. - integer,save :: nmax + + integer, parameter :: upmax = 34 + character(len=500) :: inputdir = "/discover/nobackup/yzeng3/data/river_input/" + logical, parameter :: use_res = .True. + integer, save :: nmax private @@ -68,37 +65,37 @@ module GEOS_RouteGridCompMod integer :: myPe integer :: minCatch integer :: maxCatch - integer, pointer :: pfaf(:) => NULL() - real, pointer :: tile_area(:) => NULL() !m2 - integer, pointer :: nsub(:) => NULL() - integer, pointer :: subi(:,:) => NULL() - real, pointer :: subarea(:,:) => NULL() !m2 + integer, pointer :: pfaf(:) => NULL() + real, pointer :: tile_area(:) => NULL() ! m2 + integer, pointer :: nsub(:) => NULL() + integer, pointer :: subi(:,:) => NULL() + real, pointer :: subarea(:,:) => NULL() ! m2 integer, pointer :: scounts_global(:) => NULL() integer, pointer :: rdispls_global(:) => NULL() - integer, pointer :: scounts_cat(:) => NULL() - integer, pointer :: rdispls_cat(:) => NULL() + integer, pointer :: scounts_cat(:) => NULL() + integer, pointer :: rdispls_cat(:) => NULL() - real, pointer :: runoff_save(:) => NULL() - real, pointer :: areacat(:) => NULL() !m2 - real, pointer :: lengsc(:) => NULL() !m - - real, pointer :: wstream(:) => NULL() !m3 - real, pointer :: wriver(:) => NULL() !m3 - integer, pointer :: downid(:) => NULL() - integer, pointer :: upid(:,:) => NULL() - - real, pointer :: wriver_acc(:) => NULL() - real, pointer :: wstream_acc(:) => NULL() - real, pointer :: qoutflow_acc(:) => NULL() - real, pointer :: qsflow_acc(:) => NULL() - - real, pointer :: lstr(:) => NULL() !m - real, pointer :: qri_clmt(:) => NULL() !m3/s - real, pointer :: qin_clmt(:) => NULL() !m3/s - real, pointer :: qstr_clmt(:) =>NULL() !m3/s - real, pointer :: K(:) => NULL() - real, pointer :: Kstr(:) => NULL() + real, pointer :: runoff_save(:) => NULL() + real, pointer :: areacat(:) => NULL() ! m2 + real, pointer :: lengsc(:) => NULL() ! m + + real, pointer :: wstream(:) => NULL() ! m3 + real, pointer :: wriver(:) => NULL() ! m3 + integer, pointer :: downid(:) => NULL() + integer, pointer :: upid(:,:) => NULL() + + real, pointer :: wriver_acc(:) => NULL() + real, pointer :: wstream_acc(:) => NULL() + real, pointer :: qoutflow_acc(:) => NULL() + real, pointer :: qsflow_acc(:) => NULL() + + real, pointer :: lstr(:) => NULL() ! m + real, pointer :: qri_clmt(:) => NULL() ! m3/s + real, pointer :: qin_clmt(:) => NULL() ! m3/s + real, pointer :: qstr_clmt(:) => NULL() ! m3/s + real, pointer :: K(:) => NULL() + real, pointer :: Kstr(:) => NULL() end type T_RROUTE_STATE @@ -165,8 +162,8 @@ subroutine SetServices ( GC, RC ) type (ESMF_Config ) :: CF - type (T_RROUTE_STATE), pointer :: route_internal_state => null() - type (RROUTE_wrap) :: wrap + type (T_RROUTE_STATE), pointer :: route_internal_state => null() + type (RROUTE_wrap) :: wrap integer :: RUN_DT real :: DT @@ -179,8 +176,8 @@ subroutine SetServices ( GC, RC ) ! Get my name and set-up traceback handle !------------------------------------------------------------ - call ESMF_GridCompGet(GC ,& - NAME=COMP_NAME ,& + call ESMF_GridCompGet(GC ,& + NAME=COMP_NAME ,& RC=STATUS ) VERIFY_(STATUS) @@ -238,7 +235,7 @@ subroutine SetServices ( GC, RC ) ! Import States ! ----------------------------------------------------------- - call MAPL_AddImportSpec(GC, & + call MAPL_AddImportSpec(GC, & LONG_NAME = 'runoff_total_flux' ,& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RUNOFF' ,& @@ -270,7 +267,7 @@ subroutine SetServices ( GC, RC ) ! Clocks !------- - call MAPL_TimerAdd(GC, name="INITIALIZE" ,RC=STATUS) + call MAPL_TimerAdd(GC, name="INITIALIZE" ,RC=STATUS) VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="RUN1" ,RC=STATUS) VERIFY_(STATUS) @@ -322,14 +319,14 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) integer :: beforeMe, minCatch, maxCatch, pf, i integer :: ntiles, nt_global - type(ESMF_Grid) :: tileGrid - type(ESMF_Grid) :: newTileGrid - type(ESMF_Grid) :: catchGrid + type(ESMF_Grid) :: tileGrid + type(ESMF_Grid) :: newTileGrid + type(ESMF_Grid) :: catchGrid type(ESMF_DistGrid) :: distGrid - type(ESMF_Field) :: field, field0 + type(ESMF_Field) :: field, field0 type(MAPL_MetaComp), pointer :: MAPL - type(MAPL_LocStream) :: locstream + type(MAPL_LocStream) :: locstream integer, pointer :: ims(:) => NULL() integer, pointer :: pfaf(:) => NULL() @@ -337,40 +334,41 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) integer, pointer :: arbSeq_pf(:) => NULL() integer, pointer :: arbSeq_ori(:) => NULL() integer, allocatable :: arbIndex(:,:) - real, pointer :: tile_area_src(:) => NULL() - integer,pointer :: local_id(:) => NULL() - real, pointer :: tile_area_local(:) => NULL(), tile_area_global(:) => NULL() - real, pointer :: tile_area(:) => NULL() - real, pointer :: ptr2(:) => NULL() - - real,pointer :: subarea_global(:,:)=> NULL(),subarea(:,:)=> NULL() ! Arrays for sub-area and fractions - integer,pointer :: subi_global(:,:)=> NULL(),subi(:,:)=> NULL() - integer,pointer :: nsub_global(:)=> NULL(),nsub(:)=> NULL() - real,pointer :: area_cat_global(:)=> NULL(),area_cat(:)=> NULL() - integer,pointer :: scounts(:)=>NULL() - integer,pointer :: scounts_global(:)=>NULL(),rdispls_global(:)=>NULL() - integer,pointer :: scounts_cat(:)=>NULL(),rdispls_cat(:)=>NULL() - - real,pointer :: runoff_save(:)=>NULL(), areacat(:)=>NULL() - real,pointer :: lengsc_global(:)=>NULL(), lengsc(:)=>NULL(), buff_global(:)=>NULL() - integer,pointer :: downid_global(:)=>NULL(), downid(:)=>NULL() - integer,pointer :: upid_global(:,:)=>NULL(), upid(:,:)=>NULL() - - real,pointer :: wstream(:)=>NULL(),wriver(:)=>NULL(),wres(:)=>NULL() - real,pointer :: wstream_global(:)=>NULL(),wriver_global(:)=>NULL(),wres_global(:)=>NULL() + real, pointer :: tile_area_src(:) => NULL() + integer, pointer :: local_id(:) => NULL() + real, pointer :: tile_area_local(:) => NULL(), tile_area_global(:) => NULL() + real, pointer :: tile_area(:) => NULL() + real, pointer :: ptr2(:) => NULL() + + real, pointer :: subarea_global(:,:)=> NULL(),subarea(:,:)=> NULL() ! Arrays for sub-area and fractions + integer, pointer :: subi_global(:,:)=> NULL(),subi(:,:)=> NULL() + integer, pointer :: nsub_global(:)=> NULL(),nsub(:)=> NULL() + real, pointer :: area_cat_global(:)=> NULL(),area_cat(:)=> NULL() + integer, pointer :: scounts(:)=>NULL() + integer, pointer :: scounts_global(:)=>NULL(),rdispls_global(:)=>NULL() + integer, pointer :: scounts_cat(:)=>NULL(),rdispls_cat(:)=>NULL() + + real, pointer :: runoff_save(:)=>NULL(), areacat(:)=>NULL() + real, pointer :: lengsc_global(:)=>NULL(), lengsc(:)=>NULL(), buff_global(:)=>NULL() + integer, pointer :: downid_global(:)=>NULL(), downid(:)=>NULL() + integer, pointer :: upid_global(:,:)=>NULL(), upid(:,:)=>NULL() + + real, pointer :: wstream(:)=>NULL(),wriver(:)=>NULL(),wres(:)=>NULL() + real, pointer :: wstream_global(:)=>NULL(),wriver_global(:)=>NULL(),wres_global(:)=>NULL() - type (T_RROUTE_STATE), pointer :: route => null() - type (RES_STATE), pointer :: res => NULL() - type (RROUTE_wrap) :: wrap + type (T_RROUTE_STATE), pointer :: route => null() + type (RES_STATE), pointer :: res => NULL() + type (RROUTE_wrap) :: wrap - type(ESMF_Time) :: CurrentTime - integer :: YY,MM,DD,HH,MMM,SS + type(ESMF_Time) :: CurrentTime + integer :: YY,MM,DD,HH,MMM,SS character(len=4) :: yr_s character(len=2) :: mon_s,day_s character(len=3) :: resname - real, pointer :: dataPtr(:) - integer :: j,nt_local,mpierr,it + real, pointer :: dataPtr(:) + integer :: j,nt_local,mpierr,it + ! ------------------ ! begin @@ -412,16 +410,16 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%nt_global = nt_global ! Determine the resolution if(nt_global==112573)then - resname="M36" - nmax=150 + resname="M36" + nmax=150 else if(nt_global==1684725)then - resname="M09" - nmax=458 + resname="M09" + nmax=458 else - if(mapl_am_I_root())then - print *,"unknown grid for routing model" - stop - endif + if(mapl_am_I_root())then + print *,"unknown grid for routing model" + stop + endif endif ! exchange Pfaf across PEs call MAPL_LocStreamGet(locstream, TILEAREA = tile_area_src, LOCAL_ID=local_id, RC=status) @@ -436,10 +434,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%minCatch = minCatch route%maxCatch = maxCatch - - - - ! Read sub-catchment data + ! Read sub-catchment data allocate(nsub_global(N_CatG),subarea_global(nmax,N_CatG)) open(77,file=trim(inputdir)//"/Pfaf_nsub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)nsub_global; close(77) open(77,file=trim(inputdir)//"/Pfaf_asub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)subarea_global; close(77) @@ -449,23 +444,23 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) subarea=subarea*1.e6 !km2->m2 deallocate(nsub_global,subarea_global) - route%nsub => nsub + route%nsub => nsub route%subarea => subarea - + allocate(subi_global(nmax,N_CatG),subi(nmax,ntiles)) open(77,file=trim(inputdir)//"/Pfaf_isub_"//trim(resname)//".txt",status="old",action="read");read(77,*)subi_global;close(77) subi=subi_global(:,minCatch:maxCatch) route%subi => subi deallocate(subi_global) - ! Set variables used in MPI + ! Set variables used in MPI allocate(scounts(ndes),scounts_global(ndes),rdispls_global(ndes)) scounts=0 scounts(mype+1)=nt_local call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_global, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) rdispls_global(1)=0 do i=2,nDes - rdispls_global(i)=rdispls_global(i-1)+scounts_global(i-1) + rdispls_global(i)=rdispls_global(i-1)+scounts_global(i-1) enddo deallocate(scounts) route%scounts_global=>scounts_global @@ -477,7 +472,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_cat, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) rdispls_cat(1)=0 do i=2,nDes - rdispls_cat(i)=rdispls_cat(i-1)+scounts_cat(i-1) + rdispls_cat(i)=rdispls_cat(i-1)+scounts_cat(i-1) enddo deallocate(scounts) route%scounts_cat=>scounts_cat @@ -487,7 +482,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%runoff_save => runoff_save route%runoff_save=0. - ! Read tile area data + ! Read tile area data allocate(tile_area_local(nt_local),tile_area_global(nt_global)) open(77,file=trim(inputdir)//"/area_"//trim(resname)//"_1d.txt",status="old",action="read");read(77,*)tile_area_global;close(77) tile_area_local=tile_area_global(rdispls_global(mype+1)+1:rdispls_global(mype+1)+nt_local)*1.e6 !km2->m2 @@ -497,17 +492,17 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) allocate(areacat(1:ntiles)) areacat=0. do i=1,ntiles - do j=1,nmax - it=route%subi(j,i) - if(it>0)then - areacat(i)=areacat(i)+route%subarea(j,i) - endif - if(it==0)exit - enddo - enddo + do j=1,nmax + it=route%subi(j,i) + if(it>0)then + areacat(i)=areacat(i)+route%subarea(j,i) + endif + if(it==0)exit + enddo + enddo route%areacat=>areacat - ! Read river network-realated data + ! Read river network-realated data allocate(lengsc_global(n_catg),lengsc(ntiles)) open(77,file=trim(inputdir)//"/Pfaf_lriv_PR.txt",status="old",action="read");read(77,*)lengsc_global;close(77) lengsc=lengsc_global(minCatch:maxCatch)*1.e3 !km->m @@ -526,7 +521,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%upid=>upid deallocate(upid_global) - ! Read restart data + ! Read restart data call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) write(yr_s,'(I4.4)')YY @@ -537,63 +532,63 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) allocate(wriver_global(n_catg),wstream_global(n_catg),wres_global(n_catg)) open(77,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then - read(77,*)wriver_global;close(77) + read(77,*)wriver_global;close(77) else - close(77) - open(78,file=trim(inputdir)//"/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) - if(status==0)then - read(78,*)wriver_global;close(78) - else - close(78) - open(79,file=trim(inputdir)//"/river_storage_rs.txt",status="old",action="read",iostat=status) - if(status==0)then - read(79,*)wriver_global;close(79) - else - close(79) - wriver_global=0. - endif - endif + close(77) + open(78,file=trim(inputdir)//"/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wriver_global;close(78) + else + close(78) + open(79,file=trim(inputdir)//"/river_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wriver_global;close(79) + else + close(79) + wriver_global=0. + endif + endif endif open(77,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then - read(77,*)wstream_global;close(77) + read(77,*)wstream_global;close(77) else - close(77) - open(78,file=trim(inputdir)//"/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) - if(status==0)then - read(78,*)wstream_global;close(78) - else - close(78) - open(79,file=trim(inputdir)//"/stream_storage_rs.txt",status="old",action="read",iostat=status) - if(status==0)then - read(79,*)wstream_global;close(79) - else - close(79) - wstream_global=0. - endif - endif + close(77) + open(78,file=trim(inputdir)//"/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wstream_global;close(78) + else + close(78) + open(79,file=trim(inputdir)//"/stream_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wstream_global;close(79) + else + close(79) + wstream_global=0. + endif + endif endif open(77,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then - read(77,*)wres_global;close(77) + read(77,*)wres_global;close(77) else - close(77) - open(78,file=trim(inputdir)//"/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) - if(status==0)then - read(78,*)wres_global;close(78) - else - close(78) - open(79,file=trim(inputdir)//"/res_storage_rs.txt",status="old",action="read",iostat=status) - if(status==0)then - read(79,*)wres_global;close(79) - else - close(79) - wres_global=0. - endif - endif - endif - if(mapl_am_I_root())print *, "init river storage is: ",sum(wriver_global)/1.e9 - if(mapl_am_I_root())print *, "init stream storage is: ",sum(wstream_global)/1.e9 + close(77) + open(78,file=trim(inputdir)//"/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + if(status==0)then + read(78,*)wres_global;close(78) + else + close(78) + open(79,file=trim(inputdir)//"/res_storage_rs.txt",status="old",action="read",iostat=status) + if(status==0)then + read(79,*)wres_global;close(79) + else + close(79) + wres_global=0. + endif + endif + endif + if(mapl_am_I_root())print *, "init river storage is: ",sum(wriver_global)/1.e9 + if(mapl_am_I_root())print *, "init stream storage is: ",sum(wstream_global)/1.e9 if(mapl_am_I_root())print *, "init reservoir storage is: ",sum(wres_global)/1.e9 wriver=wriver_global(minCatch:maxCatch) wstream=wstream_global(minCatch:maxCatch) @@ -603,7 +598,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%wriver=>wriver route%reservoir%Wr_res=>wres - ! accumulated variables for output + ! accumulated variables for output allocate(route%wriver_acc(ntiles),route%wstream_acc(ntiles),route%qoutflow_acc(ntiles),route%qsflow_acc(ntiles),route%reservoir%qres_acc(ntiles)) route%wriver_acc=0. route%wstream_acc=0. @@ -611,7 +606,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%qsflow_acc=0. route%reservoir%qres_acc=0. - !Read input specially for geometry hydraulic (not required by linear model) + !Read input specially for geometry hydraulic (not required by linear model) allocate(buff_global(n_catg),route%lstr(ntiles)) open(77,file=trim(inputdir)//"/Pfaf_lstr_PR.txt",status="old",action="read");read(77,*)buff_global;close(77) route%lstr=buff_global(minCatch:maxCatch)*1.e3 !km->m @@ -660,13 +655,15 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) ! enddo ! stop !endif - + deallocate(ims) call MAPL_GenericInitialize ( GC, import, export, clock, rc=status ) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine INITIALIZE + + ! -------------------------------------------------------------------------------- ! ----------------------------------------------------------- ! RUN -- Run method for the route component @@ -683,10 +680,11 @@ subroutine RUN1 (GC,IMPORT, EXPORT, CLOCK, RC ) type(ESMF_Clock), intent(inout) :: CLOCK integer, optional, intent( out) :: RC end subroutine RUN1 - - + + ! -------------------------------------------------------------------------------- + subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) - + ! ----------------------------------------------------------- ! !ARGUMENTS: ! ----------------------------------------------------------- @@ -782,14 +780,15 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) character(len=4) :: yr_s character(len=2) :: mon_s,day_s - real,pointer :: runoff_save(:)=>NULL() - real,pointer :: WSTREAM_ACT(:)=>NULL() - real,pointer :: WRIVER_ACT(:)=>NULL() - type (RES_STATE), pointer :: res => NULL() - real,allocatable :: runoff_save_m3(:),runoff_global_m3(:),QOUTFLOW_GLOBAL(:),Qres_global(:) - real,allocatable :: WTOT_BEFORE(:),WTOT_AFTER(:),QINFLOW_LOCAL(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) - real,allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) - real,allocatable :: wriver_global(:),wstream_global(:),qsflow_global(:),wres_global(:) + real, pointer :: runoff_save(:)=>NULL() + real, pointer :: WSTREAM_ACT(:)=>NULL() + real, pointer :: WRIVER_ACT(:) =>NULL() + type (RES_STATE), pointer :: res => NULL() + + real, allocatable :: runoff_save_m3(:),runoff_global_m3(:),QOUTFLOW_GLOBAL(:),Qres_global(:) + real, allocatable :: WTOT_BEFORE(:),WTOT_AFTER(:),QINFLOW_LOCAL(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) + real, allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) + real, allocatable :: wriver_global(:),wstream_global(:),qsflow_global(:),wres_global(:) ! ------------------ ! begin @@ -824,64 +823,64 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) ! get pointers to inputs variables ! ---------------------------------- - ndes = route%ndes - mype = route%mype - ntiles = route%ntiles - nt_global = route%nt_global + ndes = route%ndes + mype = route%mype + ntiles = route%ntiles + nt_global = route%nt_global runoff_save => route%runoff_save - nt_local = route%nt_local - res => route%reservoir + nt_local = route%nt_local + res => route%reservoir ! get the field from IMPORT call ESMF_StateGet(IMPORT, 'RUNOFF', field=runoff_src, RC=STATUS) VERIFY_(STATUS) call ESMF_FieldGet(runoff_src, farrayPtr=RUNOFF_SRC0, rc=status) VERIFY_(STATUS) - + call MAPL_Get(MAPL, LocStream=LOCSTREAM, RC=STATUS) VERIFY_(STATUS) call MAPL_LocStreamGet(LOCSTREAM, TILEGRID=TILEGRID, RC=STATUS) VERIFY_(STATUS) call MAPL_TimerOn ( MAPL, "-RRM" ) - + ! For efficiency, the time step to call the river routing model is set at ROUTE_DT - + N_CYC = ROUTE_DT/HEARTBEAT RUN_MODEL : if (ThisCycle == N_CYC) then - - !accumulates runoff + + !accumulates runoff runoff_save = runoff_save + RUNOFF_SRC0/real (N_CYC) - !Gets time used for output and restart + !Gets time used for output and restart call ESMF_ClockGet(clock, currTime=CurrentTime, rc=status) call ESMF_TimeGet(CurrentTime, yy=YY, mm=MM, dd=DD, h=HH, m=MMM, s=SS, rc=status) call ESMF_ClockGetNextTime(clock, nextTime=nextTime, rc=status) call ESMF_TimeGet(nextTime, yy=YY_next, mm=MM_next, dd=DD_next, rc=status) - write(yr_s,'(I4.4)')YY + write(yr_s, '(I4.4)')YY write(mon_s,'(I2.2)')MM write(day_s,'(I2.2)')DD - - !Collect runoff from all processors + + !Collect runoff from all processors allocate(runoff_global(nt_global)) call MPI_allgatherv ( & - runoff_save, route%scounts_global(mype+1) ,MPI_REAL, & - runoff_global, route%scounts_global, route%rdispls_global,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + runoff_save, route%scounts_global(mype+1) ,MPI_REAL, & + runoff_global, route%scounts_global, route%rdispls_global,MPI_REAL, & + MPI_COMM_WORLD, mpierr) !Distribute runoff from tile space to catchment space if(FirstTime.and.mapl_am_I_root()) print *,"nmax=",nmax allocate(RUNOFF_ACT(ntiles)) RUNOFF_ACT=0. do i=1,ntiles - do j=1,nmax - it=route%subi(j,i) - if(it>0)then - RUNOFF_ACT(i)=RUNOFF_ACT(i)+route%subarea(j,i)*runoff_global(it)/1000. - endif - if(it==0)exit - enddo - enddo - + do j=1,nmax + it=route%subi(j,i) + if(it>0)then + RUNOFF_ACT(i)=RUNOFF_ACT(i)+route%subarea(j,i)*runoff_global(it)/1000. + endif + if(it==0)exit + enddo + enddo + deallocate(runoff_global) ! Prepares to conduct routing model @@ -897,7 +896,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) WSTREAM_ACT => route%wstream WRIVER_ACT => route%wriver - + allocate(WTOT_BEFORE(ntiles)) WTOT_BEFORE=WSTREAM_ACT+WRIVER_ACT+res%Wr_res @@ -914,38 +913,38 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) QSFLOW_ACT,QOUTFLOW_ACT) ! Call reservoir module do i=1,ntiles - call res_cal(res%active_res(i),QOUTFLOW_ACT(i),res%type_res(i),res%cat2res(i),& - QRES_ACT(i),res%wid_res(i),res%fld_res(i),res%Wr_res(i),res%Qfld_thres(i),res%cap_res(i),real(route_dt)) + call res_cal(res%active_res(i),QOUTFLOW_ACT(i),res%type_res(i),res%cat2res(i),& + QRES_ACT(i),res%wid_res(i),res%fld_res(i),res%Wr_res(i),res%Qfld_thres(i),res%cap_res(i),real(route_dt)) enddo QOUT_CAT = QOUTFLOW_ACT where(res%active_res==1) QOUT_CAT=QRES_ACT - ! Collects dishcarge (routing model output) from all processors + ! Collects dishcarge (routing model output) from all processors allocate(QOUTFLOW_GLOBAL(n_catg)) call MPI_allgatherv ( & QOUT_CAT, route%scounts_cat(mype+1) ,MPI_REAL, & QOUTFLOW_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & MPI_COMM_WORLD, mpierr) - ! Linking discharge as inflow to downstream catchment to adjust river storage + ! Linking discharge as inflow to downstream catchment to adjust river storage allocate(QINFLOW_LOCAL(ntiles)) QINFLOW_LOCAL=0. do i=1,nTiles - do j=1,upmax - if(route%upid(j,i)>0)then - upid=route%upid(j,i) - WRIVER_ACT(i)=WRIVER_ACT(i)+QOUTFLOW_GLOBAL(upid)*real(route_dt) - QINFLOW_LOCAL(i)=QINFLOW_LOCAL(i)+QOUTFLOW_GLOBAL(upid) - else - exit - endif - enddo + do j=1,upmax + if(route%upid(j,i)>0)then + upid=route%upid(j,i) + WRIVER_ACT(i)=WRIVER_ACT(i)+QOUTFLOW_GLOBAL(upid)*real(route_dt) + QINFLOW_LOCAL(i)=QINFLOW_LOCAL(i)+QOUTFLOW_GLOBAL(upid) + else + exit + endif + enddo enddo - ! Check balance if needed + ! Check balance if needed !call check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUT_CAT,FirstTime,yr_s,mon_s) - ! Update accumulated variables for output + ! Update accumulated variables for output if(FirstTime) nstep_per_day = 86400/route_dt route%wriver_acc = route%wriver_acc + WRIVER_ACT/real(nstep_per_day) route%wstream_acc = route%wstream_acc + WSTREAM_ACT/real(nstep_per_day) @@ -954,132 +953,132 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) res%qres_acc = res%qres_acc + QRES_ACT/real(nstep_per_day) deallocate(RUNOFF_ACT,AREACAT_ACT,LENGSC_ACT,QOUTFLOW_ACT,QINFLOW_LOCAL,QOUTFLOW_GLOBAL,QSFLOW_ACT,WTOT_BEFORE,QRES_ACT,QOUT_CAT) - !initialize the cycle counter and sum (runoff_tile) + !initialize the cycle counter and sum (runoff_tile) WSTREAM_ACT=>NULL() WRIVER_ACT=>NULL() runoff_save = 0. ThisCycle = 1 - ! output variables + ! output variables !if(mapl_am_I_root())print *, "nstep_per_day=",nstep_per_day if(mapl_am_I_root())print *, "Current time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS, ", next MM_next:",MM_next if(FirstTime)then - if(mapl_am_I_root()) istat = mkdir("../river", int(o'755',c_int16_t)) + if(mapl_am_I_root()) istat = mkdir("../river", int(o'755',c_int16_t)) endif if(HH==23)then - allocate(wriver_global(n_catg),wstream_global(n_catg),qoutflow_global(n_catg),qsflow_global(n_catg)) - !call MPI_allgatherv ( & - ! route%wriver_acc, route%scounts_cat(mype+1) ,MPI_REAL, & - ! wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) - !call MPI_allgatherv ( & - ! route%wstream_acc, route%scounts_cat(mype+1) ,MPI_REAL, & - ! wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) - call MPI_allgatherv ( & - route%qoutflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & - qoutflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - !call MPI_allgatherv ( & - ! route%qsflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & - ! qsflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) - if(mapl_am_I_root())then - !open(88,file="../river/river_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - !open(89,file="../river/stream_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - open(90,file="../river/river_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - !open(91,file="../river/stream_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg + allocate(wriver_global(n_catg),wstream_global(n_catg),qoutflow_global(n_catg),qsflow_global(n_catg)) + !call MPI_allgatherv ( & + ! route%wriver_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + !call MPI_allgatherv ( & + ! route%wstream_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + route%qoutflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + qoutflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + !call MPI_allgatherv ( & + ! route%qsflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + ! qsflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + !open(88,file="../river/river_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + !open(89,file="../river/stream_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(90,file="../river/river_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + !open(91,file="../river/stream_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg !write(88,*)wriver_global(i) !write(89,*)wstream_global(i) write(90,*)qoutflow_global(i) !write(91,*)qsflow_global(i) - enddo - !close(88) - !close(89) - close(90) - !close(91) - !print *, "output river storage is: ",sum(wriver_global)/1.e9 - !print *, "output stream storage is: ",sum(wstream_global)/1.e9 - endif - - if(use_res .eqv. .True.)then - allocate(qres_global(n_catg)) - call MPI_allgatherv ( & - res%qres_acc, route%scounts_cat(mype+1) ,MPI_REAL, & - qres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - if(mapl_am_I_root())then - open(92,file="../river/res_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg - write(92,*)qres_global(i) enddo - close(92) - endif - deallocate(qres_global) - endif - - deallocate(wriver_global,wstream_global,qoutflow_global,qsflow_global) - route%wriver_acc = 0. - route%wstream_acc = 0. - route%qoutflow_acc = 0. - route%qsflow_acc = 0. - res%qres_acc = 0. + !close(88) + !close(89) + close(90) + !close(91) + !print *, "output river storage is: ",sum(wriver_global)/1.e9 + !print *, "output stream storage is: ",sum(wstream_global)/1.e9 + endif + + if(use_res .eqv. .True.)then + allocate(qres_global(n_catg)) + call MPI_allgatherv ( & + res%qres_acc, route%scounts_cat(mype+1) ,MPI_REAL, & + qres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(92,file="../river/res_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(92,*)qres_global(i) + enddo + close(92) + endif + deallocate(qres_global) + endif + + deallocate(wriver_global,wstream_global,qoutflow_global,qsflow_global) + route%wriver_acc = 0. + route%wstream_acc = 0. + route%qoutflow_acc = 0. + route%qsflow_acc = 0. + res%qres_acc = 0. endif - + !write restart if(MM_next/=MM)then - allocate(wriver_global(n_catg),wstream_global(n_catg)) - call MPI_allgatherv ( & - route%wstream, route%scounts_cat(mype+1) ,MPI_REAL, & - wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - call MPI_allgatherv ( & - route%wriver, route%scounts_cat(mype+1) ,MPI_REAL, & - wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - if(mapl_am_I_root())then - write(yr_s,'(I4.4)')YY_next - write(mon_s,'(I2.2)')MM_next - write(day_s,'(I2.2)')DD_next - open(88,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - open(89,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg + allocate(wriver_global(n_catg),wstream_global(n_catg)) + call MPI_allgatherv ( & + route%wstream, route%scounts_cat(mype+1) ,MPI_REAL, & + wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + route%wriver, route%scounts_cat(mype+1) ,MPI_REAL, & + wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + write(yr_s,'(I4.4)')YY_next + write(mon_s,'(I2.2)')MM_next + write(day_s,'(I2.2)')DD_next + open(88,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + open(89,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg write(88,*)wriver_global(i) write(89,*)wstream_global(i) - enddo - close(88);close(89) - print *, "saved river storage is: ",sum(wriver_global)/1.e9 - print *, "saved stream storage is: ",sum(wstream_global)/1.e9 - endif - - if(use_res .eqv. .True.)then - allocate(wres_global(n_catg)) - call MPI_allgatherv ( & - res%Wr_res, route%scounts_cat(mype+1) ,MPI_REAL, & - wres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - if(mapl_am_I_root())then - open(90,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg - write(90,*)wres_global(i) enddo - close(90) - print *, "saved reservoir storage is: ",sum(wres_global)/1.e9 - endif - deallocate(wres_global) - endif - - deallocate(wriver_global,wstream_global) + close(88);close(89) + print *, "saved river storage is: ",sum(wriver_global)/1.e9 + print *, "saved stream storage is: ",sum(wstream_global)/1.e9 + endif + + if(use_res .eqv. .True.)then + allocate(wres_global(n_catg)) + call MPI_allgatherv ( & + res%Wr_res, route%scounts_cat(mype+1) ,MPI_REAL, & + wres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(90,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") + do i=1,n_catg + write(90,*)wres_global(i) + enddo + close(90) + print *, "saved reservoir storage is: ",sum(wres_global)/1.e9 + endif + deallocate(wres_global) + endif + + deallocate(wriver_global,wstream_global) endif if(FirstTime) FirstTime=.False. else - + runoff_save = runoff_save + RUNOFF_SRC0/real (N_CYC) - + ThisCycle = ThisCycle + 1 endif RUN_MODEL @@ -1095,121 +1094,125 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) RETURN_(ESMF_SUCCESS) end subroutine RUN2 + + ! ------------------------------------------------------------------------------------------------------- -! -------------------------------------------------------- + subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUTFLOW_ACT,FirstTime,yr_s,mon_s) + + type(T_RROUTE_STATE), intent(in) :: route + integer, intent(in) :: ntiles,nt_local + real, intent(in) :: runoff_save(nt_local),WRIVER_ACT(ntiles),WSTREAM_ACT(ntiles),WTOT_BEFORE(ntiles),RUNOFF_ACT(ntiles) + real, intent(in) :: QINFLOW_LOCAL(ntiles),QOUTFLOW_ACT(ntiles) + logical, intent(in) :: FirstTime + character(len=*), intent(in) :: yr_s,mon_s + + ! --------------------------------------------- + + real,allocatable :: runoff_cat_global(:) + real,allocatable :: runoff_save_m3(:),runoff_global_m3(:) + real,allocatable :: WTOT_AFTER(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) + real,allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) + integer :: i, nt_global,mype,cid,temp(1),tid,mpierr + real :: wr_error, wr_tot, runf_tot - subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_ACT,WTOT_BEFORE,RUNOFF_ACT,QINFLOW_LOCAL,QOUTFLOW_ACT,FirstTime,yr_s,mon_s) - - type(T_RROUTE_STATE), intent(in) :: route - integer, intent(in) :: ntiles,nt_local - real,intent(in) :: runoff_save(nt_local),WRIVER_ACT(ntiles),WSTREAM_ACT(ntiles),WTOT_BEFORE(ntiles),RUNOFF_ACT(ntiles) - real,intent(in) :: QINFLOW_LOCAL(ntiles),QOUTFLOW_ACT(ntiles) - logical,intent(in) :: FirstTime - character(len=*), intent(in) :: yr_s,mon_s - - real,allocatable :: runoff_cat_global(:) - real,allocatable :: runoff_save_m3(:),runoff_global_m3(:) - real,allocatable :: WTOT_AFTER(:),UNBALANCE(:),UNBALANCE_GLOBAL(:),ERROR(:),ERROR_GLOBAL(:) - real,allocatable :: QFLOW_SINK(:),QFLOW_SINK_GLOBAL(:),WTOT_BEFORE_GLOBAL(:),WTOT_AFTER_GLOBAL(:) - - integer :: i, nt_global,mype,cid,temp(1),tid,mpierr - real :: wr_error, wr_tot, runf_tot - - nt_global = route%nt_global - mype = route%mype - - allocate(WTOT_AFTER(ntiles),UNBALANCE(ntiles),UNBALANCE_GLOBAL(n_catg),runoff_cat_global(n_catg)) - allocate(QFLOW_SINK(ntiles),QFLOW_SINK_GLOBAL(n_catg),WTOT_BEFORE_GLOBAL(n_catg),WTOT_AFTER_GLOBAL(n_catg)) - allocate(runoff_save_m3(nt_local),runoff_global_m3(nt_global),ERROR(ntiles),ERROR_GLOBAL(n_catg)) - - WTOT_AFTER=WRIVER_ACT+WSTREAM_ACT+route%reservoir%Wr_res - ERROR = WTOT_AFTER - (WTOT_BEFORE + RUNOFF_ACT*route_dt + QINFLOW_LOCAL*route_dt - QOUTFLOW_ACT*route_dt) - !UNBALANCE = abs(ERROR) - !call MPI_allgatherv ( & - ! UNBALANCE, route%scounts_cat(mype+1) ,MPI_REAL, & - ! UNBALANCE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) - QFLOW_SINK=0. - do i=1,ntiles - if(route%downid(i)==-1)then - QFLOW_SINK(i) = QOUTFLOW_ACT(i) - endif - enddo - call MPI_allgatherv ( & - QFLOW_SINK, route%scounts_cat(mype+1) ,MPI_REAL, & - QFLOW_SINK_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - call MPI_allgatherv ( & - WTOT_BEFORE, route%scounts_cat(mype+1) ,MPI_REAL, & - WTOT_BEFORE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - call MPI_allgatherv ( & - WTOT_AFTER, route%scounts_cat(mype+1) ,MPI_REAL, & - WTOT_AFTER_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - runoff_save_m3=runoff_save*route%tile_area/1000. - call MPI_allgatherv ( & - runoff_save_m3, route%scounts_global(mype+1) ,MPI_REAL, & - runoff_global_m3, route%scounts_global, route%rdispls_global,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - call MPI_allgatherv ( & - RUNOFF_ACT, route%scounts_cat(mype+1) ,MPI_REAL, & - runoff_cat_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - if(mapl_am_I_root())then - open(88,file="../runoff_tile_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") - write(88,*)sum(runoff_global_m3) - close(88) - open(88,file="../runoff_cat_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") - write(88,*)sum(runoff_cat_global) - close(88) - !print *,"sum(runoff_global_m3)=",sum(runoff_global_m3) - !print *,"sum(runoff_cat_global)=",sum(runoff_cat_global) - endif - if(mapl_am_I_root())then - open(88,file="../WTOT_AFTER_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") - write(88,*)sum(WTOT_AFTER_GLOBAL) - close(88) - open(88,file="../WTOT_BEFORE_RUNOFF_QSINK_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") - write(88,*) sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt - close(88) - wr_error=sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt) - runf_tot=sum(runoff_global_m3)*route_dt - wr_tot=sum(WTOT_AFTER_GLOBAL) - open(88,file="../WTOT_ERROR_2_RUNOFF_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") - write(88,*) wr_error/runf_tot - close(88) - open(88,file="../WTOT_ERROR_2_WTOT_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") - write(88,*) wr_error/wr_tot - close(88) - !print *,"WTOT_ERROR_2_RUNOFF:",(sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt))/(sum(runoff_global_m3)*route_dt) - endif - - call MPI_allgatherv ( & - ERROR, route%scounts_cat(mype+1) ,MPI_REAL, & - ERROR_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) - temp = maxloc(abs(ERROR_GLOBAL)) - cid = temp(1) - if(cid>=route%minCatch.and.cid<=route%maxCatch)then - tid=cid-route%minCatch+1 - print *,"my PE is:",mype,", max abs value of ERROR=", ERROR(tid)," at pfafid: ",route%minCatch+tid-1,", W_BEFORE=",WTOT_BEFORE(tid),", RUNOFF=",RUNOFF_ACT(tid)*route_dt,", QINFLOW=",QINFLOW_LOCAL(tid)*route_dt,", QOUTFLOW=",QOUTFLOW_ACT(tid)*route_dt,", W_AFTER=",WTOT_AFTER(tid) - endif - !if(FirstTime)then - ! if(mapl_am_I_root())then - ! open(88,file="ERROR_TOTAL.txt",action="write") - ! do i=1,n_catg - ! write(88,*)ERROR_GLOBAL(i) - ! enddo - ! endif - !endif - - deallocate(WTOT_AFTER,UNBALANCE,UNBALANCE_GLOBAL,ERROR,QFLOW_SINK,QFLOW_SINK_GLOBAL,WTOT_BEFORE_GLOBAL,WTOT_AFTER_GLOBAL) - deallocate(runoff_save_m3,runoff_global_m3,ERROR_GLOBAL,runoff_cat_global) + nt_global = route%nt_global + mype = route%mype + + allocate(WTOT_AFTER(ntiles),UNBALANCE(ntiles),UNBALANCE_GLOBAL(n_catg),runoff_cat_global(n_catg)) + allocate(QFLOW_SINK(ntiles),QFLOW_SINK_GLOBAL(n_catg),WTOT_BEFORE_GLOBAL(n_catg),WTOT_AFTER_GLOBAL(n_catg)) + allocate(runoff_save_m3(nt_local),runoff_global_m3(nt_global),ERROR(ntiles),ERROR_GLOBAL(n_catg)) + + WTOT_AFTER=WRIVER_ACT+WSTREAM_ACT+route%reservoir%Wr_res + ERROR = WTOT_AFTER - (WTOT_BEFORE + RUNOFF_ACT*route_dt + QINFLOW_LOCAL*route_dt - QOUTFLOW_ACT*route_dt) + !UNBALANCE = abs(ERROR) + !call MPI_allgatherv ( & + ! UNBALANCE, route%scounts_cat(mype+1) ,MPI_REAL, & + ! UNBALANCE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + ! MPI_COMM_WORLD, mpierr) + QFLOW_SINK=0. + do i=1,ntiles + if(route%downid(i)==-1)then + QFLOW_SINK(i) = QOUTFLOW_ACT(i) + endif + enddo + call MPI_allgatherv ( & + QFLOW_SINK, route%scounts_cat(mype+1) ,MPI_REAL, & + QFLOW_SINK_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + WTOT_BEFORE, route%scounts_cat(mype+1) ,MPI_REAL, & + WTOT_BEFORE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + WTOT_AFTER, route%scounts_cat(mype+1) ,MPI_REAL, & + WTOT_AFTER_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + runoff_save_m3=runoff_save*route%tile_area/1000. + call MPI_allgatherv ( & + runoff_save_m3, route%scounts_global(mype+1) ,MPI_REAL, & + runoff_global_m3, route%scounts_global, route%rdispls_global,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + call MPI_allgatherv ( & + RUNOFF_ACT, route%scounts_cat(mype+1) ,MPI_REAL, & + runoff_cat_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + if(mapl_am_I_root())then + open(88,file="../runoff_tile_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(runoff_global_m3) + close(88) + open(88,file="../runoff_cat_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(runoff_cat_global) + close(88) + !print *,"sum(runoff_global_m3)=",sum(runoff_global_m3) + !print *,"sum(runoff_cat_global)=",sum(runoff_cat_global) + endif + if(mapl_am_I_root())then + open(88,file="../WTOT_AFTER_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*)sum(WTOT_AFTER_GLOBAL) + close(88) + open(88,file="../WTOT_BEFORE_RUNOFF_QSINK_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt + close(88) + wr_error=sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt) + runf_tot=sum(runoff_global_m3)*route_dt + wr_tot=sum(WTOT_AFTER_GLOBAL) + open(88,file="../WTOT_ERROR_2_RUNOFF_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) wr_error/runf_tot + close(88) + open(88,file="../WTOT_ERROR_2_WTOT_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") + write(88,*) wr_error/wr_tot + close(88) + !print *,"WTOT_ERROR_2_RUNOFF:",(sum(WTOT_AFTER_GLOBAL)-(sum(WTOT_BEFORE_GLOBAL)+sum(runoff_global_m3)*route_dt-sum(QFLOW_SINK_GLOBAL)*route_dt))/(sum(runoff_global_m3)*route_dt) + endif + + call MPI_allgatherv ( & + ERROR, route%scounts_cat(mype+1) ,MPI_REAL, & + ERROR_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & + MPI_COMM_WORLD, mpierr) + temp = maxloc(abs(ERROR_GLOBAL)) + cid = temp(1) + if(cid>=route%minCatch.and.cid<=route%maxCatch)then + tid=cid-route%minCatch+1 + print *,"my PE is:",mype,", max abs value of ERROR=", ERROR(tid)," at pfafid: ",route%minCatch+tid-1,", W_BEFORE=",WTOT_BEFORE(tid),", RUNOFF=",RUNOFF_ACT(tid)*route_dt,", QINFLOW=",QINFLOW_LOCAL(tid)*route_dt,", QOUTFLOW=",QOUTFLOW_ACT(tid)*route_dt,", W_AFTER=",WTOT_AFTER(tid) + endif + !if(FirstTime)then + ! if(mapl_am_I_root())then + ! open(88,file="ERROR_TOTAL.txt",action="write") + ! do i=1,n_catg + ! write(88,*)ERROR_GLOBAL(i) + ! enddo + ! endif + !endif + + deallocate(WTOT_AFTER,UNBALANCE,UNBALANCE_GLOBAL,ERROR,QFLOW_SINK,QFLOW_SINK_GLOBAL,WTOT_BEFORE_GLOBAL,WTOT_AFTER_GLOBAL) + deallocate(runoff_save_m3,runoff_global_m3,ERROR_GLOBAL,runoff_cat_global) end subroutine check_balance end module GEOS_RouteGridCompMod + +! ======================= EOF ========================================================= + From 4e3cfec9ec475105bf455246f097b4ba21a56b47 Mon Sep 17 00:00:00 2001 From: Rolf Reichle Date: Wed, 21 May 2025 14:05:14 -0400 Subject: [PATCH 22/27] added comments to clarify connected "RUNOFF" variable (GEOS_LandGridComp.F90) --- .../GEOSland_GridComp/GEOS_LandGridComp.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 index 86321eb76..89d9f9214 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOS_LandGridComp.F90 @@ -1458,7 +1458,7 @@ subroutine SetServices ( GC, RC ) IF(RUN_ROUTE == 1) THEN call MAPL_AddConnectivity ( & GC ,& - SHORT_NAME = (/'RUNOFF '/) ,& + SHORT_NAME = (/'RUNOFF '/) ,& ! RUNOFF = total runoff = surface runoff + baseflow SRC_ID = CATCH(I) ,& DST_ID = ROUTE(I) ,& @@ -1491,7 +1491,7 @@ subroutine SetServices ( GC, RC ) IF(RUN_ROUTE == 1) THEN call MAPL_AddConnectivity ( & GC ,& - SHORT_NAME = (/'RUNOFF '/) ,& + SHORT_NAME = (/'RUNOFF '/) ,& ! RUNOFF = total runoff = surface runoff + baseflow SRC_ID = CATCHCN(I) ,& DST_ID = ROUTE(I) ,& From e36706130424a20360ce2b978cbf7c8635078451 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Fri, 23 May 2025 14:35:59 -0400 Subject: [PATCH 23/27] Update CMakeLists.txt --- .../GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt index 58f3cf452..cc018b928 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/CMakeLists.txt @@ -6,6 +6,6 @@ set (srcs reservoir.F90 ) -esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL esmf NetCDF::NetCDF_Fortran) +esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_LandShared ESMF::ESMF NetCDF::NetCDF_Fortran) install(PROGRAMS build_rivernetwork.py DESTINATION bin) From f1c450d7f5c225525a7fb41870d004e0f39dde58 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Wed, 18 Jun 2025 12:06:30 -0400 Subject: [PATCH 24/27] copying river_input through make_bcs --- .../Utils/Raster/makebcs/make_bcs_shared.py | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py index b5e651deb..d1dc3b77d 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py @@ -172,6 +172,14 @@ def get_script_mv(grid_type): echo "Successfully copied CO2_MonthlyMean_DiurnalCycle.nc4 to bcs dir." endif +if(-d land/shared/river_input) then + echo "river_input already present in bcs dir." +else + /bin/cp -rp /discover/nobackup/yzeng3/data/river_input land/shared/river_input + echo "Successfully copied river_input to bcs dir." +endif + + # adjust permissions chmod +rX -R geometry land logs From c60c59be0272407a302114c868d4b3542655d5f7 Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Thu, 19 Jun 2025 09:50:44 -0400 Subject: [PATCH 25/27] river routing input data pointing to bcs --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 48 ++++++++++--------- .../GEOSroute_GridComp/reservoir.F90 | 2 +- 2 files changed, 27 insertions(+), 23 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 85ecd8f4e..37fcc825a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -33,7 +33,6 @@ module GEOS_RouteGridCompMod implicit none integer, parameter :: upmax = 34 - character(len=500) :: inputdir = "/discover/nobackup/yzeng3/data/river_input/" logical, parameter :: use_res = .True. integer, save :: nmax @@ -327,6 +326,8 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) type(MAPL_MetaComp), pointer :: MAPL type(MAPL_LocStream) :: locstream + + character(len=ESMF_MAXSTR) :: River_RoutingFile integer, pointer :: ims(:) => NULL() integer, pointer :: pfaf(:) => NULL() @@ -368,7 +369,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) real, pointer :: dataPtr(:) integer :: j,nt_local,mpierr,it - + ! ------------------ ! begin @@ -434,10 +435,13 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%minCatch = minCatch route%maxCatch = maxCatch + + call MAPL_GetResource (MAPL, River_RoutingFile, label = 'River_Routing_FILE:', default = 'river_input', RC=STATUS ) + ! Read sub-catchment data allocate(nsub_global(N_CatG),subarea_global(nmax,N_CatG)) - open(77,file=trim(inputdir)//"/Pfaf_nsub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)nsub_global; close(77) - open(77,file=trim(inputdir)//"/Pfaf_asub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)subarea_global; close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_nsub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)nsub_global; close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_asub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)subarea_global; close(77) allocate(nsub(ntiles),subarea(nmax,ntiles)) nsub=nsub_global(minCatch:maxCatch) subarea=subarea_global(:,minCatch:maxCatch) @@ -448,7 +452,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%subarea => subarea allocate(subi_global(nmax,N_CatG),subi(nmax,ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_isub_"//trim(resname)//".txt",status="old",action="read");read(77,*)subi_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_isub_"//trim(resname)//".txt",status="old",action="read");read(77,*)subi_global;close(77) subi=subi_global(:,minCatch:maxCatch) route%subi => subi deallocate(subi_global) @@ -484,7 +488,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) ! Read tile area data allocate(tile_area_local(nt_local),tile_area_global(nt_global)) - open(77,file=trim(inputdir)//"/area_"//trim(resname)//"_1d.txt",status="old",action="read");read(77,*)tile_area_global;close(77) + open(77,file=trim(River_RoutingFile)//"/area_"//trim(resname)//"_1d.txt",status="old",action="read");read(77,*)tile_area_global;close(77) tile_area_local=tile_area_global(rdispls_global(mype+1)+1:rdispls_global(mype+1)+nt_local)*1.e6 !km2->m2 route%tile_area => tile_area_local deallocate(tile_area_global) @@ -504,19 +508,19 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) ! Read river network-realated data allocate(lengsc_global(n_catg),lengsc(ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_lriv_PR.txt",status="old",action="read");read(77,*)lengsc_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_lriv_PR.txt",status="old",action="read");read(77,*)lengsc_global;close(77) lengsc=lengsc_global(minCatch:maxCatch)*1.e3 !km->m route%lengsc=>lengsc deallocate(lengsc_global) allocate(downid_global(n_catg),downid(ntiles)) - open(77,file=trim(inputdir)//"/downstream_1D_new_noadj.txt",status="old",action="read");read(77,*)downid_global;close(77) + open(77,file=trim(River_RoutingFile)//"/downstream_1D_new_noadj.txt",status="old",action="read");read(77,*)downid_global;close(77) downid=downid_global(minCatch:maxCatch) route%downid=>downid deallocate(downid_global) allocate(upid_global(upmax,n_catg),upid(upmax,ntiles)) - open(77,file=trim(inputdir)//"/upstream_1D.txt",status="old",action="read");read(77,*)upid_global;close(77) + open(77,file=trim(River_RoutingFile)//"/upstream_1D.txt",status="old",action="read");read(77,*)upid_global;close(77) upid=upid_global(:,minCatch:maxCatch) route%upid=>upid deallocate(upid_global) @@ -535,12 +539,12 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) read(77,*)wriver_global;close(77) else close(77) - open(78,file=trim(inputdir)//"/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + open(78,file=trim(River_RoutingFile)//"/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then read(78,*)wriver_global;close(78) else close(78) - open(79,file=trim(inputdir)//"/river_storage_rs.txt",status="old",action="read",iostat=status) + open(79,file=trim(River_RoutingFile)//"/river_storage_rs.txt",status="old",action="read",iostat=status) if(status==0)then read(79,*)wriver_global;close(79) else @@ -554,12 +558,12 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) read(77,*)wstream_global;close(77) else close(77) - open(78,file=trim(inputdir)//"/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + open(78,file=trim(River_RoutingFile)//"/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then read(78,*)wstream_global;close(78) else close(78) - open(79,file=trim(inputdir)//"/stream_storage_rs.txt",status="old",action="read",iostat=status) + open(79,file=trim(River_RoutingFile)//"/stream_storage_rs.txt",status="old",action="read",iostat=status) if(status==0)then read(79,*)wstream_global;close(79) else @@ -573,12 +577,12 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) read(77,*)wres_global;close(77) else close(77) - open(78,file=trim(inputdir)//"/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) + open(78,file=trim(River_RoutingFile)//"/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then read(78,*)wres_global;close(78) else close(78) - open(79,file=trim(inputdir)//"/res_storage_rs.txt",status="old",action="read",iostat=status) + open(79,file=trim(River_RoutingFile)//"/res_storage_rs.txt",status="old",action="read",iostat=status) if(status==0)then read(79,*)wres_global;close(79) else @@ -608,38 +612,38 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) !Read input specially for geometry hydraulic (not required by linear model) allocate(buff_global(n_catg),route%lstr(ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_lstr_PR.txt",status="old",action="read");read(77,*)buff_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_lstr_PR.txt",status="old",action="read");read(77,*)buff_global;close(77) route%lstr=buff_global(minCatch:maxCatch)*1.e3 !km->m deallocate(buff_global) allocate(buff_global(n_catg),route%K(ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) route%K=buff_global(minCatch:maxCatch) deallocate(buff_global) allocate(buff_global(n_catg),route%Kstr(ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) route%Kstr=buff_global(minCatch:maxCatch) deallocate(buff_global) allocate(buff_global(n_catg),route%qri_clmt(ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_qri.txt",status="old",action="read");read(77,*)buff_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_qri.txt",status="old",action="read");read(77,*)buff_global;close(77) route%qri_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) allocate(buff_global(n_catg),route%qin_clmt(ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_qin.txt",status="old",action="read");read(77,*)buff_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_qin.txt",status="old",action="read");read(77,*)buff_global;close(77) route%qin_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) allocate(buff_global(n_catg),route%qstr_clmt(ntiles)) - open(77,file=trim(inputdir)//"/Pfaf_qstr.txt",status="old",action="read");read(77,*)buff_global;close(77) + open(77,file=trim(River_RoutingFile)//"/Pfaf_qstr.txt",status="old",action="read");read(77,*)buff_global;close(77) route%qstr_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) !Initial reservoir module res => route%reservoir - call res_init(inputdir,n_catg,ntiles,minCatch,maxCatch,use_res,res%active_res,res%type_res,res%cap_res,res%fld_res,res%Qfld_thres,res%cat2res,res%wid_res) + call res_init(River_RoutingFile,n_catg,ntiles,minCatch,maxCatch,use_res,res%active_res,res%type_res,res%cap_res,res%fld_res,res%Qfld_thres,res%cat2res,res%wid_res) if(mapl_am_I_root()) print *,"reservoir init success" !if (mapl_am_I_root())then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 index e4a576865..a01fd8e24 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/reservoir.F90 @@ -34,7 +34,7 @@ module reservoir !------------------------------------------ ! Initialization subroutine for reservoirs subroutine res_init(input_dir,nall,nc,minCatch,maxCatch,use_res,active_res,type_res,cap_res,fld_res,Qfld_thres,cat2res,wid_res) - character(len=500),intent(in) :: input_dir + character(len=*),intent(in) :: input_dir ! Define the number of reservoirs (nres) and the number of catchments (nc) integer,intent(in) :: nall,nc,minCatch,maxCatch ! Logical variable to check if reservoirs are used From 636cbf192cd869023779b5d5d14d2acc8a97e02d Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Thu, 19 Jun 2025 11:14:06 -0400 Subject: [PATCH 26/27] -diag-disable=10448 added in the building of routing_model preproc --- .../Utils/Raster/preproc/routing_model/build | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build index b9e64540e..b411a5dfa 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/routing_model/build @@ -13,6 +13,6 @@ FILENAME=${array[0]} NETCDF_PATH=/usr/local/other/GEOSpyD/23.5.2-0_py3.11/2023-11-02 LD_LIBRARY_PATH=${NETCDF_PATH}/lib:$LD_LIBRARY_PATH -ifort -qopenmp constant.f90 river_read.f90 k_module_cali.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out +ifort -diag-disable=10448 -qopenmp constant.f90 river_read.f90 k_module_cali.f90 ${FILENAME}.f90 -I$NETCDF_PATH/include -L$NETCDF_PATH/lib -lnetcdf -lnetcdff -o ${FILENAME}.out From 7305bb9684d0a48ca21cb164623b816bfe8c79bc Mon Sep 17 00:00:00 2001 From: Yujin Zeng Date: Sun, 10 Aug 2025 17:20:43 -0400 Subject: [PATCH 27/27] some modifications to address the comments from Weiyuan, yet to be tested --- .../GEOSroute_GridComp/GEOS_RouteGridComp.F90 | 108 ++++++++++-------- 1 file changed, 58 insertions(+), 50 deletions(-) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index 37fcc825a..08f0f54b4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -26,7 +26,7 @@ module GEOS_RouteGridCompMod use MAPL_ConstantsMod use ROUTING_MODEL, ONLY: river_routing_lin, river_routing_hyd, ROUTE_DT use reservoir, ONLY: res_init, res_cal - use catch_constants, ONLY: N_CatG => CATCH_N_PFAFS + use catch_constants, ONLY: N_pfaf_g => CATCH_N_PFAFS use, intrinsic :: iso_c_binding @@ -327,7 +327,9 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) type(MAPL_MetaComp), pointer :: MAPL type(MAPL_LocStream) :: locstream - character(len=ESMF_MAXSTR) :: River_RoutingFile + character(len=ESMF_MAXSTR) :: River_RoutingFile + character(len=ESMF_MAXSTR) :: gridname + type(ESMF_Grid) :: agrid integer, pointer :: ims(:) => NULL() integer, pointer :: pfaf(:) => NULL() @@ -396,7 +398,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) allocate(ims(1:ndes)) ! define catchment space for this processor - call MAPL_DecomposeDim ( n_catg,ims,ndes ) ! ims(mype+1) gives the size of my partition + call MAPL_DecomposeDim ( N_pfaf_g,ims,ndes ) ! ims(mype+1) gives the size of my partition ! myPE is 0-based! beforeMe = sum(ims(1:mype)) minCatch = beforeMe + 1 @@ -409,11 +411,17 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) tileGrid=tilegrid, nt_global=nt_global, RC=status) VERIFY_(STATUS) route%nt_global = nt_global + ! Get grid info from the gridcomp + call ESMF_GridCompGet(gc, grid=agrid, rc=status) + VERIFY_(status) + ! get grid name + call ESMF_GridGet(agrid, name=gridname, rc=status) + VERIFY_(STATUS) ! Determine the resolution - if(nt_global==112573)then + if(index(gridname,'M36') /=0)then resname="M36" nmax=150 - else if(nt_global==1684725)then + else if(index(gridname,'M09') /=0)then resname="M09" nmax=458 else @@ -439,7 +447,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource (MAPL, River_RoutingFile, label = 'River_Routing_FILE:', default = 'river_input', RC=STATUS ) ! Read sub-catchment data - allocate(nsub_global(N_CatG),subarea_global(nmax,N_CatG)) + allocate(nsub_global(N_pfaf_g),subarea_global(nmax,N_pfaf_g)) open(77,file=trim(River_RoutingFile)//"/Pfaf_nsub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)nsub_global; close(77) open(77,file=trim(River_RoutingFile)//"/Pfaf_asub_"//trim(resname)//".txt",status="old",action="read"); read(77,*)subarea_global; close(77) allocate(nsub(ntiles),subarea(nmax,ntiles)) @@ -451,7 +459,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%nsub => nsub route%subarea => subarea - allocate(subi_global(nmax,N_CatG),subi(nmax,ntiles)) + allocate(subi_global(nmax,N_pfaf_g),subi(nmax,ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_isub_"//trim(resname)//".txt",status="old",action="read");read(77,*)subi_global;close(77) subi=subi_global(:,minCatch:maxCatch) route%subi => subi @@ -461,7 +469,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) allocate(scounts(ndes),scounts_global(ndes),rdispls_global(ndes)) scounts=0 scounts(mype+1)=nt_local - call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_global, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) + call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_global, 1, MPI_INTEGER, route%comm, mpierr) rdispls_global(1)=0 do i=2,nDes rdispls_global(i)=rdispls_global(i-1)+scounts_global(i-1) @@ -473,7 +481,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) allocate(scounts(ndes),scounts_cat(ndes),rdispls_cat(ndes)) scounts=0 scounts(mype+1)=ntiles - call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_cat, 1, MPI_INTEGER, MPI_COMM_WORLD, mpierr) + call MPI_Allgather(scounts(mype+1), 1, MPI_INTEGER, scounts_cat, 1, MPI_INTEGER, route%comm, mpierr) rdispls_cat(1)=0 do i=2,nDes rdispls_cat(i)=rdispls_cat(i-1)+scounts_cat(i-1) @@ -507,19 +515,19 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%areacat=>areacat ! Read river network-realated data - allocate(lengsc_global(n_catg),lengsc(ntiles)) + allocate(lengsc_global(N_pfaf_g),lengsc(ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_lriv_PR.txt",status="old",action="read");read(77,*)lengsc_global;close(77) lengsc=lengsc_global(minCatch:maxCatch)*1.e3 !km->m route%lengsc=>lengsc deallocate(lengsc_global) - allocate(downid_global(n_catg),downid(ntiles)) + allocate(downid_global(N_pfaf_g),downid(ntiles)) open(77,file=trim(River_RoutingFile)//"/downstream_1D_new_noadj.txt",status="old",action="read");read(77,*)downid_global;close(77) downid=downid_global(minCatch:maxCatch) route%downid=>downid deallocate(downid_global) - allocate(upid_global(upmax,n_catg),upid(upmax,ntiles)) + allocate(upid_global(upmax,N_pfaf_g),upid(upmax,ntiles)) open(77,file=trim(River_RoutingFile)//"/upstream_1D.txt",status="old",action="read");read(77,*)upid_global;close(77) upid=upid_global(:,minCatch:maxCatch) route%upid=>upid @@ -533,7 +541,7 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) write(day_s,'(I2.2)')DD if(mapl_am_I_root())print *, "init time is ", YY, "/", MM, "/", DD, " ", HH, ":", MMM, ":", SS allocate(wriver(ntiles),wstream(ntiles),wres(ntiles)) - allocate(wriver_global(n_catg),wstream_global(n_catg),wres_global(n_catg)) + allocate(wriver_global(N_pfaf_g),wstream_global(N_pfaf_g),wres_global(N_pfaf_g)) open(77,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",status="old",action="read",iostat=status) if(status==0)then read(77,*)wriver_global;close(77) @@ -611,39 +619,39 @@ subroutine INITIALIZE (GC,IMPORT, EXPORT, CLOCK, RC ) route%reservoir%qres_acc=0. !Read input specially for geometry hydraulic (not required by linear model) - allocate(buff_global(n_catg),route%lstr(ntiles)) + allocate(buff_global(N_pfaf_g),route%lstr(ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_lstr_PR.txt",status="old",action="read");read(77,*)buff_global;close(77) route%lstr=buff_global(minCatch:maxCatch)*1.e3 !km->m deallocate(buff_global) - allocate(buff_global(n_catg),route%K(ntiles)) + allocate(buff_global(N_pfaf_g),route%K(ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_Kv_PR_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) route%K=buff_global(minCatch:maxCatch) deallocate(buff_global) - allocate(buff_global(n_catg),route%Kstr(ntiles)) + allocate(buff_global(N_pfaf_g),route%Kstr(ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_Kstr_PR_fac1_0p35_0p45_0p2_n0p2.txt",status="old",action="read");read(77,*)buff_global;close(77) route%Kstr=buff_global(minCatch:maxCatch) deallocate(buff_global) - allocate(buff_global(n_catg),route%qri_clmt(ntiles)) + allocate(buff_global(N_pfaf_g),route%qri_clmt(ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_qri.txt",status="old",action="read");read(77,*)buff_global;close(77) route%qri_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) - allocate(buff_global(n_catg),route%qin_clmt(ntiles)) + allocate(buff_global(N_pfaf_g),route%qin_clmt(ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_qin.txt",status="old",action="read");read(77,*)buff_global;close(77) route%qin_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) - allocate(buff_global(n_catg),route%qstr_clmt(ntiles)) + allocate(buff_global(N_pfaf_g),route%qstr_clmt(ntiles)) open(77,file=trim(River_RoutingFile)//"/Pfaf_qstr.txt",status="old",action="read");read(77,*)buff_global;close(77) route%qstr_clmt=buff_global(minCatch:maxCatch) !m3/s deallocate(buff_global) !Initial reservoir module res => route%reservoir - call res_init(River_RoutingFile,n_catg,ntiles,minCatch,maxCatch,use_res,res%active_res,res%type_res,res%cap_res,res%fld_res,res%Qfld_thres,res%cat2res,res%wid_res) + call res_init(River_RoutingFile,N_pfaf_g,ntiles,minCatch,maxCatch,use_res,res%active_res,res%type_res,res%cap_res,res%fld_res,res%Qfld_thres,res%cat2res,res%wid_res) if(mapl_am_I_root()) print *,"reservoir init success" !if (mapl_am_I_root())then @@ -869,7 +877,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) call MPI_allgatherv ( & runoff_save, route%scounts_global(mype+1) ,MPI_REAL, & runoff_global, route%scounts_global, route%rdispls_global,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) !Distribute runoff from tile space to catchment space if(FirstTime.and.mapl_am_I_root()) print *,"nmax=",nmax @@ -924,11 +932,11 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) where(res%active_res==1) QOUT_CAT=QRES_ACT ! Collects dishcarge (routing model output) from all processors - allocate(QOUTFLOW_GLOBAL(n_catg)) + allocate(QOUTFLOW_GLOBAL(N_pfaf_g)) call MPI_allgatherv ( & QOUT_CAT, route%scounts_cat(mype+1) ,MPI_REAL, & QOUTFLOW_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) ! Linking discharge as inflow to downstream catchment to adjust river storage allocate(QINFLOW_LOCAL(ntiles)) @@ -971,29 +979,29 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) if(mapl_am_I_root()) istat = mkdir("../river", int(o'755',c_int16_t)) endif if(HH==23)then - allocate(wriver_global(n_catg),wstream_global(n_catg),qoutflow_global(n_catg),qsflow_global(n_catg)) + allocate(wriver_global(N_pfaf_g),wstream_global(N_pfaf_g),qoutflow_global(N_pfaf_g),qsflow_global(N_pfaf_g)) !call MPI_allgatherv ( & ! route%wriver_acc, route%scounts_cat(mype+1) ,MPI_REAL, & ! wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) + ! route%comm, mpierr) !call MPI_allgatherv ( & ! route%wstream_acc, route%scounts_cat(mype+1) ,MPI_REAL, & ! wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) + ! route%comm, mpierr) call MPI_allgatherv ( & route%qoutflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & qoutflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) !call MPI_allgatherv ( & ! route%qsflow_acc, route%scounts_cat(mype+1) ,MPI_REAL, & ! qsflow_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) + ! route%comm, mpierr) if(mapl_am_I_root())then !open(88,file="../river/river_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") !open(89,file="../river/stream_storage_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") open(90,file="../river/river_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") !open(91,file="../river/stream_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg + do i=1,N_pfaf_g !write(88,*)wriver_global(i) !write(89,*)wstream_global(i) write(90,*)qoutflow_global(i) @@ -1008,14 +1016,14 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) endif if(use_res .eqv. .True.)then - allocate(qres_global(n_catg)) + allocate(qres_global(N_pfaf_g)) call MPI_allgatherv ( & res%qres_acc, route%scounts_cat(mype+1) ,MPI_REAL, & qres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) if(mapl_am_I_root())then open(92,file="../river/res_flow_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg + do i=1,N_pfaf_g write(92,*)qres_global(i) enddo close(92) @@ -1033,22 +1041,22 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) !write restart if(MM_next/=MM)then - allocate(wriver_global(n_catg),wstream_global(n_catg)) + allocate(wriver_global(N_pfaf_g),wstream_global(N_pfaf_g)) call MPI_allgatherv ( & route%wstream, route%scounts_cat(mype+1) ,MPI_REAL, & wstream_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) call MPI_allgatherv ( & route%wriver, route%scounts_cat(mype+1) ,MPI_REAL, & wriver_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) if(mapl_am_I_root())then write(yr_s,'(I4.4)')YY_next write(mon_s,'(I2.2)')MM_next write(day_s,'(I2.2)')DD_next open(88,file="../input/restart/river_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") open(89,file="../input/restart/stream_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg + do i=1,N_pfaf_g write(88,*)wriver_global(i) write(89,*)wstream_global(i) enddo @@ -1058,14 +1066,14 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) endif if(use_res .eqv. .True.)then - allocate(wres_global(n_catg)) + allocate(wres_global(N_pfaf_g)) call MPI_allgatherv ( & res%Wr_res, route%scounts_cat(mype+1) ,MPI_REAL, & wres_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) if(mapl_am_I_root())then open(90,file="../input/restart/res_storage_rs_"//trim(yr_s)//trim(mon_s)//trim(day_s)//".txt",action="write") - do i=1,n_catg + do i=1,N_pfaf_g write(90,*)wres_global(i) enddo close(90) @@ -1093,7 +1101,7 @@ subroutine RUN2 (GC,IMPORT, EXPORT, CLOCK, RC ) ! -------- call MAPL_TimerOff ( MAPL, "-RRM" ) call MAPL_TimerOff(MAPL,"RUN2") - !call MPI_Barrier(MPI_COMM_WORLD, mpierr) + !call MPI_Barrier(route%comm, mpierr) RETURN_(ESMF_SUCCESS) @@ -1123,9 +1131,9 @@ subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_AC nt_global = route%nt_global mype = route%mype - allocate(WTOT_AFTER(ntiles),UNBALANCE(ntiles),UNBALANCE_GLOBAL(n_catg),runoff_cat_global(n_catg)) - allocate(QFLOW_SINK(ntiles),QFLOW_SINK_GLOBAL(n_catg),WTOT_BEFORE_GLOBAL(n_catg),WTOT_AFTER_GLOBAL(n_catg)) - allocate(runoff_save_m3(nt_local),runoff_global_m3(nt_global),ERROR(ntiles),ERROR_GLOBAL(n_catg)) + allocate(WTOT_AFTER(ntiles),UNBALANCE(ntiles),UNBALANCE_GLOBAL(N_pfaf_g),runoff_cat_global(N_pfaf_g)) + allocate(QFLOW_SINK(ntiles),QFLOW_SINK_GLOBAL(N_pfaf_g),WTOT_BEFORE_GLOBAL(N_pfaf_g),WTOT_AFTER_GLOBAL(N_pfaf_g)) + allocate(runoff_save_m3(nt_local),runoff_global_m3(nt_global),ERROR(ntiles),ERROR_GLOBAL(N_pfaf_g)) WTOT_AFTER=WRIVER_ACT+WSTREAM_ACT+route%reservoir%Wr_res ERROR = WTOT_AFTER - (WTOT_BEFORE + RUNOFF_ACT*route_dt + QINFLOW_LOCAL*route_dt - QOUTFLOW_ACT*route_dt) @@ -1133,7 +1141,7 @@ subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_AC !call MPI_allgatherv ( & ! UNBALANCE, route%scounts_cat(mype+1) ,MPI_REAL, & ! UNBALANCE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - ! MPI_COMM_WORLD, mpierr) + ! route%comm, mpierr) QFLOW_SINK=0. do i=1,ntiles if(route%downid(i)==-1)then @@ -1143,24 +1151,24 @@ subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_AC call MPI_allgatherv ( & QFLOW_SINK, route%scounts_cat(mype+1) ,MPI_REAL, & QFLOW_SINK_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) call MPI_allgatherv ( & WTOT_BEFORE, route%scounts_cat(mype+1) ,MPI_REAL, & WTOT_BEFORE_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) call MPI_allgatherv ( & WTOT_AFTER, route%scounts_cat(mype+1) ,MPI_REAL, & WTOT_AFTER_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) runoff_save_m3=runoff_save*route%tile_area/1000. call MPI_allgatherv ( & runoff_save_m3, route%scounts_global(mype+1) ,MPI_REAL, & runoff_global_m3, route%scounts_global, route%rdispls_global,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) call MPI_allgatherv ( & RUNOFF_ACT, route%scounts_cat(mype+1) ,MPI_REAL, & runoff_cat_global, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) if(mapl_am_I_root())then open(88,file="../runoff_tile_global_"//trim(yr_s)//"_"//trim(mon_s)//".txt",status="unknown", position="append") write(88,*)sum(runoff_global_m3) @@ -1193,7 +1201,7 @@ subroutine check_balance(route,ntiles,nt_local,runoff_save,WRIVER_ACT,WSTREAM_AC call MPI_allgatherv ( & ERROR, route%scounts_cat(mype+1) ,MPI_REAL, & ERROR_GLOBAL, route%scounts_cat, route%rdispls_cat,MPI_REAL, & - MPI_COMM_WORLD, mpierr) + route%comm, mpierr) temp = maxloc(abs(ERROR_GLOBAL)) cid = temp(1) if(cid>=route%minCatch.and.cid<=route%maxCatch)then