module module_HYDRO_io #ifdef MPP_LAND use module_mpp_land use module_mpp_reachls, only: ReachLS_decomp, reachls_wreal, ReachLS_write_io, & ReachLS_wInt, reachls_wreal2, TONODE2RSL, TONODE2RSL8, gbcastvalue use MODULE_mpp_GWBUCKET, only: gw_write_io_real, gw_write_io_int #endif use Module_Date_utilities_rt, only: geth_newdate use module_HYDRO_utils, only: get_dist_ll use config_base, only: nlst use module_RT_data, only: rt_domain use module_gw_gw2d_data, only: gw2d use module_reservoir_utilities, only: read_reservoir_type use netcdf use module_hydro_stop, only:HYDRO_stop use hashtable use iso_fortran_env, only: int64, compiler_version implicit none interface w_rst_crt_reach module procedure w_rst_crt_reach_real module procedure w_rst_crt_reach_real8 end interface interface read_rst_crt_reach_nc module procedure read_rst_crt_reach_nc_real module procedure read_rst_crt_reach_nc_real8 end interface integer, parameter :: did=1 integer :: logUnit contains integer function get2d_real(var_name,out_buff,ix,jx,fileName, fatalErr) implicit none integer :: ivar, iret,varid,ncid,ix,jx real out_buff(ix,jx) character(len=*), intent(in) :: var_name character(len=*), intent(in) :: fileName logical, optional, intent(in) :: fatalErr logical :: fatalErr_local character(len=256) :: errMsg fatalErr_local = .false. if(present(fatalErr)) fatalErr_local=fatalErr get2d_real = -1 iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid) if (iret .ne. 0) then errMsg = "get2d_real: failed to open the netcdf file: " // trim(fileName) print*, trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) out_buff = -9999. return endif ivar = nf90_inq_varid(ncid,trim(var_name), varid) if(ivar .ne. 0) then ivar = nf90_inq_varid(ncid,trim(var_name//"_M"), varid) if(ivar .ne. 0) then errMsg = "WARNING: get2d_real: failed to find the variables: " // & trim(var_name) // ' and ' // trim(var_name//"_M") // & ' in ' // trim(fileName) write(6,*) errMsg if(fatalErr_local) call hydro_stop(errMsg) return endif end if iret = nf90_get_var(ncid, varid, out_buff) if(iret .ne. 0) then errMsg = "WARNING: get2d_real: failed to read the variable: " // & trim(var_name) // ' or ' // trim(var_name//"_M") // & ' in ' // trim(fileName) print*,trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) return endif iret = nf90_close(ncid) if(iret .ne. 0) then errMsg = "WARNING: get2d_real: failed to close the file: " // & trim(fileName) print*,trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif get2d_real = ivar end function get2d_real subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName) implicit none integer ix,jx, status character (len=*),intent(in) :: var_name, fileName real,dimension(ix,jx):: out_buff #ifdef MPP_LAND #ifdef PARALLELIO status = get2d_real(var_name,out_buff,ix,jx,fileName) #else real,allocatable, dimension(:,:) :: buff_g #ifdef HYDRO_D write(6,*) "start to read variable ", var_name #endif if(my_id .eq. IO_id) then allocate(buff_g (global_nx,global_ny) ) status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName) else allocate(buff_g (1,1) ) end if call decompose_data_real(buff_g,out_buff) if(allocated(buff_g)) deallocate(buff_g) #endif #else status = get2d_real(var_name,out_buff,ix,jx,fileName) #endif #ifdef HYDRO_D write(6,*) "finish reading variable ", var_name #endif end subroutine get2d_lsm_real subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) implicit none integer ix,jx, status,land_cat, iret, dimid,ncid character (len=*),intent(in) :: fileName character (len=256) units integer,dimension(ix,jx):: out_buff real, dimension(ix,jx) :: xdum #ifdef MPP_LAND real,allocatable, dimension(:,:) :: buff_g #ifndef PARALLELIO if(my_id .eq. IO_id) then allocate(buff_g (global_nx,global_ny) ) else allocate(buff_g (1,1) ) endif if(my_id .eq. IO_id) then #endif #endif ! Open the NetCDF file. iret = nf90_open(fileName, NF90_NOWRITE, ncid) if (iret /= 0) then write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(fileName) call hydro_stop("In get2d_lsm_vegtyp() - Problem opening geo_static file") endif iret = nf90_inq_dimid(ncid, "land_cat", dimid) if (iret /= 0) then call hydro_stop("In get2d_lsm_vegtyp() - nf90_inq_dimid: land_cat problem ") endif iret = nf90_inquire_dimension(ncid, dimid, len = land_cat) if (iret /= 0) then call hydro_stop("In get2d_lsm_vegtyp() - nf90_inquire_dimension: land_cat problem") endif #ifdef MPP_LAND #ifndef PARALLELIO call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) end if call decompose_data_real(buff_g,xdum) if(allocated(buff_g)) deallocate(buff_g) #else call get_landuse_netcdf(ncid, xdum, units, ix, jx, land_cat) #endif iret = nf90_close(ncid) #else call get_landuse_netcdf(ncid, xdum, units, ix, jx, land_cat) iret = nf90_close(ncid) #endif out_buff = nint(xdum) end subroutine get2d_lsm_vegtyp subroutine get_file_dimension(fileName, ix,jx) implicit none character(len=*) fileName integer ncid , iret, ix,jx, dimid #ifdef MPP_LAND #ifndef PARALLELIO if(my_id .eq. IO_id) then #endif #endif iret = nf90_open(fileName, NF90_NOWRITE, ncid) if (iret /= 0) then write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(fileName) call hydro_stop("In get_file_dimension() - Problem opening geo_static file") endif iret = nf90_inq_dimid(ncid, "west_east", dimid) if (iret /= 0) then call hydro_stop("In get_file_dimension() - nf90_inq_dimid: west_east problem") endif iret = nf90_inquire_dimension(ncid, dimid, len = ix) if (iret /= 0) then call hydro_stop("In get_file_dimension() - nf90_inquire_dimension: west_east problem") endif iret = nf90_inq_dimid(ncid, "south_north", dimid) if (iret /= 0) then call hydro_stop("In get_file_dimension() - nf90_inq_dimid: south_north problem.") endif iret = nf90_inquire_dimension(ncid, dimid, len = jx) if (iret /= 0) then call hydro_stop("In get_file_dimension() - nf90_inquire_dimension: south_north problem") endif iret = nf90_close(ncid) #ifdef MPP_LAND #ifndef PARALLELIO endif call mpp_land_bcast_int1(ix) call mpp_land_bcast_int1(jx) #endif #endif end subroutine get_file_dimension subroutine get_file_globalatts(fileName, iswater, islake, isurban, isoilwater) implicit none character(len=*) fileName integer iswater, islake, isurban, isoilwater integer ncid, iret, istmp #ifdef MPP_LAND #ifndef PARALLELIO if (my_id .eq. IO_id) then #endif #endif iret = nf90_open(fileName, nf90_nowrite, ncid) if (iret /= NF90_NOERR) then write(*,'("Problem opening geo file: ''", A, "''")') trim(fileName) write(*,*) "Using default (USGS) values for urban and water land use types." else iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISWATER', istmp) if (iret .eq. NF90_NOERR) then iswater = istmp else write(*,*) "Using default (USGS) values for water land use types." iswater = 16 endif iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISLAKE', istmp) if (iret .eq. NF90_NOERR) then islake = istmp else write(*,*) "Using default (USGS) values for lake land use types." islake = -1 endif iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISURBAN', istmp) if (iret .eq. NF90_NOERR) then isurban = istmp else write(*,*) "Using default (USGS) values for urban land use types." isurban = 1 endif iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISOILWATER', istmp) if (iret .eq. NF90_NOERR) then isoilwater = istmp else write(*,*) "Using default (USGS) values for water soil types." isoilwater = 14 endif iret = nf90_close(ncid) endif #ifdef HYDRO_D #ifndef NCEP_WCOSS write(6, *) "get_file_globalatts: ISWATER ISLAKE ISURBAN ISOILWATER", iswater, islake, isurban, isoilwater #endif #endif #ifdef MPP_LAND #ifndef PARALLELIO endif call mpp_land_bcast_int1(iswater) call mpp_land_bcast_int1(islake) call mpp_land_bcast_int1(isurban) call mpp_land_bcast_int1(isoilwater) #endif #endif end subroutine get_file_globalatts subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) implicit none integer ix,jx, status,land_cat, iret, dimid,ncid character (len=*),intent(in) :: fileName character (len=256) units integer,dimension(ix,jx):: out_buff real, dimension(ix,jx) :: xdum #ifdef MPP_LAND #ifndef PARALLELIO real,allocatable, dimension(:,:) :: buff_g if(my_id .eq. IO_id) then allocate(buff_g (global_nx,global_ny) ) #endif #endif ! Open the NetCDF file. iret = nf90_open(fileName, NF90_NOWRITE, ncid) if (iret /= 0) then write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(fileName) call hydro_stop("In get2d_lsm_soltyp() - problem to open geo_static file.") endif iret = nf90_inq_dimid(ncid, "soil_cat", dimid) if (iret /= 0) then call hydro_stop("In get2d_lsm_soltyp() - nf90_inq_dimid: soil_cat problem") endif iret = nf90_inquire_dimension(ncid, dimid, len = land_cat) if (iret /= 0) then call hydro_stop("In get2d_lsm_soltyp() - nf90_inquire_dimension: soil_cat problem") endif #ifdef MPP_LAND #ifndef PARALLELIO call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) end if call decompose_data_real(buff_g,xdum) if(my_id .eq. io_id) then if(allocated(buff_g)) deallocate(buff_g) endif #else call get_soilcat_netcdf(ncid, xdum, units, ix, jx, land_cat) #endif iret = nf90_close(ncid) #else call get_soilcat_netcdf(ncid, xdum, units, ix, jx, land_cat) iret = nf90_close(ncid) #endif out_buff = nint(xdum) end subroutine get2d_lsm_soltyp subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim) implicit none integer, intent(in) :: ncid integer, intent(in) :: idim, jdim, ldim real, dimension(idim,jdim), intent(out) :: array character(len=256), intent(out) :: units integer :: iret, varid ! real, dimension(idim,jdim,ldim) :: xtmp ! integer, dimension(1) :: mp ! integer :: i, j, l ! character(len=24), parameter :: name = "LANDUSEF" character(len=24), parameter :: name = "LU_INDEX" units = "" ! iret = nf90_inq_varid(ncid, trim(name), varid) ! if (iret /= 0) then ! print*, 'name = "', trim(name)//'"' ! call hydro_stop("In get_landuse_netcdf() - nf90_inq_varid problem") ! endif ! iret = nf90_get_var(ncid, varid, xtp) ! if (iret /= 0) then ! print*, 'name = "', trim(name)//'"' ! call hydro_stop("In get_landuse_netcdf() - nf90_get_var problem") ! endif ! ! do i = 1, idim ! do j = 1, jdim ! mp = maxloc(xtmp(i,j,:)) ! array(i,j) = mp(1) ! do l = 1,ldim ! if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0 ! enddo ! enddo ! enddo !!! START AD_CHANGE ! Using LU_INDEX direct from WPS for consistency with the LSMs iret = nf90_inq_varid(ncid, name, varid) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_landuse_netcdf() - nf90_inq_varid problem") endif iret = nf90_get_var(ncid, varid, array) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_landuse_netcdf() - nf90_get_var problem") endif !!! END AD_CHANGE end subroutine get_landuse_netcdf subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim) implicit none integer, intent(in) :: ncid integer, intent(in) :: idim, jdim, ldim real, dimension(idim,jdim), intent(out) :: array character(len=256), intent(out) :: units integer :: iret, varid ! real, dimension(idim,jdim,ldim) :: xtmp ! integer, dimension(1) :: mp ! integer :: i, j, did ! character(len=24), parameter :: name = "SOILCTOP" character(len=24), parameter :: name = "SCT_DOM" ! did = 1 units = "" ! iret = nf90_inq_varid(ncid, trim(name), varid) ! if (iret /= 0) then ! print*, 'name = "', trim(name)//'"' ! call hydro_stop("In get_soilcat_netcdf() - nf90_inq_varid problem") ! endif ! ! iret = nf90_get_var(ncid, varid, xtmp) ! if (iret /= 0) then ! print*, 'name = "', trim(name)//'"' ! call hydro_stop("In get_soilcat_netcdf() - nf90_get_var problem") ! endif ! ! do i = 1, idim ! do j = 1, jdim ! mp = maxloc(xtmp(i,j,:)) ! array(i,j) = mp(1) ! enddo ! enddo ! if(nlst_rt(did)%GWBASESWCRT .ne. 3) then ! where (array == 14) array = 1 ! DJG remove all 'water' soils... ! endif !!! START AD_CHANGE ! Using SCT_DOM direct from WPS for consistency with the LSMs iret = nf90_inq_varid(ncid, name, varid) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_soilcat_netcdf() - nf90_inq_varid problem") endif iret = nf90_get_var(ncid, varid, array) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_soilcat_netcdf() - nf90_get_var problem") endif !!! END AD_CHANGE end subroutine get_soilcat_netcdf subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) implicit none integer, intent(in) :: ncid,mm,dd integer, intent(in) :: idim, jdim, ldim real, dimension(idim,jdim) :: array real, dimension(idim,jdim) :: array2 real, dimension(idim,jdim) :: diff real, dimension(idim,jdim), intent(out) :: array3 character(len=256), intent(out) :: units integer :: iret, varid real, dimension(idim,jdim,ldim) :: xtmp integer, dimension(1) :: mp integer :: i, j, mm2,daytot real :: ddfrac character(len=24), parameter :: name = "GREENFRAC" units = "fraction" iret = nf90_inq_varid(ncid, trim(name), varid) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_greenfrac_netcdf() - nf90_inq_varid problem") endif iret = nf90_get_var(ncid, varid, xtmp) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_greenfrac_netcdf() - nf90_get_var problem") endif if (mm.lt.12) then mm2 = mm+1 else mm2 = 1 end if !DJG_DES Set up dates for daily interpolation... if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then daytot = 31 else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then daytot = 30 else if (mm.eq.2) then daytot = 28 end if ddfrac = float(dd)/float(daytot) if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th #ifdef HYDRO_D print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac #endif do i = 1, idim do j = 1, jdim array(i,j) = xtmp(i,j,mm) !GREENFRAC in geogrid in units of fraction from month 1 array2(i,j) = xtmp(i,j,mm2) !GREENFRAC in geogrid in units of fraction from month 1 diff(i,j) = array2(i,j) - array(i,j) array3(i,j) = array(i,j) + ddfrac * diff(i,j) enddo enddo end subroutine get_greenfrac_netcdf subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) implicit none integer, intent(in) :: ncid,mm,dd integer, intent(in) :: idim, jdim, ldim real, dimension(idim,jdim) :: array real, dimension(idim,jdim) :: array2 real, dimension(idim,jdim) :: diff real, dimension(idim,jdim), intent(out) :: array3 character(len=256), intent(out) :: units integer :: iret, varid real, dimension(idim,jdim,ldim) :: xtmp integer, dimension(1) :: mp integer :: i, j, mm2,daytot real :: ddfrac character(len=24), parameter :: name = "ALBEDO12M" units = "fraction" iret = nf90_inq_varid(ncid, trim(name), varid) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_albedo12m_netcdf() - nf90_inq_varid problem") endif iret = nf90_get_var(ncid, varid, xtmp) if (iret /= 0) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_albedo12m_netcdf() - nf90_get_var problem") endif if (mm.lt.12) then mm2 = mm+1 else mm2 = 1 end if !DJG_DES Set up dates for daily interpolation... if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then daytot = 31 else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then daytot = 30 else if (mm.eq.2) then daytot = 28 end if ddfrac = float(dd)/float(daytot) if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th #ifdef HYDRO_D print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac #endif do i = 1, idim do j = 1, jdim array(i,j) = xtmp(i,j,mm) / 100.0 !Convert ALBEDO12M from % to fraction...month 1 array2(i,j) = xtmp(i,j,mm2) / 100.0 !Convert ALBEDO12M from % to fraction... month 2 diff(i,j) = array2(i,j) - array(i,j) array3(i,j) = array(i,j) + ddfrac * diff(i,j) enddo enddo end subroutine get_albedo12m_netcdf subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & fatal_if_error, ierr) implicit none character(len=*), intent(in) :: name integer, intent(in) :: ncid integer, intent(in) :: idim, jdim real, dimension(idim,jdim), intent(inout) :: array character(len=256), intent(out) :: units ! fatal_IF_ERROR: an input code value: ! .TRUE. if an error in reading the data should stop the program. ! Otherwise the, IERR error flag is set, but the program continues. logical, intent(in) :: fatal_if_error integer, intent(out) :: ierr integer :: iret, varid real :: scale_factor, add_offset units = "" iret = nf90_inq_varid(ncid, name, varid) if (iret /= 0) then if (fatal_IF_ERROR) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_2d_netcdf() - nf90_inq_varid problem") else ierr = iret return endif endif iret = nf90_get_var(ncid, varid, array) if (iret /= 0) then if (fatal_IF_ERROR) then print*, 'name = "', trim(name)//'"' call hydro_stop("In get_2d_netcdf() - nf90_get_var problem") else ierr = iret return endif endif iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor) if(iret .eq. 0) array = array * scale_factor iret = nf90_get_att(ncid, varid, 'add_offset', add_offset) if(iret .eq. 0) array = array + add_offset ierr = 0; end subroutine get_2d_netcdf subroutine get_2d_netcdf_cows(var_name,ncid,var, & ix,jx,tlevel,fatal_if_error,ierr) character(len=*), intent(in) :: var_name integer,intent(in) :: ncid,ix,jx,tlevel real, intent(out):: var(ix,jx) logical, intent(in) :: fatal_if_error integer ierr, iret integer varid integer start(4),count(4) data count /1,1,1,1/ data start /1,1,1,1/ count(1) = ix count(2) = jx start(4) = tlevel iret = nf90_inq_varid(ncid, var_name, varid) if (iret /= 0) then if (fatal_IF_ERROR) then call hydro_stop("In get_2d_netcdf_cows() - nf90_inq_varid problem") else ierr = iret return endif endif iret = nf90_get_var(ncid, varid, var, start, count) end subroutine get_2d_netcdf_cows !--------------------------------------------------------- !DJG Subroutinesfor inputting routing fields... !DNY first reads the files to get the size of the !DNY LINKS arrays !DJG - Currently only hi-res topo is read !DJG - At a future time, use this routine to input !DJG subgrid land-use classification or routing !DJG parameters 'overland roughness' and 'retention !DJG depth' ! !DJG,DNY - Update this subroutine to read in channel and lake ! parameters if activated 11.20.2005 !--------------------------------------------------------- SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & route_direction_f, NLINKS, & CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT,NLAKES) implicit none INTEGER :: I,J,channel_option,jj INTEGER, INTENT(INOUT) :: NLINKS, NLINKSL INTEGER, INTENT(IN) :: IXRT,JXRT INTEGER :: CHNID,cnt INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT REAL, DIMENSION(IXRT,JXRT) :: LAT, LON INTEGER(kind=int64), DIMENSION(IXRT,JXRT) :: CH_LNKRT !- link routing ID integer, INTENT(IN) :: UDMP_OPT integer :: NLAKES !!Dummy read in grids for inverted y-axis CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f CHARACTER(len=*) :: geo_finegrid_flnm CHARACTER(len=256) :: var_name ! variables for handling netcdf dimensions integer :: iRet, ncid, dimId logical :: routeLinkNetcdf NLINKS = 0 CH_NETRT = -9999 CH_NETLNK = -9999 NLINKSL = 0 CH_LNKRT = -9999 cnt = 0 #ifdef HYDRO_D print *, "Channel Option in Routedim is ", channel_option #endif if (channel_option .eq. 4) return ! it will run Rapid !-- will always read channel grid IF(channel_option.eq.3) then !get maxnodes and links from grid var_name = "CHANNELGRID" call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) !-- new link id variable to handle link routing var_name = "LINKID" #ifdef MPP_LAND #ifdef HYDRO_D write(6,*) "read LINKID for CH_LNKRT from ", trim(geo_finegrid_flnm) #endif #endif !!!! LINKID is used for reach based method. ? IF(channel_option.ne.3 .and. UDMP_OPT.ne.1) then !get maxnodes and links from grid call readRT2d_int8(var_name,CH_LNKRT,ixrt,jxrt,& trim(geo_finegrid_flnm), fatalErr=.TRUE.) endif var_name = "FLOWDIRECTION" call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& trim(geo_finegrid_flnm)) !note that this is not used for link routing var_name = "LAKEGRID" call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "LATITUDE" call readRT2d_real(var_name,LAT,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "LONGITUDE" call readRT2d_real(var_name,LON,ixrt,jxrt,& trim(geo_finegrid_flnm)) ! temp fix for buggy Arc export... do j=1,jxrt do i=1,ixrt if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 end do end do !DJG inv do j=jxrt,1,-1 do j=1,jxrt do i = 1, ixrt ! if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then if (CH_NETRT(i,j) .ge.0) then NLINKS = NLINKS + 1 if( UDMP_OPT .eq. 1) CH_NETLNK(i,j) = 2 endif end do end do #ifdef HYDRO_D print *, "NLINKS IS ", NLINKS #endif if( UDMP_OPT .eq. 1) then return endif !DJG inv DO j = JXRT,1,-1 !rows DO j = 1,JXRT !rows DO i = 1 ,IXRT !colsumns If (CH_NETRT(i, j) .ge. 0) then !get its direction If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT) ) then !North if(CH_NETRT(i,j+1) .ge.0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & .AND. (j + 1 .LE. JXRT) ) then !North East if(CH_NETRT(i+1,j+1) .ge.0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT)) then !East if(CH_NETRT(i+1,j) .ge. 0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & .AND. (j - 1 .NE. 0)) then !south east if(CH_NETRT(i+1,j-1).ge.0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0)) then !due south if(CH_NETRT(i,j-1).ge.0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & .AND. (j - 1 .NE. 0) ) then !south west if(CH_NETRT(i-1,j-1).ge.0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0)) then !West if(CH_NETRT(i-1,j).ge.0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & .AND. (j + 1 .LE. JXRT) ) then !North West if(CH_NETRT(i-1,j+1).ge.0) then cnt = cnt + 1 CH_NETLNK(i,j) = cnt endif else #ifdef HYDRO_D write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j #endif 135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) if (DIRECTION(i,j) .eq. 0) then #ifdef HYDRO_D print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" #endif endif End If End If !CH_NETRT check for this node END DO END DO #ifdef HYDRO_D print *, "found type 0 nodes", cnt #endif !Find out if the boundaries are on an edge or flow into a lake !DJG inv DO j = JXRT,1,-1 DO j = 1,JXRT DO i = 1 ,IXRT If (CH_NETRT(i, j) .ge. 0) then !get its direction If ( (DIRECTION(i, j).EQ. 64) )then if( j + 1 .GT. JXRT) then !-- 64's can only flow north cnt = cnt + 1 CH_NETLNK(i,j) = cnt elseif(CH_NETRT(i,j+1) .lt. 0) then !North cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point N", cnt,CH_NETRT(i,j), i,j #endif endif else if ( DIRECTION(i, j) .EQ. 128) then if ((i + 1 .GT. IXRT) .or. (j + 1 .GT. JXRT)) then !-- 128's can flow out of the North or East edge cnt = cnt + 1 CH_NETLNK(i,j) = cnt ! this is due north edge elseif(CH_NETRT(i + 1, j + 1).lt.0) then !North East cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point NE", cnt, CH_NETRT(i,j),i,j #endif endif else if (DIRECTION(i, j) .EQ. 1) then if (i + 1 .GT. IXRT) then !-- 1's can only flow due east cnt = cnt + 1 CH_NETLNK(i,j) = cnt elseif(CH_NETRT(i + 1, j) .lt. 0) then !East cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point E", cnt,CH_NETRT(i,j), i,j #endif endif else if (DIRECTION(i, j) .EQ. 2) then !-- 2's can flow out of east or south edge if( (i + 1 .GT. IXRT) .OR. (j - 1 .EQ. 0)) then !-- this is the south edge cnt = cnt + 1 CH_NETLNK(i,j) = cnt elseif(CH_NETRT(i + 1, j - 1) .lt.0) then !south east cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j #endif endif else if ( DIRECTION(i, j) .EQ. 4) then if( (j - 1 .EQ. 0)) then !-- 4's can only flow due south cnt = cnt + 1 CH_NETLNK(i,j) = cnt elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j #endif endif else if ( DIRECTION(i, j) .EQ. 8) then !-- 8's can flow south or west if( (i - 1 .eq. 0) .OR. ( j - 1 .EQ. 0)) then !-- this is the south edge cnt = cnt + 1 CH_NETLNK(i,j) = cnt elseif (CH_NETRT(i - 1, j - 1).lt.0) then !south west cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j #endif endif else if ( DIRECTION(i, j) .EQ. 16) then if(i - 1 .eq. 0) then !-- 16's can only flow due west cnt = cnt + 1 CH_NETLNK(i,j) = cnt elseif (CH_NETRT(i - 1, j).lt.0) then !West cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j #endif endif else if ( DIRECTION(i, j) .EQ. 32) then if ( (i - 1 .eq. 0) & !-- 32's can flow either west or north .OR. (j .eq. JXRT)) then !-- this is the north edge cnt = cnt + 1 CH_NETLNK(i,j) = cnt elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West cnt = cnt + 1 CH_NETLNK(i,j) = cnt #ifdef HYDRO_D print *, "Boundary Pour Point NW", cnt,CH_NETRT(i,j), i,j #endif endif endif endif !CH_NETRT check for this node END DO END DO #ifdef HYDRO_D print *, "total number of channel elements", cnt print *, "total number of NLINKS ", NLINKS #endif !-- get the number of lakes if (cnt .ne. NLINKS) then print *, "Apparent error in network topology", cnt, NLINKS print* , "ixrt =", ixrt, "jxrt =", jxrt call hydro_stop("READ_ROUTEDIM") endif !!-- no longer find the lakes from the 2-d hi res grid !DJG inv do j=jxrt,1,-1 ! follwoing is modified by Wei Yu 03/24/2017 if(UDMP_OPT .eq. 0) then NLAKES = 0 do j=1,jxrt do i = 1,ixrt if (LAKE_MSKRT(i,j) .gt. NLAKES) then NLAKES = LAKE_MSKRT(i,j) endif end do end do #ifdef HYDRO_D write(6,*) "finish read_red .. Total Number of Lakes in Domain = ", NLAKES #endif endif !-- don't return here--! return END SUBROUTINE READ_ROUTEDIM !!! This subroutine gets the NLINKSL subroutine get_NLINKSL(NLINKSL, channel_option, route_link_f) implicit none CHARACTER(len=*) :: route_link_f integer :: NLINKSL, channel_option CHARACTER(len=256) :: route_link_f_r integer :: lenRouteLinkFR logical :: routeLinkNetcdf CHARACTER(len=256) :: InputLine if (channel_option.ne.3) then ! overwrite the NLINKS !-IF is now commented above else ! get nlinks from the ascii file of links #ifdef HYDRO_D write(6,*) "read file to get NLINKSL from", trim(route_link_f) call flush(6) #endif !! is RouteLink file netcdf (*.nc) or csv (*.csv) route_link_f_r = adjustr(route_link_f) lenRouteLinkFR = len(route_link_f_r) routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq. '.nc' if(routeLinkNetcdf) then NLINKSL = -99 NLINKSL = get_netcdf_dim(trim(route_link_f), 'feature_id', & 'READ_ROUTEDIM', fatalErr=.false.) if(NLINKSL .eq. -99) then ! We were unsucessful in getting feature_id, try linkDim NLINKSL = get_netcdf_dim(trim(route_link_f), 'linkDim', & 'READ_ROUTEDIM', fatalErr=.false.) endif if(NLINKSL .eq. -99) then ! Neither the feature_id or linkDim dimensions were found in ! the RouteLink file. Throw an error... call hydro_stop("Could not find either feature_id or linkDim in RouteLink file.") endif else open(unit=17,file=trim(route_link_f), & !link form='formatted',status='old') 1011 read(17,*,end= 1999) InputLine NLINKSL = NLINKSL + 1 goto 1011 1999 continue NLINKSL = NLINKSL - 1 !-- first line is a comment close(17) end if ! routeLinkNetcdf #ifdef HYDRO_D print *, "Number of Segments or Links on sparse network", NLINKSL write(6,*) "NLINKSL = ", NLINKSL call flush(6) #endif end if !end-if is now for channel_option just above, not IF from further up end subroutine get_NLINKSL subroutine nreadRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) implicit none INTEGER :: iret INTEGER, INTENT(IN) :: ixrt,jxrt INTEGER :: i, j, ii,jj CHARACTER(len=*):: var_name,fileName real, INTENT(OUT), dimension(ixrt,jxrt) :: inv #ifndef MPP_LAND real, dimension(ixrt,jxrt) :: inv_tmp #endif logical, optional, intent(in) :: fatalErr logical :: fatalErr_local #ifdef MPP_LAND real, allocatable,dimension(:,:) :: g_inv_tmp, g_inv #endif fatalErr_local = .FALSE. if(present(fatalErr)) fatalErr_local=fatalErr #ifdef MPP_LAND if(my_id .eq. io_id) then allocate(g_inv_tmp(global_rt_nx,global_rt_ny)) allocate(g_inv(global_rt_nx,global_rt_ny)) g_inv_tmp = -9999.9 iret = get2d_real(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,& trim(fileName), fatalErr=fatalErr_local) jj = global_rt_ny do j = 1, global_rt_ny g_inv(:,j) = g_inv_tmp(:,jj) jj = global_rt_ny - j end do if(allocated(g_inv_tmp)) deallocate(g_inv_tmp) else allocate(g_inv(1,1)) endif call decompose_RT_real(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT) if(allocated(g_inv)) deallocate(g_inv) #else inv_tmp = -9999.9 iret = get2d_real(var_name,inv_tmp,ixrt,jxrt,& trim(fileName), fatalErr=fatalErr_local) do i=1,ixrt jj=jxrt do j=1,jxrt inv(i,j)=inv_tmp(i,jj) jj=jxrt-j end do end do #endif end SUBROUTINE nreadRT2d_real subroutine nreadRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr) implicit none INTEGER, INTENT(IN) :: ixrt,jxrt INTEGER :: i, j, ii,jj, iret CHARACTER(len=*):: var_name,fileName integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv integer, dimension(ixrt,jxrt) :: inv_tmp logical, optional, intent(in) :: fatalErr logical :: fatalErr_local #ifdef MPP_LAND integer, allocatable,dimension(:,:) :: g_inv_tmp, g_inv #endif fatalErr_local = .FALSE. if(present(fatalErr)) fatalErr_local=fatalErr #ifdef MPP_LAND if(my_id .eq. io_id) then allocate(g_inv_tmp(global_rt_nx,global_rt_ny)) allocate(g_inv(global_rt_nx,global_rt_ny)) g_inv_tmp = -9999.9 call get2d_int(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,& trim(fileName), fatalErr=fatalErr_local) jj = global_rt_ny do j = 1, global_rt_ny g_inv(:,j) = g_inv_tmp(:,jj) jj = global_rt_ny - j end do else allocate(g_inv_tmp(1,1)) allocate(g_inv(1,1)) endif call decompose_RT_int(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT) if(allocated(g_inv_tmp)) deallocate(g_inv_tmp) if(allocated(g_inv)) deallocate(g_inv) #else call get2d_int(var_name,inv_tmp,ixrt,jxrt,& trim(fileName), fatalErr=fatalErr_local) do i=1,ixrt jj=jxrt do j=1,jxrt inv(i,j)=inv_tmp(i,jj) jj=jxrt-j end do end do #endif end SUBROUTINE nreadRT2d_int subroutine nreadRT2d_int8(var_name, inv, ixrt, jxrt, fileName, fatalErr) implicit none INTEGER, INTENT(IN) :: ixrt,jxrt INTEGER :: i, j, ii,jj, iret CHARACTER(len=*):: var_name,fileName integer(kind=int64), INTENT(OUT), dimension(ixrt,jxrt) :: inv integer(kind=int64), dimension(ixrt,jxrt) :: inv_tmp logical, optional, intent(in) :: fatalErr logical :: fatalErr_local #ifdef MPP_LAND integer(kind=int64), allocatable,dimension(:,:) :: g_inv_tmp, g_inv #endif fatalErr_local = .FALSE. if(present(fatalErr)) fatalErr_local=fatalErr #ifdef MPP_LAND if(my_id .eq. io_id) then allocate(g_inv_tmp(global_rt_nx,global_rt_ny)) allocate(g_inv(global_rt_nx,global_rt_ny)) g_inv_tmp = -9999.9 call get2d_int8(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,& trim(fileName), fatalErr=fatalErr_local) jj = global_rt_ny do j = 1, global_rt_ny g_inv(:,j) = g_inv_tmp(:,jj) jj = global_rt_ny - j end do else allocate(g_inv_tmp(1,1)) allocate(g_inv(1,1)) endif call decompose_RT_int8(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT) if(allocated(g_inv_tmp)) deallocate(g_inv_tmp) if(allocated(g_inv)) deallocate(g_inv) #else call get2d_int(var_name,inv_tmp,ixrt,jxrt,& trim(fileName), fatalErr=fatalErr_local) do i=1,ixrt jj=jxrt do j=1,jxrt inv(i,j)=inv_tmp(i,jj) jj=jxrt-j end do end do #endif end SUBROUTINE nreadRT2d_int8 !--------------------------------------------------------- !DJG ----------------------------------------------------- subroutine readRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) implicit none INTEGER :: iret INTEGER, INTENT(IN) :: ixrt,jxrt INTEGER :: i, j, ii,jj CHARACTER(len=*):: var_name,fileName real, INTENT(OUT), dimension(ixrt,jxrt) :: inv real, dimension(ixrt,jxrt) :: inv_tmp logical, optional, intent(in) :: fatalErr logical :: fatalErr_local fatalErr_local = .FALSE. if(present(fatalErr)) fatalErr_local=fatalErr inv_tmp = -9999.9 iret = get2d_real(var_name,inv_tmp,ixrt,jxrt,& trim(fileName), fatalErr=fatalErr_local) jj = jxrt do j = 1, jxrt inv(:,j) = inv_tmp(:,jj) jj = jxrt - j end do end SUBROUTINE readRT2d_real subroutine readRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr) implicit none INTEGER, INTENT(IN) :: ixrt,jxrt INTEGER :: i, j, ii,jj CHARACTER(len=*):: var_name,fileName integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv integer, dimension(ixrt,jxrt) :: inv_tmp logical, optional, intent(in) :: fatalErr logical :: fatalErr_local fatalErr_local = .FALSE. if(present(fatalErr)) fatalErr_local=fatalErr call get2d_int(var_name,inv_tmp,ixrt,jxrt,& trim(fileName), fatalErr=fatalErr_local) jj = jxrt do j = 1, jxrt inv(:,j) = inv_tmp(:,jj) jj = jxrt - j end do end SUBROUTINE readRT2d_int subroutine readRT2d_int8(var_name, inv, ixrt, jxrt, fileName, fatalErr) implicit none INTEGER, INTENT(IN) :: ixrt,jxrt INTEGER :: i, j, ii,jj CHARACTER(len=*):: var_name,fileName integer(kind=int64), INTENT(OUT), dimension(ixrt,jxrt) :: inv integer(kind=int64), dimension(ixrt,jxrt) :: inv_tmp logical, optional, intent(in) :: fatalErr logical :: fatalErr_local fatalErr_local = .FALSE. if(present(fatalErr)) fatalErr_local=fatalErr call get2d_int8(var_name,inv_tmp,ixrt,jxrt,& trim(fileName), fatalErr=fatalErr_local) jj = jxrt do j = 1, jxrt inv(:,j) = inv_tmp(:,jj) jj = jxrt - j end do end SUBROUTINE readRT2d_int8 !--------------------------------------------------------- !DJG ----------------------------------------------------- #ifdef MPP_LAND subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& gw_strm_msk,numbasns,ch_netrt,AGGFACTRT) USE module_mpp_land integer, intent(in) :: IX,JX,IXRT,JXRT,AGGFACTRT integer, intent(out) :: numbasns integer, intent(out), dimension(IX,JX) :: GWSUBBASMSK integer, intent(out), dimension(IXRT,JXRT) :: gw_strm_msk integer, intent(in), dimension(IXRT,JXRT) :: ch_netrt character(len=*) :: gwbasmskfil !integer,dimension(global_nX,global_ny) :: g_GWSUBBASMSK !yw integer,dimension(global_rt_nx, global_rt_ny) :: g_gw_strm_msk,g_ch_netrt integer,allocatable,dimension(:,:) :: g_GWSUBBASMSK integer,allocatable,dimension(:, :) :: g_gw_strm_msk,g_ch_netrt if(my_id .eq. IO_id) then allocate(g_gw_strm_msk(global_rt_nx, global_rt_ny)) allocate(g_ch_netrt(global_rt_nx, global_rt_ny)) allocate(g_GWSUBBASMSK(global_nX,global_ny)) else allocate(g_gw_strm_msk(1,1)) allocate(g_ch_netrt(1,1)) allocate(g_GWSUBBASMSK(1,1)) endif call write_IO_rt_int(ch_netrt,g_ch_netrt) if(my_id .eq. IO_id) then call READ_SIMP_GW(global_nX,global_ny,global_rt_nx,global_rt_ny,& g_GWSUBBASMSK,gwbasmskfil,g_gw_strm_msk,numbasns,& g_ch_netrt,AGGFACTRT) endif call decompose_data_int(g_GWSUBBASMSK,GWSUBBASMSK) call decompose_RT_int(g_gw_strm_msk,gw_strm_msk, & global_rt_nx, global_rt_ny,ixrt,jxrt) call mpp_land_bcast_int1(numbasns) if(allocated(g_gw_strm_msk)) deallocate(g_gw_strm_msk) if(allocated(g_ch_netrt)) deallocate(g_ch_netrt) if(allocated(g_GWSUBBASMSK)) deallocate(g_GWSUBBASMSK) end subroutine MPP_READ_SIMP_GW #endif !DJG ----------------------------------------------------- ! SUBROUTINE READ_SIMP_GW !DJG ----------------------------------------------------- subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& gw_strm_msk,numbasns,ch_netrt,AGGFACTRT) implicit none integer, intent(in) :: IX,JX,IXRT,JXRT,AGGFACTRT integer, intent(in), dimension(IXRT,JXRT) :: ch_netrt integer, intent(out) :: numbasns integer, intent(out), dimension(IX,JX) :: GWSUBBASMSK integer, intent(out), dimension(IXRT,JXRT) :: gw_strm_msk character(len=*) :: gwbasmskfil integer :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt integer :: iret, ncid logical :: fexist integer, allocatable, dimension(:,:) :: GWSUBBASMSK_tmp numbasns = 0 gw_strm_msk = -9999 inquire (file=trim(gwbasmskfil), exist=fexist) if(.not. fexist) then call hydro_stop("Cound not find file : "//trim(gwbasmskfil)) endif iret = nf90_open(trim(gwbasmskfil), NF90_NOWRITE, ncid) if( iret .eq. 0 ) then iret = nf90_close(ncid) print*, "read gwbasmskfil as nc format: ", trim(gwbasmskfil) allocate(GWSUBBASMSK_tmp(ix,jx)) call get2d_int("BASIN",GWSUBBASMSK_tmp,ix,jx,trim(gwbasmskfil), .true.) do j = jx, 1, -1 GWSUBBASMSK(:,j) = GWSUBBASMSK_tmp (:,jx-j+1) end do deallocate(GWSUBBASMSK_tmp) else print*, "read gwbasmskfil as txt format: ", trim(gwbasmskfil) open(unit=18,file=trim(gwbasmskfil), & form='formatted',status='old') do j=jx,1,-1 read (18,*) (GWSUBBASMSK(i,j),i=1,ix) end do close(18) endif !Loop through to count number of basins and assign basin indices to chan grid do J=1,JX do I=1,IX !Determine max number of basins...(assumes basins are numbered ! sequentially from 1 to max number of basins...) if (GWSUBBASMSK(i,j).gt.numbasns) then numbasns = GWSUBBASMSK(i,j) ! get count of basins... end if !Assign gw basin index values to channel grid... do AGGFACYRT=AGGFACTRT-1,0,-1 do AGGFACXRT=AGGFACTRT-1,0,-1 IXXRT=I*AGGFACTRT-AGGFACXRT JYYRT=J*AGGFACTRT-AGGFACYRT IF(ch_netrt(IXXRT,JYYRT).ge.0) then !If channel grid cell gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j) ! assign coarse grid basn indx to chan grid END IF end do !AGGFACXRT end do !AGGFACYRT end do !I-ix end do !J-jx #ifdef HYDRO_D write(6,*) "numbasns = ", numbasns #endif !DJG ----------------------------------------------------- END SUBROUTINE READ_SIMP_GW !DJG ----------------------------------------------------- !Wei Yu subroutine get_gw_strm_msk_lind (ixrt,jxrt,gw_strm_msk,numbasns,basnsInd,gw_strm_msk_lind) implicit none integer, intent(in) :: ixrt,jxrt, numbasns integer, dimension(:,:) :: gw_strm_msk, gw_strm_msk_lind integer(kind=int64), dimension(:) :: basnsInd integer:: i,j,k,bas gw_strm_msk_lind = -999 do j = 1, jxrt do i = 1, ixrt if(gw_strm_msk(i,j) .gt. 0) then do k = 1, numbasns if(gw_strm_msk(i,j) .eq. basnsInd(k)) then gw_strm_msk_lind(i,j) = k endif end do end if end do end do end subroutine get_gw_strm_msk_lind subroutine SIMP_GW_IND(ix,jx,GWSUBBASMSK,numbasns,gnumbasns,basnsInd) ! create an index of basin mask so that it is faster for parallel computation. implicit none integer, intent(in) :: ix,jx integer, intent(in),dimension(ix,jx) :: GWSUBBASMSK integer, intent(out):: gnumbasns integer, intent(inout):: numbasns integer(kind=int64), intent(inout),allocatable,dimension(:):: basnsInd integer,dimension(numbasns):: tmpbuf integer :: i,j,k gnumbasns = numbasns numbasns = 0 tmpbuf = -999. do j = 1,jx do i = 1, ix if(GWSUBBASMSK(i,j) .gt.0) then tmpbuf(GWSUBBASMSK(i,j)) = GWSUBBASMSK(i,j) endif end do end do do k = 1, gnumbasns if(tmpbuf(k) .gt. 0) numbasns = numbasns + 1 end do allocate(basnsInd(numbasns)) i = 1 do k = 1, gnumbasns if(tmpbuf(k) .gt. 0) then basnsInd(i) = tmpbuf(k) i = i + 1 endif end do #ifdef HYDRO_D write(6,*) "check numbasns, gnumbasns : ", numbasns, gnumbasns #endif end subroutine SIMP_GW_IND subroutine read_GWBUCKPARM (inFile, numbasns, gnumbasns, basnsInd, & gw_buck_coeff, gw_buck_exp, gw_buck_loss, & z_max, z_gwsubbas, bas_id, basns_area) ! read GWBUCKPARM file implicit none integer, intent(in) :: gnumbasns, numbasns integer(kind=int64), intent(in), dimension(numbasns) :: basnsInd real, intent(out), dimension(numbasns) :: gw_buck_coeff, gw_buck_exp real, intent(out), dimension(:), allocatable :: gw_buck_loss real, intent(out), dimension(numbasns) :: z_max, z_gwsubbas, basns_area integer, intent(out), dimension(numbasns) :: bas_id real, dimension(gnumbasns) :: tmp_buck_coeff, tmp_buck_exp, tmp_buck_loss real, dimension(gnumbasns) :: tmp_z_max, tmp_z_gwsubbas, tmp_basns_area integer, dimension(gnumbasns) :: tmp_bas_id CHARACTER(len=100) :: header CHARACTER(len=1) :: jnk character(len=*) :: inFile integer :: bas,k integer :: iret, ncid logical :: fexist #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif inquire (file=trim(inFile), exist=fexist) if(.not. fexist) then call hydro_stop("Cound not find file : "//trim(inFile)) endif iret = nf90_open(trim(inFile), NF90_NOWRITE, ncid) if(iret .eq. 0 ) then print*, "read GWBUCKPARM file as nc format: " , trim(inFile) call get_1d_netcdf_int(ncid, "Basin", tmp_bas_id, "read GWBUCKPARM", .true.) call get_1d_netcdf_real(ncid, "Coeff",tmp_buck_coeff , "read GWBUCKPARM", .true.) call get_1d_netcdf_real(ncid, "Expon",tmp_buck_exp , "read GWBUCKPARM", .true.) if(nlst(did)%bucket_loss .eq. 1) then call get_1d_netcdf_real(ncid, "Loss",tmp_buck_loss, "read GWBUCKPARM", .true.) endif call get_1d_netcdf_real(ncid, "Zmax" ,tmp_z_max , "read GWBUCKPARM", .true.) call get_1d_netcdf_real(ncid, "Zinit",tmp_z_gwsubbas , "read GWBUCKPARM", .true.) call get_1d_netcdf_real(ncid, "Area_sqkm",tmp_basns_area , "read GWBUCKPARM", .true.) iret = nf90_close(ncid) else !iret = nf90_close(ncid) print*, "read GWBUCKPARM file as TBL format : " #ifndef NCEP_WCOSS !yw OPEN(81, FILE='GWBUCKPARM.TBL',FORM='FORMATTED',STATUS='OLD') OPEN(81, FILE=trim(inFile),FORM='FORMATTED',STATUS='OLD') read(81,811) header #else OPEN(24, FORM='FORMATTED',STATUS='OLD') read(24,811) header #endif 811 FORMAT(A19) #ifndef NCEP_WCOSS do bas = 1,gnumbasns read(81,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas) end do 812 FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4) close(81) #else do bas = 1,gnumbasns read(24,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas) end do 812 FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4) close(24) #endif endif #ifdef MPP_LAND endif if(gnumbasns .gt. 0 ) then call mpp_land_bcast_real(gnumbasns,tmp_buck_coeff) call mpp_land_bcast_real(gnumbasns,tmp_buck_exp ) if(nlst(did)%bucket_loss .eq. 1) then call mpp_land_bcast_real(gnumbasns,tmp_buck_loss ) endif call mpp_land_bcast_real(gnumbasns,tmp_z_max ) call mpp_land_bcast_real(gnumbasns,tmp_z_gwsubbas ) call mpp_land_bcast_real(gnumbasns,tmp_basns_area ) call mpp_land_bcast_int(gnumbasns,tmp_bas_id) endif #endif do k = 1, numbasns bas = basnsInd(k) gw_buck_coeff(k) = tmp_buck_coeff(bas) gw_buck_exp(k) = tmp_buck_exp(bas) if(nlst(did)%bucket_loss .eq. 1) then gw_buck_loss(k) = tmp_buck_loss(bas) endif z_max(k) = tmp_z_max(bas) z_gwsubbas(k) = tmp_z_gwsubbas(bas) basns_area(k) = tmp_basns_area(bas) bas_id(k) = tmp_bas_id(bas) end do end subroutine read_GWBUCKPARM ! BF read the static input fields needed for the 2D GW scheme subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype, ihShift) implicit none integer, intent(in) :: ix, jx real, intent(in) :: ihShift integer, dimension(ix,jx), intent(inout):: ltype real, dimension(ix,jx), intent(inout) :: hc, ihead, botelv, por #ifdef MPP_LAND integer, dimension(:,:), allocatable :: gLtype real, dimension(:,:), allocatable :: gHC, gIHEAD, gBOTELV, gPOR #endif integer :: i #ifdef MPP_LAND if(my_id .eq. IO_id) then allocate(gHC(global_rt_nx, global_rt_ny)) allocate(gIHEAD(global_rt_nx, global_rt_ny)) allocate(gBOTELV(global_rt_nx, global_rt_ny)) allocate(gPOR(global_rt_nx, global_rt_ny)) allocate(gLtype(global_rt_nx, global_rt_ny)) else allocate(gHC(1, 1)) allocate(gIHEAD(1, 1)) allocate(gBOTELV(1, 1)) allocate(gPOR(1, 1)) allocate(gLtype(1, 1)) endif #ifndef PARALLELIO if(my_id .eq. IO_id) then #endif #ifdef HYDRO_D print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..." #endif #endif ! hydraulic conductivity i = get2d_real("HC", & #ifdef MPP_LAND #ifndef PARALLELIO gHC, global_nx, global_ny, & #else hc, ix, jx, & #endif #else hc, ix, jx, & #endif trim("./gwhires.nc")) ! initial head i = get2d_real("IHEAD", & #ifdef MPP_LAND gIHEAD, global_nx, global_ny, & #else ihead, ix, jx, & #endif trim("./gwhires.nc")) ! aquifer bottom elevation i = get2d_real("BOTELV", & #ifdef MPP_LAND #ifndef PARALLELIO gBOTELV, global_nx, global_ny, & #else botelv, ix, jx, & #endif #else botelv, ix, jx, & #endif trim("./gwhires.nc")) ! aquifer porosity i = get2d_real("POR", & #ifdef MPP_LAND #ifndef PARALLELIO gPOR, global_nx, global_ny, & #else por, ix, jx, & #endif #else por, ix, jx, & #endif trim("./gwhires.nc")) ! groundwater model mask (0 no aquifer, aquifer > 0 call get2d_int("LTYPE", & #ifdef MPP_LAND #ifndef PARALLELIO gLtype, global_nx, global_ny, & #else ltype, ix, jx, & #endif #else ltype, ix, jx, & #endif trim("./gwhires.nc")) #ifdef MPP_LAND #ifndef PARALLELIO gLtype(1,:) = 2 gLtype(:,1) = 2 gLtype(global_rt_nx,:) = 2 gLtype(:,global_rt_ny) = 2 #else ! BF TODO parallel io for gw ltype #endif #else ltype(1,:) = 2 ltype(:,1) = 2 ltype(ix,:)= 2 ltype(:,jx)= 2 #endif #ifdef MPP_LAND #ifndef PARALLELIO endif call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx) call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx) call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx) call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx) call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx) if(allocated(gLtype)) deallocate(gLtype) if(allocated(gHC)) deallocate(gHC) if(allocated(gIHEAD)) deallocate(gIHEAD) if(allocated(gBOTELV)) deallocate(gBOTELV) if(allocated(gPOR)) deallocate(gPOR) #endif #endif ihead = ihead + ihShift where(ltype .eq. 0) hc = 0. !yw por = 10**21 por = 10E21 end where !bftodo: make filename accessible in namelist end subroutine readGW2d !BF subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,CHRTOUT_GRID, & QBDRYRT, & io_config_outputs & ) !output the routing variables over routing grid. implicit none integer, intent(in) :: igrid integer, intent(in) :: io_config_outputs integer, intent(in) :: split_output_count integer, intent(in) :: ixrt,jxrt real, intent(in) :: dt real, intent(in) :: dist(ixrt,jxrt,9) integer, intent(in) :: nsoil integer, intent(in) :: CHRTOUT_GRID character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date character(len=*), intent(in) :: geo_finegrid_flnm real, dimension(nsoil), intent(in) :: sldpth real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable real*8, allocatable, DIMENSION(:) :: xcoord_d real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord integer, save :: ncid,ncstatic integer, save :: output_count real, dimension(nsoil) :: asldpth integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n integer :: iret, dimid_soil, i,j,ii,jj character(len=256) :: output_flnm character(len=19) :: date19 character(len=32) :: convention character(len=34) :: sec_since_date character(len=34) :: sec_valid_date character(len=30) :: soilm real :: long_cm,lat_po,fe,fn, chan_in real, dimension(2) :: sp real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y real, dimension(ixrt,jxrt) :: QSTRMVOLRT real, dimension(ixrt,jxrt) :: SFCHEADSUBRT real, dimension(ixrt,jxrt) :: soxrt,soyrt real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT real, dimension(ixrt,jxrt,nsoil) :: SMCRT character(len=2) :: strTmp integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' decimation = 1 !-- decimation factor #ifdef MPP_LAND ixrtd = int(global_rt_nx/decimation) jxrtd = int(global_rt_ny/decimation) #else ixrtd = int(ixrt/decimation) jxrtd = int(jxrt/decimation) #endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif allocate(xdumd(ixrtd,jxrtd)) allocate(xcoord_d(ixrtd)) allocate(ycoord_d(jxrtd)) allocate(ycoord(jxrtd)) xdumd = -999 xcoord_d = -999 ycoord_d = -999 ycoord = -999 #ifdef MPP_LAND else allocate(xdumd(1,1)) allocate(xcoord_d(1)) allocate(ycoord_d(1)) allocate(ycoord(1)) endif #endif ii = 0 !DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09) chan_in = 0.0 do j=1,jxrt do i=1,ixrt chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9)) !(units m^3) enddo enddo #ifdef MPP_LAND call sum_real1(chan_in) #endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif #ifdef NCEP_WCOSS open (unit=54, form='formatted', status='unknown', position='append') write (54,713) chan_in close (54) #else if (io_config_outputs .le. 0) then open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',& status='unknown',position='append') write (46,713) chan_in close (46) endif #endif #ifdef MPP_LAND endif #endif 713 FORMAT (F20.7) ! return !DJG end dump of channel inflow for calibration.... if (CHRTOUT_GRID.eq.0) return ! return if hires flag eq 1, if =2 output full grid if (output_count == 0) then !-- Open the finemesh static files to obtain projection information #ifdef HYDRO_D write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) #endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic) #ifdef MPP_LAND endif call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & trim(geo_finegrid_flnm) write(*,*) "HIRES_OUTPUT will not be georeferenced..." hires_flag = 0 else hires_flag = 1 endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif if(hires_flag.eq.1) then !if/then hires_georef ! Get Latitude (X) iret = NF90_INQ_VARID(ncstatic,'x',varid) if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord_d) ! Get Longitude (Y) iret = NF90_INQ_VARID(ncstatic,'y',varid) if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord) else ycoord_d = 0. xcoord_d = 0. end if !endif hires_georef jj = 0 #ifdef MPP_LAND do j=global_rt_ny,1,-1*decimation #else do j=jxrt,1,-1*decimation #endif jj = jj+1 if (jj<= jxrtd) then ycoord_d(jj) = ycoord(j) endif enddo if (io_config_outputs .le. 0) then if(hires_flag.eq.1) then !if/then hires_georef ! Get projection information from finegrid netcdf file iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'false_easting', fe) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'false_northing', fn) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file end if !endif hires_georef iret = nf90_close(ncstatic) endif !-- create the fine grid routing file write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_rt() - Problem nf90_create") endif iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times) iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx) if (io_config_outputs .le. 0) then iret = nf90_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils endif !--- define variables ! !- time definition, timeObs iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) if (io_config_outputs .le. 0) then !- x-coordinate in cartesian system iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection') iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate') iret = nf90_put_att(ncid, varid, 'units', 'Meter') !- y-coordinate in cartesian ssystem iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection') iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate') iret = nf90_put_att(ncid, varid, 'units', 'Meter') !- LATITUDE iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE') iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE') iret = nf90_put_att(ncid, varid, 'units', 'deg North') !- LONGITUDE iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE') iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE') iret = nf90_put_att(ncid, varid, 'units', 'deg east') !-- z-level is soil iret = nf90_def_var(ncid, "depth", NF90_FLOAT, (/dimid_soil/), varid) iret = nf90_put_att(ncid, varid, 'units', 'cm') iret = nf90_put_att(ncid, varid, 'long_name', 'depth of soil layer') do n = 1, NSOIL write(strTmp,'(I2)') n iret = nf90_def_var(ncid, "SOIL_M"//trim(strTmp), NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) end do iret = nf90_put_att(ncid, varid, 'units', 'm^3/m^3') iret = nf90_put_att(ncid, varid, 'description', 'moisture content') iret = nf90_put_att(ncid, varid, 'long_name', soilm) ! iret = nf90_put_att(ncid, varid, 'coordinates', 'x y z') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) ! iret = nf90_def_var(ncid, "ESNOW2D", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) ! iret = nf90_def_var(ncid, "QSUBRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) ! iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1') ! iret = nf90_put_att(ncid, varid, 'long_name', 'subsurface flow') ! iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') ! iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') ! iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) endif ! All but long range if ( io_config_outputs .ne. 4 ) then iret = nf90_def_var(ncid, "zwattablrt", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'm') iret = nf90_put_att(ncid, varid, 'long_name', 'water table depth') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) !iret = nf90_def_var(ncid, "Q_SFCFLX_X", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) !iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1') !iret = nf90_put_att(ncid, varid, 'long_name', 'surface flux x') !iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') !iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') !iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) !iret = nf90_def_var(ncid, "Q_SFCFLX_Y", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) !iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1') !iret = nf90_put_att(ncid, varid, 'long_name', 'surface flux y') !iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') !iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') !iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "sfcheadsubrt", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') iret = nf90_put_att(ncid, varid, 'long_name', 'surface head') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) endif if (io_config_outputs .le. 0) then iret = nf90_def_var(ncid, "QSTRMVOLRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') iret = nf90_put_att(ncid, varid, 'long_name', 'accum channel inflow') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) ! iret = nf90_def_var(ncid, "SOXRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) ! iret = nf90_put_att(ncid, varid, 'units', '1') ! iret = nf90_put_att(ncid, varid, 'long_name', 'slope x') ! iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') ! iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') ! iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) ! iret = nf90_def_var(ncid, "SOYRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) ! iret = nf90_put_att(ncid, varid, 'units', '1') ! iret = nf90_put_att(ncid, varid, 'long_name', 'slope 7') ! iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') ! iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') ! iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) ! iret = nf90_def_var(ncid, "SUB_RESID", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_def_var(ncid, "QBDRYRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') iret = nf90_put_att(ncid,varid,'long_name',& 'accumulated value of the boundary flux, + into domain, - out of domain') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) !-- place projection information if(hires_flag.eq.1) then !if/then hires_georef iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid) iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm) iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po) iret = nf90_put_att(ncid, varid, 'false_easting', fe) iret = nf90_put_att(ncid, varid, 'false_northing', fn) iret = nf90_put_att(ncid, varid, 'standard_parallel', sp) end if !endif hires_georef endif ! iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid) date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(startdate)) = startdate convention(1:32) = "CF-1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation) ! iret = nf90_redef(ncid) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) ! iret = nf90_enddef(ncid) iret = nf90_enddef(ncid) if (io_config_outputs .le. 0) then !!-- write latitude and longitude locations iret = nf90_inq_varid(ncid,"x", varid) iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array iret = nf90_inq_varid(ncid,"y", varid) iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array endif #ifdef MPP_LAND endif #endif iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) if (io_config_outputs .le. 0) then #ifdef MPP_LAND call write_IO_rt_real(LATVAL,xdumd) if( my_id .eq. io_id) then #else xdumd = LATVAL #endif iret = nf90_inq_varid(ncid,"LATITUDE", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) #ifdef MPP_LAND endif !!! end if block of my_id .eq. io_id call write_IO_rt_real(LONVAL,xdumd) if( my_id .eq. io_id) then #else xdumd = LONVAL #endif iret = nf90_inq_varid(ncid,"LONGITUDE", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) #ifdef MPP_LAND endif if( my_id .eq. io_id) then #endif do n = 1,nsoil if(n == 1) then asldpth(n) = -sldpth(n) else asldpth(n) = asldpth(n-1) - sldpth(n) endif enddo iret = nf90_inq_varid(ncid,"depth", varid) iret = nf90_put_var(ncid, varid, asldpth, (/1/), (/nsoil/)) !yw iret = nf90_close(ncstatic) #ifdef MPP_LAND endif ! end of my_id .eq. io_id #endif endif endif !!! end of if block output_count == 0 output_count = output_count + 1 if (io_config_outputs .le. 0) then !-- 3-d soils do n = 1, nsoil #ifdef MPP_LAND call write_IO_rt_real(smcrt(:,:,n),xdumd) #else xdumd(:,:) = smcrt(:,:,n) #endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif write(strTmp,'(I2)') n iret = nf90_inq_varid(ncid, "SOIL_M"//trim(strTmp), varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND endif #endif enddo !-n soils endif ! All but long range if ( (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then #ifdef MPP_LAND call write_IO_rt_real(ZWATTABLRT,xdumd) #else xdumd(:,:) = ZWATTABLRT(:,:) #endif #ifdef MPP_LAND if (my_id .eq. io_id) then #endif iret = nf90_inq_varid(ncid, "zwattablrt", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND endif #endif endif if (io_config_outputs .le. 0) then #ifdef MPP_LAND call write_IO_rt_real(QBDRYRT,xdumd) #else xdumd(:,:) = QBDRYRT(:,:) #endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif iret = nf90_inq_varid(ncid, "QBDRYRT", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND endif #endif #ifdef MPP_LAND call write_IO_rt_real(QSTRMVOLRT,xdumd) #else xdumd(:,:) = QSTRMVOLRT(:,:) #endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif iret = nf90_inq_varid(ncid, "QSTRMVOLRT", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND endif #endif endif ! All but long range if ( io_config_outputs .ne. 4 ) then #ifdef MPP_LAND call write_IO_rt_real(SFCHEADSUBRT,xdumd) #else xdumd(:,:) = SFCHEADSUBRT(:,:) #endif #ifdef MPP_LAND if (my_id .eq. io_id) then #endif iret = nf90_inq_varid(ncid, "sfcheadsubrt", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND endif #endif endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif !yw iret = nf90_sync(ncid) if (output_count == split_output_count) then output_count = 0 iret = nf90_close(ncid) endif #ifdef MPP_LAND endif call mpp_land_bcast_int1(output_count) #endif if(allocated(xdumd)) deallocate(xdumd) if(allocated(xcoord_d)) deallocate(xcoord_d) if(allocated(ycoord_d)) deallocate(ycoord_d) if(allocated(ycoord)) deallocate(ycoord) #ifdef HYDRO_D write(6,*) "end of output_rt" #endif end subroutine output_rt !BF output section for gw2d model !bftodo: clean up an customize for GW usage subroutine output_gw_spinup(igrid, split_output_count, ixrt, jxrt, & startdate, date, HEAD, convgw, excess, & geo_finegrid_flnm,dt,LATVAL,LONVAL,dist,output_gw) #ifdef MPP_LAND USE module_mpp_land #endif !output the routing variables over routing grid. implicit none integer, intent(in) :: igrid integer, intent(in) :: split_output_count integer, intent(in) :: ixrt,jxrt real, intent(in) :: dt real, intent(in) :: dist(ixrt,jxrt,9) integer, intent(in) :: output_gw character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date character(len=*), intent(in) :: geo_finegrid_flnm real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord integer, save :: ncid,ncstatic integer, save :: output_count integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n integer :: iret, dimid_soil, i,j,ii,jj character(len=256) :: output_flnm character(len=19) :: date19 character(len=32) :: convention character(len=34) :: sec_since_date character(len=34) :: sec_valid_date character(len=30) :: soilm real :: long_cm,lat_po,fe,fn, chan_in real, dimension(2) :: sp real, dimension(ixrt,jxrt) :: head, convgw, excess, & latval, lonval integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag #ifdef MPP_LAND real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gExcess real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval #endif #ifdef MPP_LAND call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99) call write_IO_rt_real(latval,gLatval) call write_IO_rt_real(lonval,gLonval) call write_IO_rt_real(head,gHead) call write_IO_rt_real(convgw,gConvgw) call write_IO_rt_real(excess,gExcess) if(my_id.eq.IO_id) then #endif seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' decimation = 1 !-- decimation factor #ifdef MPP_LAND ixrtd = int(global_rt_nx/decimation) jxrtd = int(global_rt_ny/decimation) #else ixrtd = int(ixrt/decimation) jxrtd = int(jxrt/decimation) #endif allocate(xdumd(ixrtd,jxrtd)) allocate(xcoord_d(ixrtd)) allocate(ycoord_d(jxrtd)) allocate(xcoord(ixrtd)) allocate(ycoord(jxrtd)) ii = 0 jj = 0 if (output_gw.eq.0) return ! return if hires flag eq 0, if =1 output full grid if (output_count == 0) then !-- Open the finemesh static files to obtain projection information #ifdef HYDRO_D write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) #endif iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic) if (iret /= 0) then #ifdef HYDRO_D write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & trim(geo_finegrid_flnm) write(*,*) "HIRES_OUTPUT will not be georeferenced..." #endif hires_flag = 0 else hires_flag = 1 endif if(hires_flag.eq.1) then !if/then hires_georef ! Get Latitude (X) iret = NF90_INQ_VARID(ncstatic,'x',varid) if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord) ! Get Longitude (Y) iret = NF90_INQ_VARID(ncstatic,'y',varid) if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord) else xcoord_d = 0. ycoord_d = 0. end if !endif hires_georef do j=jxrtd,1,-1*decimation jj = jj+1 if (jj<= jxrtd) then ycoord_d(jj) = ycoord(j) endif enddo !yw do i = 1,ixrt,decimation !yw ii = ii + 1 !yw if (ii <= ixrtd) then !yw xcoord_d(ii) = xcoord(i) xcoord_d = xcoord !yw endif !yw enddo if(hires_flag.eq.1) then !if/then hires_georef ! Get projection information from finegrid netcdf file iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'false_easting', fe) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'false_northing', fn) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file end if !endif hires_georef iret = nf90_close(ncstatic) !-- create the fine grid routing file write(output_flnm, '(A12,".GW_SPINUP",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_gw_spinup() - Problem nf90_create") endif iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times) iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx) !--- define variables !- time definition, timeObs iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) !- x-coordinate in cartesian system iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection') iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate') iret = nf90_put_att(ncid, varid, 'units', 'Meter') !- y-coordinate in cartesian ssystem iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection') iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate') iret = nf90_put_att(ncid, varid, 'units', 'Meter') !- LATITUDE iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE') iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE') iret = nf90_put_att(ncid, varid, 'units', 'deg North') !- LONGITUDE iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE') iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE') iret = nf90_put_att(ncid, varid, 'units', 'deg east') iret = nf90_def_var(ncid, "GwHead", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'm') iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater head') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "GwConv", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater convergence') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "GwExcess", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'm') iret = nf90_put_att(ncid, varid, 'long_name', 'surface excess groundwater') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) !-- place projection information if(hires_flag.eq.1) then !if/then hires_georef iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid) iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm) iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po) iret = nf90_put_att(ncid, varid, 'false_easting', fe) iret = nf90_put_att(ncid, varid, 'false_northing', fn) iret = nf90_put_att(ncid, varid, 'standard_parallel', sp) end if !endif hires_georef ! iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid) date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(startdate)) = startdate convention(1:32) = "CF-1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation) iret = nf90_enddef(ncid) !!-- write latitude and longitude locations ! xdumd = LATVAL iret = nf90_inq_varid(ncid,"x", varid) ! iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array ! xdumd = LONVAL iret = nf90_inq_varid(ncid,"y", varid) ! iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array #ifdef MPP_LAND xdumd = gLATVAL #else xdumd = LATVAL #endif iret = nf90_inq_varid(ncid,"LATITUDE", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) #ifdef MPP_LAND xdumd = gLONVAL #else xdumd = LONVAL #endif iret = nf90_inq_varid(ncid,"LONGITUDE", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) endif output_count = output_count + 1 !!-- time iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/output_count/)) #ifdef MPP_LAND xdumd = gHead #else xdumd = head #endif iret = nf90_inq_varid(ncid, "GwHead", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND xdumd = gConvgw #else xdumd = convgw #endif iret = nf90_inq_varid(ncid, "GwConv", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND xdumd = gExcess #else xdumd = excess #endif iret = nf90_inq_varid(ncid, "GwExcess", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) !!time in seconds since startdate iret = nf90_redef(ncid) date19(1:len_trim(date)) = date iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_enddef(ncid) iret = nf90_sync(ncid) if (output_count == split_output_count) then output_count = 0 iret = nf90_close(ncid) endif if(allocated(xdumd)) deallocate(xdumd) if(allocated(xcoord_d)) deallocate(xcoord_d) if(allocated(xcoord)) deallocate(xcoord) if(allocated(ycoord_d)) deallocate(ycoord_d) if(allocated(ycoord)) deallocate(ycoord) #ifdef MPP_LAND endif #endif end subroutine output_gw_spinup subroutine sub_output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & startdate, date, HEAD, SMCRT, convgw, excess, qsgwrt, qgw_chanrt, & geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,output_gw) #ifdef MPP_LAND USE module_mpp_land #endif !output the routing variables over routing grid. implicit none integer, intent(in) :: igrid integer, intent(in) :: split_output_count integer, intent(in) :: ixrt,jxrt real, intent(in) :: dt real, intent(in) :: dist(ixrt,jxrt,9) integer, intent(in) :: nsoil integer, intent(in) :: output_gw character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date character(len=*), intent(in) :: geo_finegrid_flnm real, dimension(nsoil), intent(in) :: sldpth real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord integer, save :: ncid,ncstatic integer, save :: output_count real, dimension(nsoil) :: asldpth integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n integer :: iret, dimid_soil, i,j,ii,jj character(len=256) :: output_flnm character(len=19) :: date19 character(len=32) :: convention character(len=34) :: sec_since_date character(len=34) :: sec_valid_date character(len=30) :: soilm real :: long_cm,lat_po,fe,fn, chan_in real, dimension(2) :: sp real, dimension(ixrt,jxrt) :: head, convgw, excess, & qsgwrt, qgw_chanrt, & latval, lonval real, dimension(ixrt,jxrt,nsoil) :: SMCRT integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag #ifdef MPP_LAND real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gqsgwrt, gExcess, & gQgw_chanrt real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT #endif #ifdef MPP_LAND call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99) call MPP_LAND_COM_REAL(qsgwrt, ixrt, jxrt, 99) call MPP_LAND_COM_REAL(qgw_chanrt, ixrt, jxrt, 99) call write_IO_rt_real(latval,gLatval) call write_IO_rt_real(lonval,gLonval) call write_IO_rt_real(qsgwrt,gqsgwrt) call write_IO_rt_real(qgw_chanrt,gQgw_chanrt) call write_IO_rt_real(head,gHead) call write_IO_rt_real(convgw,gConvgw) call write_IO_rt_real(excess,gExcess) do i = 1, NSOIL call MPP_LAND_COM_REAL(smcrt(:,:,i), ixrt, jxrt, 99) call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i)) end do if(my_id.eq.IO_id) then #endif seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' decimation = 1 !-- decimation factor #ifdef MPP_LAND ixrtd = int(global_rt_nx/decimation) jxrtd = int(global_rt_ny/decimation) #else ixrtd = int(ixrt/decimation) jxrtd = int(jxrt/decimation) #endif allocate(xdumd(ixrtd,jxrtd)) allocate(xcoord_d(ixrtd)) allocate(ycoord_d(jxrtd)) allocate(xcoord(ixrtd)) allocate(ycoord(jxrtd)) ii = 0 jj = 0 if (output_gw.eq.0) return ! return if hires flag eq 0, if =1 output full grid if (output_count == 0) then !-- Open the finemesh static files to obtain projection information #ifdef HYDRO_D write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) #endif iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic) if (iret /= 0) then #ifdef HYDRO_D write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & trim(geo_finegrid_flnm) write(*,*) "HIRES_OUTPUT will not be georeferenced..." #endif hires_flag = 0 else hires_flag = 1 endif if(hires_flag.eq.1) then !if/then hires_georef ! Get Latitude (X) iret = NF90_INQ_VARID(ncstatic,'x',varid) if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord) ! Get Longitude (Y) iret = NF90_INQ_VARID(ncstatic,'y',varid) if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord) else xcoord_d = 0. ycoord_d = 0. end if !endif hires_georef do j=jxrtd,1,-1*decimation jj = jj+1 if (jj<= jxrtd) then ycoord_d(jj) = ycoord(j) endif enddo !yw do i = 1,ixrt,decimation !yw ii = ii + 1 !yw if (ii <= ixrtd) then !yw xcoord_d(ii) = xcoord(i) xcoord_d = xcoord !yw endif !yw enddo if(hires_flag.eq.1) then !if/then hires_georef ! Get projection information from finegrid netcdf file iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'false_easting', fe) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'false_northing', fn) !-- read it from the static file iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file end if !endif hires_georef iret = nf90_close(ncstatic) !-- create the fine grid routing file write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_gw_spinup() - Problem nf90_create") endif iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times) iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx) iret = nf90_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils !--- define variables !- time definition, timeObs iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) !- x-coordinate in cartesian system iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection') iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate') iret = nf90_put_att(ncid, varid, 'units', 'Meter') !- y-coordinate in cartesian ssystem iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection') iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate') iret = nf90_put_att(ncid, varid, 'units', 'Meter') !- LATITUDE iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE') iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE') iret = nf90_put_att(ncid, varid, 'units', 'deg North') !- LONGITUDE iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE') iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE') iret = nf90_put_att(ncid, varid, 'units', 'deg east') !-- z-level is soil iret = nf90_def_var(ncid, "depth", NF90_FLOAT, (/dimid_soil/), varid) iret = nf90_put_att(ncid, varid, 'units', 'cm') iret = nf90_put_att(ncid, varid, 'long_name', 'depth of soil layer') iret = nf90_def_var(ncid, "SOIL_M", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'kg m-2') iret = nf90_put_att(ncid, varid, 'description', 'moisture content') iret = nf90_put_att(ncid, varid, 'long_name', soilm) ! iret = nf90_put_att(ncid, varid, 'coordinates', 'x y z') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "HEAD", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'm') iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater head') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "CONVGW", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') iret = nf90_put_att(ncid, varid, 'long_name', 'channel flux') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "GwExcess", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') iret = nf90_put_att(ncid, varid, 'long_name', 'surface excess groundwater') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "QSGWRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') iret = nf90_put_att(ncid, varid, 'long_name', 'surface head') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "QGW_CHANRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid) iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1') iret = nf90_put_att(ncid, varid, 'long_name', 'surface head') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) !-- place projection information if(hires_flag.eq.1) then !if/then hires_georef iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid) iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm) iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po) iret = nf90_put_att(ncid, varid, 'false_easting', fe) iret = nf90_put_att(ncid, varid, 'false_northing', fn) iret = nf90_put_att(ncid, varid, 'standard_parallel', sp) end if !endif hires_georef ! iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid) date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(startdate)) = startdate convention(1:32) = "CF-1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation) iret = nf90_enddef(ncid) !!-- write latitude and longitude locations ! xdumd = LATVAL iret = nf90_inq_varid(ncid,"x", varid) ! iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array ! xdumd = LONVAL iret = nf90_inq_varid(ncid,"y", varid) ! iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array #ifdef MPP_LAND xdumd = gLATVAL #else xdumd = LATVAL #endif iret = nf90_inq_varid(ncid,"LATITUDE", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) #ifdef MPP_LAND xdumd = gLONVAL #else xdumd = LONVAL #endif iret = nf90_inq_varid(ncid,"LONGITUDE", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/)) do n = 1,nsoil if(n == 1) then asldpth(n) = -sldpth(n) else asldpth(n) = asldpth(n-1) - sldpth(n) endif enddo iret = nf90_inq_varid(ncid,"depth", varid) iret = nf90_put_var(ncid, varid, asldpth, (/1/), (/nsoil/)) !yw iret = nf90_close(ncstatic) endif output_count = output_count + 1 !!-- time iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/output_count/)) !-- 3-d soils do n = 1, nsoil #ifdef MPP_LAND xdumd = gSMCRT(:,:,n) #else xdumd = SMCRT(:,:,n) #endif ! !DJG inv jj = int(jxrt/decimation) ! jj = 1 ! ii = 0 ! !DJG inv do j = jxrt,1,-decimation ! do j = 1,jxrt,decimation ! do i = 1,ixrt,decimation ! ii = ii + 1 ! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then ! xdumd(ii,jj) = smcrt(i,j,n) ! endif ! enddo ! ii = 0 ! !DJG inv jj = jj -1 ! jj = jj + 1 ! enddo ! where (vegtyp(:,:) == 16) xdum = -1.E33 iret = nf90_inq_varid(ncid, "SOIL_M", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/)) enddo !-n soils #ifdef MPP_LAND xdumd = gHead #else xdumd = head #endif iret = nf90_inq_varid(ncid, "HEAD", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND xdumd = gConvgw #else xdumd = convgw #endif iret = nf90_inq_varid(ncid, "CONVGW", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND xdumd = gExcess #else xdumd = excess #endif iret = nf90_inq_varid(ncid, "GwExcess", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND xdumd = gqsgwrt #else xdumd = qsgwrt #endif iret = nf90_inq_varid(ncid, "QSGWRT", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) #ifdef MPP_LAND xdumd = gQgw_chanrt #else xdumd = qgw_chanrt #endif iret = nf90_inq_varid(ncid, "QGW_CHANRT", varid) iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/)) !!time in seconds since startdate iret = nf90_redef(ncid) date19(1:len_trim(date)) = date iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_enddef(ncid) iret = nf90_sync(ncid) if (output_count == split_output_count) then output_count = 0 iret = nf90_close(ncid) endif if(allocated(xdumd)) deallocate(xdumd) if(allocated(xcoord_d)) deallocate(xcoord_d) if(allocated(xcoord)) deallocate(xcoord) if(allocated(ycoord_d)) deallocate(ycoord_d) if(allocated(ycoord)) deallocate(ycoord) #ifdef HYDRO_D write(6,*) "end of output_ge" #endif #ifdef MPP_LAND endif #endif end subroutine sub_output_gw !NOte: output_chrt is the old version comparing to "output_chrt_bak". subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & lsmDt & #ifdef WRF_HYDRO_NUDGING , nudge & #endif , accSfcLatRunoff, accBucket & , qSfcLatRunoff, qBucket, qBtmVertRunoff & , UDMP_OPT & ) implicit none !!output the routing variables over just channel integer, intent(in) :: igrid,K,channel_option integer, intent(in) :: split_output_count integer, intent(in) :: NLINKS, NLINKSL real, dimension(:), intent(in) :: chlon,chlat real, dimension(:), intent(in) :: hlink,zelev integer, dimension(:), intent(in) :: ORDER integer, dimension(:), intent(inout) :: STRMFRXSTPTS character(len=15), dimension(:), intent(inout) :: gages character(len=15), intent(in) :: gageMiss real, intent(in) :: lsmDt real, intent(in) :: dtrt_ch real, dimension(:,:), intent(in) :: qlink #ifdef WRF_HYDRO_NUDGING real, dimension(:), intent(in) :: nudge #endif integer, intent(in) :: UDMP_OPT character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date real, allocatable, DIMENSION(:) :: chanlat,chanlon real, allocatable, DIMENSION(:) :: chanlatO,chanlonO real, allocatable, DIMENSION(:) :: elevation real, allocatable, DIMENSION(:) :: elevationO integer, allocatable, DIMENSION(:) :: station_id integer, allocatable, DIMENSION(:) :: station_idO integer, allocatable, DIMENSION(:) :: rec_num_of_station integer, allocatable, DIMENSION(:) :: rec_num_of_stationO integer, allocatable, DIMENSION(:) :: lOrder !- local stream order integer, allocatable, DIMENSION(:) :: lOrderO !- local stream order integer, save :: output_count integer, save :: ncid,ncid2 integer :: stationdim, dimdata, varid, charid, n integer :: obsdim, dimdataO, charidO integer :: timedim, timedim2 character(len=34) :: sec_valid_date integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output integer :: start_posO, prev_posO, nlk integer :: previous_pos !-- used for the station model character(len=256) :: output_flnm,output_flnm2 character(len=19) :: date19,date19start, hydroTime character(len=34) :: sec_since_date integer :: seconds_since,nstations,cnt,ObsStation,nobs character(len=32) :: convention character(len=11),allocatable, DIMENSION(:) :: stname character(len=15),allocatable, DIMENSION(:) :: stnameO !--- all this for writing the station id string INTEGER TDIMS, TXLEN PARAMETER (TDIMS=2) ! number of TX dimensions PARAMETER (TXLEN = 11) ! length of example string INTEGER TIMEID ! record dimension id INTEGER TXID ! variable ID INTEGER TXDIMS(TDIMS) ! variable shape INTEGER TSTART(TDIMS), TCOUNT(TDIMS) !-- observation point ids INTEGER OTDIMS, OTXLEN PARAMETER (OTDIMS=2) ! number of TX dimensions PARAMETER (OTXLEN = 15) ! length of example string INTEGER OTIMEID ! record dimension id INTEGER OTXID ! variable ID INTEGER OTXDIMS(OTDIMS) ! variable shape INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket real, dimension(:), intent(in) :: qSfcLatRunoff, qBucket, qBtmVertRunoff !! currently, this is the time of the hydro model, it's !! lsm time (olddate) plus one lsm timestep !call geth_newdate(hydroTime, date, nint(lsmDt)) hydroTime=date seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' ! order_to_write = 2 !-- 1 all; 6 fewest nstations = 0 ! total number of channel points to display nobs = 0 ! number of observation points if(channel_option .ne. 3) then nlk = NLINKSL else nlk = NLINKS endif !-- output only the higher oder streamflows and only observation points do i=1,nlk if(ORDER(i) .ge. order_to_write) nstations = nstations + 1 if(channel_option .ne. 3) then if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1 else if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1 endif enddo if (nobs .eq. 0) then ! let's at least make one obs point nobs = 1 if(channel_option .ne. 3) then ! 123456789012345 gages(1) = ' dummy' else STRMFRXSTPTS(1) = 1 endif endif allocate(chanlat(nstations)) allocate(chanlon(nstations)) allocate(elevation(nstations)) allocate(lOrder(nstations)) allocate(stname(nstations)) allocate(station_id(nstations)) allocate(rec_num_of_station(nstations)) allocate(chanlatO(nobs)) allocate(chanlonO(nobs)) allocate(elevationO(nobs)) allocate(lOrderO(nobs)) allocate(stnameO(nobs)) allocate(station_idO(nobs)) allocate(rec_num_of_stationO(nobs)) if(output_count == 0) then !-- have moved sec_since_date from above here.. sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & //startdate(12:13)//':'//startdate(15:16)//':00' nstations = 0 nobs = 0 write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create points") endif iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create observation") endif do i=1,nlk if(ORDER(i) .ge. order_to_write) then nstations = nstations + 1 chanlat(nstations) = chlat(i) chanlon(nstations) = chlon(i) elevation(nstations) = zelev(i) lOrder(nstations) = ORDER(i) station_id(nstations) = i if(STRMFRXSTPTS(nstations) .eq. -9999) then ObsStation = 0 else ObsStation = 1 endif write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation endif enddo do i=1,nlk if(channel_option .ne. 3) then if(trim(gages(i)) .ne. trim(gageMiss)) then nobs = nobs + 1 chanlatO(nobs) = chlat(i) chanlonO(nobs) = chlon(i) elevationO(nobs) = zelev(i) lOrderO(nobs) = ORDER(i) station_idO(nobs) = i stnameO(nobs) = gages(i) endif else if(STRMFRXSTPTS(i) .ne. -9999) then nobs = nobs + 1 chanlatO(nobs) = chlat(i) chanlonO(nobs) = chlon(i) elevationO(nobs) = zelev(i) lOrderO(nobs) = ORDER(i) station_idO(nobs) = i write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) #ifdef HYDRO_D ! print *,"stationobservation name", stnameO(nobs) #endif endif endif enddo iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata) !--for linked list approach iret = nf90_def_dim(ncid, "station", nstations, stationdim) iret = nf90_def_dim(ncid, "time", 1, timedim) iret = nf90_def_dim(ncid2, "recNum", NF90_UNLIMITED, dimdataO) !--for linked list approach iret = nf90_def_dim(ncid2, "station", nobs, obsdim) iret = nf90_def_dim(ncid2, "time", 1, timedim2) !- station location definition all, lat iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid) #ifdef HYDRO_D write(6,*) "iret 2.1, ", iret, stationdim #endif iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude') #ifdef HYDRO_D write(6,*) "iret 2.2", iret #endif iret = nf90_put_att(ncid, varid, 'units', 'degrees_north') #ifdef HYDRO_D write(6,*) "iret 2.3", iret #endif !- station location definition obs, lat iret = nf90_def_var(ncid2, "latitude", NF90_FLOAT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation latitude') iret = nf90_put_att(ncid2, varid, 'units', 'degrees_north') !- station location definition, long iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_east') !- station location definition, obs long iret = nf90_def_var(ncid2, "longitude", NF90_FLOAT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation longitude') iret = nf90_put_att(ncid2, varid, 'units', 'degrees_east') ! !-- elevation is ZELEV iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude') iret = nf90_put_att(ncid, varid, 'units', 'meters') ! !-- elevation is obs ZELEV iret = nf90_def_var(ncid2, "altitude", NF90_FLOAT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation altitude') iret = nf90_put_att(ncid2, varid, 'units', 'meters') ! !-- gage observation ! iret = nf90_def_var(ncid, "gages", NF90_FLOAT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'Stream Gage Location') ! iret = nf90_put_att(ncid, varid, 'units', 'none') !-- parent index iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record') iret = nf90_def_var(ncid2, "parent_index", NF90_INT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'index of the station for this record') !-- prevChild iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station') !ywtmp iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_def_var(ncid2, "prevChild", NF90_INT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'record number of the previous record for the same station') !ywtmp iret = nf90_put_att(ncid2, varid, '_FillValue', -1) iret = nf90_put_att(ncid2, varid, '_FillValue', -1) !-- lastChild iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station') !ywtmp iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_def_var(ncid2, "lastChild", NF90_INT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'latest report for this station') !ywtmp iret = nf90_put_att(ncid2, varid, '_FillValue', -1) iret = nf90_put_att(ncid2, varid, '_FillValue', -1) ! !- flow definition, var if(UDMP_OPT .eq. 1) then !! FLUXES to channel if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') if(nlst(did)%OVRTSWCRT .eq. 1) then !123456789112345678921234567 iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing') else iret = nf90_put_att(ncid, varid, 'long_name', 'runoff') end if iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket') end if !! Bucket influx if(nlst(did)%output_channelBucket_influx .eq. 2) then iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket') end if !! ACCUMULATIONS if(nlst(did)%output_channelBucket_influx .eq. 3) then iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3') if(nlst(did)%OVRTSWCRT .eq. 1) then iret = nf90_put_att(ncid,varid,'long_name',& 'ACCUMULATED runoff from terrain routing') else iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land') end if iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3') iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from gw bucket') endif endif iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow') iret = nf90_def_var(ncid2, "streamflow", NF90_FLOAT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid2, varid, 'long_name', 'River Flow') #ifdef WRF_HYDRO_NUDGING iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration') iret = nf90_def_var(ncid2, "nudge", NF90_FLOAT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid2, varid, 'long_name', 'Amount of stream flow alteration') #endif ! !- flow definition, var ! iret = nf90_def_var(ncid, "pos_streamflow", NF90_FLOAT, (/dimdata/), varid) ! iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') ! iret = nf90_put_att(ncid, varid, 'long_name', 'abs streamflow') ! !- head definition, var iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter') iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage') iret = nf90_def_var(ncid2, "head", NF90_FLOAT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'units', 'meter') iret = nf90_put_att(ncid2, varid, 'long_name', 'River Stage') ! !- order definition, var iret = nf90_def_var(ncid, "order", NF90_INT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order') iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_def_var(ncid2, "order", NF90_INT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Strahler Stream Order') iret = nf90_put_att(ncid, varid, '_FillValue', -1) !-- station id ! define character-position dimension for strings of max length 11 iret = NF90_DEF_DIM(ncid, "id_len", 11, charid) TXDIMS(1) = charid ! define char-string variable and position dimension first TXDIMS(2) = stationdim iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station id') iret = NF90_DEF_DIM(ncid2, "id_len", 15, charidO) OTXDIMS(1) = charidO ! define char-string variable and position dimension first OTXDIMS(2) = obsdim iret = nf90_def_var(ncid2, "station_id", NF90_CHAR, OTXDIMS, varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation id') ! !- time definition, timeObs iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') iret = nf90_def_var(ncid2, "time", NF90_INT, (/timedim2/), varid) iret = nf90_put_att(ncid2, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid2, varid, 'long_name', 'valid output time') iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention) convention(1:32) = "Unidata Observation Dataset v1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station") iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", order_to_write) iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid2, NF90_GLOBAL, "cdm_datatype", "Station") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_max", "90.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_min", "-90.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_max", "180.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_min", "-180.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid2, NF90_GLOBAL, "station_dimension", "station") iret = nf90_put_att(ncid2, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid2, NF90_GLOBAL, "stream_order_output", order_to_write) iret = nf90_enddef(ncid) iret = nf90_enddef(ncid2) !-- write latitudes iret = nf90_inq_varid(ncid,"latitude", varid) iret = nf90_put_var(ncid, varid, chanlat, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid2,"latitude", varid) iret = nf90_put_var(ncid2, varid, chanlatO, (/1/), (/nobs/)) !-- write longitudes iret = nf90_inq_varid(ncid,"longitude", varid) iret = nf90_put_var(ncid, varid, chanlon, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid2,"longitude", varid) iret = nf90_put_var(ncid2, varid, chanlonO, (/1/), (/nobs/)) !-- write elevations iret = nf90_inq_varid(ncid,"altitude", varid) iret = nf90_put_var(ncid, varid, elevation, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid2,"altitude", varid) iret = nf90_put_var(ncid2, varid, elevationO, (/1/), (/nobs/)) !-- write gage location ! iret = nf90_inq_varid(ncid,"gages", varid) ! iret = nf90_put_var(ncid, varid, STRMFRXSTPTS, (/1/), (/nstations/)) !-- write number_of_stations, OPTIONAL !! iret = nf90_inq_varid(ncid,"number_stations", varid) !! iret = nf90_put_var_int(ncid, varid, nstations) !-- write station id's do i=1,nstations TSTART(1) = 1 TSTART(2) = i TCOUNT(1) = TXLEN TCOUNT(2) = 1 iret = nf90_inq_varid(ncid,"station_id", varid) iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT) enddo !-- write observation id's do i=1, nobs OTSTART(1) = 1 OTSTART(2) = i OTCOUNT(1) = OTXLEN OTCOUNT(2) = 1 iret = nf90_inq_varid(ncid2,"station_id", varid) iret = nf90_put_var(ncid2, varid, stnameO(i), OTSTART, OTCOUNT) enddo endif output_count = output_count + 1 open (unit=55, & #ifndef NCEP_WCOSS file='frxst_pts_out.txt', & #endif status='unknown',position='append') cnt=0 do i=1,nlk if(ORDER(i) .ge. order_to_write) then start_pos = (cnt+1)+(nstations*(output_count-1)) !!--time in seconds since startdate iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) if(UDMP_OPT .eq. 1) then !! FLUXES to channel if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid) iret = nf90_put_var(ncid, varid, qSfcLatRunoff(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"qBucket", varid) iret = nf90_put_var(ncid, varid, qBucket(i), (/start_pos/)) end if !! FLUXES to bucket if(nlst(did)%output_channelBucket_influx .eq. 2) then iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid) iret = nf90_put_var(ncid, varid, qBtmVertRunoff(i), (/start_pos/)) end if !! ACCUMULATIONS if(nlst(did)%output_channelBucket_influx .eq. 3) then iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid) iret = nf90_put_var(ncid, varid, accSfcLatRunoff(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"accBucket", varid) iret = nf90_put_var(ncid, varid, accBucket(i), (/start_pos/)) end if endif iret = nf90_inq_varid(ncid,"streamflow", varid) iret = nf90_put_var(ncid, varid, qlink(i,1), (/start_pos/)) #ifdef WRF_HYDRO_NUDGING iret = nf90_inq_varid(ncid,"nudge", varid) iret = nf90_put_var(ncid, varid, nudge(i), (/start_pos/)) #endif ! iret = nf90_inq_varid(ncid,"pos_streamflow", varid) ! iret = nf90_put_var(ncid, varid, abs(qlink(i,1), (/start_pos/))) iret = nf90_inq_varid(ncid,"head", varid) iret = nf90_put_var(ncid, varid, hlink(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"order", varid) iret = nf90_put_var(ncid, varid, ORDER(i), (/start_pos/)) !-- station index.. will repeat for every timesstep iret = nf90_inq_varid(ncid,"parent_index", varid) iret = nf90_put_var(ncid, varid, cnt, (/start_pos/)) !--record number of previous record for same station !obsolete format prev_pos = cnt+(nstations*(output_count-1)) prev_pos = cnt+(nobs*(output_count-2)) if(output_count.ne.1) then !-- only write next set of records iret = nf90_inq_varid(ncid,"prevChild", varid) iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/)) endif cnt=cnt+1 !--indices are 0 based rec_num_of_station(cnt) = start_pos-1 !-- save position for last child, 0-based!! endif enddo ! close(999) !-- output only observation points cnt=0 do i=1,nlk if(channel_option .ne. 3) then ! jlm this verry repetitiuos, oh well. if(trim(gages(i)) .ne. trim(gageMiss)) then start_posO = (cnt+1)+(nobs * (output_count-1)) !Write frxst_pts to text file... !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & 118 FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) !write(55,118) seconds_since, date(1:10), date(12:19), & write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), & gages(i), chlon(i), chlat(i), & qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) !yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) !!--time in seconds since startdate iret = nf90_inq_varid(ncid2,"time", varid) iret = nf90_put_var(ncid2, varid, seconds_since, (/1/)) iret = nf90_inq_varid(ncid2,"streamflow", varid) iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/)) #ifdef WRF_HYDRO_NUDGING iret = nf90_inq_varid(ncid2,"nudge", varid) iret = nf90_put_var(ncid2, varid, nudge(i), (/start_posO/)) #endif iret = nf90_inq_varid(ncid2,"head", varid) iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/)) iret = nf90_inq_varid(ncid,"order", varid) iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/)) !-- station index.. will repeat for every timesstep iret = nf90_inq_varid(ncid2,"parent_index", varid) iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/)) !--record number of previous record for same station !obsolete format prev_posO = cnt+(nobs*(output_count-1)) prev_posO = cnt+(nobs*(output_count-2)) if(output_count.ne.1) then !-- only write next set of records iret = nf90_inq_varid(ncid2,"prevChild", varid) iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) !IF block to add -1 to last element of prevChild array to designate end of list... ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then ! iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) ! else ! iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) ! endif endif cnt=cnt+1 !--indices are 0 based rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! endif else !! channel options 3 below if(STRMFRXSTPTS(i) .ne. -9999) then start_posO = (cnt+1)+(nobs * (output_count-1)) !Write frxst_pts to text file... !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & 117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & ! qlink(i,1), qlink(i,1)*35.315,hlink(i) ! JLM: makes more sense to output the value in frxstpts incase they have meaning, ! as below, but I'm not going to make this change until I'm working with gridded ! streamflow again. write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), & strmfrxstpts(i), chlon(i), chlat(i), & qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) !!--time in seconds since startdate iret = nf90_inq_varid(ncid2,"time", varid) iret = nf90_put_var(ncid2, varid, seconds_since, (/1/)) iret = nf90_inq_varid(ncid2,"streamflow", varid) iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/)) iret = nf90_inq_varid(ncid2,"head", varid) iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/)) iret = nf90_inq_varid(ncid,"order", varid) iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/)) !-- station index.. will repeat for every timesstep iret = nf90_inq_varid(ncid2,"parent_index", varid) iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/)) !--record number of previous record for same station !obsolete format prev_posO = cnt+(nobs*(output_count-1)) prev_posO = cnt+(nobs*(output_count-2)) if(output_count.ne.1) then !-- only write next set of records iret = nf90_inq_varid(ncid2,"prevChild", varid) iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) !IF block to add -1 to last element of prevChild array to designate end of list... ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then ! iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) ! else ! iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) ! endif endif cnt=cnt+1 !--indices are 0 based rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! endif endif enddo close(55) !-- lastChild variable gives the record number of the most recent report for the station iret = nf90_inq_varid(ncid,"lastChild", varid) iret = nf90_put_var(ncid, varid, rec_num_of_station, (/1/), (/nstations/)) !-- lastChild variable gives the record number of the most recent report for the station iret = nf90_inq_varid(ncid2,"lastChild", varid) iret = nf90_put_var(ncid2, varid, rec_num_of_stationO, (/1/), (/nobs/)) iret = nf90_redef(ncid) date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(date)) = date iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_redef(ncid2) iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_enddef(ncid) iret = nf90_sync(ncid) iret = nf90_enddef(ncid2) iret = nf90_sync(ncid2) if (output_count == split_output_count) then output_count = 0 iret = nf90_close(ncid) iret = nf90_close(ncid2) endif deallocate(chanlat) deallocate(chanlon) deallocate(elevation) deallocate(station_id) deallocate(lOrder) deallocate(rec_num_of_station) deallocate(stname) deallocate(chanlatO) deallocate(chanlonO) deallocate(elevationO) deallocate(station_idO) deallocate(lOrderO) deallocate(rec_num_of_stationO) deallocate(stnameO) #ifdef HYDRO_D print *, "Exited Subroutine output_chrt" #endif close(16) 20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3) end subroutine output_chrt !-- output the channel route in an IDV 'station' compatible format !Note: This version has pool output performance need to be !solved. We renamed it from output_chrt to be output_chrt_bak. subroutine output_chrt_bak(igrid, split_output_count, NLINKS, ORDER, & startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & lsmDt & #ifdef WRF_HYDRO_NUDGING , nudge & #endif , accSfcLatRunoff, accBucket & , qSfcLatRunoff, qBucket, qBtmVertRunoff & , UDMP_OPT & ) implicit none !!output the routing variables over just channel integer, intent(in) :: igrid,K,channel_option integer, intent(in) :: split_output_count integer, intent(in) :: NLINKS, NLINKSL real, dimension(:), intent(in) :: chlon,chlat real, dimension(:), intent(in) :: hlink,zelev integer, dimension(:), intent(in) :: ORDER integer, dimension(:), intent(inout) :: STRMFRXSTPTS character(len=15), dimension(:), intent(inout) :: gages character(len=15), intent(in) :: gageMiss real, intent(in) :: lsmDt real, intent(in) :: dtrt_ch real, dimension(:,:), intent(in) :: qlink #ifdef WRF_HYDRO_NUDGING real, dimension(:), intent(in) :: nudge #endif integer, intent(in) :: UDMP_OPT character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date real, allocatable, DIMENSION(:) :: chanlat,chanlon real, allocatable, DIMENSION(:) :: chanlatO,chanlonO real, allocatable, DIMENSION(:) :: elevation real, allocatable, DIMENSION(:) :: elevationO integer, allocatable, DIMENSION(:) :: station_id integer, allocatable, DIMENSION(:) :: station_idO integer, allocatable, DIMENSION(:) :: rec_num_of_station integer, allocatable, DIMENSION(:) :: rec_num_of_stationO integer, allocatable, DIMENSION(:) :: lOrder !- local stream order integer, allocatable, DIMENSION(:) :: lOrderO !- local stream order integer, save :: output_count integer, save :: ncid,ncid2 integer :: stationdim, dimdata, varid, charid, n integer :: obsdim, dimdataO, charidO integer :: timedim, timedim2 character(len=34) :: sec_valid_date integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output integer :: start_posO, prev_posO, nlk integer :: previous_pos !-- used for the station model character(len=256) :: output_flnm,output_flnm2 character(len=19) :: date19,date19start, hydroTime character(len=34) :: sec_since_date integer :: seconds_since,nstations,cnt,ObsStation,nobs character(len=32) :: convention character(len=11),allocatable, DIMENSION(:) :: stname character(len=15),allocatable, DIMENSION(:) :: stnameO !--- all this for writing the station id string INTEGER TDIMS, TXLEN PARAMETER (TDIMS=2) ! number of TX dimensions PARAMETER (TXLEN = 11) ! length of example string INTEGER TIMEID ! record dimension id INTEGER TXID ! variable ID INTEGER TXDIMS(TDIMS) ! variable shape INTEGER TSTART(TDIMS), TCOUNT(TDIMS) !-- observation point ids INTEGER OTDIMS, OTXLEN PARAMETER (OTDIMS=2) ! number of TX dimensions PARAMETER (OTXLEN = 15) ! length of example string INTEGER OTIMEID ! record dimension id INTEGER OTXID ! variable ID INTEGER OTXDIMS(OTDIMS) ! variable shape INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket real, dimension(:), intent(in) :: qSfcLatRunoff, qBucket, qBtmVertRunoff !! currently, this is the time of the hydro model, it's !! lsm time (olddate) plus one lsm timestep !call geth_newdate(hydroTime, date, nint(lsmDt)) hydroTime=date seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' ! order_to_write = 2 !-- 1 all; 6 fewest nstations = 0 ! total number of channel points to display nobs = 0 ! number of observation points if(channel_option .ne. 3) then nlk = NLINKSL else nlk = NLINKS endif !-- output only the higher oder streamflows and only observation points do i=1,nlk if(ORDER(i) .ge. order_to_write) nstations = nstations + 1 if(channel_option .ne. 3) then if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1 else if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1 endif enddo if (nobs .eq. 0) then ! let's at least make one obs point nobs = 1 if(channel_option .ne. 3) then ! 123456789012345 gages(1) = ' dummy' else STRMFRXSTPTS(1) = 1 endif endif allocate(chanlat(nstations)) allocate(chanlon(nstations)) allocate(elevation(nstations)) allocate(lOrder(nstations)) allocate(stname(nstations)) allocate(station_id(nstations)) allocate(rec_num_of_station(nstations)) allocate(chanlatO(nobs)) allocate(chanlonO(nobs)) allocate(elevationO(nobs)) allocate(lOrderO(nobs)) allocate(stnameO(nobs)) allocate(station_idO(nobs)) allocate(rec_num_of_stationO(nobs)) if(output_count == 0) then !-- have moved sec_since_date from above here.. sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & //startdate(12:13)//':'//startdate(15:16)//':00' nstations = 0 nobs = 0 write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create points") endif iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2) if (iret /= 0) then call hydro_stop("In output_chrt() - Problem nf90_create observation") endif do i=1,nlk if(ORDER(i) .ge. order_to_write) then nstations = nstations + 1 chanlat(nstations) = chlat(i) chanlon(nstations) = chlon(i) elevation(nstations) = zelev(i) lOrder(nstations) = ORDER(i) station_id(nstations) = i if(STRMFRXSTPTS(nstations) .eq. -9999) then ObsStation = 0 else ObsStation = 1 endif write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation endif enddo do i=1,nlk if(channel_option .ne. 3) then if(trim(gages(i)) .ne. trim(gageMiss)) then nobs = nobs + 1 chanlatO(nobs) = chlat(i) chanlonO(nobs) = chlon(i) elevationO(nobs) = zelev(i) lOrderO(nobs) = ORDER(i) station_idO(nobs) = i stnameO(nobs) = gages(i) endif else if(STRMFRXSTPTS(i) .ne. -9999) then nobs = nobs + 1 chanlatO(nobs) = chlat(i) chanlonO(nobs) = chlon(i) elevationO(nobs) = zelev(i) lOrderO(nobs) = ORDER(i) station_idO(nobs) = i write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) #ifdef HYDRO_D ! print *,"stationobservation name", stnameO(nobs) #endif endif endif enddo iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata) !--for linked list approach iret = nf90_def_dim(ncid, "station", nstations, stationdim) iret = nf90_def_dim(ncid, "time", 1, timedim) iret = nf90_def_dim(ncid2, "recNum", NF90_UNLIMITED, dimdataO) !--for linked list approach iret = nf90_def_dim(ncid2, "station", nobs, obsdim) iret = nf90_def_dim(ncid2, "time", 1, timedim2) !- station location definition all, lat iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_north') !- station location definition obs, lat iret = nf90_def_var(ncid2, "latitude", NF90_FLOAT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation latitude') iret = nf90_put_att(ncid2, varid, 'units', 'degrees_north') !- station location definition, long iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_east') !- station location definition, obs long iret = nf90_def_var(ncid2, "longitude", NF90_FLOAT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation longitude') iret = nf90_put_att(ncid2, varid, 'units', 'degrees_east') ! !-- elevation is ZELEV iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude') iret = nf90_put_att(ncid, varid, 'units', 'meters') ! !-- elevation is obs ZELEV iret = nf90_def_var(ncid2, "altitude", NF90_FLOAT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation altitude') iret = nf90_put_att(ncid2, varid, 'units', 'meters') ! !-- gage observation ! iret = nf90_def_var(ncid, "gages", NF90_FLOAT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'Stream Gage Location') ! iret = nf90_put_att(ncid, varid, 'units', 'none') !-- parent index iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record') iret = nf90_def_var(ncid2, "parent_index", NF90_INT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'index of the station for this record') !-- prevChild iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station') !ywtmp iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_def_var(ncid2, "prevChild", NF90_INT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'record number of the previous record for the same station') !ywtmp iret = nf90_put_att(ncid2, varid, '_FillValue', -1) iret = nf90_put_att(ncid2, varid, '_FillValue', -1) !-- lastChild iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station') !ywtmp iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_def_var(ncid2, "lastChild", NF90_INT, (/obsdim/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'latest report for this station') !ywtmp iret = nf90_put_att(ncid2, varid, '_FillValue', -1) iret = nf90_put_att(ncid2, varid, '_FillValue', -1) ! !- flow definition, var if(UDMP_OPT .eq. 1) then !! FLUXES to channel if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') if(nlst(did)%OVRTSWCRT .eq. 1) then !123456789112345678921234567 iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing') else iret = nf90_put_att(ncid, varid, 'long_name', 'runoff') end if iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket') end if !! Bucket influx if(nlst(did)%output_channelBucket_influx .eq. 2) then iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket') end if !! ACCUMULATIONS if(nlst(did)%output_channelBucket_influx .eq. 3) then iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3') if(nlst(did)%OVRTSWCRT .eq. 1) then iret = nf90_put_att(ncid,varid,'long_name', & 'ACCUMULATED runoff from terrain routing') else iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land') end if iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3') iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from gw bucket') endif endif iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow') iret = nf90_def_var(ncid2, "streamflow", NF90_FLOAT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid2, varid, 'long_name', 'River Flow') #ifdef WRF_HYDRO_NUDGING iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration') iret = nf90_def_var(ncid2, "nudge", NF90_FLOAT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid2, varid, 'long_name', 'Amount of stream flow alteration') #endif ! !- flow definition, var ! iret = nf90_def_var(ncid, "pos_streamflow", NF90_FLOAT, (/dimdata/), varid) ! iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') ! iret = nf90_put_att(ncid, varid, 'long_name', 'abs streamflow') ! !- head definition, var iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter') iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage') iret = nf90_def_var(ncid2, "head", NF90_FLOAT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'units', 'meter') iret = nf90_put_att(ncid2, varid, 'long_name', 'River Stage') ! !- order definition, var iret = nf90_def_var(ncid, "order", NF90_INT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order') iret = nf90_put_att(ncid, varid, '_FillValue', -1) iret = nf90_def_var(ncid2, "order", NF90_INT, (/dimdataO/), varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Strahler Stream Order') iret = nf90_put_att(ncid, varid, '_FillValue', -1) !-- station id ! define character-position dimension for strings of max length 11 iret = NF90_DEF_DIM(ncid, "id_len", 11, charid) TXDIMS(1) = charid ! define char-string variable and position dimension first TXDIMS(2) = stationdim iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station id') iret = NF90_DEF_DIM(ncid2, "id_len", 15, charidO) OTXDIMS(1) = charidO ! define char-string variable and position dimension first OTXDIMS(2) = obsdim iret = nf90_def_var(ncid2, "station_id", NF90_CHAR, OTXDIMS, varid) iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation id') ! !- time definition, timeObs iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') iret = nf90_def_var(ncid2, "time", NF90_INT, (/timedim2/), varid) iret = nf90_put_att(ncid2, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid2, varid, 'long_name', 'valid output time') iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention) convention(1:32) = "Unidata Observation Dataset v1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station") iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", order_to_write) iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid2, NF90_GLOBAL, "cdm_datatype", "Station") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_max", "90.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_min", "-90.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_max", "180.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_min", "-180.0") iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid2, NF90_GLOBAL, "station_dimension", "station") iret = nf90_put_att(ncid2, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid2, NF90_GLOBAL, "stream_order_output", order_to_write) iret = nf90_enddef(ncid) iret = nf90_enddef(ncid2) !-- write latitudes iret = nf90_inq_varid(ncid,"latitude", varid) iret = nf90_put_var(ncid, varid, chanlat, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid2,"latitude", varid) iret = nf90_put_var(ncid2, varid, chanlatO, (/1/), (/nobs/)) !-- write longitudes iret = nf90_inq_varid(ncid,"longitude", varid) iret = nf90_put_var(ncid, varid, chanlon, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid2,"longitude", varid) iret = nf90_put_var(ncid2, varid, chanlonO, (/1/), (/nobs/)) !-- write elevations iret = nf90_inq_varid(ncid,"altitude", varid) iret = nf90_put_var(ncid, varid, elevation, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid2,"altitude", varid) iret = nf90_put_var(ncid2, varid, elevationO, (/1/), (/nobs/)) !-- write gage location ! iret = nf90_inq_varid(ncid,"gages", varid) ! iret = nf90_put_var(ncid, varid, STRMFRXSTPTS, (/1/), (/nstations/)) !-- write number_of_stations, OPTIONAL !! iret = nf90_inq_varid(ncid,"number_stations", varid) !! iret = nf90_put_var_int(ncid, varid, nstations) !-- write station id's do i=1,nstations TSTART(1) = 1 TSTART(2) = i TCOUNT(1) = TXLEN TCOUNT(2) = 1 iret = nf90_inq_varid(ncid,"station_id", varid) iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT) enddo !-- write observation id's do i=1, nobs OTSTART(1) = 1 OTSTART(2) = i OTCOUNT(1) = OTXLEN OTCOUNT(2) = 1 iret = nf90_inq_varid(ncid2,"station_id", varid) iret = nf90_put_var(ncid2, varid, stnameO(i), OTSTART, OTCOUNT) enddo endif output_count = output_count + 1 open (unit=55, & #ifndef NCEP_WCOSS file='frxst_pts_out.txt', & #endif status='unknown',position='append') cnt=0 do i=1,nlk if(ORDER(i) .ge. order_to_write) then start_pos = (cnt+1)+(nstations*(output_count-1)) !!--time in seconds since startdate iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) if(UDMP_OPT .eq. 1) then !! FLUXES to channel if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid) iret = nf90_put_var(ncid, varid, qSfcLatRunoff(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"qBucket", varid) iret = nf90_put_var(ncid, varid, qBucket(i), (/start_pos/)) end if !! FLUXES to bucket if(nlst(did)%output_channelBucket_influx .eq. 2) then iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid) iret = nf90_put_var(ncid, varid, qBtmVertRunoff(i), (/start_pos/)) end if !! ACCUMULATIONS if(nlst(did)%output_channelBucket_influx .eq. 3) then iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid) iret = nf90_put_var(ncid, varid, accSfcLatRunoff(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"accBucket", varid) iret = nf90_put_var(ncid, varid, accBucket(i), (/start_pos/)) end if endif iret = nf90_inq_varid(ncid,"streamflow", varid) iret = nf90_put_var(ncid, varid, qlink(i,1), (/start_pos/)) #ifdef WRF_HYDRO_NUDGING iret = nf90_inq_varid(ncid,"nudge", varid) iret = nf90_put_var(ncid, varid, nudge(i), (/start_pos/)) #endif ! iret = nf90_inq_varid(ncid,"pos_streamflow", varid) ! iret = nf90_put_var(ncid, varid, abs(qlink(i,1), (/start_pos/))) iret = nf90_inq_varid(ncid,"head", varid) iret = nf90_put_var(ncid, varid, hlink(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"order", varid) iret = nf90_put_var(ncid, varid, ORDER(i), (/start_pos/)) !-- station index.. will repeat for every timesstep iret = nf90_inq_varid(ncid,"parent_index", varid) iret = nf90_put_var(ncid, varid, cnt, (/start_pos/)) !--record number of previous record for same station !obsolete format prev_pos = cnt+(nstations*(output_count-1)) prev_pos = cnt+(nobs*(output_count-2)) if(output_count.ne.1) then !-- only write next set of records iret = nf90_inq_varid(ncid,"prevChild", varid) iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/)) endif cnt=cnt+1 !--indices are 0 based rec_num_of_station(cnt) = start_pos-1 !-- save position for last child, 0-based!! endif enddo ! close(999) !-- output only observation points cnt=0 do i=1,nlk if(channel_option .ne. 3) then ! jlm this verry repetitiuos, oh well. if(trim(gages(i)) .ne. trim(gageMiss)) then start_posO = (cnt+1)+(nobs * (output_count-1)) !Write frxst_pts to text file... !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & 118 FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) !write(55,118) seconds_since, date(1:10), date(12:19), & write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), & gages(i), chlon(i), chlat(i), & qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) !yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) !!--time in seconds since startdate iret = nf90_inq_varid(ncid2,"time", varid) iret = nf90_put_var(ncid2, varid, seconds_since, (/1/)) iret = nf90_inq_varid(ncid2,"streamflow", varid) iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/)) #ifdef WRF_HYDRO_NUDGING iret = nf90_inq_varid(ncid2,"nudge", varid) iret = nf90_put_var(ncid2, varid, nudge(i), (/start_posO/)) #endif iret = nf90_inq_varid(ncid2,"head", varid) iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/)) iret = nf90_inq_varid(ncid,"order", varid) iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/)) !-- station index.. will repeat for every timesstep iret = nf90_inq_varid(ncid2,"parent_index", varid) iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/)) !--record number of previous record for same station !obsolete format prev_posO = cnt+(nobs*(output_count-1)) prev_posO = cnt+(nobs*(output_count-2)) if(output_count.ne.1) then !-- only write next set of records iret = nf90_inq_varid(ncid2,"prevChild", varid) iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) !IF block to add -1 to last element of prevChild array to designate end of list... ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then ! iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) ! else ! iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) ! endif endif cnt=cnt+1 !--indices are 0 based rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! endif else !! channel options 3 below if(STRMFRXSTPTS(i) .ne. -9999) then start_posO = (cnt+1)+(nobs * (output_count-1)) !Write frxst_pts to text file... !yw write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & 117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & ! qlink(i,1), qlink(i,1)*35.315,hlink(i) ! JLM: makes more sense to output the value in frxstpts incase they have meaning, ! as below, but I'm not going to make this change until I'm working with gridded ! streamflow again. write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), & strmfrxstpts(i), chlon(i), chlat(i), & qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i) !!--time in seconds since startdate iret = nf90_inq_varid(ncid2,"time", varid) iret = nf90_put_var(ncid2, varid, seconds_since, (/1/)) iret = nf90_inq_varid(ncid2,"streamflow", varid) iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/)) iret = nf90_inq_varid(ncid2,"head", varid) iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/)) iret = nf90_inq_varid(ncid,"order", varid) iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/)) !-- station index.. will repeat for every timesstep iret = nf90_inq_varid(ncid2,"parent_index", varid) iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/)) !--record number of previous record for same station !obsolete format prev_posO = cnt+(nobs*(output_count-1)) prev_posO = cnt+(nobs*(output_count-2)) if(output_count.ne.1) then !-- only write next set of records iret = nf90_inq_varid(ncid2,"prevChild", varid) iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) !IF block to add -1 to last element of prevChild array to designate end of list... ! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then ! iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) ! else ! iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/)) ! endif endif cnt=cnt+1 !--indices are 0 based rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! endif endif enddo close(55) !-- lastChild variable gives the record number of the most recent report for the station iret = nf90_inq_varid(ncid,"lastChild", varid) iret = nf90_put_var(ncid, varid, rec_num_of_station, (/1/), (/nstations/)) !-- lastChild variable gives the record number of the most recent report for the station iret = nf90_inq_varid(ncid2,"lastChild", varid) iret = nf90_put_var(ncid2, varid, rec_num_of_stationO, (/1/), (/nobs/)) iret = nf90_redef(ncid) date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(date)) = date iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_redef(ncid2) iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_enddef(ncid) iret = nf90_sync(ncid) iret = nf90_enddef(ncid2) iret = nf90_sync(ncid2) if (output_count == split_output_count) then output_count = 0 iret = nf90_close(ncid) iret = nf90_close(ncid2) endif if(allocated(chanlat)) deallocate(chanlat) if(allocated(chanlon)) deallocate(chanlon) if(allocated(elevation)) deallocate(elevation) if(allocated(station_id)) deallocate(station_id) if(allocated(lOrder)) deallocate(lOrder) if(allocated(rec_num_of_station)) deallocate(rec_num_of_station) if(allocated(stname)) deallocate(stname) if(allocated(chanlatO)) deallocate(chanlatO) if(allocated(chanlonO)) deallocate(chanlonO) if(allocated(elevationO)) deallocate(elevationO) if(allocated(station_idO)) deallocate(station_idO) if(allocated(lOrderO)) deallocate(lOrderO) if(allocated(rec_num_of_stationO)) deallocate(rec_num_of_stationO) if(allocated(stnameO)) deallocate(stnameO) #ifdef HYDRO_D print *, "Exited Subroutine output_chrt" #endif close(16) 20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3) end subroutine output_chrt_bak #ifdef MPP_LAND !-- output the channel route in an IDV 'station' compatible format subroutine mpp_output_chrt(gnlinks,gnlinksl,map_l2g,igrid, & split_output_count, NLINKS, ORDER, & startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch, & K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, & lsmDt & #ifdef WRF_HYDRO_NUDGING , nudge & #endif , accSfcLatRunoff, accBucket & , qSfcLatRunoff, qBucket, qBtmVertRunoff & , UDMP_OPT & ) USE module_mpp_land implicit none !!output the routing variables over just channel integer, intent(in) :: igrid,K,channel_option,NLINKSL integer, intent(in) :: split_output_count integer, intent(in) :: NLINKS real, dimension(:), intent(in) :: chlon,chlat real, dimension(:), intent(in) :: hlink,zelev integer, dimension(:), intent(in) :: ORDER integer, dimension(:), intent(inout) :: STRMFRXSTPTS character(len=15), dimension(:), intent(inout) :: gages character(len=15), intent(in) :: gageMiss real, intent(in) :: lsmDt real, intent(in) :: dtrt_ch real, dimension(:,:), intent(in) :: qlink #ifdef WRF_HYDRO_NUDGING real, dimension(:), intent(in) :: nudge #endif integer, intent(in) :: UDMP_OPT character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer :: gnlinks, map_l2g(nlinks), order_to_write, gnlinksl real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev #ifdef WRF_HYDRO_NUDGING real, allocatable,dimension(:) :: g_nudge #endif integer, allocatable,dimension(:) :: g_order,g_STRMFRXSTPTS real,allocatable,dimension(:,:) :: g_qlink integer :: gsize character(len=15),allocatable,dimension(:) :: g_gages real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket real , dimension(:), intent(in) :: qSfcLatRunoff, qBucket, qBtmVertRunoff real*8,allocatable,dimension(:) :: g_accSfcLatRunoff, g_accBucket real ,allocatable,dimension(:) :: g_qSfcLatRunoff, g_qBucket, g_qBtmVertRunoff gsize = gNLINKS if(gnlinksl .gt. gsize) gsize = gnlinksl if(my_id .eq. io_id ) then allocate(g_chlon(gsize )) allocate(g_chlat(gsize )) allocate(g_hlink(gsize )) allocate(g_zelev(gsize )) allocate(g_qlink(gsize ,2)) #ifdef WRF_HYDRO_NUDGING allocate(g_nudge(gsize)) #endif allocate(g_order(gsize )) allocate(g_STRMFRXSTPTS(gsize )) allocate(g_gages(gsize)) if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then allocate(g_qSfcLatRunoff( gsize )) allocate(g_qBucket( gsize )) endif if(nlst(did)%output_channelBucket_influx .eq. 2) & allocate(g_qBtmVertRunoff( gsize )) if(nlst(did)%output_channelBucket_influx .eq. 3) then allocate(g_accSfcLatRunoff(gsize )) allocate(g_accBucket( gsize )) endif else if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then allocate(g_qSfcLatRunoff( 1)) allocate(g_qBucket( 1)) end if if(nlst(did)%output_channelBucket_influx .eq. 2) & allocate(g_qBtmVertRunoff( 1)) if(nlst(did)%output_channelBucket_influx .eq. 3) then allocate(g_accSfcLatRunoff(1)) allocate(g_accBucket( 1)) end if allocate(g_chlon(1)) allocate(g_chlat(1)) allocate(g_hlink(1)) allocate(g_zelev(1)) allocate(g_qlink(1,2)) #ifdef WRF_HYDRO_NUDGING allocate(g_nudge(1)) #endif allocate(g_order(1)) allocate(g_STRMFRXSTPTS(1)) allocate(g_gages(1)) endif call mpp_land_sync() if(channel_option .eq. 1 .or. channel_option .eq. 2) then g_qlink = 0 g_gages = gageMiss call ReachLS_write_io(qlink(:,1), g_qlink(:,1)) call ReachLS_write_io(qlink(:,2), g_qlink(:,2)) #ifdef WRF_HYDRO_NUDGING g_nudge=0 call ReachLS_write_io(nudge,g_nudge) #endif call ReachLS_write_io(order, g_order) call ReachLS_write_io(chlon, g_chlon) call ReachLS_write_io(chlat, g_chlat) call ReachLS_write_io(zelev, g_zelev) call ReachLS_write_io(gages, g_gages) call ReachLS_write_io(STRMFRXSTPTS, g_STRMFRXSTPTS) call ReachLS_write_io(hlink, g_hlink) if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then call ReachLS_write_io(qSfcLatRunoff, g_qSfcLatRunoff) call ReachLS_write_io(qBucket, g_qBucket) end if if(nlst(did)%output_channelBucket_influx .eq. 2) & call ReachLS_write_io(qBtmVertRunoff, g_qBtmVertRunoff) if(nlst(did)%output_channelBucket_influx .eq. 3) then call ReachLS_write_io(accSfcLatRunoff, g_accSfcLatRunoff) call ReachLS_write_io(accBucket, g_accBucket) end if else call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS) call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) endif if(my_id .eq. IO_id) then call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER, & startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K, & g_STRMFRXSTPTS,order_to_write,gNLINKSL,channel_option, g_gages, gageMiss, & lsmDt & #ifdef WRF_HYDRO_NUDGING , g_nudge & #endif , g_accSfcLatRunoff, g_accBucket & , g_qSfcLatRunoff, g_qBucket, g_qBtmVertRunoff & , UDMP_OPT & ) end if call mpp_land_sync() if(allocated(g_order)) deallocate(g_order) if(allocated(g_STRMFRXSTPTS)) deallocate(g_STRMFRXSTPTS) if(allocated(g_chlon)) deallocate(g_chlon) if(allocated(g_chlat)) deallocate(g_chlat) if(allocated(g_hlink)) deallocate(g_hlink) if(allocated(g_zelev)) deallocate(g_zelev) if(allocated(g_qlink)) deallocate(g_qlink) if(allocated(g_gages)) deallocate(g_gages) #ifdef WRF_HYDRO_NUDGING if(allocated(g_nudge)) deallocate(g_nudge) #endif if(allocated(g_qSfcLatRunoff)) deallocate(g_qSfcLatRunoff) if(allocated(g_qBucket)) deallocate(g_qBucket) if(allocated(g_qBtmVertRunoff)) deallocate(g_qBtmVertRunoff) if(allocated(g_accSfcLatRunoff)) deallocate(g_accSfcLatRunoff) if(allocated(g_accBucket)) deallocate(g_accBucket) end subroutine mpp_output_chrt !--------- lake netcdf output ----------------------------------------- !-- output the ilake info an IDV 'station' compatible format ----------- subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, & startdate, date, latlake, lonlake, elevlake, & qlakei,qlakeo, resht,dtrt_ch,K) USE module_mpp_land !!output the routing variables over just channel integer, intent(in) :: igrid, K integer, intent(in) :: split_output_count integer, intent(in) :: NLAKES real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake real, intent(in) :: dtrt_ch character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer lake_index(nlakes) call write_lake_real(latlake,lake_index,nlakes) call write_lake_real(lonlake,lake_index,nlakes) call write_lake_real(elevlake,lake_index,nlakes) call write_lake_real(resht,lake_index,nlakes) call write_lake_real(qlakei,lake_index,nlakes) call write_lake_real(qlakeo,lake_index,nlakes) if(my_id.eq. IO_id) then call output_lakes(igrid, split_output_count, NLAKES, & startdate, date, latlake, lonlake, elevlake, & qlakei,qlakeo, resht,dtrt_ch,K) end if call mpp_land_sync() end subroutine mpp_output_lakes subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, & startdate, date, latlake, lonlake, elevlake, & qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM) USE module_mpp_land !!output the routing variables over just channel integer, intent(in) :: igrid, K integer, intent(in) :: split_output_count integer, intent(in) :: NLAKES real, dimension(NLAKES), intent(inout) :: latlake,lonlake,elevlake,resht real, dimension(NLAKES), intent(inout) :: qlakei,qlakeo !-- inflow and outflow of lake real, intent(in) :: dtrt_ch integer(kind=int64), dimension(NLAKES), intent(in) :: LAKEIDM ! lake id character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer lake_index(nlakes) call write_lake_real(latlake,lake_index,nlakes) call write_lake_real(lonlake,lake_index,nlakes) call write_lake_real(elevlake,lake_index,nlakes) call write_lake_real(resht,lake_index,nlakes) call write_lake_real(qlakei,lake_index,nlakes) call write_lake_real(qlakeo,lake_index,nlakes) if(my_id.eq. IO_id) then call output_lakes2(igrid, split_output_count, NLAKES, & startdate, date, latlake, lonlake, elevlake, & qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM) end if call mpp_land_sync() end subroutine mpp_output_lakes2 #endif !----------------------------------- lake netcdf output !-- output the ilake info an IDV 'station' compatible format subroutine output_lakes(igrid, split_output_count, NLAKES, & startdate, date, latlake, lonlake, elevlake, & qlakei,qlakeo, resht,dtrt_ch,K) !!output the routing variables over just channel integer, intent(in) :: igrid, K integer, intent(in) :: split_output_count integer, intent(in) :: NLAKES real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake real, intent(in) :: dtrt_ch character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer, allocatable, DIMENSION(:) :: station_id integer, allocatable, DIMENSION(:) :: rec_num_of_lake integer, save :: output_count integer, save :: ncid integer :: stationdim, dimdata, varid, charid, n integer :: iret,i, start_pos, prev_pos !-- integer :: previous_pos !-- used for the station model character(len=256) :: output_flnm character(len=19) :: date19, date19start character(len=34) :: sec_since_date integer :: seconds_since,cnt character(len=32) :: convention character(len=6),allocatable, DIMENSION(:) :: stname integer :: timedim character(len=34) :: sec_valid_date !--- all this for writing the station id string INTEGER TDIMS, TXLEN PARAMETER (TDIMS=2) ! number of TX dimensions PARAMETER (TXLEN = 6) ! length of example string INTEGER TIMEID ! record dimension id INTEGER TXID ! variable ID INTEGER TXDIMS(TDIMS) ! variable shape INTEGER TSTART(TDIMS), TCOUNT(TDIMS) ! sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' ! seconds_since = int(dtrt_ch)*output_count seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' allocate(station_id(NLAKES)) allocate(rec_num_of_lake(NLAKES)) allocate(stname(NLAKES)) if (output_count == 0) then !-- have moved sec_since_date from above here.. sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & //startdate(12:13)//':'//startdate(15:16)//':00' write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_lakes() - Problem nf90_create") endif do i=1,NLAKES station_id(i) = i write(stname(i),'(I6)') i enddo iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata) !--for linked list approach iret = nf90_def_dim(ncid, "station", nlakes, stationdim) iret = nf90_def_dim(ncid, "time", 1, timedim) !#ifndef HYDRO_REALTIME !- station location definition, lat iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Lake latitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_north') !- station location definition, long iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Lake longitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_east') ! !-- lake's phyical elevation ! iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'Lake altitude') ! iret = nf90_put_att(ncid, varid, 'units', 'meters') !#endif !-- parent index ! iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'index of the lake for this record') !-- prevChild ! iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same lake') !ywtmp iret = nf90_put_att(ncid, varid, '_FillValue', -1) ! iret = nf90_put_att(ncid, varid, '_FillValue', -1) !-- lastChild ! iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this lake') !ywtmp iret = nf90_put_att(ncid, varid, '_FillValue', -1) ! iret = nf90_put_att(ncid, varid, '_FillValue', -1) ! !- water surface elevation iret = nf90_def_var(ncid, "wse", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meters') iret = nf90_put_att(ncid, varid, 'long_name', 'Water Surface Elevation') ! !- inflow to lake iret = nf90_def_var(ncid, "inflow", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') ! !- outflow to lake iret = nf90_def_var(ncid, "outflow", NF90_FLOAT, (/dimdata/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') !-- station id ! define character-position dimension for strings of max length 6 iret = NF90_DEF_DIM(ncid, "id_len", 6, charid) TXDIMS(1) = charid ! define char-string variable and position dimension first TXDIMS(2) = stationdim iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station id') ! !- time definition, timeObs iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') ! date19(1:19) = "0000-00-00_00:00:00" ! date19(1:len_trim(startdate)) = startdate ! iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) ! date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(startdate)) = startdate convention(1:32) = "Unidata Observation Dataset v1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station") !#ifndef HYDRO_REALTIME iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0") !#endif iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station") !! iret = nf90_put_att(ncid, NF90_GLOBAL, "observation_dimension", "recNum") !! iret = nf90_put_att(ncid, NF90_GLOBAL, "time_coordinate", "time_observation") iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_enddef(ncid) !#ifndef HYDRO_REALTIME !-- write latitudes iret = nf90_inq_varid(ncid,"latitude", varid) iret = nf90_put_var(ncid, varid, LATLAKE, (/1/), (/NLAKES/)) !-- write longitudes iret = nf90_inq_varid(ncid,"longitude", varid) iret = nf90_put_var(ncid, varid, LONLAKE, (/1/), (/NLAKES/)) !-- write physical height of lake ! iret = nf90_inq_varid(ncid,"altitude", varid) ! iret = nf90_put_var(ncid, varid, elevlake, (/1/), (/NLAKES/)) !#endif !-- write station id's do i=1,nlakes TSTART(1) = 1 TSTART(2) = i TCOUNT(1) = TXLEN TCOUNT(2) = 1 iret = nf90_inq_varid(ncid,"station_id", varid) iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT) enddo endif iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) output_count = output_count + 1 cnt=0 do i=1,NLAKES start_pos = (cnt+1)+(nlakes*(output_count-1)) !!--time in seconds since startdate iret = nf90_inq_varid(ncid,"time_observation", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/start_pos/)) iret = nf90_inq_varid(ncid,"wse", varid) iret = nf90_put_var(ncid, varid, resht(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"inflow", varid) iret = nf90_put_var(ncid, varid, qlakei(i), (/start_pos/)) iret = nf90_inq_varid(ncid,"outflow", varid) iret = nf90_put_var(ncid, varid, qlakeo(i), (/start_pos/)) !-- station index.. will repeat for every timesstep ! iret = nf90_inq_varid(ncid,"parent_index", varid) ! iret = nf90_put_var(ncid, varid, cnt, (/start_pos/)) !--record number of previous record for same station ! prev_pos = cnt+(nlakes*(output_count-1)) ! if(output_count.ne.1) then !-- only write next set of records ! iret = nf90_inq_varid(ncid,"prevChild", varid) ! iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/)) ! endif cnt=cnt+1 !--indices are 0 based rec_num_of_lake(cnt) = start_pos-1 !-- save position for last child, 0-based!! enddo !-- lastChild variable gives the record number of the most recent report for the station iret = nf90_inq_varid(ncid,"lastChild", varid) iret = nf90_put_var(ncid, varid, rec_num_of_lake, (/1/), (/nlakes/)) !-- number of children reported for this station, OPTIONAL !-- iret = nf90_inq_varid(ncid,"numChildren", varid) !-- iret = nf90_put_var(ncid, varid, rec_num_of_lake, (/1/), (/nlakes/)) iret = nf90_redef(ncid) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_enddef(ncid) iret = nf90_sync(ncid) if (output_count == split_output_count) then output_count = 0 iret = nf90_close(ncid) endif if(allocated(station_id)) deallocate(station_id) if(allocated(rec_num_of_lake)) deallocate(rec_num_of_lake) if(allocated(stname)) deallocate(stname) #ifdef HYDRO_D print *, "Exited Subroutine output_lakes" #endif close(16) end subroutine output_lakes !----------------------------------- lake netcdf output !-- output the lake as regular netcdf file format for better performance than point netcdf file. subroutine output_lakes2(igrid, split_output_count, NLAKES, & startdate, date, latlake, lonlake, elevlake, & qlakei,qlakeo, resht,dtrt_ch,K,LAKEIDM) !!output the routing variables over just channel integer, intent(in) :: igrid, K integer, intent(in) :: split_output_count integer, intent(in) :: NLAKES real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake integer(kind=int64), dimension(NLAKES), intent(in) :: LAKEIDM !-- LAKE ID real, intent(in) :: dtrt_ch character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer, save :: output_count integer, save :: ncid integer :: stationdim, varid, n integer :: iret,i !-- character(len=256) :: output_flnm character(len=19) :: date19, date19start character(len=32) :: convention integer :: timedim integer :: seconds_since character(len=34) :: sec_valid_date sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) if (output_count == 0) then date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & //startdate(12:13)//':'//startdate(15:16)//':00' write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_lakes() - Problem nf90_create") endif iret = nf90_def_dim(ncid, "station", nlakes, stationdim) iret = nf90_def_dim(ncid, "time", 1, timedim) !#ifndef HYDRO_REALTIME !- station location definition, lat iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Lake latitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_north') !#endif !- station location definition, LAKEIDM iret = nf90_def_var(ncid, "lake_id", NF90_INT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Lake COMMON ID') !#ifndef HYDRO_REALTIME !- station location definition, long iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Lake longitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_east') ! !-- lake's phyical elevation ! iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'Lake altitude') ! iret = nf90_put_att(ncid, varid, 'units', 'meters') !#endif ! !- water surface elevation iret = nf90_def_var(ncid, "wse", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meters') iret = nf90_put_att(ncid, varid, 'long_name', 'Water Surface Elevation') ! !- inflow to lake iret = nf90_def_var(ncid, "inflow", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') ! !- outflow to lake iret = nf90_def_var(ncid, "outflow", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') ! Time variable iret = nf90_def_var(ncid, "time", NF90_INT, (/timeDim/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(startdate)) = startdate !#ifndef HYDRO_REALTIME iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0") !#endif iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_enddef(ncid) iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) !#ifndef HYDRO_REALTIME !-- write latitudes iret = nf90_inq_varid(ncid,"latitude", varid) iret = nf90_put_var(ncid, varid, LATLAKE, (/1/), (/NLAKES/)) !-- write longitudes iret = nf90_inq_varid(ncid,"longitude", varid) iret = nf90_put_var(ncid, varid, LONLAKE, (/1/), (/NLAKES/)) !-- write physical height of lake ! iret = nf90_inq_varid(ncid,"altitude", varid) ! iret = nf90_put_var(ncid, varid, elevlake, (/1/), (/NLAKES/)) !#endif !-- write elevation of lake iret = nf90_inq_varid(ncid,"wse", varid) iret = nf90_put_var(ncid, varid, resht, (/1/), (/NLAKES/)) !-- write elevation of inflow iret = nf90_inq_varid(ncid,"inflow", varid) iret = nf90_put_var(ncid, varid, qlakei, (/1/), (/NLAKES/)) !-- write elevation of inflow iret = nf90_inq_varid(ncid,"outflow", varid) iret = nf90_put_var(ncid, varid, qlakeo, (/1/), (/NLAKES/)) !-- write lake id iret = nf90_inq_varid(ncid,"lake_id", varid) iret = nf90_put_var(ncid, varid, LAKEIDM, (/1/), (/NLAKES/)) endif output_count = output_count + 1 iret = nf90_redef(ncid) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_enddef(ncid) iret = nf90_sync(ncid) if (output_count == split_output_count) then output_count = 0 iret = nf90_close(ncid) endif end subroutine output_lakes2 !----------------------------------- lake netcdf output #ifdef MPP_LAND !-- output the channel route in an IDV 'grid' compatible format subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & NLINKS,CH_NETLNK_in, startdate, date, & qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt ) USE module_mpp_land implicit none integer g_ixrt,g_jxrt integer, intent(in) :: igrid integer, intent(in) :: split_output_count integer, intent(in) :: NLINKS,ixrt,jxrt real, intent(in) :: dt real, dimension(:,:), intent(in) :: qlink integer(kind=int64), dimension(IXRT,JXRT), intent(in) :: CH_NETLNK_in character(len=*), intent(in) :: geo_finegrid_flnm character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer:: gnlinks , map_l2g(nlinks) integer(kind=int64), allocatable,dimension(:,:) :: CH_NETLNK real, allocatable,dimension(:,:) :: g_qlink if(my_id .eq. io_id) then allocate(CH_NETLNK(g_IXRT,g_JXRT)) allocate(g_qlink(gNLINKS,2) ) else allocate(CH_NETLNK(1,1)) allocate(g_qlink(1,2) ) endif call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) call write_IO_rt_int8(CH_NETLNK_in, CH_NETLNK) if(my_id.eq.IO_id) then call output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, & GNLINKS, CH_NETLNK, startdate, date, & g_qlink, dt, geo_finegrid_flnm) endif if(allocated(g_qlink)) deallocate(g_qlink) if(allocated(CH_NETLNK)) deallocate(CH_NETLNK) end subroutine mpp_output_chrtgrd #endif !-- output the channel route in an IDV 'grid' compatible format subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & NLINKS, CH_NETLNK, startdate, date, & qlink, dt, geo_finegrid_flnm) integer, intent(in) :: igrid integer, intent(in) :: split_output_count integer, intent(in) :: NLINKS,ixrt,jxrt real, intent(in) :: dt real, dimension(:,:), intent(in) :: qlink integer(kind=int64), dimension(IXRT,JXRT), intent(in) :: CH_NETLNK character(len=*), intent(in) :: geo_finegrid_flnm character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date character(len=32) :: convention integer,save :: output_count integer, save :: ncid,ncstatic real, dimension(IXRT,JXRT) :: tmpflow real, dimension(IXRT) :: xcoord real, dimension(JXRT) :: ycoord real :: long_cm,lat_po,fe,fn real, dimension(2) :: sp integer :: varid, n integer :: jxlatdim,ixlondim,timedim !-- dimension ids integer :: timedim2 character(len=34) :: sec_valid_date integer :: iret,i,j character(len=256) :: output_flnm character(len=19) :: date19 character(len=34) :: sec_since_date integer :: seconds_since seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' tmpflow = -9E15 write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif !--- define dimension iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then call hydro_stop("In output_chrtgrd() - Problem nf90_create") endif iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, timedim) iret = nf90_def_dim(ncid, "x", ixrt, ixlondim) iret = nf90_def_dim(ncid, "y", jxrt, jxlatdim) !--- define variables ! !- time definition, timeObs !- x-coordinate in cartesian system !yw iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/ixlondim/), varid) !yw iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection') !yw iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate') !yw iret = nf90_put_att(ncid, varid, 'units', 'Meter') !- y-coordinate in cartesian ssystem !yw iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/jxlatdim/), varid) !yw iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection') !yw iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate') !yw iret = nf90_put_att(ncid, varid, 'units', 'Meter') ! !- flow definition, var iret = nf90_def_var(ncid, "streamflow", NF90_REAL, (/ixlondim,jxlatdim,timedim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1') iret = nf90_put_att(ncid, varid, 'long_name', 'water flow rate') iret = nf90_put_att(ncid, varid, 'coordinates', 'x y') iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic') iret = nf90_put_att(ncid, varid, 'missing_value', -9E15) iret = nf90_def_var(ncid, "index", NF90_INT, (/ixlondim,jxlatdim/), varid) iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) !-- place prjection information date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(startdate)) = startdate convention(1:32) = "CF-1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_enddef(ncid) iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) !!-- write latitude and longitude locations !DJG inv do j=jxrt,1,-1 do j=1,jxrt do i=1,ixrt if(CH_NETLNK(i,j).GE.0) then tmpflow(i,j) = qlink(CH_NETLNK(i,j),1) else tmpflow(i,j) = -9E15 endif enddo enddo !!time in seconds since startdate iret = nf90_inq_varid(ncid,"index", varid) iret = nf90_put_var(ncid, varid, CH_NETLNK, (/1,1/), (/ixrt,jxrt/)) iret = nf90_inq_varid(ncid,"streamflow", varid) iret = nf90_put_var(ncid, varid, tmpflow, (/1,1,1/), (/ixrt,jxrt,1/)) iret = nf90_close(ncid) end subroutine output_chrtgrd subroutine read_chan_forcing( & indir,olddate,startdate,hgrid,& ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT) ! This subrouting is going to read channel forcing for ! the old, channel-only simulations (ie when CHANRTSWCRT = 2) ! forced by RTOUT_DOMAIN files. implicit none ! in variable character(len=*) :: olddate,hgrid,indir,startdate character(len=256) :: filename integer :: ixrt,jxrt real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT ! tmp variable character(len=256) :: inflnm, product integer :: i,j,mmflag character(len=256) :: units integer :: ierr integer :: ncid !DJG Create filename... inflnm = trim(indir)//"/"//& olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& olddate(15:16)//".RTOUT_DOMAIN"//hgrid #ifdef HYDRO_D print *, "Channel forcing file...",inflnm #endif !DJG Open NetCDF file... ierr = nf90_open(inflnm, NF90_NOWRITE, ncid) if (ierr /= 0) then write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm) call hydro_stop("In read_chan_forcing() - Problem opening netcdf file") endif !DJG read data... call get_2d_netcdf("QSTRMVOLRT", ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr) !DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) !DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) ierr = nf90_close(ncid) end subroutine read_chan_forcing subroutine get2d_int(var_name,out_buff,ix,jx,fileName, fatalErr) implicit none integer :: iret,varid,ncid,ix,jx integer out_buff(ix,jx) character(len=*), intent(in) :: var_name character(len=*), intent(in) :: fileName logical, optional, intent(in) :: fatalErr logical :: fatalErr_local character(len=256) :: errMsg fatalErr_local = .false. if(present(fatalErr)) fatalErr_local=fatalErr iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid) if (iret .ne. 0) then errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName) print*, trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif iret = nf90_inq_varid(ncid,trim(var_name), varid) if(iret .ne. 0) then errMsg = "get2d_int: failed to find the variable: " // & trim(var_name) // ' in ' // trim(fileName) print*, trim(errMsg) if(fatalErr_local) call hydro_stop(errMsg) endif iret = nf90_get_var(ncid, varid, out_buff) if(iret .ne. 0) then errMsg = "get2d_int: failed to read the variable: " // & trim(var_name) // " in " //trim(fileName) print*,trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif iret = nf90_close(ncid) if(iret .ne. 0) then errMsg = "get2d_int: failed to close the file: " // & trim(fileName) print*,trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif end subroutine get2d_int subroutine get2d_int8(var_name,out_buff,ix,jx,fileName, fatalErr) implicit none integer :: iret,varid,ncid,ix,jx integer(kind=int64) out_buff(ix,jx) character(len=*), intent(in) :: var_name character(len=*), intent(in) :: fileName logical, optional, intent(in) :: fatalErr logical :: fatalErr_local character(len=256) :: errMsg fatalErr_local = .false. if(present(fatalErr)) fatalErr_local=fatalErr iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid) if (iret .ne. 0) then errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName) print*, trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif iret = nf90_inq_varid(ncid,trim(var_name), varid) if(iret .ne. 0) then errMsg = "get2d_int: failed to find the variable: " // & trim(var_name) // ' in ' // trim(fileName) print*, trim(errMsg) if(fatalErr_local) call hydro_stop(errMsg) endif iret = nf90_get_var(ncid, varid, out_buff) if(iret .ne. 0) then errMsg = "get2d_int: failed to read the variable: " // & trim(var_name) // " in " //trim(fileName) print*,trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif iret = nf90_close(ncid) if(iret .ne. 0) then errMsg = "get2d_int: failed to close the file: " // & trim(fileName) print*,trim(errMsg) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif end subroutine get2d_int8 #ifdef MPP_LAND SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & route_chan_f,route_link_f, & route_direction_f, NLINKS, & CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT,NLAKES) USE module_mpp_land implicit none INTEGER :: channel_option, did INTEGER :: g_IXRT,g_JXRT INTEGER, INTENT(INOUT) :: NLINKS, GNLINKS,NLINKSL INTEGER, INTENT(IN) :: IXRT,JXRT INTEGER :: CHNID,cnt INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK !- each node gets unique id based on global domain ! INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK ! temp array INTEGER, allocatable,DIMENSION(:,:) :: g_CH_NETLNK ! temp array INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT REAL, DIMENSION(IXRT,JXRT) :: LAT, LON INTEGER, INTENT(IN) :: UDMP_OPT integer:: i,j, NLAKES CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f CHARACTER(len=*) :: geo_finegrid_flnm ! CHARACTER(len=*) :: geo_finegrid_flnm ! integer, allocatable, dimension(:) :: tmp_int integer :: ywcount if(my_id .eq. IO_id) then allocate(g_CH_NETLNK(g_IXRT,g_JXRT)) g_CH_NETLNK = -9999 CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, & route_direction_f, GNLINKS, & g_CH_NETLNK, channel_option,geo_finegrid_flnm,NLINKSL, UDMP_OPT,nlakes) call get_NLINKSL(NLINKSL, channel_option, route_link_f) else allocate(g_CH_NETLNK(1,1)) endif call mpp_land_bcast_int1(GNLINKS) call mpp_land_bcast_int1(NLINKSL) call mpp_land_bcast_int1(NLAKES) call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt) if(allocated(g_CH_NETLNK)) deallocate(g_CH_NETLNK) ywcount = 0 CH_NETLNK = -9999 do j = 1, jxrt do i = 1, ixrt if(GCH_NETLNK(i,j) .gt. 0) then ywcount = ywcount + 1 CH_NETLNK(i,j) = ywcount endif end do end do NLINKS = ywcount !ywcheck ! CH_NETLNK = GCH_NETLNK allocate(rt_domain(did)%map_l2g(NLINKS)) rt_domain(did)%map_l2g = -1 do j = 1, jxrt do i = 1, ixrt if(CH_NETLNK(i,j) .gt. 0) then rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j) endif end do end do call mpp_chrt_nlinks_collect(NLINKS) end SUBROUTINE MPP_READ_ROUTEDIM #endif SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo_f, & route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC,IMPERVFRAC, & channel_option, UDMP_OPT, imperv_adj) INTEGER, INTENT(IN) :: IXRT,JXRT REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT INTEGER(kind=int64), INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_LNKRT !Dummy inverted grids REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: IMPERVFRAC integer :: I,J, iret, jj, channel_option, UDMP_OPT, imperv_adj CHARACTER(len=256) :: var_name CHARACTER(len=* ) :: route_topo_f CHARACTER(len=* ) :: route_chan_f CHARACTER(len=* ) :: geo_finegrid_flnm var_name = "TOPOGRAPHY" call nreadRT2d_real(var_name,ELRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) IF(channel_option .ne. 3 .and. UDMP_OPT .ne. 1) then !get maxnodes and links from grid var_name = "LINKID" call nreadRT2d_int8(var_name,CH_LNKRT,ixrt,jxrt,& trim(geo_finegrid_flnm), fatalErr=.true.) endif #ifdef HYDRO_D write(6,*) "read linkid grid CH_LNKRT ",var_name #endif !!!DY to be fixed ... 6/27/08 ! var_name = "BED_ELEVATION" ! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& ! trim(geo_finegrid_flnm)) var_name = "CHANNELGRID" call nreadRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D write(6,*) "read ",var_name #endif var_name = "LKSATFAC" LKSATFAC = -9999.9 call nreadRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D write(6,*) "read ",var_name #endif where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... !1.12.2012...Read in routing calibration factors... var_name = "RETDEPRTFAC" call nreadRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists var_name = "OVROUGHRTFAC" call nreadRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists !Read in new optional impervious layer var_name = "IMPERVFRAC" IMPERVFRAC = -9999.9 if (imperv_adj > 0) then call nreadRT2d_real(var_name,IMPERVFRAC,ixrt,jxrt,& trim(geo_finegrid_flnm), fatalErr=.true.) where (IMPERVFRAC < 0.) IMPERVFRAC = 0.0 ! reset grid to = 0.0 if non-valid value exists else IMPERVFRAC = 0.0 endif #ifdef HYDRO_D write(6,*) "finish READ_ROUTING_seq" #endif !DJG ----------------------------------------------------- END SUBROUTINE READ_ROUTING_seq !DJG _____________________________ subroutine output_lsm(outFile,did) implicit none integer did character(len=*) outFile integer :: ncid,irt, dimid_ix, dimid_jx, & dimid_ixrt, dimid_jxrt, varid, & dimid_links, dimid_basns, dimid_soil integer :: iret, n character(len=2) tmpStr #ifdef MPP_LAND if(IO_id.eq.my_id) & #endif iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then call hydro_stop("In output_lsm() - Problem nf90_create") endif #ifdef MPP_LAND if(IO_id.eq.my_id) then #endif #ifdef HYDRO_D write(6,*) "output file ", outFile #endif ! define dimension for variables iret = nf90_def_dim(ncid, "depth", nlst(did)%nsoil, dimid_soil) !-- 3-d soils #ifdef MPP_LAND iret = nf90_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid iret = nf90_def_dim(ncid, "iy", global_ny, dimid_jx) #else iret = nf90_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid iret = nf90_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) #endif !define variables do n = 1, nlst(did)%nsoil if( n .lt. 10) then write(tmpStr, '(i1)') n else write(tmpStr, '(i2)') n endif iret = nf90_def_var(ncid, "stc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "smc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "sh2ox"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) end do !iret = nf90_def_var(ncid, "smcmax1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) !iret = nf90_def_var(ncid, "smcref1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) !iret = nf90_def_var(ncid, "smcwlt1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "infxsrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "sfcheadrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_enddef(ncid) #ifdef MPP_LAND endif #endif call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc") call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc") call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt" ) #ifdef MPP_LAND if(IO_id.eq.my_id) then #endif iret = nf90_close(ncid) #ifdef HYDRO_D write(6,*) "finish writing outFile : ", outFile #endif #ifdef MPP_LAND endif #endif end subroutine output_lsm subroutine RESTART_OUT_nc(outFile,did) implicit none integer did integer :: n character(len=2) :: tmpStr character(len=*) outFile integer :: ncid,irt, dimid_ix, dimid_jx, & dimid_ixrt, dimid_jxrt, varid, & dimid_links, dimid_basns, dimid_soil, dimid_lakes integer :: iret #ifdef MPP_LAND if(IO_id.eq.my_id) & #endif iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then call hydro_stop("In RESTART_OUT_nc() - Problem nf90_create") endif #ifdef MPP_LAND if(IO_id.eq.my_id) then #endif if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then ! define dimension for variables iret = nf90_def_dim(ncid, "depth", nlst(did)%nsoil, dimid_soil) !-- 3-d soils #ifdef MPP_LAND iret = nf90_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid iret = nf90_def_dim(ncid, "iy", global_ny, dimid_jx) iret = nf90_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt) !-- make a decimated grid iret = nf90_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt) #else iret = nf90_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid iret = nf90_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) iret = nf90_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt) !-- make a decimated grid iret = nf90_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt) #endif endif ! neither channel_only nor channelBucket_only if(nlst(did)%channel_option .eq. 3) then iret = nf90_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links) else iret = nf90_def_dim(ncid, "links", rt_domain(did)%gnlinksl, dimid_links) endif iret = nf90_def_dim(ncid, "basns", rt_domain(did)%gnumbasns, dimid_basns) if(rt_domain(did)%nlakes .gt. 0) then iret = nf90_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes) endif !define variables if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then do n = 1, nlst(did)%nsoil if( n .lt. 10) then write(tmpStr, '(i1)') n else write(tmpStr, '(i2)') n endif iret = nf90_def_var(ncid, "stc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "smc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "sh2ox"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) end do !iret = nf90_def_var(ncid, "smcmax1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) !iret = nf90_def_var(ncid, "smcref1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) !iret = nf90_def_var(ncid, "smcwlt1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "infxsrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "soldrain", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) iret = nf90_def_var(ncid, "sfcheadrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid) end if ! neither channel_only nor channelBucket_only if(nlst(did)%SUBRTSWCRT .eq. 1 .or. & nlst(did)%OVRTSWCRT .eq. 1 .or. & nlst(did)%GWBASESWCRT .ne. 0 ) then if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then iret = nf90_def_var(ncid, "QBDRYRT", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) iret = nf90_def_var(ncid, "infxswgt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) iret = nf90_def_var(ncid, "sfcheadsubrt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) do n = 1, nlst(did)%nsoil if( n .lt. 10) then write(tmpStr, '(i1)') n else write(tmpStr, '(i2)') n endif iret = nf90_def_var(ncid, "sh2owgt"//trim(tmpStr), NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) end do iret = nf90_def_var(ncid, "qstrmvolrt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) !AD_CHANGE: Not needed in RESTART !iret = nf90_def_var(ncid, "RETDEPRT", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) end if ! neither channel_only nor channelBucket_only if(nlst(did)%CHANRTSWCRT.eq.1) then !yw based on Laura request, hlink will do the restart for reach method. ! if(nlst(did)%channel_option .eq. 3) & iret = nf90_def_var(ncid, "hlink", NF90_FLOAT, (/dimid_links/), varid) iret = nf90_def_var(ncid, "qlink1", NF90_FLOAT, (/dimid_links/), varid) iret = nf90_def_var(ncid, "qlink2", NF90_FLOAT, (/dimid_links/), varid) if(nlst(did)%channel_option .eq. 3) & iret = nf90_def_var(ncid, "cvol", NF90_FLOAT, (/dimid_links/), varid) if(rt_domain(did)%nlakes .gt. 0) then iret = nf90_def_var(ncid, "resht", NF90_FLOAT, (/dimid_lakes/), varid) iret = nf90_def_var(ncid, "qlakeo", NF90_FLOAT, (/dimid_lakes/), varid) iret = nf90_def_var(ncid, "qlakei", NF90_FLOAT, (/dimid_lakes/), varid) endif if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) & iret = nf90_def_var(ncid, "lake_inflort", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) !! JLM: who wants these? They can be put back if someone cares. !! But just calculate accQLateral locally so the redundant variable isnt held in !! memory with all the other variables !if(nlst_rt(did)%UDMP_OPT .eq. 1) then ! iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimid_links/), varid) ! iret = nf90_def_var(ncid, "accQLateral", NF90_DOUBLE, (/dimid_links/), varid) ! iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_DOUBLE, (/dimid_links/), varid) ! iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimid_links/), varid) !endif end if ! CHANRTSWCRT .eq. 1 if(nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.ge.4) then if( nlst(did)%channel_only .eq. 0) then if(nlst(did)%UDMP_OPT .eq. 1) then iret = nf90_def_var(ncid, "z_gwsubbas", NF90_FLOAT, (/dimid_links/), varid) else iret = nf90_def_var(ncid, "z_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid) endif end if ! not channel_only : dont use buckets in channel only runs !yw test bucket model ! iret = nf90_def_var(ncid, "gwbas_pix_ct", NF90_FLOAT, (/dimid_basns/), varid) ! iret = nf90_def_var(ncid, "gw_buck_exp", NF90_FLOAT, (/dimid_basns/), varid) ! iret = nf90_def_var(ncid, "z_max", NF90_FLOAT, (/dimid_basns/), varid) ! iret = nf90_def_var(ncid, "gw_buck_coeff", NF90_FLOAT, (/dimid_basns/), varid) ! iret = nf90_def_var(ncid, "qin_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid) ! iret = nf90_def_var(ncid, "qinflowbase", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) ! iret = nf90_def_var(ncid, "qout_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid) end if ! GWBASESWCRT .eq.1 .or. GWBASESWCRT .ge. 4 !! What is this option?? if(nlst(did)%gwBaseSwCRT .eq. 3)then iret = nf90_def_var(ncid, "HEAD", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid) end if end if ! end if(nlst(did)%SUBRTSWCRT .eq. 1 .or. & ! nlst(did)%OVRTSWCRT .eq. 1 .or. & ! nlst(did)%GWBASESWCRT .ne. 0 ) ! put global attribute iret = nf90_put_att(ncid, NF90_GLOBAL, "compiler_version", compiler_version()) iret = nf90_put_att(ncid, NF90_GLOBAL, "his_out_counts", rt_domain(did)%his_out_counts) iret = nf90_put_att(ncid, NF90_GLOBAL, "Restart_Time", nlst(did)%olddate(1:19)) iret = nf90_put_att(ncid, NF90_GLOBAL, "Since_Date", nlst(did)%sincedate(1:19)) iret = nf90_put_att(ncid, NF90_GLOBAL, "DTCT", nlst(did)%DTCT) iret = nf90_put_att(ncid, NF90_GLOBAL, "channel_only", nlst(did)%channel_only) iret = nf90_put_att(ncid, NF90_GLOBAL, "channelBucket_only", nlst(did)%channelBucket_only) !! end definition iret = nf90_enddef(ncid) #ifdef MPP_LAND endif ! my_id .eq. io_id #endif if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc") call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc") call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt" ) end if ! neither channel_only nor channelBucket_only if(nlst(did)%SUBRTSWCRT .eq. 1 .or. & nlst(did)%OVRTSWCRT .eq. 1 .or. & nlst(did)%GWBASESWCRT .ne. 0 ) then if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%boundary_flux, "QBDRYRT" ) call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" ) call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%surface_water_head_routing, "sfcheadsubrt" ) call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" ) call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT_ACC, "qstrmvolrt" ) !AD_CHANGE: Not needed in RESTART !call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%properties%retention_depth, "RETDEPRT" ) end if ! neither channel_only nor channelBucket_only if(nlst(did)%CHANRTSWCRT.eq.1) then if(nlst(did)%channel_option .eq. 3) then call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" & #ifdef MPP_LAND ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) else call w_rst_crt_reach(ncid,rt_domain(did)%HLINK, "hlink" & #ifdef MPP_LAND ,rt_domain(did)%gnlinksl& #endif ) !call checkReach(99,rt_domain(did)%HLINK) endif if(nlst(did)%channel_option .eq. 3) then call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" & #ifdef MPP_LAND ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) else call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,1), "qlink1" & #ifdef MPP_LAND ,rt_domain(did)%gnlinksl & #endif ) endif if(nlst(did)%channel_option .eq. 3) then call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" & #ifdef MPP_LAND ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) else call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,2), "qlink2" & #ifdef MPP_LAND ,rt_domain(did)%gnlinksl & #endif ) !! JLM If someone really wants the accumulated fluxes in the restart file, you can add them back. !! But Calculate accQLateral locally ! if(nlst_rt(did)%UDMP_OPT .eq. 1) then ! call w_rst_crt_reach(ncid,rt_domain(did)%accSfcLatRunoff, "accSfcLatRunoff" & !#ifdef MPP_LAND ! ,rt_domain(did)%gnlinksl & !#endif ! ) ! call w_rst_crt_reach(ncid,rt_domain(did)%accQLateral, "accQLateral" & !#ifdef MPP_LAND ! ,rt_domain(did)%gnlinksl & !#endif ! ) ! call w_rst_crt_reach(ncid,rt_domain(did)%qSfcLatRunoff, "qSfcLatRunoff" & !#ifdef MPP_LAND ! ,rt_domain(did)%gnlinksl & !#endif ! ) ! call w_rst_crt_reach(ncid,rt_domain(did)%accBucket, "accBucket" & !#ifdef MPP_LAND ! ,rt_domain(did)%gnlinksl & !#endif ! ) ! endif ! end if of UDMP_OPT .eq. 1 endif ! channel_option .eq. 3 !! Cvol is not prognostic for Musk-cunge. if(nlst(did)%channel_option .eq. 3) then call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" & #ifdef MPP_LAND ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) ! else ! call w_rst_crt_reach(ncid,rt_domain(did)%cvol, "cvol" & !#ifdef MPP_LAND ! ,rt_domain(did)%gnlinksl & !#endif ! ) endif ! call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" & !#ifdef MPP_LAND ! ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & !#endif ! ) call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" & #ifdef MPP_LAND ,rt_domain(did)%lake_index & #endif ) call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" & #ifdef MPP_LAND ,rt_domain(did)%lake_index & #endif ) call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakei,"qlakei" & #ifdef MPP_LAND ,rt_domain(did)%lake_index & #endif ) if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) & call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake,"lake_inflort") end if ! if(nlst_rt(did)%CHANRTSWCRT.eq.1) if(nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.ge.4) then !call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) if( nlst(did)%channel_only .eq. 0) then if(nlst(did)%UDMP_OPT .eq. 1) then call w_rst_crt_reach(ncid,rt_domain(did)%z_gwsubbas, "z_gwsubbas" & #ifdef MPP_LAND ,rt_domain(did)%gnlinksl & #endif ) else call w_rst_gwbucket_real(ncid,rt_domain(did)%numbasns,rt_domain(did)%gnumbasns, & rt_domain(did)%basnsInd, rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) endif end if ! not channel_only : dont use buckets in channel only runs !yw test bucket model ! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" ) ! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" ) ! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" ) ! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" ) ! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" ) ! call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase") ! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" ) end if ! GWBASESWCRT .eq. 1 .or. GWBASESWCRT .ge. 4 if(nlst(did)%GWBASESWCRT.eq.3) then if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) & call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho, "HEAD" ) end if end if ! end if(nlst_rt(did)%SUBRTSWCRT .eq. 1 .or. & ! nlst_rt(did)%OVRTSWCRT .eq. 1 .or. & ! nlst_rt(did)%GWBASESWCRT .ne. 0 ) #ifdef MPP_LAND if(IO_id.eq.my_id) & #endif iret = nf90_close(ncid) end subroutine RESTART_OUT_nc #ifdef MPP_LAND subroutine RESTART_OUT_bi(outFile,did) implicit none integer did character(len=*) outFile integer :: iunit integer :: i0,ie, i, istep, mkdirStatus call mpp_land_sync() iunit = 81 istep = 64 i0 = 0 ie = istep do i = 0, numprocs,istep if(my_id .ge. i0 .and. my_id .lt. ie) then open(iunit, file = "restart/"//trim(outFile), form="unformatted",ERR=101, access="sequential") write(iunit,ERR=101) rt_domain(did)%his_out_counts ! write(iunit,ERR=101) nlst(did)%olddate(1:19) write(iunit,ERR=101) nlst(did)%sincedate(1:19) ! write(iunit,ERR=101) nlst_rt(did)%DTCT write(iunit,ERR=101) rt_domain(did)%stc write(iunit,ERR=101) rt_domain(did)%smc write(iunit,ERR=101) rt_domain(did)%sh2ox write(iunit,ERR=101) rt_domain(did)%SMCMAX1 write(iunit,ERR=101) rt_domain(did)%SMCREF1 write(iunit,ERR=101) rt_domain(did)%SMCWLT1 write(iunit,ERR=101) rt_domain(did)%INFXSRT write(iunit,ERR=101) rt_domain(did)%soldrain write(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_lsm if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1 .or. nlst(did)%GWBASESWCRT .ne. 0) then if(nlst(did)%CHANRTSWCRT.EQ.1) then write(iunit,ERR=101) rt_domain(did)%HLINK write(iunit,ERR=101) rt_domain(did)%QLINK(:,1) write(iunit,ERR=101) rt_domain(did)%QLINK(:,2) write(iunit,ERR=101) rt_domain(did)%cvol write(iunit,ERR=101) rt_domain(did)%resht write(iunit,ERR=101) rt_domain(did)%qlakeo write(iunit,ERR=101) rt_domain(did)%qlakei write(iunit,ERR=101) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake end if if(nlst(did)%GWBASESWCRT.EQ.1.OR.nlst(did)%GWBASESWCRT.GE.4) then write(iunit,ERR=101) rt_domain(did)%z_gwsubbas end if if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1) then write(iunit,ERR=101) rt_domain(did)%overland%control%boundary_flux write(iunit,ERR=101) rt_domain(did)%INFXSWGT write(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_routing write(iunit,ERR=101) rt_domain(did)%SH2OWGT write(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT_ACC !AD_CHANGE: Not needed in RESTART !write(iunit,ERR=101) rt_domain(did)%RETDEPRT endif end if close(iunit) endif call mpp_land_sync() i0 = i0 + istep ie = ie + istep end do ! end do of i loop return 101 continue call hydro_stop("FATAL ERROR: failed to output the hydro restart file.") end subroutine RESTART_OUT_bi subroutine RESTART_in_bi(inFileTmp,did) implicit none integer did character(len=*) inFileTmp character(len=256) inFile character(len=19) str_tmp integer :: iunit logical :: fexist integer :: i0,ie, i, istep iunit = 81 if(my_id .lt. 10) then write(str_tmp,'(I1)') my_id else if(my_id .lt. 100) then write(str_tmp,'(I2)') my_id else if(my_id .lt. 1000) then write(str_tmp,'(I3)') my_id else if(my_id .lt. 10000) then write(str_tmp,'(I4)') my_id else if(my_id .lt. 100000) then write(str_tmp,'(I5)') my_id endif inFile = trim(inFileTmp)//"."//str_tmp inquire (file=trim(inFile), exist=fexist) if(.not. fexist) then call hydro_stop("In RESTART_in_bi()- Could not find restart file "//trim(inFile)) endif istep = 64 i0 = 0 ie = istep do i = 0, numprocs,istep if(my_id .ge. i0 .and. my_id .lt. ie) then open(iunit, file = inFile, form="unformatted",ERR=101,access="sequential") read(iunit,ERR=101) rt_domain(did)%his_out_counts ! read(iunit,ERR=101) nlst_rt(did)%olddate(1:19) read(iunit,ERR=101) nlst(did)%sincedate(1:19) ! read(iunit,ERR=101) nlst_rt(did)%DTCT read(iunit,ERR=101) rt_domain(did)%stc read(iunit,ERR=101) rt_domain(did)%smc read(iunit,ERR=101) rt_domain(did)%sh2ox read(iunit,ERR=101) rt_domain(did)%SMCMAX1 read(iunit,ERR=101) rt_domain(did)%SMCREF1 read(iunit,ERR=101) rt_domain(did)%SMCWLT1 read(iunit,ERR=101) rt_domain(did)%INFXSRT read(iunit,ERR=101) rt_domain(did)%soldrain read(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_lsm if(nlst(did)%SUBRTSWCRT.EQ.0.and.nlst(did)%OVRTSWCRT.EQ.0) rt_domain(did)%overland%control%surface_water_head_lsm = 0 if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1 .or. nlst(did)%GWBASESWCRT .ne. 0) then if(nlst(did)%CHANRTSWCRT.EQ.1) then read(iunit,ERR=101) rt_domain(did)%HLINK read(iunit,ERR=101) rt_domain(did)%QLINK(:,1) read(iunit,ERR=101) rt_domain(did)%QLINK(:,2) read(iunit,ERR=101) rt_domain(did)%cvol read(iunit,ERR=101) rt_domain(did)%resht read(iunit,ERR=101) rt_domain(did)%qlakeo read(iunit,ERR=101) rt_domain(did)%qlakei read(iunit,ERR=101) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake end if if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then read(iunit,ERR=101) rt_domain(did)%z_gwsubbas end if if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1) then read(iunit,ERR=101) rt_domain(did)%overland%control%boundary_flux read(iunit,ERR=101) rt_domain(did)%INFXSWGT read(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_routing read(iunit,ERR=101) rt_domain(did)%SH2OWGT read(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT_ACC !AD_CHANGE: This is overwriting the RETDEPRTFAC version, so causes issues when changing that factor. !No need to have in restart since live calculated. !read(iunit,ERR=101) rt_domain(did)%RETDEPRT endif end if close(iunit) endif call mpp_land_sync() i0 = i0 + istep ie = ie + istep end do ! end do of i loop return 101 continue call hydro_stop("In RESTART_in_bi() - failed to read the hydro restart file "//trim(inFile)) end subroutine RESTART_in_bi #endif subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) implicit none integer:: ncid,ix,jx,varid , iret character(len=*) varName real, dimension(ix,jx):: inVar #ifdef MPP_LAND real, allocatable, dimension(:,:) :: varTmp if(my_id .eq. io_id ) then allocate(varTmp(global_rt_nx, global_rt_ny)) else allocate(varTmp(1,1)) endif call write_IO_rt_real(inVar,varTmp) if(my_id .eq. IO_id) then iret = nf90_inq_varid(ncid,varName, varid) if(iret .eq. 0) then iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_rt_nx,global_rt_ny/)) else write(6,*) "Error: variable not defined in rst file before write: ", varName endif endif if(allocated(varTmp)) deallocate(varTmp) #else iret = nf90_inq_varid(ncid,varName, varid) if(iret .eq. 0) then iret = nf90_put_var(ncid, varid, inVar, (/1,1/), (/ix,jx/)) else write(6,*) "Error : variable not defined in rst file before write: ", varName endif #endif end subroutine w_rst_rt_nc2 subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) implicit none integer:: ncid,ix,jx,varid , iret, nsoil character(len=*) varName real,dimension(ix,jx,nsoil):: inVar character(len=2) tmpStr integer k #ifdef MPP_LAND real varTmp(global_rt_nx,global_rt_ny) do k = 1, nsoil call write_IO_rt_real(inVar(:,:,k),varTmp(:,:)) if(my_id .eq. IO_id) then if( k .lt. 10) then write(tmpStr, '(i1)') k else write(tmpStr, '(i2)') k endif iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid) iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_rt_nx,global_rt_ny/)) endif end do #else do k = 1, nsoil if( k .lt. 10) then write(tmpStr, '(i1)') k else write(tmpStr, '(i2)') k endif iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid) iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/)) end do #endif end subroutine w_rst_rt_nc3 subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) implicit none integer:: ncid,ix,jx,varid , iret character(len=*) varName real inVar(ix,jx) #ifdef MPP_LAND real varTmp(global_nx,global_ny) call write_IO_real(inVar,varTmp) if(my_id .eq. IO_id) then iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_nx,global_ny/)) endif #else iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, invar, (/1,1/), (/ix,jx/)) #endif end subroutine w_rst_nc2 subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) implicit none integer:: ncid,ix,jx,varid , iret, nsoil character(len=*) varName real inVar(ix,jx,nsoil) integer k character(len=2) tmpStr #ifdef MPP_LAND real varTmp(global_nx,global_ny) do k = 1, nsoil call write_IO_real(inVar(:,:,k),varTmp(:,:)) if(my_id .eq. IO_id) then if( k .lt. 10) then write(tmpStr, '(i1)') k else write(tmpStr, '(i2)') k endif iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid) iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_nx,global_ny/)) endif end do #else do k = 1, nsoil if( k .lt. 10) then write(tmpStr, '(i1)') k else write(tmpStr, '(i2)') k endif iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid) iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/)) end do #endif end subroutine w_rst_nc3 subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & #ifdef MPP_LAND ,nodelist & #endif ) implicit none integer:: ncid,n,varid , iret character(len=*) varName real inVar(n) #ifdef MPP_LAND integer:: nodelist(n) if(n .eq. 0) return call write_lake_real(inVar,nodelist,n) if(my_id .eq. IO_id) then #endif iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #ifdef MPP_LAND endif #endif end subroutine w_rst_crt_nc1_lake subroutine w_rst_crt_reach_real(ncid,inVar,varName & #ifdef MPP_LAND , gnlinksl& #endif ) implicit none integer:: ncid,varid , iret, n character(len=*) varName real, dimension(:) :: inVar #ifdef MPP_LAND integer:: gnlinksl real,allocatable,dimension(:) :: g_var if(my_id .eq. io_id) then allocate(g_var(gnlinksl)) g_var = 0 else allocate(g_var(1) ) endif call ReachLS_write_io(inVar, g_var) if(my_id .eq. IO_id) then iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinksl/)) endif if(allocated(g_var)) deallocate(g_var) #else n = size(inVar,1) iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #endif end subroutine w_rst_crt_reach_real subroutine w_rst_crt_reach_real8(ncid,inVar,varName & #ifdef MPP_LAND , gnlinksl& #endif ) implicit none integer:: ncid,varid , iret, n character(len=*) varName real*8, dimension(:) :: inVar #ifdef MPP_LAND integer:: gnlinksl real*8,allocatable,dimension(:) :: g_var if(my_id .eq. io_id) then allocate(g_var(gnlinksl)) g_var = 0 else allocate(g_var(1) ) endif call ReachLS_write_io(inVar, g_var) if(my_id .eq. IO_id) then iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinksl/)) endif if(allocated(g_var)) deallocate(g_var) #else n = size(inVar,1) iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #endif end subroutine w_rst_crt_reach_real8 subroutine w_rst_crt_nc1(ncid,n,inVar,varName & #ifdef MPP_LAND ,map_l2g, gnlinks& #endif ) implicit none integer:: ncid,n,varid , iret character(len=*) varName real inVar(n) #ifdef MPP_LAND integer:: gnlinks, map_l2g(n) real g_var(gnlinks) call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var) if(my_id .eq. IO_id) then iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinks/)) #else iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #endif #ifdef MPP_LAND endif #endif end subroutine w_rst_crt_nc1 subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) implicit none integer:: ncid,n,varid , iret character(len=*) varName real,dimension(:) :: inVar #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #ifdef MPP_LAND endif #endif end subroutine w_rst_crt_nc1g subroutine w_rst_gwbucket_real(ncid,numbasns,gnumbasns, & basnsInd, inV,vName ) implicit none integer :: ncid,numbasns,gnumbasns integer(kind=int64), dimension(:) :: basnsInd real, dimension(:) :: inV character(len=*) :: vName integer i, j, k real, allocatable,dimension(:) :: buf #ifdef MPP_LAND if (my_id .eq. IO_id) then allocate(buf(gnumbasns)) else allocate(buf(1)) endif call gw_write_io_real(numbasns,inV,basnsInd,buf) #else allocate(buf(gnumbasns)) do k = 1, numbasns buf(basnsInd(k)) = inV(k) end do #endif call w_rst_crt_nc1g(ncid,gnumbasns,buf,vName) if(allocated(buf)) deallocate(buf) end subroutine w_rst_gwbucket_real subroutine read_rst_gwbucket_real(ncid,outV,numbasns,& gnumbasns,basnsInd, vName) implicit none integer :: ncid,numbasns,gnumbasns integer(kind=int64), dimension(:) :: basnsInd real, dimension(:) :: outV character(len=*) :: vName integer i, j,k real, dimension(gnumbasns) :: buf call read_rst_crt_nc(ncid,buf,gnumbasns,vName) do k = 1, numbasns outV(k) = buf(basnsInd(k)) end do end subroutine read_rst_gwbucket_real subroutine RESTART_IN_NC(inFile,did) implicit none character(len=*) inFile integer :: ierr, iret,ncid, did integer :: channel_only_in, channelBucket_only_in integer :: i, j #ifdef MPP_LAND if(IO_id .eq. my_id) then #endif !open a netcdf file iret = nf90_open(trim(inFile), NF90_NOWRITE, ncid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then write(*,'("Problem opening file: ''", A, "''")') & trim(inFile) call hydro_stop("In RESTART_IN_NC() - Problem opening file") endif #ifdef MPP_LAND if(IO_id .eq. my_id) then #endif !! Dont use a restart from a channel_only run if you're not running channel_only iret = nf90_get_att(ncid, NF90_GLOBAL, "channel_only", channel_only_in) if(iret .eq. 0) then !! If channel_only attribute prsent, then proceed with this logic iret = nf90_get_att(ncid, NF90_GLOBAL, "channelBucket_only", channelBucket_only_in) iret=0 ! borrow the variable for our own error flagging !! Hierarchy of model restarting ability. !! 1) Full model restarts: all model runs (full, channel_only and channelBucket_only) !! No test needed here. !! 2) channelBucket_only restarts: channelBucket_only and channel_only runs if(channelBucket_only_in .eq. 1) then if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) iret=1 end if !! 3) channel_only restarts: only channel_only runs if(channel_only_in .eq. 1) then if(nlst(did)%channel_only .eq. 0) iret=1 end if if(iret .eq. 1) then !! JLM Why dont we adopt this strategy elsewhere, e.g. define logUnit as a module variable. !! JLM Would massively cut down on #ifdefs and repetitive code in certain parts of the code. #ifdef NCEP_WCOSS logUnit=78 #else logUnit=6 #endif write(logUnit,*) 'Restart is not respecting the hierarchy of model restarting ability:' write(logUnit,*) '1) Full model restarts: all model runs (full, channel_only and channelBucket_only),' write(logUnit,*) '2) channelBucket_only restarts: channelBucket_only and channel_only runs,' write(logUnit,*) '3) channel_only restarts: only channel_only runs.' write(logUnit,*) 'Diagnostics:' write(logUnit,*) 'channel_only restart present:', channel_only_in write(logUnit,*) 'channel_only run:', nlst(did)%channel_only write(logUnit,*) 'channelBucket_only restart present:', channelBucket_only_in write(logUnit,*) 'channelBucket_only run:', nlst(did)%channelBucket_only call flush(logUnit) call hydro_stop('Channel Only: Restart file in consistent with forcing type.') end if end if iret = nf90_get_att(ncid, NF90_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) iret = nf90_get_att(ncid, NF90_GLOBAL, 'DTCT', nlst(did)%DTCT) iret = nf90_get_att(ncid,NF90_GLOBAL,"Since_Date",nlst(did)%sincedate(1:19)) ! if( nlst(did)%channel_only .eq. 1 .or. & ! nlst(did)%channelBucket_only .eq. 1 ) & ! iret = nf90_get_att(ncid,NF90_GLOBAL,"Restart_Time",nlst(did)%olddate(1:19)) if(iret /= 0) nlst(did)%sincedate = nlst(did)%startdate if(nlst(did)%DTCT .gt. 0) then nlst(did)%DTCT = min(nlst(did)%DTCT, nlst(did)%DTRT_CH) else nlst(did)%DTCT = nlst(did)%DTRT_CH endif #ifdef MPP_LAND endif !yw call mpp_land_bcast_int1(rt_domain(did)%out_counts) ! Not sure what caused the problem. added out_counts = 1 as a temporary fix for the hydro output. rt_domain(did)%out_counts = 1 call mpp_land_bcast_real1(nlst(did)%DTCT) !if( nlst_rt(did)%channel_only .eq. 1 .or. & ! nlst_rt(did)%channelBucket_only .eq. 1 ) & ! call mpp_land_bcast_char(19, nlst_rt(did)%olddate) !! call mpp_land_bcast_char(19, nlst_rt(did)%sincedate) ! why not? we read it in. #endif #ifdef HYDRO_D write(6,*) "nlst(did)%nsoil=",nlst(did)%nsoil #endif if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then if(nlst(did)%rst_typ .eq. 1 ) then call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc") call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc") call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt") call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt") call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain") end if ! rst_typ .eq. 1 !yw check !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1") !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1") endif ! neither channel_only nor channelBucket_only if(nlst(did)%SUBRTSWCRT .eq. 1 .or. & nlst(did)%OVRTSWCRT .eq. 1 .or. & nlst(did)%GWBASESWCRT .ne. 0 ) then !! JLM ?? restarting channel depends on these options? if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt") call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%surface_water_head_routing,"sfcheadsubrt") call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%boundary_flux,"QBDRYRT") call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT_ACC,"qstrmvolrt") !AD_CHANGE: This is overwriting the RETDEPRTFAC version, so causes issues when changing that factor. !No need to have in restart since live calculated. !call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%properties%retention_depth,"RETDEPRT") call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt") endif end if ! neither channel_only nor channelBucket_only if(nlst(did)%CHANRTSWCRT.eq.1) then if(nlst(did)%channel_option .eq. 3) then !! Have not setup channel_only for gridded routing YET call read_rst_crt_stream_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) call read_rst_crt_stream_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) else call read_rst_crt_reach_nc(ncid,rt_domain(did)%HLINK,"hlink",rt_domain(did)%GNLINKSL,fatalErr=.FALSE.) call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,1),"qlink1",rt_domain(did)%GNLINKSL) call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,2),"qlink2",rt_domain(did)%GNLINKSL) !call read_rst_crt_reach_nc(ncid,rt_domain(did)%CVOL,"cvol",rt_domain(did)%GNLINKSL) !if(nlst_rt(did)%UDMP_OPT .eq. 1) then ! read in the statistic value !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accSfcLatRunoff,"accSfcLatRunoff",rt_domain(did)%GNLINKSL) !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accQLateral,"accQLateral",rt_domain(did)%GNLINKSL) !call read_rst_crt_reach_nc(ncid,rt_domain(did)%qSfcLatRunoff,"qSfcLatRunoff",rt_domain(did)%GNLINKSL) !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accBucket,"accBucket",rt_domain(did)%GNLINKS) !endif endif if(rt_domain(did)%NLAKES .gt. 0) then call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht") call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo") call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEI,rt_domain(did)%NLAKES,"qlakei") endif if( nlst(did)%channel_only .eq. 0 .and. & nlst(did)%channelBucket_only .eq. 0 ) then if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake,"lake_inflort") endif end if end if ! end if(nlst_rt(did)%CHANRTSWCRT.eq.1) if((nlst(did)%GWBASESWCRT .eq. 1 .or. & nlst(did)%GWBASESWCRT .ge. 4) .and. & nlst(did)%GW_RESTART .ne. 0 .and. & rt_domain(did)%gnumbasns .gt. 0) then if(nlst(did)%channel_only .eq. 0) then if(nlst(did)%UDMP_OPT .eq. 1) then call read_rst_crt_reach_nc(ncid,rt_domain(did)%z_gwsubbas,"z_gwsubbas",rt_domain(did)%GNLINKSL) else call read_rst_gwbucket_real(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,& rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd, "z_gwsubbas") endif end if ! if( nlst_rt(did)%channel_only .eq. 0 ) then end if ! end if((nlst_rt(did)%GWBASESWCRT .eq. 1 .or. nlst_rt(did)%GWBASESWCRT .ge. 4) .and. & ! nlst_rt(did)%GW_RESTART .ne. 0 .and. & ! rt_domain(did)%gnumbasns .gt. 0 ) !! JLM: WHat is this option?? if(nlst(did)%GWBASESWCRT.eq.3) then if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho,"HEAD") endif end if end if ! end if(nlst_rt(did)%SUBRTSWCRT .eq. 1 .or. & ! nlst_rt(did)%OVRTSWCRT .eq. 1 .or. & ! nlst_rt(did)%GWBASESWCRT .ne. 0 ) !! Resetting these after writing the t=0 output file instead so that no information is !! lost. !if(nlst_rt(did)%rstrt_swc.eq.1) then !Switch for rest of restart accum vars... !#ifdef HYDRO_D ! print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc !#endif !! JLM: !! Reset of accumulation variables move to end of subroutine !! Routing/module_HYDRO_drv.F: HYDRO_ini !! See comments there. !! Conensed, commented code: !! rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake=0.!rt_domain(did)%surface_water_to_channel=0. !end if #ifdef MPP_LAND if(my_id .eq. IO_id) & #endif iret = nf90_close(ncid) #ifdef HYDRO_D write(6,*) "end of RESTART_IN" call flush(6) #endif end subroutine RESTART_IN_nc subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr) implicit none integer :: ix,jx,nsoil, ireg, ncid, varid, iret real,dimension(ix,jx,nsoil) :: var character(len=*) :: varStr character(len=2) :: tmpStr integer :: n integer i #ifdef MPP_LAND real,dimension(global_nx,global_ny) :: xtmp #endif do i = 1, nsoil #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif if( i .lt. 10) then write(tmpStr, '(i1)') i else write(tmpStr, '(i2)') i endif iret = nf90_inq_varid(ncid, trim(varStr)//trim(tmpStr), varid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif return endif #ifdef HYDRO_D print*, "read restart variable ", varStr//trim(tmpStr) #endif #ifdef MPP_LAND if(my_id .eq. IO_id) & iret = nf90_get_var(ncid, varid, xtmp) call decompose_data_real(xtmp(:,:), var(:,:,i)) #else iret = nf90_get_var(ncid, varid, var(:,:,i)) #endif end do end subroutine read_rst_nc3 subroutine read_rst_nc2(ncid,ix,jx,var,varStr) implicit none integer :: ix,jx,ireg, ncid, varid, iret real,dimension(ix,jx) :: var character(len=*) :: varStr #ifdef MPP_LAND real,dimension(global_nx,global_ny) :: xtmp if(my_id .eq. IO_id) & #endif iret = nf90_inq_varid(ncid, trim(varStr), varid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif return endif #ifdef HYDRO_D print*, "read restart variable ", varStr #endif #ifdef MPP_LAND if(my_id .eq. IO_id) & iret = nf90_get_var(ncid, varid, xtmp) call decompose_data_real(xtmp, var) #else var = 0.0 iret = nf90_get_var(ncid, varid, var) #endif end subroutine read_rst_nc2 subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) implicit none integer :: ix,jx,nsoil, ireg, ncid, varid, iret real,dimension(ix,jx,nsoil) :: var character(len=*) :: varStr character(len=2) :: tmpStr integer i #ifdef MPP_LAND real,dimension(global_rt_nx,global_rt_ny) :: xtmp #endif do i = 1, nsoil if( i .lt. 10) then write(tmpStr, '(i1)') i else write(tmpStr, '(i2)') i endif #ifdef MPP_LAND if(my_id .eq. IO_id) & #endif iret = nf90_inq_varid(ncid, trim(varStr)//trim(tmpStr), varid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif return endif #ifdef HYDRO_D print*, "read restart variable ", varStr//trim(tmpStr) #endif #ifdef MPP_LAND iret = nf90_get_var(ncid, varid, xtmp) call decompose_RT_real(xtmp(:,:),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx) #else iret = nf90_get_var(ncid, varid, var(:,:,i)) #endif end do end subroutine read_rst_rt_nc3 subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) implicit none integer :: ix,jx,ireg, ncid, varid, iret real,dimension(ix,jx) :: var character(len=*) :: varStr #ifdef MPP_LAND real,dimension(global_rt_nx,global_rt_ny) :: xtmp #endif iret = nf90_inq_varid(ncid, trim(varStr), varid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif return endif #ifdef HYDRO_D print*, "read restart variable ", varStr #endif #ifdef MPP_LAND if(my_id .eq. IO_id) & iret = nf90_get_var(ncid, varid, xtmp) call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) #else iret = nf90_get_var(ncid, varid, var) #endif end subroutine read_rst_rt_nc2 subroutine read_rt_nc2(ncid,ix,jx,var,varStr) implicit none integer :: ix,jx, ncid, varid, iret real,dimension(ix,jx) :: var character(len=*) :: varStr #ifdef MPP_LAND real,allocatable, dimension(:,:) :: xtmp !yw real,dimension(global_rt_nx,global_rt_ny) :: xtmp if(my_id .eq. io_id ) then allocate(xtmp(global_rt_nx,global_rt_ny)) else allocate(xtmp(1,1)) endif xtmp = 0.0 #endif iret = nf90_inq_varid(ncid, trim(varStr), varid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif return endif #ifdef HYDRO_D print*, "read restart variable ", varStr #endif #ifdef MPP_LAND if(my_id .eq. IO_id) then iret = nf90_get_var(ncid, varid, xtmp) endif call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) if(allocated(xtmp)) deallocate(xtmp) #else iret = nf90_get_var(ncid, varid, var) #endif end subroutine read_rt_nc2 subroutine read_rst_crt_nc(ncid,var,n,varStr) implicit none integer :: ireg, ncid, varid, n, iret real,dimension(n) :: var character(len=*) :: varStr if( n .le. 0) return #ifdef MPP_LAND if(my_id .eq. IO_id) & #endif iret = nf90_inq_varid(ncid, trim(varStr), varid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif return endif #ifdef HYDRO_D print*, "read restart variable ", varStr #endif #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif iret = nf90_get_var(ncid, varid, var) #ifdef MPP_LAND endif if(n .gt. 0) then call mpp_land_bcast_real(n,var) endif #endif end subroutine read_rst_crt_nc subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) implicit none integer :: ncid, varid, n, iret, gnlinks integer, intent(in), dimension(:) :: map_l2g character(len=*) :: varStr integer :: l, g real,intent(out) , dimension(:) :: var_out #ifdef MPP_LAND real,dimension(gnlinks) :: var #else real,dimension(n) :: var #endif #ifdef MPP_LAND if(my_id .eq. IO_id) & #endif iret = nf90_inq_varid(ncid, trim(varStr), varid) #ifdef MPP_LAND call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif return endif #ifdef HYDRO_D print*, "read restart variable ", varStr #endif #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif var = 0.0 iret = nf90_get_var(ncid, varid, var) #ifdef MPP_LAND endif if(gnlinks .gt. 0) then call mpp_land_bcast_real(gnlinks,var) endif if(n .le. 0) return var_out = 0 do l = 1, n g = map_l2g(l) var_out(l) = var(g) end do #else var_out = var #endif end subroutine read_rst_crt_stream_nc subroutine read_rst_crt_reach_nc_real(ncid,var_out,varStr,gnlinksl, fatalErr) implicit none integer :: ncid, varid, n, iret, gnlinksl character(len=*) :: varStr integer :: l, g real, dimension(:) :: var_out logical, optional, intent(in) :: fatalErr logical :: fatalErr_local real :: scale_factor, add_offset integer :: ovrtswcrt_in, ss real,allocatable,dimension(:) :: var, varTmp fatalErr_local = .false. if(present(fatalErr)) fatalErr_local=fatalErr n = size(var_out,1) #ifdef MPP_LAND if(my_id .eq. IO_id) then allocate(var(gnlinksl)) else allocate(var(1)) endif #else allocate(var(n)) #endif #ifdef MPP_LAND if(my_id .eq. IO_id) then iret = nf90_inq_varid(ncid, trim(varStr), varid) endif call mpp_land_bcast_int1(iret) if (iret /= 0) then #ifdef HYDRO_D print*, 'read_rst_crt_reach_nc: variable not found: name = "', trim(varStr)//'"' #endif if(allocated(var)) deallocate(var) !! JLM: is this desirable? !! JLM I think so, maybe an option to this routine specifying if errors are fatal? if (fatalErr_local) & call hydro_stop("read_rst_crt_reach_nc: variable not found: "//trim(varStr)) return endif if(my_id .eq. IO_id) then #ifdef HYDRO_D print*, "read restart variable ", varStr call flush(6) #endif var = 0.0 iret = nf90_get_var(ncid, varid, var) !! JLM: need a check here. iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor) if(iret .eq. 0) var = var * scale_factor iret = nf90_get_att(ncid, varid, 'add_offset', add_offset) if(iret .eq. 0) var = var + add_offset !! NWM channel-only forcings have to be "decoded"/unshuffled. !! As of NWM1.2 the following global attribute is different/identifiable !! for files created when io_form_outputs=1,2 (not 0). iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_OVRTSWCRT', ovrtswcrt_in) if((nlst(did)%channel_only .eq. 1 .or. nlst(did)%channelBucket_only .eq. 1) .and. & iret .eq. 0) then allocate(varTmp(gnlinksl)) do ss=1,gnlinksl varTmp(rt_domain(did)%ascendIndex(ss)+1)=var(ss) end do var=varTmp deallocate(varTmp) end if endif call ReachLS_decomp(var, var_out) if(allocated(var)) deallocate(var) #else iret = nf90_inq_varid(ncid, trim(varStr), varid) if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif if(allocated(var)) deallocate(var) return endif #ifdef HYDRO_D print*, "read restart variable ", varStr #endif iret = nf90_get_var(ncid, varid, var_out) if(allocated(var)) deallocate(var) #endif end subroutine read_rst_crt_reach_nc_real subroutine read_rst_crt_reach_nc_real8(ncid, var_out, varStr, gnlinksl, fatalErr) implicit none integer, intent(in) :: ncid, gnlinksl real*8, dimension(:), intent(inout) :: var_out character(len=*), intent(in) :: varStr logical, optional, intent(in) :: fatalErr integer :: varid, n, iret, l, g logical :: fatalErr_local real*8,allocatable,dimension(:) :: var real :: scale_factor, add_offset fatalErr_local = .false. if(present(fatalErr)) fatalErr_local=fatalErr n = size(var_out,1) #ifdef MPP_LAND if(my_id .eq. IO_id) then allocate(var(gnlinksl)) else allocate(var(1)) endif #else allocate(var(n)) #endif #ifdef MPP_LAND if(my_id .eq. IO_id) then iret = nf90_inq_varid(ncid, trim(varStr), varid) endif call mpp_land_bcast_int1(iret) if (iret /= 0) then #ifdef HYDRO_D print*, 'read_rst_crt_reach_nc: variable not found: name = "', trim(varStr)//'"' #endif if(allocated(var)) deallocate(var) !! JLM: is this desirable? !! JLM I think so, maybe an option to this routine specifying if errors are fatal? if (fatalErr_local) & call hydro_stop("read_rst_crt_reach_nc: variable not found: "//trim(varStr)) return endif #ifdef HYDRO_D print*, "read restart variable ", varStr call flush(6) #endif if(my_id .eq. IO_id) then var = 0.0 iret = nf90_get_var(ncid, varid, var) !! JLM need a check here... iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor) if(iret .eq. 0) var = var * scale_factor iret = nf90_get_att(ncid, varid, 'add_offset', add_offset) if(iret .eq. 0) var = var + add_offset endif call ReachLS_decomp(var, var_out) if(allocated(var)) deallocate(var) #else iret = nf90_inq_varid(ncid, trim(varStr), varid) if (iret /= 0) then #ifdef HYDRO_D print*, 'variable not found: name = "', trim(varStr)//'"' #endif if(allocated(var)) deallocate(var) return endif #ifdef HYDRO_D print*, "read restart variable ", varStr #endif iret = nf90_get_var(ncid, varid, var_out) if(allocated(var)) deallocate(var) #endif end subroutine read_rst_crt_reach_nc_real8 subroutine hrldas_out() end subroutine hrldas_out subroutine READ_CHROUTING1( & IXRT, JXRT, fgDEM, CH_NETRT, & CH_LNKRT, LAKE_MSKRT, FROM_NODE, TO_NODE, & TYPEL, ORDER, MAXORDER, NLINKS, & NLAKES, CHANLEN, MannN, So, & ChSSlp, Bw, Tw, & Tw_CC, n_CC, ChannK, HRZAREA, LAKEMAXH, & WEIRH, WEIRC, WEIRL, DAML, & ORIFICEC, ORIFICEA, ORIFICEE, & reservoir_type_specified, reservoir_type, & reservoir_parameter_file, LATLAKE, LONLAKE, & ELEVLAKE, dist, ZELEV, LAKENODE, & CH_NETLNK, CHANXI, CHANYJ, CHLAT, & CHLON, channel_option, LATVAL, LONVAL, & STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f, LAKEIDM, & UDMP_OPT & !! no comma at end #ifdef MPP_LAND ,Link_Location & #endif ) #ifdef MPP_LAND use module_mpp_land, only: my_id, io_id #endif integer, intent(IN) :: IXRT,JXRT, UDMP_OPT integer :: CHANRTSWCRT, NLINKS, NLAKES real, intent(IN), dimension(IXRT,JXRT) :: fgDEM integer, dimension(IXRT,JXRT) :: DIRECTION integer, dimension(IXRT,JXRT) :: GSTRMFRXSTPTS integer, intent(IN), dimension(IXRT,JXRT) :: CH_NETRT integer(kind=int64), intent(IN), dimension(IXRT,JXRT) :: CH_LNKRT integer, intent(INOUT), dimension(IXRT,JXRT) :: LAKE_MSKRT integer, dimension(IXRT,JXRT) :: GORDER !-- gridded stream orderk #ifdef MPP_LAND integer(kind=int64), dimension(IXRT,JXRT) :: Link_Location !-- gridded stream orderk integer :: LNLINKSL #endif integer :: I,J,K,channel_option real, intent(OUT), dimension(IXRT,JXRT) :: LATVAL, LONVAL character(len=28) :: dir !Dummy inverted grids from arc !----DJG,DNY New variables for channel and lake routing character(len=155) :: header integer(kind=int64), intent(INOUT), dimension(NLINKS) :: FROM_NODE real, intent(INOUT), dimension(NLINKS) :: ZELEV real, intent(INOUT), dimension(NLINKS) :: CHLAT,CHLON integer(kind=int64), intent(INOUT), dimension(NLINKS) :: TO_NODE integer, intent(INOUT), dimension(NLINKS) :: TYPEL integer, intent(INOUT), dimension(NLINKS) :: ORDER integer, intent(INOUT), dimension(NLINKS) :: STRMFRXSTPTS integer, intent(INOUT) :: MAXORDER real, intent(INOUT), dimension(NLINKS) :: CHANLEN !channel length real, intent(INOUT), dimension(NLINKS) :: MannN, So !mannings N integer(kind=int64), intent(INOUT), dimension(NLINKS) :: LAKENODE !,LINKID ! identifies which nodes pour into which lakes real, intent(IN) :: dist(ixrt,jxrt,9) integer(kind=int64), intent(IN), dimension(IXRT,JXRT) :: CH_NETLNK real, dimension(IXRT,JXRT) :: ChSSlpG,BwG,TwG,MannNG !channel properties real, dimension(IXRT,JXRT) :: Tw_CCG,n_CCG !channel properties of compound real, dimension(IXRT,JXRT) :: ChannKG !Channel Infiltration real, dimension(IXRT,JXRT) :: chanDepth, elrt !-- store the location x,y location of the channel element integer, intent(INOUT), dimension(NLINKS) :: CHANXI, CHANYJ integer(kind=int64), dimension(:) :: LAKEIDM !--reservoir/lake attributes logical, intent(IN) :: reservoir_type_specified real, intent(INOUT), dimension(:) :: HRZAREA real, intent(INOUT), dimension(:) :: LAKEMAXH, WEIRH real, intent(INOUT), dimension(:) :: WEIRC real, intent(INOUT), dimension(:) :: WEIRL real, intent(INOUT), dimension(:) :: DAML real, intent(INOUT), dimension(:) :: ORIFICEC real, intent(INOUT), dimension(:) :: ORIFICEA real, intent(INOUT), dimension(:) :: ORIFICEE integer, intent(INOUT), dimension(:) :: reservoir_type character(len=*), intent(in) :: reservoir_parameter_file real, intent(INOUT), dimension(:) :: LATLAKE,LONLAKE,ELEVLAKE real, intent(INOUT), dimension(:) :: ChSSlp, Bw, Tw real, intent(INOUT), dimension(:) :: Tw_CC, n_CC, ChannK ! channel properties of compund character(len=* ) :: geo_finegrid_flnm, route_lake_f character(len=256) :: var_name integer :: tmp, cnt, ncid, iret, jj,ct integer :: IOstatus integer(kind=int64) :: OUTLAKEID real :: gc,n integer :: did logical :: fexist did = 1 !--------------------------------------------------------- ! End Declarations !--------------------------------------------------------- !LAKEIDX = -999 !LAKELINKID = 0 MAXORDER = -9999 !initialize GSTRM GSTRMFRXSTPTS = -9999 !yw initialize the array. to_node = MAXORDER from_node = MAXORDER #ifdef MPP_LAND Link_location = MAXORDER #endif var_name = "LATITUDE" call nreadRT2d_real ( & var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) var_name = "LONGITUDE" call nreadRT2d_real( & var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) var_name = "LAKEGRID" call nreadRT2d_int(& var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) var_name = "FLOWDIRECTION" call nreadRT2d_int(& var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm)) var_name = "STREAMORDER" call nreadRT2d_int(& var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm)) var_name = "frxst_pts" call nreadRT2d_int(& var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm)) !!!Flip y-dimension of highres grids from exported Arc files... var_name = "CHAN_DEPTH" call nreadRT2d_real( & var_name,chanDepth,ixrt,jxrt,trim(geo_finegrid_flnm)) if(nlst(did)%GWBASESWCRT .eq. 3) then elrt = fgDEM - chanDepth else elrt = fgDEM !ywtmp endif ct = 0 ! temp fix for buggy Arc export... do j=1,jxrt do i=1,ixrt if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 end do end do cnt = 0 BwG = 0.0 TwG = 0.0 Tw_CCG = 0.0 n_CCG = 0.0 ChSSlpG = 0.0 MannNG = 0.0 TYPEL = 0 MannN = 0.0 Bw = 0.0 Tw = 0.0 Tw_CC = 0.0 n_CC = 0.0 ChSSlp = 0.0 ChannK = 0.0 ChannKG = 0.0 if (channel_option .eq. 3) then #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif if (NLAKES .gt. 0) then inquire (file=trim(route_lake_f), exist=fexist) if(fexist) then ! use netcdf lake file of LAKEPARM.nc iret = nf90_open(trim(route_lake_f), NF90_NOWRITE, ncid) if( iret .eq. 0 ) then iret = nf90_close(ncid) write(6,*) "Before read LAKEPARM from NetCDF ", trim(route_lake_f) write(6,*) "NLAKES = ", NLAKES call flush(6) call read_route_lake_netcdf(trim(route_lake_f),HRZAREA, & LAKEMAXH, WEIRH, WEIRC,WEIRL, DAML, ORIFICEC, & ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, & reservoir_parameter_file, LAKEIDM, latlake, lonlake, ELEVLAKE, NLAKES) else open(unit=79,file=trim(route_lake_f), form='formatted',status='old') write(6,*) "Before read LAKEPARM from text ", trim(route_lake_f) write(6,*) "NLAKES = ", NLAKES call flush(6) read(79,*) header !-- read the lake file do i=1, NLAKES read (79,*,err=5101) tmp, HRZAREA(i),LAKEMAXH(i), & WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& LATLAKE(i), LONLAKE(i),ELEVLAKE(i), WEIRH(i), reservoir_type(i) enddo 5101 continue close(79) endif !endif for iret else ! lake parm files does not exist call hydro_stop("Fatal error: route_lake_f must be specified in the hydro.namelist") !write(6,*) "ERROR: route_lake_f required for lakes" !write(6,*) "NLAKES = ", NLAKES !call flush(6) endif !endif for fexist endif ! endif for nlakes #ifdef MPP_LAND endif if (NLAKES > 0) then call mpp_land_bcast_real(NLAKES,HRZAREA) call mpp_land_bcast_real(NLAKES,LAKEMAXH) call mpp_land_bcast_real(NLAKES,WEIRH ) call mpp_land_bcast_real(NLAKES,WEIRC ) call mpp_land_bcast_real(NLAKES,WEIRL ) call mpp_land_bcast_real(NLAKES,DAML) call mpp_land_bcast_real(NLAKES,ORIFICEC) call mpp_land_bcast_real(NLAKES,ORIFICEA) call mpp_land_bcast_real(NLAKES,ORIFICEE) call mpp_land_bcast_real(NLAKES,LATLAKE ) call mpp_land_bcast_real(NLAKES,LONLAKE ) call mpp_land_bcast_real(NLAKES,ELEVLAKE) call mpp_land_bcast_int(NLAKES, reservoir_type) endif #endif end if !! channel_option .eq. 3 if (UDMP_OPT .eq. 1) return !DJG inv DO j = JXRT,1,-1 !rows do j = 1,JXRT !rows do i = 1 ,IXRT !colsumns if (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order if ((DIRECTION(i, j) .eq. 64) .and. (j + 1 .le. JXRT) ) then !North if(CH_NETRT(i,j+1).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) FROM_NODE(cnt) = CH_NETLNK(i, j) TO_NODE(cnt) = CH_NETLNK(i, j + 1) CHANLEN(cnt) = dist(i,j,1) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else if ((DIRECTION(i, j) .eq. 128) .and. (i + 1 .le. IXRT) & .and. (j + 1 .le. JXRT) ) then !North East if(CH_NETRT(i+1,j+1).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) FROM_NODE(cnt) = CH_NETLNK(i, j) TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) CHANLEN(cnt) = dist(i,j,2) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else if ((DIRECTION(i, j) .eq. 1) .and. (i + 1 .le. IXRT) ) then !East if(CH_NETRT(i+1,j).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) FROM_NODE(cnt) = CH_NETLNK(i, j) TO_NODE(cnt) = CH_NETLNK(i + 1, j) CHANLEN(cnt) = dist(i,j,3) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else if ((DIRECTION(i, j) .eq. 2) .and. (i + 1 .le. IXRT) & .and. (j - 1 .ne. 0) ) then !south east if(CH_NETRT(i+1,j-1).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) FROM_NODE(cnt) = CH_NETLNK(i, j) TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) CHANLEN(cnt) = dist(i,j,4) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else if ((DIRECTION(i, j) .eq. 4) .and. (j - 1 .ne. 0) ) then !due south if(CH_NETRT(i,j-1).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) FROM_NODE(cnt) = CH_NETLNK(i, j) TO_NODE(cnt) = CH_NETLNK(i, j - 1) CHANLEN(cnt) = dist(i,j,5) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else if ((DIRECTION(i, j) .eq. 8) .and. (i - 1 .gt. 0) & .and. (j - 1 .ne. 0) ) then !south west if(CH_NETRT(i-1,j-1).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) FROM_NODE(cnt) = CH_NETLNK(i,j) TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) CHANLEN(cnt) = dist(i,j,6) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else if ((DIRECTION(i, j) .eq. 16) .and. (i - 1 .gt. 0) ) then !West if(CH_NETRT(i-1,j).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif FROM_NODE(cnt) = CH_NETLNK(i, j) ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) TO_NODE(cnt) = CH_NETLNK(i - 1, j) CHANLEN(cnt) = dist(i,j,7) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else if ((DIRECTION(i, j) .eq. 32) .and. (i - 1 .gt. 0) & .and. (j + 1 .le. JXRT) ) then !North West if(CH_NETRT(i-1,j+1).ge.0) then #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) FROM_NODE(cnt) = CH_NETLNK(i, j) TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) CHANLEN(cnt) = dist(i,j,8) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif endif else #ifdef HYDRO_D !print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east #endif end if end if !CH_NETRT check for this node end do end do #ifdef HYDRO_D print *, "after exiting the channel, this many nodes", cnt write(*,*) " " #endif !Find out if the boundaries are on an edge !DJG inv DO j = JXRT,1,-1 do j = 1,JXRT do i = 1 ,IXRT if (CH_NETRT(i, j) .ge. 0) then !get its direction if (DIRECTION(i, j).eq. 64) then if( j + 1 .gt. JXRT) then !-- 64's can only flow north goto 101 elseif ( CH_NETRT(i,j+1) .lt. 0) then !North goto 101 endif goto 102 101 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if(j+1 .gt. JXRT) then !-- an edge TYPEL(cnt) = 1 elseif(LAKE_MSKRT(i,j+1).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i,j+1) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,1) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D ! print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 102 continue else if ( DIRECTION(i, j) .eq. 128) then !-- 128's can flow out of the North or East edge if ((i + 1 .gt. IXRT) .or. (j + 1 .gt. JXRT)) then ! this is due north edge goto 201 elseif (CH_NETRT(i + 1, j + 1).lt.0) then !North East goto 201 endif !#endif goto 202 201 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if((i+1 .gt. IXRT) .or. (j+1 .gt. JXRT)) then ! an edge TYPEL(cnt) = 1 elseif(LAKE_MSKRT(i+1,j+1).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i+1,j+1) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,2) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D !print *, "Pour Point NE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 202 continue else if (DIRECTION(i, j) .eq. 1) then if(i + 1 .gt. IXRT) then !-- 1's can only flow due east goto 301 elseif(CH_NETRT(i + 1, j) .lt. 0) then !East goto 301 endif goto 302 301 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if(i+1 .gt. IXRT) then !an edge TYPEL(cnt) = 1 elseif(LAKE_MSKRT(i+1,j).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i+1,j) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,3) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D !print *, "Pour Point E", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 302 continue else if (DIRECTION(i, j) .eq. 2) then !-- 2's can flow out of east or south edge if((i + 1 .gt. IXRT) .or. (j - 1 .eq. 0)) then !-- this is the south edge goto 401 elseif (CH_NETRT(i + 1, j - 1) .lt.0) then !south east goto 401 endif goto 402 401 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if((i+1 .gt. IXRT) .or. (j-1 .eq. 0)) then !an edge TYPEL(cnt) = 1 elseif(LAKE_MSKRT(i+1,j-1).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,4) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D !print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 402 continue else if (DIRECTION(i, j) .eq. 4) then if(j - 1 .eq. 0) then !-- 4's can only flow due south goto 501 elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south goto 501 endif goto 502 501 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if(j-1 .eq. 0) then !- an edge TYPEL(cnt) =1 elseif(LAKE_MSKRT(i,j-1).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i,j-1) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,5) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D !print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 502 continue else if ( DIRECTION(i, j) .eq. 8) then !-- 8's can flow south or west if( (i - 1 .le. 0) .or. (j - 1 .eq. 0)) then !-- this is the south edge goto 601 elseif (CH_NETRT(i - 1, j - 1).lt.0) then !south west goto 601 endif goto 602 601 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if( (i-1 .eq. 0) .or. (j-1 .eq. 0) ) then !- an edge TYPEL(cnt) = 1 elseif(LAKE_MSKRT(i-1,j-1).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,6) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D !print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 602 continue else if (DIRECTION(i, j) .eq. 16) then if( i - 1 .le.0) then !16's can only flow due west goto 701 elseif( CH_NETRT(i - 1, j).lt.0) then !West goto 701 endif goto 702 701 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if(i-1 .eq. 0) then !-- an edge TYPEL(cnt) = 1 elseif(LAKE_MSKRT(i-1,j).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i-1,j) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,7) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D ! print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 702 continue else if ( DIRECTION(i, j) .eq. 32) then !-- 32's can flow either west or north if( (i - 1 .le. 0) .or. (j + 1 .gt. JXRT)) then !-- this is the north edge goto 801 elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West goto 801 endif goto 802 801 continue #ifdef MPP_LAND cnt = CH_NETLNK(i,j) #else cnt = cnt + 1 #endif ORDER(cnt) = GORDER(i,j) STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) ZELEV(cnt) = ELRT(i,j) MannN(cnt) = MannNG(i,j) ChSSlp(cnt) = ChSSlpG(i,j) Bw(cnt) = BwG(i,j) ChannK(cnt) = ChannKG(i,j) Tw(cnt) = TwG(i,j) Tw_CC(cnt) = Tw_CCG(i,j) n_CC(cnt) = n_CCG(i,j) CHLAT(cnt) = LATVAL(i,j) CHLON(cnt) = LONVAL(i,j) if( (i-1 .eq. 0) .or. (j+1 .gt. JXRT)) then !-- an edge TYPEL(cnt) = 1 elseif(LAKE_MSKRT(i-1,j+1).gt.0) then TYPEL(cnt) = 2 LAKENODE(cnt) = LAKE_MSKRT(i-1,j+1) else TYPEL(cnt) = 1 endif FROM_NODE(cnt) = CH_NETLNK(i, j) CHANLEN(cnt) = dist(i,j,8) CHANXI(cnt) = i CHANYJ(cnt) = j #ifdef MPP_LAND Link_Location(i,j) = cnt #endif #ifdef HYDRO_D !print *, "Pour Point NW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt #endif 802 continue endif endif !CH_NETRT check for this node end do end do #ifdef MPP_LAND #ifdef HYDRO_D print*, "my_id=",my_id, "cnt = ", cnt #endif #endif #ifdef MPP_LAND Link_location = CH_NETLNK call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,int(TYPEL, int64),NLINKS,99) call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,LAKENODE,NLINKS,99) #endif end subroutine READ_CHROUTING1 !! Author JLM. !! Separate the 2D channel routing memory from the vector/routelink channel routing memory. subroutine read_routelink(& TO_NODE, TYPEL, ORDER, MAXORDER, & NLAKES, MUSK, MUSX, & QLINK, CHANLEN, MannN, So, & ChSSlp, Bw, Tw, Tw_CC, & n_CC, ChannK, LAKEIDA, HRZAREA, & LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, & ORIFICEC, ORIFICEA, ORIFICEE, & reservoir_type_specified, reservoir_type, & reservoir_parameter_file, LATLAKE, & LONLAKE, ELEVLAKE, LAKEIDM, LAKEIDX, & route_link_f, route_lake_f, ZELEV, CHLAT, & CHLON, NLINKSL, LINKID, GNLINKSL, & NLINKS, gages, gageMiss ) integer, intent(INOUT), dimension(NLINKS) :: TYPEL, ORDER integer, intent(INOUT) :: MAXORDER integer :: NLAKES real, intent(INOUT), dimension(NLINKS) :: MUSK, MUSX real, intent(INOUT), dimension(:,:) :: QLINK !channel flow real, intent(INOUT), dimension(NLINKS) :: CHANLEN, MannN, So real, intent(INOUT), dimension(:) :: ChSSlp, Bw, Tw !added Top Width LKR/DY real, intent(INOUT), dimension(:) :: Tw_CC, n_CC !compound chnannel params real, intent(INOUT), dimension(:) :: ChannK !added ChanLoss real, intent(INOUT), dimension(:) :: HRZAREA real, intent(INOUT), dimension(:) :: LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML real, intent(INOUT), dimension(:) :: ORIFICEC, ORIFICEA, ORIFICEE logical, intent(IN) :: reservoir_type_specified integer, intent(INOUT), dimension(:) :: reservoir_type character(len=*), intent(in) :: reservoir_parameter_file real, intent(INOUT), dimension(:) :: LATLAKE, LONLAKE, ELEVLAKE integer(kind=int64), intent(INOUT), dimension(:) :: LAKEIDM !lake id in LAKEPARM table (.nc or .tbl) integer(kind=int64), intent(INOUT), dimension(:) :: LAKEIDA !lake COMid 4all link on full nlinks database integer, intent(INOUT), dimension(:) :: LAKEIDX !seq index of lakes(1:Nlakes) mapped to COMID character(len=256) :: route_link_f, route_lake_f real, intent(INOUT), dimension(NLINKS) :: ZELEV, CHLAT, CHLON integer :: NLINKS, NLINKSL integer(kind=int64), intent(INOUT), dimension(NLINKS) :: TO_NODE, LINKID ! which nodes pour into which lakes integer :: GNLINKSL character(len=15), intent(inout), dimension(nlinks) :: gages !! need to respect the default values character(len=15), intent(in) :: gageMiss integer :: did !! local variables integer(kind=int64), dimension(NLAKES) :: LAKELINKID !temporarily store the outlet index for each modeled lake did = 1 LAKELINKID = 0 call readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f,maxorder, & LINKID, TO_NODE, TYPEL, ORDER , & QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, & MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, ChannK, LAKEIDA, HRZAREA, & LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, ORIFICEC, & ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, & gages, gageMiss, LAKEIDM, NLAKES, latlake, lonlake,ELEVLAKE) !--- get the lake configuration here. #ifdef MPP_LAND call nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, & TO_NODE, LINKID, LAKEIDM, LAKEIDA, GNLINKSL ) !call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA #else call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA) #endif #ifdef MPP_LAND if (NLAKES > 0) then ! call mpp_land_bcast_int(NLINKSL,LAKEIDA) ! call mpp_land_bcast_int(NLINKSL,LAKEIDX) call mpp_land_bcast_real(NLAKES,HRZAREA) call mpp_land_bcast_int8(NLAKES,LAKEIDM) call mpp_land_bcast_real(NLAKES,LAKEMAXH) call mpp_land_bcast_real(NLAKES,WEIRH ) call mpp_land_bcast_real(NLAKES,WEIRC ) call mpp_land_bcast_real(NLAKES,WEIRL ) call mpp_land_bcast_real(NLAKES,DAML) call mpp_land_bcast_real(NLAKES,ORIFICEC) call mpp_land_bcast_real(NLAKES,ORIFICEA) call mpp_land_bcast_real(NLAKES,ORIFICEE) call mpp_land_bcast_real(NLAKES,LATLAKE ) call mpp_land_bcast_real(NLAKES,LONLAKE ) call mpp_land_bcast_real(NLAKES,ELEVLAKE) call mpp_land_bcast_int(NLAKES, reservoir_type) endif #endif end subroutine read_routelink subroutine readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f, maxorder, & LINKID, TO_NODE, TYPEL, ORDER , & QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, & MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, ChannK, LAKEIDA, HRZAREA, & LAKEMAXH,WEIRH, WEIRC, WEIRL, DAML, ORIFICEC, & ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, & gages, gageMiss, LAKEIDM,NLAKES, latlake, lonlake, ELEVLAKE) implicit none character(len=*) :: route_link_f,route_lake_f integer :: GNLINKSL, NLINKSL, tmp_from_node,NLAKES INTEGER, INTENT(INOUT) :: MAXORDER integer(kind=int64), intent(out), dimension(:) :: LAKEIDA, LINKID, TO_NODE INTEGER, intent(out), dimension(:) :: TYPEL, ORDER real,dimension(:,:) :: QLINK real, intent(out), dimension(:) :: CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN real, intent(out), dimension(:) :: MannN, So, ChSSlp, Bw, Tw, latlake, lonlake, Tw_CC, n_CC real, intent(out), dimension(:) :: ChannK character(len=15), dimension(:), intent(inout) :: gages character(len=15), intent(in) :: gageMiss !NLAKES integer(kind=int64), intent(out), dimension(:) :: LAKEIDM integer, intent(out), dimension(:) :: reservoir_type logical, intent(in) :: reservoir_type_specified character(len=*), intent(in) :: reservoir_parameter_file REAL, intent(out), dimension(:) :: HRZAREA,LAKEMAXH, WEIRC, WEIRL, DAML, ORIFICEC, WEIRH, & ORIFICEA, ORIFICEE, ELEVLAKE !end NLAKES INTEGER(kind=int64), dimension(GNLINKSL) :: tmpLAKEIDA, tmpLINKID, tmpTO_NODE INTEGER, dimension(GNLINKSL) :: tmpTYPEL, tmpORDER character(len=15), dimension(gnlinksl) :: tmpGages CHARACTER(len=155) :: header integer :: i character(len=256) :: route_link_f_r,route_lake_f_r integer :: lenRouteLinkFR,lenRouteLakeFR ! so the preceeding chan be changed without changing code logical :: routeLinkNetcdf, routeLakeNetcdf #ifdef MPP_LAND real :: tmpQLINK(GNLINKSL,2) real, allocatable, dimension(:) :: tmpCHLON, tmpCHLAT, tmpZELEV, tmpMUSK, tmpMUSX, tmpCHANLEN real, allocatable, dimension(:) :: tmpMannN, tmpSo, tmpChSSlp, tmpBw, tmpTw, tmpTw_CC, tmpn_CC real, allocatable, dimension(:) :: tmpChannK #endif !! is RouteLink file netcdf (*.nc) or csv (*.csv) route_link_f_r = adjustr(route_link_f) lenRouteLinkFR = len(route_link_f_r) routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq. '.nc' !! is RouteLake file netcdf (*.nc) or .TBL route_lake_f_r = adjustr(route_lake_f) lenRouteLakeFR = len(route_lake_f_r) routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc' #ifdef MPP_LAND tmpQLINK = 0 tmpGages = gageMiss if(my_id .eq. IO_id) then allocate(tmpCHLON(GNLINKSL)) allocate(tmpCHLAT(GNLINKSL)) allocate(tmpZELEV(GNLINKSL)) allocate(tmpMUSK(GNLINKSL)) allocate(tmpMUSX(GNLINKSL)) allocate(tmpCHANLEN(GNLINKSL)) allocate(tmpMannN(GNLINKSL)) allocate(tmpSo(GNLINKSL)) allocate(tmpChSSlp(GNLINKSL)) allocate(tmpBw(GNLINKSL)) allocate(tmpTw(GNLINKSL)) allocate(tmpTw_CC(GNLINKSL)) allocate(tmpn_CC(GNLINKSL)) allocate(tmpChannK(GNLINKSL)) if(routeLinkNetcdf) then call read_route_link_netcdf( & route_link_f, & tmpLINKID, tmpTO_NODE, tmpCHLON, & tmpCHLAT, tmpZELEV, tmpTYPEL, tmpORDER, & tmpQLINK(:,1), tmpMUSK, tmpMUSX, tmpCHANLEN, & tmpMannN, tmpSo, tmpChSSlp, tmpBw, & tmpTw, tmpTw_CC, tmpn_CC, tmpChannK, & tmpGages, tmpLAKEIDA ) else open(unit=17,file=trim(route_link_f),form='formatted',status='old') read(17,*) header #ifdef HYDRO_D print *, "header ", header, "NLINKSL = ", NLINKSL, GNLINKSL #endif call flush(6) do i=1,GNLINKSL read (17,*) tmpLINKID(i), tmp_from_node, tmpTO_NODE(i), tmpCHLON(i), & tmpCHLAT(i), tmpZELEV(i), tmpTYPEL(i), tmpORDER(i), & tmpQLINK(i,1), tmpMUSK(i), tmpMUSX(i), tmpCHANLEN(i), & tmpMannN(i), tmpSo(i), tmpChSSlp(i), tmpBw(i), & tmpTw(i), tmpTw_CC(i), tmpn_CC(i), tmpChannK(i) ! if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement if (tmpORDER(i) .gt. MAXORDER) MAXORDER = tmpORDER(i) end do close(17) end if ! routeLinkNetcdf if(routeLakeNetcdf) then call read_route_lake_netcdf(route_lake_f,HRZAREA, & LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, ORIFICEC, & ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, & LAKEIDM, latlake, lonlake, ELEVLAKE, NLAKES) endif !!- initialize channel if missing in input do i=1,GNLINKSL if(tmpQLINK(i,1) .le. 1e-3) then tmpQLINK(i,1) = 20.0 * (1.0/(float(MAXORDER+1) - float(tmpORDER(i))))**3 tmpQLINK(i,2) = tmpQLINK(i,1) !## initialize the current flow at each link endif end do endif ! my_id .eq. IO_id call ReachLS_decomp(tmpLINKID, LINKID ) call ReachLS_decomp(tmpLAKEIDA, LAKEIDA ) call ReachLS_decomp(tmpTO_NODE, TO_NODE) call ReachLS_decomp(tmpCHLON, CHLON ) call ReachLS_decomp(tmpCHLAT, CHLAT ) call ReachLS_decomp(tmpZELEV, ZELEV ) call ReachLS_decomp(tmpTYPEL, TYPEL ) call ReachLS_decomp(tmpORDER, ORDER ) call ReachLS_decomp(tmpQLINK(:,1), QLINK(:,1)) call ReachLS_decomp(tmpQLINK(:,2), QLINK(:,2)) call ReachLS_decomp(tmpMUSK, MUSK ) call ReachLS_decomp(tmpMUSX, MUSX ) call ReachLS_decomp(tmpCHANLEN, CHANLEN) call ReachLS_decomp(tmpMannN, MannN ) call ReachLS_decomp(tmpSo, So ) call ReachLS_decomp(tmpChSSlp, ChSSlp ) call ReachLS_decomp(tmpBw, Bw ) call ReachLS_decomp(tmpTw, Tw ) call ReachLS_decomp(tmpTw_CC, Tw_CC ) call ReachLS_decomp(tmpn_CC, n_CC ) call ReachLS_decomp(tmpChannK, ChannK ) ! call ReachLS_decomp(tmpHRZAREA, HRZAREA) ! call ReachLS_decomp(tmpLAKEMAXH, LAKEMAXH) ! call ReachLS_decomp(tmpWEIRC, WEIRC ) ! call ReachLS_decomp(tmpWEIRL, WEIRL ) ! call ReachLS_decomp(tmpORIFICEC, ORIFICEC) ! call ReachLS_decomp(tmpORIFICEA, ORIFICEA) ! call ReachLS_decomp(tmpORIFICEE, ORIFICEE) call ReachLS_decomp(tmpGages, gages) call mpp_land_bcast_int1(MAXORDER) if (NLAKES > 0) then call mpp_land_bcast_real(NLAKES, HRZAREA) call mpp_land_bcast_real(NLAKES, LAKEMAXH) call mpp_land_bcast_real(NLAKES, WEIRH) call mpp_land_bcast_real(NLAKES, WEIRC) call mpp_land_bcast_real(NLAKES, WEIRL) call mpp_land_bcast_real(NLAKES, DAML) call mpp_land_bcast_real(NLAKES, ORIFICEC) call mpp_land_bcast_real(NLAKES, ORIFICEA) call mpp_land_bcast_real(NLAKES, ORIFICEE) call mpp_land_bcast_int8(NLAKES, LAKEIDM) call mpp_land_bcast_real(NLAKES, ELEVLAKE) call mpp_land_bcast_int(NLAKES, reservoir_type) endif if(my_id .eq. io_id ) then if(allocated(tmpCHLON)) deallocate(tmpCHLON) if(allocated(tmpCHLAT)) deallocate(tmpCHLAT) if(allocated(tmpZELEV)) deallocate(tmpZELEV) if(allocated(tmpMUSK)) deallocate(tmpMUSK) if(allocated(tmpMUSX)) deallocate(tmpMUSX) if(allocated(tmpCHANLEN)) deallocate(tmpCHANLEN) if(allocated(tmpMannN)) deallocate(tmpMannN) if(allocated(tmpSo)) deallocate(tmpSo) if(allocated(tmpChSSlp)) deallocate(tmpChSSlp) if(allocated(tmpBw)) deallocate(tmpBw) if(allocated(tmpTw)) deallocate(tmpTw) if(allocated(tmpTw_CC)) deallocate(tmpTw_CC) if(allocated(tmpn_CC)) deallocate(tmpn_CC) if(allocated(tmpChannK)) deallocate(tmpChannK) !, tmpHRZAREA,& ! tmpLAKEMAXH, tmpWEIRC, tmpWEIRL, tmpORIFICEC, & ! tmpORIFICEA,tmpORIFICEE) endif #else QLINK = 0 if(routeLinkNetcdf) then call read_route_link_netcdf( & route_link_f, & LINKID, TO_NODE, CHLON, & CHLAT, ZELEV, TYPEL, ORDER, & QLINK(:,1), MUSK, MUSX, CHANLEN, & MannN, So, ChSSlp, Bw, & Tw, Tw_CC, n_CC, ChannK, gages, & LAKEIDA ) else open(unit=17,file=trim(route_link_f),form='formatted',status='old') read(17,*) header #ifdef HYDRO_D print *, "header ", header, "NLINKSL = ", NLINKSL #endif do i=1,NLINKSL read (17,*) LINKID(i), tmp_from_node, TO_NODE(i), CHLON(i),CHLAT(i),ZELEV(i), & TYPEL(i), ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & MannN(i), So(i), ChSSlp(i), Bw(i), Tw(i), Tw_CC(i), n_CC(i), ChannK(i) ! if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement if (ORDER(i) .gt. MAXORDER) MAXORDER = ORDER(i) end do close(17) end if ! routeLinkNetcdf !!- initialize channel according to order if missing in input do i=1,NLINKSL if(QLINK(i,1) .le. 1e-3) then QLINK(i,1) = 20.0 * (1/(float(MAXORDER+1) - float(ORDER(i))))**3 QLINK(i,2) = QLINK(i,1) !## initialize the current flow at each link endif end do !!================================ !!! need to add the sequential lake read here !!================================= #endif do i=1,NLINKSL ! if(So(i) .lt. 0.001) So(i) = 0.001 So(i) = max(So(i), 0.00001) end do #ifdef HYDRO_D write(6,*) "finish read readLinkSL " call flush(6) #endif end subroutine readLinkSL #ifdef MPP_LAND !yw continue subroutine MPP_READ_CHROUTING_new(& IXRT, JXRT, ELRT, CH_NETRT, & CH_LNKRT, LAKE_MSKRT, FROM_NODE, TO_NODE, & TYPEL, ORDER, MAXORDER, NLINKS, & NLAKES, CHANLEN, MannN, So, & ChSSlp, Bw, Tw, Tw_CC, & n_CC, ChannK, HRZAREA, LAKEMAXH, & WEIRH, WEIRC, WEIRL, DAML, & ORIFICEC, ORIFICEA, ORIFICEE, & reservoir_type_specified, reservoir_type, & reservoir_parameter_file, LATLAKE, LONLAKE, & ELEVLAKE, dist, ZELEV, LAKENODE, & CH_NETLNK, CHANXI, CHANYJ, CHLAT, & CHLON, channel_option, LATVAL, LONVAL, & STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f, LAKEIDM, & UDMP_OPT, g_ixrt, g_jxrt, gnlinks, & GCH_NETLNK, map_l2g, link_location, yw_mpp_nlinks, & lake_index, nlinks_index ) implicit none integer, intent(IN) :: IXRT,JXRT,g_IXRT,g_JXRT, GNLINKS, UDMP_OPT integer :: CHANRTSWCRT, NLINKS, NLAKES integer :: I,J,channel_option character(len=28) :: dir character(len=155) :: header integer(kind=int64), intent(INOUT), dimension(NLINKS) :: FROM_NODE real, intent(INOUT), dimension(NLINKS) :: ZELEV real, intent(INOUT), dimension(NLINKS) :: CHLAT,CHLON integer(kind=int64), intent(INOUT), dimension(NLINKS) :: TO_NODE integer, intent(INOUT), dimension(NLINKS) :: TYPEL integer, intent(INOUT), dimension(NLINKS) :: ORDER integer, intent(INOUT), dimension(NLINKS) :: STRMFRXSTPTS integer, intent(INOUT) :: MAXORDER real, intent(INOUT), dimension(NLINKS) :: CHANLEN !channel length real, intent(INOUT), dimension(NLINKS) :: MannN, So !mannings N integer(kind=int64), intent(INOUT), dimension(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes real, intent(IN) :: dist(ixrt,jxrt,9) integer, intent(INOUT), dimension(NLINKS) :: map_l2g !-- store the location x,y location of the channel element integer, intent(INOUT), dimension(NLINKS) :: CHANXI, CHANYJ logical, intent(IN) :: reservoir_type_specified real, intent(INOUT), dimension(NLAKES) :: HRZAREA real, intent(INOUT), dimension(NLAKES) :: LAKEMAXH, WEIRH real, intent(INOUT), dimension(NLAKES) :: WEIRC real, intent(INOUT), dimension(NLAKES) :: WEIRL real, intent(INOUT), dimension(NLAKES) :: DAML real, intent(INOUT), dimension(NLAKES) :: ORIFICEC real, intent(INOUT), dimension(NLAKES) :: ORIFICEA real, intent(INOUT), dimension(NLAKES) :: ORIFICEE integer, intent(INOUT), dimension(NLAKES) :: reservoir_type character(len=*), intent(in) :: reservoir_parameter_file real, intent(INOUT), dimension(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE real, intent(INOUT), dimension(NLINKS) :: ChSSlp, Bw, Tw real, intent(INOUT), dimension(NLINKS) :: Tw_CC, n_CC, ChannK character(len=* ) :: geo_finegrid_flnm, route_lake_f character(len=256) :: var_name integer :: tmp, cnt, ncid real :: gc,n integer(kind=int64), intent(IN), dimension(IXRT,JXRT) :: CH_NETLNK,GCH_NETLNK real, intent(IN), dimension(IXRT,JXRT) :: ELRT integer, intent(IN), dimension(IXRT,JXRT) :: CH_NETRT integer(kind=int64), intent(IN), dimension(IXRT,JXRT) :: CH_LNKRT integer, intent(OUT), dimension(IXRT,JXRT) :: LAKE_MSKRT integer(kind=int64), intent(OUT), dimension(IXRT,JXRT) :: link_location real, intent(OUT), dimension(IXRT,JXRT) :: latval,lonval integer :: k integer, dimension(nlinks) :: node_table, nlinks_index integer, dimension(nlakes) :: lake_index integer(kind=int64), dimension(nlakes) :: LAKEIDM integer :: yw_mpp_nlinks , l, mpp_nlinks call READ_CHROUTING1( & IXRT, JXRT, ELRT, CH_NETRT,& CH_LNKRT, LAKE_MSKRT, FROM_NODE, TO_NODE, & TYPEL, ORDER, MAXORDER, NLINKS, & NLAKES, CHANLEN, MannN, So, & ChSSlp, Bw, Tw, Tw_CC, & n_CC, ChannK, HRZAREA, LAKEMAXH, & WEIRH, WEIRC, WEIRL, DAML, & ORIFICEC, ORIFICEA, ORIFICEE, & reservoir_type_specified, reservoir_type, & reservoir_parameter_file, LATLAKE, LONLAKE, & ELEVLAKE, dist, ZELEV, LAKENODE,& CH_NETLNK, CHANXI, CHANYJ, CHLAT, & CHLON, channel_option, LATVAL, LONVAL, & STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f, LAKEIDM, UDMP_OPT & #ifdef MPP_LAND ,Link_Location & #endif ) call mpp_land_max_int1(MAXORDER) if(MAXORDER .eq. 0) MAXORDER = -9999 lake_index = -99 if(channel_option .eq. 3) then do j = 1, jxrt do i = 1, ixrt if (LAKE_MSKRT(i,j) .gt. 0) then lake_index(LAKE_MSKRT(i,j)) = LAKE_MSKRT(i,j) endif enddo enddo endif CHANXI = 0 CHANYj = 0 do j = 1, jxrt do i = 1, ixrt if(CH_NETLNK(i,j) .gt. 0) then CHANXI(CH_NETLNK(i,j)) = i CHANYJ(CH_NETLNK(i,j)) = j endif end do end do node_table = 0 yw_mpp_nlinks = 0 do j = 1, jxrt do i = 1, ixrt if(CH_NETLNK(i,j) .ge. 0) then if( (i.eq.1) .and. (left_id .ge. 0) ) then continue elseif ( (i.eq. ixrt) .and. (right_id .ge. 0) ) then continue elseif ( (j.eq. 1) .and. (down_id .ge. 0) ) then continue elseif ( (j.eq. jxrt) .and. (up_id .ge. 0) ) then continue else l = CH_NETLNK(i,j) ! if(from_node(l) .gt. 0 .and. to_node(l) .gt. 0) then yw_mpp_nlinks = yw_mpp_nlinks + 1 nlinks_index(yw_mpp_nlinks) = l ! endif endif endif end do end do #ifdef HYDRO_D write(6,*) "nlinks=", nlinks, " yw_mpp_nlinks=", yw_mpp_nlinks," nlakes=", nlakes call flush(6) #endif if (NLAKES > 0) then call mpp_land_bcast_real(NLAKES,HRZAREA) call mpp_land_bcast_real(NLAKES,LAKEMAXH) call mpp_land_bcast_real(NLAKES,WEIRC) call mpp_land_bcast_real(NLAKES,WEIRC) call mpp_land_bcast_real(NLAKES,WEIRL) call mpp_land_bcast_real(NLAKES,DAML) call mpp_land_bcast_real(NLAKES,ORIFICEC) call mpp_land_bcast_real(NLAKES,ORIFICEA) call mpp_land_bcast_real(NLAKES,ORIFICEE) call mpp_land_bcast_real(NLAKES,LATLAKE) call mpp_land_bcast_real(NLAKES,LONLAKE) call mpp_land_bcast_real(NLAKES,ELEVLAKE) call mpp_land_bcast_int(NLAKES, reservoir_type) endif link_location = CH_NETLNK end subroutine MPP_READ_CHROUTING_new #endif #ifdef MPP_LAND subroutine out_day_crt(dayMean,outFile) implicit none integer :: did real :: dayMean(:) character(len=*) :: outFile integer:: ywflag ywflag = -999 did = 1 if((nlst(did)%olddate(12:13) .eq. "00") .and. (nlst(did)%olddate(15:16) .eq. "00") ) ywflag = 99 call mpp_land_bcast_int1(ywflag) if(ywflag <0) return ! output daily call out_obs_crt(did,dayMean,outFile) end subroutine out_day_crt subroutine out_obs_crt(did,dayMean,outFile) implicit none integer did, i, cnt real :: dayMean(:) character(len=*) :: outFile real,dimension(rt_domain(did)%gnlinks) :: g_dayMean, chlat, chlon integer,dimension(rt_domain(did)%gnlinks) :: STRMFRXSTPTS g_dayMean = -999 chlat = -999 chlon = -999 STRMFRXSTPTS = 0 call write_chanel_int(RT_DOMAIN(did)%STRMFRXSTPTS,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,STRMFRXSTPTS) call write_chanel_real(dayMean,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,g_dayMean) call write_chanel_real(RT_DOMAIN(did)%CHLON,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlon) call write_chanel_real(RT_DOMAIN(did)%CHLAT,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlat) open (unit=75,file=outFile,status='unknown',position='append') cnt = 0 do i = 1, rt_domain(did)%gnlinks if(STRMFRXSTPTS(i) .gt. 0) then write(75,114) nlst(did)%olddate(1:4),nlst(did)%olddate(6:7),nlst(did)%olddate(9:10), nlst(did)%olddate(12:13), & cnt,chlon(i),chlat(i),g_dayMean(i) cnt = cnt + 1 endif end do close(75) 114 FORMAT(1x,A4,A2,A2,A2,",",I7,", ",F10.5,",",F10.5,",",F12.3) end subroutine out_obs_crt #endif subroutine outPutChanInfo(fromNode,toNode,chlon,chlat) implicit none integer, dimension(:) :: fromNode,toNode real, dimension(:) :: chlat,chlon integer :: iret, nodes, i, ncid, dimid_n, varid nodes = size(chlon,1) iret = nf90_create("nodeInfor.nc", OR(NF90_CLOBBER, NF90_NETCDF4), ncid) iret = nf90_def_dim(ncid, "node", nodes, dimid_n) !-- make a decimated grid ! define the varialbes iret = nf90_def_var(ncid, "fromNode", NF90_INT, (/dimid_n/), varid) iret = nf90_def_var(ncid, "toNode", NF90_INT, (/dimid_n/), varid) iret = nf90_def_var(ncid, "chlat", NF90_FLOAT, (/dimid_n/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'node latitude') iret = nf90_def_var(ncid, "chlon", NF90_FLOAT, (/dimid_n/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'node longitude') iret = nf90_enddef(ncid) !write to the file iret = nf90_inq_varid(ncid,"fromNode", varid) iret = nf90_put_var(ncid, varid, fromNode, (/1/), (/nodes/)) iret = nf90_inq_varid(ncid,"toNode", varid) iret = nf90_put_var(ncid, varid, toNode, (/1/), (/nodes/)) iret = nf90_inq_varid(ncid,"chlat", varid) iret = nf90_put_var(ncid, varid, chlat, (/1/), (/nodes/)) iret = nf90_inq_varid(ncid,"chlon", varid) iret = nf90_put_var(ncid, varid, chlon, (/1/), (/nodes/)) iret = nf90_close(ncid) end subroutine outPutChanInfo !=================================================================================================== ! Program Name: read_route_link_netcdf ! Author(s)/Contact(s): James L McCreight ! Abstract: Read in the "RouteLink.nc" netcdf file specifing the channel topology. ! History Log: ! 7/17/15 -Created, JLM. ! Usage: ! Parameters: ! Input Files: netcdf file RouteLink.nc or other name. ! Output Files: None. ! Condition codes: Currently incomplete error handling. ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code ! ! User controllable options: None. subroutine read_route_link_netcdf( route_link_file, & LINKID, TO_NODE, CHLON, & CHLAT, ZELEV, TYPEL, ORDER, & QLINK, MUSK, MUSX, CHANLEN, & MannN, So, ChSSlp, Bw, & Tw, Tw_CC, n_CC, ChannK, & gages, LAKEIDA ) implicit none character(len=*), intent(in) :: route_link_file integer(kind=int64), dimension(:), intent(out) :: LAKEIDA, LINKID, TO_NODE real, dimension(:), intent(out) :: CHLON, CHLAT, ZELEV integer, dimension(:), intent(out) :: TYPEL, ORDER real, dimension(:), intent(out) :: QLINK real, dimension(:), intent(out) :: MUSK, MUSX, CHANLEN real, dimension(:), intent(out) :: MannN, So, ChSSlp, Bw, Tw real, dimension(:), intent(out) :: Tw_CC, n_CC, ChannK character(len=15), dimension(:), intent(inout) :: gages integer :: iRet, ncid, ii, varid logical :: fatal_if_error fatal_if_error = .TRUE. !! was thinking this would be a global variable...could become an input. #ifdef HYDRO_D print*,"start read_route_link_netcdf" #endif iRet = nf90_open(trim(route_link_file), nf90_nowrite, ncid) if (iRet /= nf90_noErr) then write(*,'("read_route_link_netcdf: Problem opening: ''", A, "''")') trim(route_link_file) if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem opening file.") endif call get_1d_netcdf_int64(ncid, 'link', LINKID, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_int64(ncid, 'NHDWaterbodyComID', LAKEIDA, 'read_route_link_netcdf', .FALSE.) call get_1d_netcdf_int64(ncid, 'to', TO_NODE, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'lon', CHLON, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'lat', CHLAT, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'alt', ZELEV, 'read_route_link_netcdf', .TRUE.) !yw call get_1d_netcdf_int(ncid, 'type', TYPEL, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_int(ncid, 'order', ORDER, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'Qi', QLINK, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'MusK', MUSK, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'MusX', MUSX, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'Length', CHANLEN, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'n', MannN, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'So', So, 'read_route_link_netcdf', .TRUE.) !! impose a minimum as this sometimes fails in the file. where(So .lt. 0.00001) So=0.00001 call get_1d_netcdf_real(ncid, 'ChSlp', ChSSlp, 'read_route_link_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'BtmWdth', Bw, 'read_route_link_netcdf', .TRUE.) !! Loads channel infiltration, by default is zero, my need to add namelist option in future call get_1d_netcdf_real(ncid, 'Kchan', ChannK, 'read_route_link_netcdf', .TRUE.) ! Compound channel variables, contingent on nlst_rt(did)%compound_channel option if(nlst(did)%compound_channel) then print*, "compound_channel is TRUE in hydro.namelist." print*, "Variables are all required in route link: TopWdth, TopWdthCC, nCC." ! the fatal_if_error option is tru for all of these. An error in any will be a fatal error. call get_1d_netcdf_real(ncid, 'TopWdth', Tw, 'read_route_link_netcdf', .true.) call get_1d_netcdf_real(ncid, 'TopWdthCC', Tw_CC, 'read_route_link_netcdf', .true.) call get_1d_netcdf_real(ncid, 'nCC', n_CC, 'read_route_link_netcdf', .true.) else print*, "compound_channel is FALSE in hydro.namelist." Tw = 0.0 !force top width to 0.0, this deactivates the compound channel formulation. end if ! gages is optional, only get it if it's defined in the file. iRet = nf90_inq_varid(ncid, 'gages', varid) if (iret .eq. nf90_NoErr) then call get_1d_netcdf_text(ncid, 'gages', gages, 'read_route_link_netcdf', .true.) end if iRet = nf90_close(ncId) if (iRet /= nf90_noErr) then write(*,'("read_route_link_netcdf: Problem closing: ''", A, "''")') trim(route_link_file) if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem closing file.") end if #ifdef HYDRO_D ii = size(LINKID) print*,'last index=',ii print*, 'CHLON', CHLON(ii), 'CHLAT', CHLAT(ii), 'ZELEV', ZELEV(ii) print*,'TYPEL', TYPEL(ii), 'ORDER', ORDER(ii), 'QLINK', QLINK(ii), 'MUSK', MUSK(ii) print*, 'MUSX', MUSX(ii), 'CHANLEN', CHANLEN(ii), 'MannN', MannN(ii) print*,'So', So(ii), 'ChSSlp', ChSSlp(ii), 'Bw', Bw(ii), 'Tw', Tw(ii) print*,'TwCompund', Tw_CC(ii), 'Mann Compund', n_CC(ii), 'ChannK', ChannK(ii) print*,'gages(ii): ',trim(gages(ii)) print*,"finish read_route_link_netcdf" #endif end subroutine read_route_link_netcdf !=================================================================================================== ! Program Name: read_route_lake_netcdf ! Abstract: Read in the "LAKEPARM.nc" netcdf file specifing the channel topology. ! History Log: ! 7/17/15 -Created, JLM., then used by DNY ! Usage: ! Parameters: ! Input Files: netcdf file RouteLink.nc or other name. ! Output Files: None. ! Condition codes: Currently incomplete error handling. ! subroutine read_route_lake_netcdf(route_lake_file, & HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, & ORIFICEC, ORIFICEA, ORIFICEE, reservoir_type_specified, & reservoir_type, reservoir_parameter_file, & LAKEIDM, lakelat, lakelon, ELEVLAKE, NLAKES) implicit none character(len=*), intent(in) :: route_lake_file integer, intent(in) :: NLAKES logical, intent(in) :: reservoir_type_specified character(len=*), intent(in) :: reservoir_parameter_file integer(kind=int64), dimension(:), intent(out) :: LAKEIDM real, dimension(:), intent(out) :: HRZAREA, LAKEMAXH, WEIRC, WEIRL, WEIRH, DAML real, dimension(:), intent(out) :: ORIFICEC, ORIFICEA, ORIFICEE, lakelat, lakelon real, dimension(:), intent(out) :: ELEVLAKE integer, dimension(:), intent(out) :: reservoir_type integer :: iRet, ncid, ii, varid logical :: fatal_if_error fatal_if_error = .TRUE. !! was thinking this would be a global variable...could become an input. #ifdef HYDRO_D print*,"start read_route_lake_netcdf" #endif iRet = nf90_open(trim(route_lake_file), nf90_nowrite, ncid) if (iRet /= nf90_noErr) then write(*,'("read_route_lake_netcdf: Problem opening: ''", A, "''")') trim(route_lake_file) if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem opening file.") endif call get_1d_netcdf_int64(ncid, 'lake_id', LAKEIDM, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'LkArea', HRZAREA, 'read_route_lake_netcdf', .TRUE.) !rename the LAKEPARM input vars for Elev instead of Ht, 08/23/17 LKR/DY call get_1d_netcdf_real(ncid, 'LkMxE', LAKEMAXH, 'read_route_lake_netcdf', .TRUE.) !rename WeirH to WeirE call get_1d_netcdf_real(ncid, 'WeirE', WEIRH, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'WeirC', WEIRC, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'WeirL', WEIRL, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'Dam_Length', DAML, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'OrificeC', ORIFICEC, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'OrificeA', ORIFICEA, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'OrificeE', ORIFICEE, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'lat', lakelat, 'read_route_lake_netcdf', .TRUE.) call get_1d_netcdf_real(ncid, 'lon', lakelon, 'read_route_lake_netcdf', .TRUE.) !remove the alt var. and add initial fractional depth var. LKR/DY call get_1d_netcdf_real(ncid, 'ifd', ELEVLAKE, 'read_route_lake_netcdf', .FALSE.) iRet = nf90_close(ncId) if (iRet /= nf90_noErr) then write(*,'("read_route_lake_netcdf: Problem closing: ''", A, "''")') trim(route_lake_file) if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem closing file.") end if ! If reservoir_type_specified is set to true, then call function to read reservoir_type ! from the reservoir parameter file if (reservoir_type_specified) then call read_reservoir_type(reservoir_parameter_file, LAKEIDM, NLAKES, reservoir_type) end if #ifdef HYDRO_D ii = size(LAKEIDM) print*,'last index=',ii print*,'HRZAREA', HRZAREA(ii) print*,'LAKEMAXH', LAKEMAXH(ii), 'WEIRC', WEIRC(ii), 'WEIRL', WEIRL(ii), 'DAML', DAML(ii) print*,'ORIFICEC', ORIFICEC(ii), 'ORIFICEA', ORIFICEA(ii), 'ORIFICEE', ORIFICEE(ii) print*,"finish read_route_lake_netcdf" #endif end subroutine read_route_lake_netcdf !=================================================================================================== ! Program Names: get_1d_netcdf_real, get_1d_netcdf_int, get_1d_netcdf_text ! Author(s)/Contact(s): James L McCreight ! Abstract: Read a variable of real or integer type from an open netcdf file, respectively. ! History Log: ! 7/17/15 -Created, JLM. ! Usage: ! Parameters: See definitions. ! Input Files: This file is refered to by it's "ncid" obtained from nc_open ! prior to calling this routine. ! Output Files: None. ! Condition codes: hydro_stop is passed "get_1d_netcdf". ! ! If appropriate, descriptive troubleshooting instructions or ! likely causes for failures could be mentioned here with the ! appropriate error code ! ! User controllable options: None. !! could define an interface for these. subroutine get_1d_netcdf_int(ncid, varName, var, callingRoutine, fatal_if_error) integer, intent(in) :: ncid !! the file identifier character(len=*), intent(in) :: varName integer, dimension(:), intent(out) :: var character(len=*), intent(in) :: callingRoutine logical, intent(in) :: fatal_if_error integer :: varid, iret iRet = nf90_inq_varid(ncid, varName, varid) if (iret /= nf90_noErr) then if (fatal_IF_ERROR) then print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName) call hydro_stop("get_1d_netcdf") end if end if iRet = nf90_get_var(ncid, varid, var) if (iRet /= nf90_NoErr) then print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName) if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int") end if end subroutine get_1d_netcdf_int subroutine get_1d_netcdf_int64(ncid, varName, var, callingRoutine, fatal_if_error) integer, intent(in) :: ncid !! the file identifier character(len=*), intent(in) :: varName integer(kind=int64), dimension(:), intent(out) :: var character(len=*), intent(in) :: callingRoutine logical, intent(in) :: fatal_if_error integer :: varid, iret iRet = nf90_inq_varid(ncid, varName, varid) if (iret /= nf90_noErr) then if (fatal_IF_ERROR) then print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName) call hydro_stop("get_1d_netcdf") end if end if iRet = nf90_get_var(ncid, varid, var) if (iRet /= nf90_NoErr) then print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName) if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int") end if end subroutine get_1d_netcdf_int64 subroutine get_1d_netcdf_real(ncid, varName, var, callingRoutine, fatal_if_error) integer, intent(in) :: ncid !! the file identifier character(len=*), intent(in) :: varName real, dimension(:), intent(out) :: var character(len=*), intent(in) :: callingRoutine logical, intent(in) :: fatal_if_error integer :: varid, iret iRet = nf90_inq_varid(ncid, varName, varid) if (iret /= nf90_noErr) then if (fatal_IF_ERROR) then print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName) call hydro_stop("get_1d_netcdf") end if end if iRet = nf90_get_var(ncid, varid, var) if (iRet /= nf90_NoErr) then print*, trim(callingRoutine) // ": get_1d_netcdf_real: values: " // trim(varName) if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_real") end if end subroutine get_1d_netcdf_real subroutine get_1d_netcdf_text(ncid, varName, var, callingRoutine, fatal_if_error) integer, intent(in) :: ncid !! the file identifier character(len=*), intent(in) :: varName character(len=*), dimension(:), intent(out) :: var character(len=*), intent(in) :: callingRoutine logical, intent(in) :: fatal_if_error integer :: varId, iRet iRet = nf90_inq_varid(ncid, varName, varid) if (iret /= nf90_NoErr) then print*, trim(callingRoutine) // ": get_1d_netcdf_text: variable: " // trim(varName) if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text") end if iRet = nf90_get_var(ncid, varid, var) if (iret /= nf90_NoErr) then print*, trim(callingRoutine) // ": get_1d_netcdf_text: values: " // trim(varName) if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text") end if end subroutine get_1d_netcdf_text !=================================================================================================== ! Program Names: ! get_netcdf_dim ! Author(s)/Contact(s): ! James L McCreight ! Abstract: ! Get the length of a provided dimension. ! History Log: ! 7/23/15 -Created, JLM. ! Usage: ! Parameters: ! file: character, the file to query ! dimName: character, the name of the dimension ! callingRoutine: character, the name of the calling routine for error messages ! fatalErr: Optional, Logical - all errors are fatal, calling hydro_stop() ! Input Files: ! Specified argument. ! Output Files: ! Condition codes: ! hydro_stop is called. . ! User controllable options: ! Notes: function get_netcdf_dim(file, dimName, callingRoutine, fatalErr) implicit none integer :: get_netcdf_dim !! return value character(len=*), intent(in) :: file, dimName, callingRoutine integer :: ncId, dimId, iRet logical, optional, intent(in) :: fatalErr logical :: fatalErr_local character(len=256) :: errMsg fatalErr_local = .false. if(present(fatalErr)) fatalErr_local=fatalErr write(*,'("getting dimension from file: ", A)') trim(file) iRet = nf90_open(trim(file), nf90_NOWRITE, ncId) if (iret /= nf90_noerr) then write(*,'("Problem opening file: ", A)') trim(file) if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') if(.not. fatalErr_local) get_netcdf_dim = -99 if(.not. fatalErr_local) return endif iRet = nf90_inq_dimid(ncId, trim(dimName), dimId) if (iret /= nf90_noerr) then write(*,'("Problem getting the dimension ID ", A)') & '"' // trim(dimName) // '" in file: ' // trim(file) if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') if(.not. fatalErr_local) get_netcdf_dim = -99 if(.not. fatalErr_local) return endif iRet = nf90_inquire_dimension(ncId, dimId, len= get_netcdf_dim) if (iret /= nf90_noerr) then write(*,'("Problem getting the dimension length of ", A)') & '"' // trim(dimName) // '" in file: ' // trim(file) if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') if(.not. fatalErr_local) get_netcdf_dim = -99 if(.not. fatalErr_local) return endif iRet = nf90_close(ncId) if (iret /= nf90_noerr) then write(*,'("Problem closing file: ", A)') trim(file) if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim') if(.not. fatalErr_local) get_netcdf_dim = -99 if(.not. fatalErr_local) return endif end function get_netcdf_dim ! read the GWBUCKET Parm for NHDPlus subroutine readBucket_nhd(infile, numbasns, gw_buck_coeff, gw_buck_exp, & gw_buck_loss, z_max, z_init, LINKID, nhdBuckMask) implicit none integer, intent(in) :: numbasns integer(kind=int64), dimension(numbasns) :: LINKID real, dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, gw_buck_loss real, dimension(numbasns) :: z_max, z_init integer, dimension(numbasns) :: nhdBuckMask character(len=*), intent(in) :: infile ! define temp array integer, volatile :: i,j,k, gnid, ncid, varid, ierr, dimid, iret integer(kind=int64), allocatable, dimension(:) :: tmpLinkid real, allocatable, dimension(:) :: tmpCoeff, tmpExp, tmpLoss real, allocatable, dimension(:) :: tmpz_max, tmpz_init ! get gnid gnid = 0 #ifdef MPP_LAND if(my_id .eq. io_id ) then #endif iret = nf90_open(trim(infile), NF90_NOWRITE, ncid) #ifdef MPP_LAND if(iret .ne. 0) then call hydro_stop("Failed to open GWBUCKET Parameter file.") endif iret = nf90_inq_dimid(ncid, "BasinDim", dimid) if (iret /= 0) then !print*, "nf90_inq_dimid: BasinDim" call hydro_stop("Failed read GBUCKETPARM - nf90_inq_dimid: BasinDim") endif iret = nf90_inquire_dimension(ncid, dimid, len=gnid) endif call mpp_land_bcast_int1(gnid) #endif allocate(tmpLinkid(gnid)) allocate(tmpCoeff(gnid)) allocate(tmpExp(gnid)) allocate(tmpLoss(gnid)) allocate(tmpz_max(gnid)) allocate(tmpz_init(gnid)) #ifdef MPP_LAND if(my_id .eq. io_id ) then #endif ! read the file data. iret = nf90_inq_varid(ncid,"Coeff", varid) if(iret /= 0) then print * , "could not find Coeff from ", infile call hydro_stop("Failed to read BUCKETPARM") endif iret = nf90_get_var(ncid, varid, tmpCoeff) iret = nf90_inq_varid(ncid,"Expon", varid) if(iret /= 0) then print * , "could not find Expon from ", infile call hydro_stop("Failed to read BUCKETPARM") endif iret = nf90_get_var(ncid, varid, tmpExp) if(nlst(did)%bucket_loss .eq. 1) then iret = nf90_inq_varid(ncid,"Loss", varid) if(iret /= 0) then print * , "could not find Loss from ", infile call hydro_stop("Failed to read BUCKETPARM") endif iret = nf90_get_var(ncid, varid, tmpLoss) endif iret = nf90_inq_varid(ncid,"Zmax", varid) if(iret /= 0) then print * , "could not find Zmax from ", infile call hydro_stop("Failed to read BUCKETPARM") endif iret = nf90_get_var(ncid, varid, tmpz_max) iret = nf90_inq_varid(ncid,"Zinit", varid) if(iret /= 0) then print * , "could not find Zinit from ", infile call hydro_stop("Failed to read BUCKETPARM") endif iret = nf90_get_var(ncid, varid, tmpz_init) iret = nf90_inq_varid(ncid, "ComID", varid) if(iret /= 0) then print * , "could not find ComID from ", infile call hydro_stop("Failed to read BUCKETPARM") endif iret = nf90_get_var(ncid, varid, tmpLinkID) #ifdef MPP_LAND endif if(gnid .gt. 0) then call mpp_land_bcast_real_1d(tmpCoeff) call mpp_land_bcast_real_1d(tmpExp) if(nlst(did)%bucket_loss .eq. 1) then call mpp_land_bcast_real_1d(tmpLoss) endif call mpp_land_bcast_real_1d(tmpz_max) call mpp_land_bcast_real_1d(tmpz_init) call mpp_land_bcast_int8(gnid ,tmpLinkid) endif #endif nhdBuckMask = -999 ! The following loops are replaced by a hashtable-based algorithm ! do k = 1, numbasns ! do i = 1, gnid ! if(LINKID(k) .eq. tmpLinkid(i)) then ! gw_buck_coeff(k) = tmpCoeff(i) ! gw_buck_exp(k) = tmpExp(i) ! z_max(k) = tmpz_max(i) ! z_init(k) = tmpz_init(i) ! nhdBuckMask(k) = 1 ! goto 301 ! endif ! end do ! 301 continue ! end do block type(hash_t) :: hash_table integer(kind=int64) :: val,it logical :: found call hash_table%set_all_idx(LINKID,numbasns) do it=1, gnid call hash_table%get(tmpLinkid(it), val, found) if((found .eqv. .true.)) then if((nhdBuckMask(val) == -999)) then gw_buck_coeff(val) = tmpCoeff(it) gw_buck_exp(val) = tmpExp(it) if(nlst(did)%bucket_loss == 1) then gw_buck_loss(val) = tmpLoss(it) end if z_max(val) = tmpz_max(it) z_init(val) = tmpz_init(it) nhdBuckMask(val) = 1 end if end if end do call hash_table%clear() end block if(allocated(tmpCoeff)) deallocate(tmpCoeff) if(allocated(tmpExp)) deallocate(tmpExp) if(allocated(tmpLoss)) deallocate(tmpLoss) if(allocated(tmpz_max)) deallocate(tmpz_max) if(allocated(tmpz_init)) deallocate(tmpz_init) if(allocated(tmpLinkid)) deallocate(tmpLinkid) end subroutine readBucket_nhd !-- output the channel routine for fast output. ! subroutine mpp_output_chrt2(gnlinks,gnlinksl,map_l2g,igrid, & ! split_output_count, NLINKS, ORDER, & ! startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch, & ! K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, & ! lsmDt & ! ) #ifdef MPP_LAND subroutine mpp_output_chrt2( & gnlinks, gnlinksl, map_l2g, & igrid, split_output_count, & NLINKS, ORDER, & startdate, date, & chlon, chlat, & hlink, zelev, & qlink, dtrt_ch, K, & NLINKSL, channel_option, & linkid & #ifdef WRF_HYDRO_NUDGING , nudge & #endif , QLateral, io_config_outputs & , velocity & , accSfcLatRunoff, accBucket & , qSfcLatRunoff, qBucket & , qBtmVertRunoff, UDMP_OPT & ) USE module_mpp_land implicit none !!output the routing variables over just channel integer, intent(in) :: igrid,K,NLINKSL integer, intent(in) :: split_output_count integer, intent(in) :: NLINKS real, dimension(:), intent(in) :: chlon,chlat real, dimension(:), intent(in) :: hlink,zelev integer, dimension(:), intent(in) :: ORDER integer(kind=int64), dimension(:), intent(in) :: linkid real, intent(in) :: dtrt_ch real, dimension(:,:), intent(in) :: qlink #ifdef WRF_HYDRO_NUDGING real, dimension(:), intent(in) :: nudge #endif real, dimension(:), intent(in) :: QLateral, velocity integer, intent(in) :: io_config_outputs real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket real , dimension(:), intent(in) :: qSfcLatRunoff, qBucket, qBtmVertRunoff integer, intent(in) :: UDMP_OPT integer :: channel_option character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer :: gnlinks, map_l2g(nlinks), gnlinksl real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev #ifdef WRF_HYDRO_NUDGING real, allocatable,dimension(:) :: g_nudge #endif integer, allocatable,dimension(:) :: g_order integer(kind=int64), allocatable, dimension(:) :: g_linkid real,allocatable,dimension(:,:) :: g_qlink integer :: gsize real*8, allocatable, dimension(:) :: g_accSfcLatRunoff, g_accBucket real , allocatable, dimension(:) :: g_qSfcLatRunoff, g_qBucket, g_qBtmVertRunoff real, allocatable, dimension(:) :: g_QLateral, g_velocity gsize = gNLINKS if(gnlinksl .gt. gsize) gsize = gnlinksl if(my_id .eq. io_id ) then allocate(g_chlon(gsize )) allocate(g_chlat(gsize )) allocate(g_hlink(gsize )) allocate(g_zelev(gsize )) allocate(g_qlink(gsize ,2)) #ifdef WRF_HYDRO_NUDGING allocate(g_nudge(gsize)) #endif allocate(g_order(gsize )) allocate(g_linkid(gsize )) if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then allocate(g_qSfcLatRunoff( gsize )) allocate(g_qBucket( gsize )) end if if(nlst(did)%output_channelBucket_influx .eq. 2) & allocate(g_qBtmVertRunoff( gsize )) if(nlst(did)%output_channelBucket_influx .eq. 3) then allocate(g_accSfcLatRunoff(gsize )) allocate(g_accBucket( gsize )) end if allocate(g_QLateral(gsize )) allocate(g_velocity(gsize )) else if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then allocate(g_qSfcLatRunoff( 1)) allocate(g_qBucket( 1)) end if if(nlst(did)%output_channelBucket_influx .eq. 2) & allocate(g_qBtmVertRunoff( 1)) if(nlst(did)%output_channelBucket_influx .eq. 3) then allocate(g_accSfcLatRunoff(1)) allocate(g_accBucket( 1)) end if allocate(g_QLateral(1)) allocate(g_velocity(1)) allocate(g_chlon(1)) allocate(g_chlat(1)) allocate(g_hlink(1)) allocate(g_zelev(1)) allocate(g_qlink(1,2)) #ifdef WRF_HYDRO_NUDGING allocate(g_nudge(1)) #endif allocate(g_order(1)) allocate(g_linkid(1)) endif call mpp_land_sync() if(channel_option .eq. 1 .or. channel_option .eq. 2) then g_qlink = 0 call ReachLS_write_io(qlink(:,1), g_qlink(:,1)) call ReachLS_write_io(qlink(:,2), g_qlink(:,2)) #ifdef WRF_HYDRO_NUDGING g_nudge=0 call ReachLS_write_io(nudge,g_nudge) #endif call ReachLS_write_io(order, g_order) call ReachLS_write_io(linkid, g_linkid) call ReachLS_write_io(chlon, g_chlon) call ReachLS_write_io(chlat, g_chlat) call ReachLS_write_io(zelev, g_zelev) if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then call ReachLS_write_io(qSfcLatRunoff, g_qSfcLatRunoff) call ReachLS_write_io(qBucket, g_qBucket) end if if(nlst(did)%output_channelBucket_influx .eq. 2) & call ReachLS_write_io(qBtmVertRunoff, g_qBtmVertRunoff) if(nlst(did)%output_channelBucket_influx .eq. 3) then call ReachLS_write_io(accSfcLatRunoff, g_accSfcLatRunoff) call ReachLS_write_io(accBucket, g_accBucket) end if call ReachLS_write_io(QLateral, g_QLateral) call ReachLS_write_io(velocity, g_velocity) !yw call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) call ReachLS_write_io(hlink,g_hlink) else call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) call write_chanel_int8(linkid,map_l2g,gnlinks,nlinks,g_linkid) call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) endif if(my_id .eq. IO_id) then call output_chrt2(igrid, split_output_count, GNLINKS, g_ORDER, & startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K, & gNLINKSL,channel_option, g_linkid & #ifdef WRF_HYDRO_NUDGING , g_nudge & #endif , g_QLateral, io_config_outputs, g_velocity & , g_accSfcLatRunoff, g_accBucket & , g_qSfcLatRunoff, g_qBucket, g_qBtmVertRunoff & , UDMP_OPT & ) end if call mpp_land_sync() if(allocated(g_order)) deallocate(g_order) if(allocated(g_chlon)) deallocate(g_chlon) if(allocated(g_chlat)) deallocate(g_chlat) if(allocated(g_hlink)) deallocate(g_hlink) if(allocated(g_zelev)) deallocate(g_zelev) if(allocated(g_qlink)) deallocate(g_qlink) if(allocated(g_linkid)) deallocate(g_linkid) #ifdef WRF_HYDRO_NUDGING if(allocated(g_nudge)) deallocate(g_nudge) #endif if(allocated(g_QLateral)) deallocate(g_QLateral) if(allocated(g_velocity)) deallocate(g_velocity) if(allocated(g_qSfcLatRunoff)) deallocate(g_qSfcLatRunoff) if(allocated(g_qBucket)) deallocate(g_qBucket) if(allocated(g_qBtmVertRunoff)) deallocate(g_qBtmVertRunoff) if(allocated(g_accSfcLatRunoff)) deallocate(g_accSfcLatRunoff) if(allocated(g_accBucket)) deallocate(g_accBucket) end subroutine mpp_output_chrt2 #endif !subroutine output_chrt2 !For realtime output only when CHRTOUT_GRID = 2. ! subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER, & ! startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & ! STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & ! lsmDt & ! ) subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER, & startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K, & NLINKSL, channel_option ,linkid & #ifdef WRF_HYDRO_NUDGING , nudge & #endif , QLateral, io_config_outputs, velocity & , accSfcLatRunoff, accBucket & , qSfcLatRunoff, qBucket, qBtmVertRunoff & , UDMP_OPT & ) implicit none !!output the routing variables over just channel integer, intent(in) :: igrid,K,channel_option integer, intent(in) :: split_output_count integer, intent(in) :: NLINKS, NLINKSL real, dimension(:), intent(in) :: chlon,chlat real, dimension(:), intent(in) :: hlink,zelev integer, dimension(:), intent(in) :: ORDER real, intent(in) :: dtrt_ch real, dimension(:,:), intent(in) :: qlink #ifdef WRF_HYDRO_NUDGING real, dimension(:), intent(in) :: nudge #endif real, dimension(:), intent(in) :: QLateral, velocity integer, intent(in) :: io_config_outputs real*8, dimension(nlinks), intent(in) :: accSfcLatRunoff, accBucket real , dimension(nlinks), intent(in) :: qSfcLatRunoff, qBucket, qBtmVertRunoff integer :: UDMP_OPT character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer(kind=int64), allocatable, dimension(:) :: linkid integer, allocatable, DIMENSION(:) :: rec_num_of_station integer, allocatable, DIMENSION(:) :: rec_num_of_stationO integer, allocatable, DIMENSION(:) :: lOrder !- local stream order integer, save :: output_count integer, save :: ncid integer :: stationdim, dimdata, varid, charid, n integer :: timedim integer :: iret,i !-- order_to_write is the lowest stream order to output integer :: start_posO, prev_posO, nlk integer :: previous_pos !-- used for the station model character(len=256) :: output_flnm character(len=34) :: sec_since_date integer :: seconds_since,nstations,cnt,ObsStation character(len=32) :: convention character(len=11),allocatable, DIMENSION(:) :: stname character(len=34) :: sec_valid_date !--- all this for writing the station id string INTEGER TDIMS, TXLEN PARAMETER (TDIMS=2) ! number of TX dimensions PARAMETER (TXLEN = 11) ! length of example string INTEGER TIMEID ! record dimension id INTEGER TXID ! variable ID INTEGER TXDIMS(TDIMS) ! variable shape INTEGER TSTART(TDIMS), TCOUNT(TDIMS) !-- observation point ids INTEGER OTDIMS, OTXLEN PARAMETER (OTDIMS=2) ! number of TX dimensions PARAMETER (OTXLEN = 15) ! length of example string INTEGER OTIMEID ! record dimension id INTEGER OTXID ! variable ID INTEGER OTXDIMS(OTDIMS) ! variable shape INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) character(len=19) :: date19, date19start seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) if(channel_option .ne. 3) then nstations = NLINKSL else nstations = NLINKS endif if(split_output_count .ne. 1 ) then write(6,*) "WARNING: split_output_count need to be 1 for this output option." endif !-- have moved sec_since_date from above here.. sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & //startdate(12:13)//':'//startdate(15:16)//':00' seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then print*, "Problem nf90_create points" call hydro_stop("In output_chrt2() - Problem nf90_create points.") endif iret = nf90_def_dim(ncid, "station", nstations, stationdim) iret = nf90_def_dim(ncid, "time", 1, timedim) if (io_config_outputs .le. 0) then !- station location definition all, lat iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_north') !- station location definition, long iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude') iret = nf90_put_att(ncid, varid, 'units', 'degrees_east') ! !-- elevation is ZELEV iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude') iret = nf90_put_att(ncid, varid, 'units', 'meters') !-- parent index ! iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record') !-- prevChild ! iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station') ! iret = nf90_put_att(ncid, varid, '_FillValue', -1) !-- lastChild ! iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station') ! iret = nf90_put_att(ncid, varid, '_FillValue', -1) endif iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') !- flow definition, var iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow') #ifdef WRF_HYDRO_NUDGING !- nudge definition iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration') #endif ! !- head definition, var if(channel_option .eq. 3) then iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter') iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage') endif !#ifdef HYDRO_REALTIME ! if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then ! iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/stationdim/), varid) ! iret = nf90_put_att(ncid, varid, 'units', 'meter') ! iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage') ! endif !#endif !-- NEW lateral inflow definition, var if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then iret = nf90_def_var(ncid, "q_lateral", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') iret = nf90_put_att(ncid, varid, 'long_name', 'Runoff into channel reach') endif !-- NEW velocity definition, var if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then iret = nf90_def_var(ncid, "velocity", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter/sec') iret = nf90_put_att(ncid, varid, 'long_name', 'River Velocity') endif if (io_config_outputs .le. 0) then ! !- order definition, var iret = nf90_def_var(ncid, "order", NF90_INT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order') iret = nf90_put_att(ncid, varid, '_FillValue', -1) endif !-- station id ! define character-position dimension for strings of max length 11 iret = nf90_def_var(ncid, "station_id", NF90_INT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Station id') !! JLM: Write/define a global attribute of the file as the LSM timestep. Enforce !! JLM: force_type=9 only reads these discharges to the channel if the LSM timesteps match. if(UDMP_OPT .eq. 1 .and. nlst(did)%output_channelBucket_influx .ne. 0) then !! channel & channelBucketOnly global atts iret = nf90_put_att(ncid, NF90_GLOBAL, 'OVRTSWCRT', nlst(1)%OVRTSWCRT ) iret = nf90_put_att(ncid, NF90_GLOBAL, 'NOAH_TIMESTEP', int(nlst(1)%dt) ) iret = nf90_put_att(ncid, NF90_GLOBAL, "channel_only", nlst(did)%channel_only ) iret = nf90_put_att(ncid, NF90_GLOBAL, "channelBucket_only", nlst(did)%channelBucket_only ) !! FLUXES to channel if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') if(nlst(did)%OVRTSWCRT .eq. 1) then !123456789112345678921234567 iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing') else iret = nf90_put_att(ncid, varid, 'long_name', 'runoff') end if iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') ! 1234567891234567892 iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket') end if !! Bucket influx !! In channel_only mode, there are not valie qBtmVertRunoff values if(nlst(did)%output_channelBucket_influx .eq. 2 .and. & nlst(did)%channel_only .eq. 0 ) then iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s') iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket') endif !! ACCUMULATIONS if(nlst(did)%output_channelBucket_influx .eq. 3) then iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3') if(nlst(did)%OVRTSWCRT .eq. 1) then iret = nf90_put_att(ncid,varid,'long_name',& 'ACCUMULATED runoff from terrain routing') else iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land') end if iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/stationdim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3') iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED flux from gw bucket') endif endif convention(1:32) = "Unidata Observation Dataset v1.0" iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention) iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station") if (io_config_outputs .le. 0) then iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0") iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0") endif iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station") iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", 1) !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! END DEF iret = nf90_enddef(ncid) iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) if (io_config_outputs .le. 0) then !-- write latitudes iret = nf90_inq_varid(ncid,"latitude", varid) iret = nf90_put_var(ncid, varid, chlat, (/1/), (/nstations/)) !-- write longitudes iret = nf90_inq_varid(ncid,"longitude", varid) iret = nf90_put_var(ncid, varid, chlon, (/1/), (/nstations/)) !-- write elevations iret = nf90_inq_varid(ncid,"altitude", varid) iret = nf90_put_var(ncid, varid, zelev, (/1/), (/nstations/)) !-- write order iret = nf90_inq_varid(ncid,"order", varid) iret = nf90_put_var(ncid, varid, ORDER, (/1/), (/nstations/)) endif !-- write stream flow iret = nf90_inq_varid(ncid,"streamflow", varid) iret = nf90_put_var(ncid, varid, qlink(:,1), (/1/), (/nstations/)) #ifdef WRF_HYDRO_NUDGING !-- write nudge iret = nf90_inq_varid(ncid,"nudge", varid) iret = nf90_put_var(ncid, varid, nudge, (/1/), (/nstations/)) #endif !-- write head if(channel_option .eq. 3) then iret = nf90_inq_varid(ncid,"head", varid) iret = nf90_put_var(ncid, varid, hlink, (/1/), (/nstations/)) endif !#ifdef HYDRO_REALTIME ! if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then ! ! dummy value for now ! iret = nf90_inq_varid(ncid,"head", varid) ! iret = nf90_put_vara_real(ncid, varid, (/1/), (/nstations/), chlon*0.-9999.) ! endif !#endif !-- write lateral inflow if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then iret = nf90_inq_varid(ncid,"q_lateral", varid) iret = nf90_put_var(ncid, varid, QLateral, (/1/), (/nstations/)) endif !-- writelvelocity (dummy value for now) if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then iret = nf90_inq_varid(ncid,"velocity", varid) iret = nf90_put_var(ncid, varid, velocity, (/1/), (/nstations/)) endif !! JLM: Write/define a global attribute of the file as the LSM timestep. Enforce !! JLM: force_type=9 only reads these discharges to the channel if the LSM timesteps match. if(UDMP_OPT .eq. 1 .and. nlst(did)%output_channelBucket_influx .ne. 0) then !! FLUXES if(nlst(did)%output_channelBucket_influx .eq. 1 .or. & nlst(did)%output_channelBucket_influx .eq. 2 ) then iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid) iret = nf90_put_var(ncid, varid, qSfcLatRunoff, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid,"qBucket", varid) iret = nf90_put_var(ncid, varid, qBucket, (/1/), (/nstations/)) end if !! Bucket model influxes if(nlst(did)%output_channelBucket_influx .eq. 2 .and. & nlst(did)%channel_only .eq. 0 ) then iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid) iret = nf90_put_var(ncid, varid, qBtmVertRunoff, (/1/), (/nstations/)) endif !! ACCUMULATIONS if(nlst(did)%output_channelBucket_influx .eq. 3) then iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid) iret = nf90_put_var(ncid, varid, accSfcLatRunoff, (/1/), (/nstations/)) iret = nf90_inq_varid(ncid,"accBucket", varid) iret = nf90_put_var(ncid, varid, accBucket, (/1/), (/nstations/)) end if endif !-- write id iret = nf90_inq_varid(ncid,"station_id", varid) iret = nf90_put_var(ncid, varid, linkid, (/1/), (/nstations/)) iret = nf90_redef(ncid) date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(date)) = date iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_enddef(ncid) iret = nf90_sync(ncid) iret = nf90_close(ncid) #ifdef HYDRO_D print *, "Exited Subroutine output_chrt" #endif end subroutine output_chrt2 subroutine output_GW_Diag(did) implicit none integer :: i , did, gnbasns #ifdef MPP_LAND real, allocatable, dimension(:) :: g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas integer(kind=int64), allocatable, dimension(:) :: g_basnsInd if(my_id .eq. io_id) then if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then allocate(g_qin_gwsubbas(rt_domain(did)%gnumbasns)) allocate(g_qout_gwsubbas(rt_domain(did)%gnumbasns)) allocate(g_z_gwsubbas(rt_domain(did)%gnumbasns)) allocate(g_basnsInd(rt_domain(did)%gnumbasns)) gnbasns = rt_domain(did)%gnumbasns else allocate(g_qin_gwsubbas(rt_domain(did)%gnlinksl)) allocate(g_qout_gwsubbas(rt_domain(did)%gnlinksl)) allocate(g_z_gwsubbas(rt_domain(did)%gnlinksl)) allocate(g_basnsInd(rt_domain(did)%gnlinksl)) gnbasns = rt_domain(did)%gnlinksl endif endif if(nlst(did)%channel_option .ne. 3) then call ReachLS_write_io(rt_domain(did)%qin_gwsubbas,g_qin_gwsubbas) call ReachLS_write_io(rt_domain(did)%qout_gwsubbas,g_qout_gwsubbas) call ReachLS_write_io(rt_domain(did)%z_gwsubbas,g_z_gwsubbas) call ReachLS_write_io(rt_domain(did)%linkid,g_basnsInd) else call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas, & rt_domain(did)%basnsInd,g_qin_gwsubbas) call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas, & rt_domain(did)%basnsInd,g_qout_gwsubbas) call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas, & rt_domain(did)%basnsInd,g_z_gwsubbas) call gw_write_io_int(rt_domain(did)%numbasns,rt_domain(did)%basnsInd, & rt_domain(did)%basnsInd,g_basnsInd) endif if(my_id .eq. io_id) then ! open (unit=51,file='GW_inflow.txt',form='formatted',& ! status='unknown',position='append') ! open (unit=52,file='GW_outflow.txt',form='formatted',& ! status='unknown',position='append') ! open (unit=53,file='GW_zlev.txt',form='formatted',& ! status='unknown',position='append') ! do i=1,RT_DOMAIN(did)%gnumbasns ! write (51,951) i,nlst_rt(did)%olddate,g_qin_gwsubbas(i) 951 FORMAT(I3,1X,A19,1X,F11.3) ! write (52,951) i,nlst_rt(did)%olddate,g_qout_gwsubbas(i) ! write (53,951) i,nlst_rt(did)%olddate,g_z_gwsubbas(i) ! end do ! close(51) ! close(52) ! close(53) call output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, gnbasns, & trim(nlst(did)%sincedate), trim(nlst(did)%olddate), & g_basnsInd,g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas ) deallocate(g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas, g_basnsInd) endif if(allocated(g_qin_gwsubbas)) deallocate(g_qin_gwsubbas) if(allocated(g_qout_gwsubbas)) deallocate(g_qout_gwsubbas) if(allocated(g_z_gwsubbas)) deallocate(g_z_gwsubbas) # else ! open (unit=51,file='GW_inflow.txt',form='formatted',& ! status='unknown',position='append') ! open (unit=52,file='GW_outflow.txt',form='formatted',& ! status='unknown',position='append') ! open (unit=53,file='GW_zlev.txt',form='formatted',& ! status='unknown',position='append') ! do i=1,RT_DOMAIN(did)%numbasns ! write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) 951 FORMAT(I3,1X,A19,1X,F11.3) ! write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) ! write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) ! end do ! close(51) ! close(52) ! close(53) if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then call output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, RT_DOMAIN(did)%numbasns, & trim(nlst(did)%sincedate), trim(nlst(did)%olddate), & rt_domain(did)%basnsInd,rt_domain(did)%qin_gwsubbas, & rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas ) else call output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, RT_DOMAIN(did)%nlinksl, & trim(nlst(did)%sincedate), trim(nlst(did)%olddate), & rt_domain(did)%linkid,rt_domain(did)%qin_gwsubbas, & rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas ) endif #endif end subroutine output_GW_Diag !----------------------------------- gw netcdf output subroutine output_gw_netcdf(igrid, split_output_count, nbasns, & startdate, date, & gw_id_var, gw_in_var, gw_out_var, gw_z_var) integer, intent(in) :: igrid integer, intent(in) :: split_output_count integer, intent(in) :: nbasns real, dimension(:), intent(in) :: gw_in_var, gw_out_var, gw_z_var integer(kind=int64), dimension(:), intent(in) :: gw_id_var character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date integer, save :: output_count integer, save :: ncid integer :: basindim, varid, n, nstations integer :: iret,i !-- character(len=256) :: output_flnm character(len=19) :: date19, date19start character(len=32) :: convention integer :: timedim integer :: seconds_since character(len=34) :: sec_since_date character(len=34) :: sec_valid_date if(split_output_count .ne. 1 ) then write(6,*) "WARNING: split_output_count need to be 1 for this output option." endif sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & //startdate(12:13)//':'//startdate(15:16)//':00' seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1)) sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) & //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC' write(output_flnm, '(A12,".GWOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid #ifdef HYDRO_D print*, 'output_flnm = "'//trim(output_flnm)//'"' #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then print*, "Problem nf90_create" call hydro_stop("output_gw_netcdf") endif !!! Define dimensions nstations =nbasns iret = nf90_def_dim(ncid, "basin", nstations, basindim) iret = nf90_def_dim(ncid, "time", 1, timedim) !!! Define variables !- gw basin ID iret = nf90_def_var(ncid, "gwbas_id", NF90_INT, (/basindim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'GW basin ID') !- gw inflow iret = nf90_def_var(ncid, "gw_inflow", NF90_FLOAT, (/basindim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') !- gw outflow iret = nf90_def_var(ncid, "gw_outflow", NF90_FLOAT, (/basindim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec') !- depth in gw bucket iret = nf90_def_var(ncid, "gw_zlev", NF90_FLOAT, (/basindim/), varid) iret = nf90_put_att(ncid, varid, 'units', 'mm') ! Time variable iret = nf90_def_var(ncid, "time", NF90_INT, (/timeDim/), varid) iret = nf90_put_att(ncid, varid, 'units', sec_valid_date) iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time') date19(1:19) = "0000-00-00_00:00:00" date19(1:len_trim(startdate)) = startdate iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate)) iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15) iret = nf90_enddef(ncid) !!! Input variables !-- write lake id iret = nf90_inq_varid(ncid,"gwbas_id", varid) iret = nf90_put_var(ncid, varid, gw_id_var, (/1/), (/nstations/)) !-- write gw inflow iret = nf90_inq_varid(ncid,"gw_inflow", varid) iret = nf90_put_var(ncid, varid, gw_in_var, (/1/), (/nstations/)) !-- write elevation of inflow iret = nf90_inq_varid(ncid,"gw_outflow", varid) iret = nf90_put_var(ncid, varid, gw_out_var, (/1/), (/nstations/)) !-- write elevation of inflow iret = nf90_inq_varid(ncid,"gw_zlev", varid) iret = nf90_put_var(ncid, varid, gw_z_var, (/1/), (/nstations/)) !-- write time variable iret = nf90_inq_varid(ncid,"time", varid) iret = nf90_put_var(ncid, varid, seconds_since, (/1/)) iret = nf90_close(ncid) end subroutine output_gw_netcdf !------------------------------- end gw netcdf output subroutine read_NSIMLAKES(NLAKES,route_lake_f) integer :: NLAKES CHARACTER(len=* ) :: route_lake_f character(len=256) :: route_lake_f_r integer :: lenRouteLakeFR, iRet, ncid, dimId logical :: routeLakeNetcdf !! is RouteLake file netcdf (*.nc) or from the LAKEPARM.TBL ascii #ifdef MPP_LAND if(my_id .eq. io_id) then #endif route_lake_f_r = adjustr(route_lake_f) lenRouteLakeFR = len(route_Lake_f_r) routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc' write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f) write(6,*) "routeLakeNetcdf TF Name Len",routeLakeNetcdf, route_lake_f,lenRouteLakeFR call flush(6) if(routeLakeNetcdf) then write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f) NLAKES = -99 NLAKES = get_netcdf_dim(trim(route_lake_f), 'feature_id', & 'read_NSIMLAKES', fatalErr=.false.) if (NLAKES .eq. -99) then ! We were unsucessful in getting feature_id, try linkDim NLAKES = get_netcdf_dim(trim(route_lake_f), 'nlakes', & 'read_NSIMLAKES', fatalErr=.false.) endif if (NLAKES .eq. -99) then ! Neither the feature_id nor nlakes dimensions were found in ! the LAKEPARM file. Throw an error... call hydro_stop("Could not find either feature_id or nlakes in LAKEPARM netcdf file.") endif else !yw for IOC reach based routing, if netcdf lake file is not set from the hydro.namelist, ! we will assume that no lake will be assimilated. write(6,*) "Lakes have been disabled -- NLAKES will be set to zero." NLAKES = 0 endif #ifdef MPP_LAND endif ! end if block of my_id .eq. io_id call mpp_land_bcast_int1(NLAKES) #endif end subroutine read_NSIMLAKES ! sequential code: not used.!!!!!! subroutine nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, gTO_NODE,LINKID, LAKEIDM, LAKEIDA) !--- get the lake configuration here. implicit none integer, dimension(:), intent(inout) :: TYPEL, LAKEIDX integer(kind=int64), dimension(:), intent(inout) :: LINKID, LAKEIDA, LAKELINKID, LAKEIDM, gTO_NODE integer, intent(in) :: NLAKES, NLINKSL integer, dimension(NLINKSL) :: OUTLAKEID integer :: i,j,k, kk TYPEL = -999 !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach #ifdef MPP_LAND call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, gTO_NODE,LINKID, LAKEIDM, LAKEIDA,NLINKSL) #endif OUTLAKEID = gTO_NODE DO i = 1, NLAKES DO j = 1, NLINKSL DO k = 1, NLINKSL if( (gTO_NODE(j) .eq. LINKID(k) ) .and. & (LAKEIDA(k) .lt. 0 .and. LAKEIDA(j) .eq. LAKEIDM(i))) then TYPEL(j) = 1 !this is the link flowing out of the lake OUTLAKEID(j) = LAKEIDA(j) ! LINKID(j) LAKELINKID(i) = j ! write(61,*) gTO_NODE(j),LAKEIDA(j),LAKEIDA(k),LAKELINKID(i) , j ! call flush(61) elseif( (gTO_NODE(j) .eq. LINKID(k)) .and. & (LAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. & (LAKEIDA(k) .eq. LAKEIDM(i)) ) then TYPEL(j) = 3 !type_3 inflow link to lake OUTLAKEID(j) = LAKEIDM(i) elseif (LAKEIDA(j) .eq. LAKEIDM(i) .and. .not. TYPEL(j) .eq. 1) then TYPEL(j) = 2 ! internal lake linkd endif END DO END DO END DO DO i = 1, NLAKES if(LAKELINKID(i) .gt. 0) then LAKEIDX(LAKELINKID(i)) = i endif ENDDO ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link DO i = 1, NLINKSL DO j = 1, NLINKSL if(TYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. OUTLAKEID(i))) then gTO_NODE(i) = LINKID(j) ! OUTLAKEID(i) endif ENDDO ENDDO ! do k = 1, NLINKSL ! write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k) ! call flush(60+my_id) ! end do ! DO i = 1, NLINKSL ! write(61,*) i,LAKEIDX(i), TYPEL(i) ! end do ! DO i = 1, NLAKES ! write(62,*) i,LAKELINKID(i) ! write(63,*) i,LAKEIDM(i) ! end do ! close(61) ! close(62) ! close(63) ! call hydro_finish() ! write(60,*) TYPEL ! write(63,*) LAKELINKID, LAKEIDX ! write(64,*) gTO_NODE ! write(61,*) LINKID ! write(62,*) LAKEIDM, LAKEIDA ! close(60) ! close(61) ! close(62) ! close(63) ! close(64) ! call hydro_finish() end subroutine nhdLakeMap #ifdef MPP_LAND subroutine nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL) !--- get the lake configuration here. implicit none integer, dimension(:), intent(out) :: TYPEL integer, dimension(:), intent(out) :: LAKEIDX integer(kind=int64), dimension(:), intent(inout) :: TO_NODE integer(kind=int64), dimension(:), intent(out) :: LAKELINKID integer(kind=int64), dimension(:), intent(in) :: LINKID, LAKEIDA integer(kind=int64), dimension(:), intent(inout) :: LAKEIDM integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL !yw integer, dimension(NLINKSL) :: OUTLAKEID integer(kind=int64), allocatable, dimension(:) :: OUTLAKEID integer :: i,size2 ,j,k, kk, num, maxNum, m, mm, tmpSize integer, allocatable, dimension(:) :: tmpTYPEL, ind, gLAKEIDX integer(kind=int64), allocatable, dimension(:) :: gLINKID, tmpLINKID, tmplakeida, tmpoutlakeid, gLAKEIDA integer(kind=int64), allocatable, dimension(:,:) :: gtonodeout integer, allocatable, dimension(:) :: gTYPEL integer(kind=int64), allocatable, dimension(:) :: tmpLAKELINKID, gOUTLAKEID, tmpTO_NODE, gto integer(kind=int64) tmpBuf(GNLINKSL) tmpSize = size(TO_NODE,1) allocate(OUTLAKEID(tmpSize)) allocate (gto(GNLINKSL)) if(my_id .eq. io_id) then allocate (tmpLAKELINKID(nlakes) ) else allocate (tmpLAKELINKID(1)) endif ! prescan the data and remove the LAKEIDM which point to two links. #ifdef MPP_LAND call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL) #endif call gBcastValue(TO_NODE,gto) maxNum = 0 kk = 0 ! The following loops are replaced by a hashtable-based algorithm ! do m = 1, NLINKSL ! num = 0 ! do k = 1, gnlinksl ! if(gto(k) .eq. LINKID(m) ) then ! kk = kk +1 ! num = num + 1 ! endif ! end do ! if(num .gt. maxNum) maxNum = num ! end do block type(hash_t) :: hash_table integer(kind=int64) :: val,it integer(kind=int64), allocatable :: num_a(:) logical :: found allocate(num_a(NLINKSL)) num_a = 0 kk = 0 call hash_table%set_all_idx(linkid, NLINKSL) do it=1, gnlinksl call hash_table%get(gto(it), val, found) if(found .eqv. .true.) then kk = kk + 1 num_a(val) = num_a(val) + 1 end if end do maxNum = maxval(num_a) num_a = 1 allocate(ind(kk)) allocate(gToNodeOut(NLINKSL,maxNum+1)) gToNodeOut = -99 allocate(tmpTYPEL(kk)) allocate(tmpLINKID(kk)) allocate(tmpLAKEIDA(kk)) allocate(tmpOUTLAKEID(kk)) allocate(tmpTO_NODE(kk)) if(kk .gt. 0) then tmpOUTLAKEID = -999 tmpTYPEL = -999 tmpTO_NODE = -999 endif if(NLINKSL .gt. 0) then OUTLAKEID = -999 TYPEL = -999 endif kk = 0 ! The following loops are replaced by a hashtable-based algorithm ! do m = 1, NLINKSL ! num = 1 ! do k = 1, gnlinksl ! if(gto(k) .eq. LINKID(m) ) then ! kk = kk +1 ! ind(kk) = k ! tmpTO_NODE(kk) = gto(k) ! gToNodeOut(m,num+1) = kk ! gToNodeOut(m,1) = num ! num = num + 1 ! endif ! end do ! enddo do it=1, gnlinksl call hash_table%get(gto(it), val, found) if(found .eqv. .true.) then kk = kk + 1 ind(kk) = it tmpTO_NODE(kk) = gto(it) gToNodeOut(val,num_a(val)+1) = kk gToNodeOut(val,1) = num_a(val) num_a(val) = num_a(val) + 1 end if end do deallocate(num_a) call hash_table%clear() end block size2 = kk deallocate (gto) allocate(gLINKID(gnlinksl)) call gBcastValue(LINKID,gLINKID) do i = 1, size2 k = ind(i) tmpLINKID(i) = gLINKID(k) enddo allocate(gLAKEIDA(gnlinksl)) call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) ) do i = 1, size2 k = ind(i) tmpLAKEIDA(i) = gLAKEIDA(k) enddo if(allocated(gLAKEIDA)) deallocate(gLAKEIDA) !yw LAKELINKID = 0 tmpLAKELINKID = LAKELINKID tmpOUTLAKEID = tmpTO_NODE OUTLAKEID(1:NLINKSL) = TO_NODE(1:NLINKSL) !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach DO i = 1, NLAKES DO k = 1, NLINKSL do m = 1, gToNodeOut(k,1) j = gToNodeOut(k,m+1) if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. & (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then tmpTYPEL(j) = 1 !this is the link flowing out of the lake tmpOUTLAKEID(j) = tmpLAKEIDA(j) !tmpLINKID(j) ! Wei Check LAKELINKID(i) = ind(j) ! write(61,*) tmpTO_NODE(j),tmpLAKEIDA(j),LAKEIDA(k),LAKELINKID(i) ! call flush(61) elseif( (tmpTO_NODE(j) .eq. LINKID(k)) .and. & (tmpLAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. & (LAKEIDA(k) .eq. LAKEIDM(i)) ) then tmpTYPEL(j) = 3 !type_3 inflow link to lake tmpOUTLAKEID(j) = LAKEIDM(i) !Wei Check ! write(62,*) tmpTO_NODE(j),tmpOUTLAKEID(j),LAKEIDM(i) ! call flush(62) elseif (tmpLAKEIDA(j) .eq. LAKEIDM(i) .and. tmpTYPEL(j) .ne. 1) then tmpTYPEL(j) = 2 ! internal lake linkd !! print the following to get the list of links which are ignored bc they are internal to lakes. !print*,'Ndg: tmpLAKEIDA(j):', tmpLAKEIDA(j) endif END DO END DO END DO !yw call sum_int1d(LAKELINKID, NLAKES) call updateLake_seqInt8(LAKELINKID,nlakes,tmpLAKELINKID) if(allocated(tmplakelinkid)) deallocate(tmpLAKELINKID) if(gNLINKSL .gt. 0) then if(my_id .eq. 0) then allocate(gLAKEIDX(gNLINKSL)) gLAKEIDX = -999 DO i = 1, NLAKES if(LAKELINKID(i) .gt. 0) then gLAKEIDX(LAKELINKID(i)) = i endif ENDDO else allocate(gLAKEIDX(1)) endif call ReachLS_decomp(gLAKEIDX, LAKEIDX) if(allocated(gLAKEIDX)) deallocate(gLAKEIDX) endif ! do k = 1, size ! write(70+my_id,*) "k, ind(k), typel, lakeidx", k, ind(k),tmpTYPEL(k), lakeidx(ind(k)) ! call flush(70+my_id) ! end do call TONODE2RSL(ind,tmpTYPEL,size2,gNLINKSL,NLINKSL,TYPEL(1:NLINKSL), -999 ) call TONODE2RSL8(ind,tmpOUTLAKEID,size2,gNLINKSL,NLINKSL,OUTLAKEID(1:NLINKSL), -999 ) ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link !yw DO i = 1, NLINKSL !yw 105 ! DO k = 1, NLINKSL ! do m = 1, gToNodeOut(k,1) ! i = gToNodeOut(k,m+1) ! DO j = 1, NLINKSL ! if (tmpTYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. tmpOUTLAKEID(i)) & ! .and. tmpOUTLAKEID(i) .ne. -999) then ! !yw tmpTO_NODE(i) = tmpOUTLAKEID(i) !Wei Check ! tmpTO_NODE(i) = LINKID(j) !Wei Check ! endif ! END DO ! END DO ! END DO ! call TONODE2RSL(ind,tmpTO_NODE,size,gNLINKSL,NLINKSL,TO_NODE(1:NLINKSL), -999 ) ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link allocate(gTYPEL(gNLINKSL)) allocate(gOUTLAKEID(gNLINKSL)) call gBcastValue(TYPEL,gTYPEL) call gBcastValue(OUTLAKEID,gOUTLAKEID) DO i = 1, NLINKSL DO j = 1, gNLINKSL if(TYPEL(i) .eq. 3 .and. gTYPEL(j) .eq. 1 .and. (gOUTLAKEID(j) .eq. OUTLAKEID(i))) then TO_NODE(i) = gLINKID(j) ! OUTLAKEID(i) endif ENDDO ENDDO deallocate(gLINKID) deallocate(gTYPEL) deallocate(gOUTLAKEID) deallocate(tmpTYPEL,tmpLINKID, tmpTO_NODE, tmpLAKEIDA, tmpOUTLAKEID,OUTLAKEID) ! do k = 1, NLINKSL ! write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k) ! call flush(60+my_id) ! end do ! call ReachLS_write_io(TO_NODE(1:NLINKSL), tmpBuf(1:gNLINKSL) ) ! if(my_id .eq. io_id ) then ! write(70,*) tmpBuf(1:gNLINKSL) ! call flush(70) ! endif ! call ReachLS_write_io(TYPEL(1:NLINKSL), tmpBuf(1:gNLINKSL) ) ! if(my_id .eq. io_id ) then ! write(71,*) tmpBuf ! call flush(71) ! endif ! call ReachLS_write_io(LAKEIDX(1:NLINKSL), tmpBuf(1:gNLINKSL)) ! if(my_id .eq. io_id ) then ! write(72,*) tmpBuf ! call flush(72) ! close(72) ! endif ! call ReachLS_write_io(OUTLAKEID(1:NLINKSL), tmpBuf(1:gNLINKSL)) ! if(my_id .eq. io_id ) then ! write(73,*) tmpBuf ! call flush(73) ! endif ! call hydro_finish() ! DO i = 1, NLINKSL ! write(61,*) i,LAKEIDX(i), TYPEL(i) ! end do ! DO i = 1, NLAKES ! write(63,*) i,LAKEIDM(i) ! write(62,*) i,LAKELINKID(i) ! end do ! close(61) ! close(62) ! close(63) ! write(60,*) TYPEL ! write(63,*) LAKELINKID, LAKEIDX ! write(64,*) TO_NODE ! write(61,*) LINKID ! write(62,*) LAKEIDM, LAKEIDA ! close(60) ! close(61) ! close(62) ! close(63) ! close(64) ! call hydro_finish() end subroutine nhdLakeMap_mpp subroutine nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL) !--- get the lake configuration here. implicit none integer(kind=int64), dimension(:), intent(in) :: TO_NODE integer(kind=int64), dimension(NLAKES) :: LAKELINKID integer(kind=int64), dimension(:), intent(in) :: LINKID, LAKEIDA integer(kind=int64), dimension(:), intent(inout) :: LAKEIDM integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL integer :: i,size ,j,k, kk, num, maxNum, m, mm integer(kind=int64), allocatable, dimension(:) :: tmplakeida, tmpoutlakeid, gLAKEIDA, tmpTO_NODE, gto integer(kind=int64), allocatable, dimension(:) :: ind integer(kind=int64), allocatable, dimension(:,:) :: gtonodeout integer(kind=int64), allocatable, dimension(:) :: tmpLAKELINKID, gtoLakeId_g, gtoLakeId ! integer tmpBuf(GNLINKSL) integer, dimension(nlakes) :: lakemask integer ii allocate (gto(GNLINKSL)) allocate (gtoLakeId_g(GNLINKSL)) allocate (gtoLakeId(NLINKSL)) if(my_id .eq. io_id) then allocate(tmpLAKELINKID(nlakes)) else allocate(tmpLAKELINKID(1)) endif gtoLakeId_g=-999 call gBcastValue(TO_NODE,gto) maxNum = 0 kk = 0 ! The following loops are replaced by a hashtable-based algorithm ! do m = 1, NLINKSL ! num = 0 ! do k = 1, gnlinksl ! if(gto(k) .eq. LINKID(m) ) then ! gtoLakeId_g(k) = lakeida(m) ! kk = kk +1 ! num = num + 1 ! endif ! end do ! if(num .gt. maxNum) maxNum = num ! end do block type(hash_t) :: hash_table integer(kind=int64) :: val,it integer(kind=int64), allocatable :: num_a(:) logical :: found allocate(num_a(NLINKSL)) num_a = 0 kk = 0 call hash_table%set_all_idx(linkid, NLINKSL) do it=1, gnlinksl call hash_table%get(gto(it), val, found) if(found .eqv. .true.) then gtoLakeId_g(it) = lakeida(val) kk = kk + 1 num_a(val) = num_a(val) + 1 end if end do maxNum = maxval(num_a) num_a = 1 allocate(ind(kk)) allocate(gToNodeOut(NLINKSL,maxNum+1)) gToNodeOut = -99 allocate(tmpLAKEIDA(kk)) allocate(tmpTO_NODE(kk)) kk = 0 ! The following loops are replaced by a hashtable-based algorithm ! do m = 1, NLINKSL ! num = 1 ! do k = 1, gnlinksl ! if(gto(k) .eq. LINKID(m) ) then ! kk = kk +1 ! ind(kk) = k ! tmpTO_NODE(kk) = gto(k) ! gToNodeOut(m,num+1) = kk ! gToNodeOut(m,1) = num ! num = num + 1 ! endif ! end do ! end do do it=1, gnlinksl call hash_table%get(gto(it), val, found) if(found .eqv. .true.) then kk = kk + 1 ind(kk) = it tmpTO_NODE(kk) = gto(it) gToNodeOut(val,num_a(val)+1) = kk gToNodeOut(val,1) = num_a(val) num_a(val) = num_a(val) + 1 end if end do deallocate(num_a) call hash_table%clear() end block size = kk if(allocated(gto)) deallocate (gto) allocate(gLAKEIDA(gnlinksl)) call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) ) do i = 1, size k = ind(i) tmpLAKEIDA(i) = gLAKEIDA(k) enddo if(allocated(gLAKEIDA)) deallocate(gLAKEIDA) tmpLAKELINKID = LAKELINKID ! LAKELINKID = 0 DO i = 1, NLAKES DO k = 1, NLINKSL do m = 1, gToNodeOut(k,1) j = gToNodeOut(k,m+1) if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. & (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then if(LAKELINKID(i) .gt. 0) then LAKELINKID(i) = -999 #ifdef HYDRO_D write(6,*) "remove the lake LAKEIDM(i) ", i, LAKEIDM(i) call flush(6) #endif endif if(LAKELINKID(i) .eq. 0) LAKELINKID(i) = ind(j) endif END DO END DO END DO !yw call match1dLake(LAKELINKID, NLAKES, -999) !yw double check call combine_int8_1d(gtoLakeId_g,gnlinksl, -999) call ReachLS_decomp(gtoLakeId_g,gtoLakeId) lakemask = 0 DO k = 1, NLINKSL if(LAKEIDA(k) .gt. 0) then DO i = 1, NLAKES if(gtoLakeId(k) .eq. LAKEIDM(i) ) then goto 992 endif enddo DO i = 1, NLAKES if(LAKEIDA(k) .eq. LAKEIDM(i) ) then lakemask(i) = lakemask(i) + 1 goto 992 endif enddo 992 continue endif enddo if(allocated(gtoLakeId_g)) deallocate(gtoLakeId_g) if(allocated(gtoLakeId)) deallocate(gtoLakeId) call sum_int1d(lakemask, NLAKES) do i = 1, nlakes if(lakemask(i) .ne. 1) then LAKELINKID(i) = -999 #ifdef HYDRO_D if(my_id .eq. IO_id) then write(6,*) "double check remove the lake : ",LAKEIDM(i) call flush(6) endif #endif endif enddo !end double check call updateLake_seqInt8(LAKELINKID,nlakes,tmpLAKELINKID) ! if(my_id .eq. 0) then ! write(65,*) "check LAKEIDM *****," ! write(65,*) LAKEIDM ! call flush(6) ! endif do k = 1, NLAKES if(LAKELINKID(k) .eq. -999) LAKEIDM(k) = -999 end do ! if(my_id .eq. 0) then ! write(65,*) "check LAKEIDM *****," ! write(65,*) LAKEIDM ! call flush(6) ! endif close(65) if(allocated(tmpTO_NODE)) deallocate(tmpTO_NODE) if(allocated(tmpLAKEIDA)) deallocate(tmpLAKEIDA) if(allocated(tmplakelinkid)) deallocate(tmplakelinkid) end subroutine nhdLakeMap_scan #endif !ADCHANGE: New output lake types routine subroutine output_lake_types( inNLINKS, inLINKID, inTYPEL ) #ifdef MPP_LAND use module_mpp_land #endif implicit none integer, dimension(:), intent(in) :: inTYPEL integer(kind=int64), dimension(:), intent(in) :: inLINKID integer, intent(in) :: inNLINKS integer :: iret integer :: ncid, varid integer :: linkdim character(len=256), parameter :: output_flnm = "LAKE_TYPES.nc" integer, allocatable, dimension(:) :: typeL integer(kind=int64), allocatable, dimension(:) :: linkId #ifdef MPP_LAND if(my_id .eq. io_id) then allocate( linkId(inNLINKS) ) allocate( typeL(inNLINKS) ) else allocate(linkId(1), typeL(1)) end if call mpp_land_sync() call ReachLS_write_io(inLINKID, linkId) call ReachLS_write_io(inTYPEL, typeL) #else allocate( linkId(inNLINKS) ) allocate( typeL(inNLINKS) ) linkId = inLINKID typeL = inTYPEL #endif #ifdef MPP_LAND if(my_id .eq. io_id) then #endif ! Create the channel connectivity file #ifdef HYDRO_D print*,'Lakes: output_flnm = "'//trim(output_flnm)//'"' flush(6) #endif iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) if (iret /= 0) then print*,"Lakes: Problem nf90_create" call hydro_stop("output_lake_types") endif iret = nf90_def_dim(ncid, "link", inNLINKS, linkdim) !-- link id iret = nf90_def_var(ncid, "LINKID", NF90_INT64, (/linkdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Link ID') !- lake reach type, var iret = nf90_def_var(ncid, "TYPEL", NF90_INT, (/linkdim/), varid) iret = nf90_put_att(ncid, varid, 'long_name', 'Lake reach type') iret = nf90_enddef(ncid) !-- write id iret = nf90_inq_varid(ncid,"LINKID", varid) iret = nf90_put_var(ncid, varid, linkId, (/1/), (/inNLINKS/)) !-- write type iret = nf90_inq_varid(ncid,"TYPEL", varid) iret = nf90_put_var(ncid, varid, typeL, (/1/), (/inNLINKS/)) iret = nf90_close(ncid) #ifdef MPP_LAND endif #endif if(allocated(linkId)) deallocate(linkId) if(allocated(typeL)) deallocate(typeL) #ifdef MPP_LAND if(my_id .eq. io_id) then #endif #ifdef HYDRO_D write(6,*) "end of output_lake_types" flush(6) #endif #ifdef MPP_LAND endif #endif end subroutine output_lake_types subroutine hdtbl_out_nc(did,ncid,count,count_flag,varName,varIn,descrip,ixd,jxd) implicit none integer :: did, iret, ncid, ixd,jxd, ix,jx, err_flag,count_flag, count,varid real, allocatable, dimension(:,:) :: xdump real, dimension(:,:) :: varIn character(len=*) :: descrip character(len=*) ::varName #ifdef MPP_LAND ix=global_nx jx=global_ny #else ix=RT_DOMAIN(did)%ix jx=RT_DOMAIN(did)%jx #endif if( count == 0 .and. count_flag == 0) then count_flag = 1 #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif iret = nf90_create(trim(nlst(did)%hydrotbl_f), OR(NF90_CLOBBER, NF90_NETCDF4), ncid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(iret) #endif if (iret /= 0) then call hydro_stop("FATAL ERROR: - Problem nf90_create in nc of hydrotab_f file") endif #ifdef MPP_LAND if(my_id .eq. IO_id) then #endif iret = nf90_def_dim(ncid, "west_east", ix, ixd) !-- make a decimated grid iret = nf90_def_dim(ncid, "south_north", jx, jxd) #ifdef MPP_LAND endif #endif endif ! count == 0 if( count == 1 ) then ! define variables #ifdef MPP_LAND if(my_id .eq. io_id) then #endif iret = nf90_def_var(ncid, trim(varName), NF90_FLOAT, (/ixd,jxd/), varid) ! iret = nf90_put_att(ncid, varid, 'description', trim(descrip)) iret = nf90_put_att(ncid, varid, 'description', "test") #ifdef MPP_LAND endif #endif endif !!! end of count == 1 if (count == 2) then ! write out the variables if(count_flag == 2) iret = nf90_enddef(ncid) count_flag = 3 #ifdef MPP_LAND if(my_id .eq. io_id) then #endif allocate (xdump(ix, jx)) #ifdef MPP_LAND else allocate (xdump(1, 1)) endif #endif #ifdef MPP_LAND call write_io_real(varIn,xdump) if(my_id .eq. io_id) iret = nf90_inq_varid(ncid,trim(varName), varid) if(my_id .eq. io_id) iret = nf90_put_var(ncid, varid, xdump, (/1,1/), (/ix,jx/)) #else iret = nf90_inq_varid(ncid,trim(varName), varid) iret = nf90_put_var(ncid, varid, varIn, (/1,1/), (/ix,jx/)) #endif deallocate(xdump) endif !! end of count == 2 if(count == 3 .and. count_flag == 3) then count_flag = 4 #ifdef MPP_LAND if(my_id .eq. io_id ) & #endif iret = nf90_close(ncid) endif !! end of count == 3 end subroutine hdtbl_out_nc subroutine hdtbl_out(did) implicit none integer :: did, ncid, count,count_flag, i, ixd,jxd do i = 0,3 count = i count_flag = i call hdtbl_out_nc(did,ncid, count,count_flag,"SMCMAX1",rt_domain(did)%SMCMAX1,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"SMCREF1",rt_domain(did)%SMCREF1,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"SMCWLT1",rt_domain(did)%SMCWLT1,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"LKSAT",rt_domain(did)%LKSAT,"",ixd,jxd) call hdtbl_out_nc(did,ncid, count,count_flag,"NEXP",rt_domain(did)%NEXP,"",ixd,jxd) end do end subroutine hdtbl_out subroutine hdtbl_in_nc(did) implicit none integer :: did integer :: ierr call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCMAX1",rt_domain(did)%SMCMAX1,ierr) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCREF1",rt_domain(did)%SMCREF1,ierr) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCWLT1",rt_domain(did)%SMCWLT1,ierr) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%overland%properties%roughness,ierr, rt=.true.) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"LKSAT",rt_domain(did)%LKSAT,ierr) call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"NEXP",rt_domain(did)%NEXP,ierr) ! Letting this variable be optional and setting to global default value if not found if (ierr /= 0) then write(6,*) "WARNING (hydtbl_in_nc): NEXP not found so setting to global 1.0" rt_domain(did)%NEXP = 1.0 endif end subroutine hdtbl_in_nc subroutine read2dlsm(did,file,varName,varOut,ierr,rt) use module_mpp_land,only: mpp_land_bcast_int1 implicit none integer :: did, ncid , iret character(len=*) :: file,varName real,dimension(:,:) :: varOut character(len=256) :: units integer, intent(out) :: ierr logical, optional, intent(in) :: rt logical :: regrid real,allocatable,dimension(:,:) :: tmpArr #ifdef MPP_LAND if(my_id .eq. io_id) then #endif allocate(tmpArr(global_nx,global_ny)) iret = nf90_open(trim(file), NF90_NOWRITE, ncid) call get_2d_netcdf(trim(varName), ncid, tmpArr, units, global_nx, global_ny, & .false., ierr) iret = nf90_close(ncid) #ifdef MPP_LAND else allocate(tmpArr(1,1)) endif #endif if (present(rt)) then regrid = rt else regrid = .false. endif if (regrid) then call regrid_lowres_to_highres(did, tmpArr, varOut, rt_domain(did)%ixrt, rt_domain(did)%jxrt) else call decompose_data_real (tmpArr,varOut) endif #ifdef MPP_LAND call mpp_land_bcast_int1(ierr) #endif deallocate(tmpArr) end subroutine read2dlsm subroutine regrid_lowres_to_highres(did, lowres_grid, highres_grid, ixrt, jxrt) implicit none integer :: did integer :: ixrt, jxrt real, dimension(global_nx, global_ny) :: lowres_grid real, dimension(ixrt,jxrt) :: highres_grid ! Local variables integer :: i, j, irt, jrt, aggfacxrt, aggfacyrt #ifdef MPP_LAND real,allocatable,dimension(:,:) :: tmpArr if(my_id .eq. io_id) then allocate(tmpArr(global_rt_nx, global_rt_ny)) #endif do j = 1,global_ny ! Start coarse grid j loop do i = 1,global_nx ! Start coarse grid i loop do aggfacyrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid j loop do aggfacxrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid i loop irt = i * nlst(did)%AGGFACTRT - aggfacxrt ! Define fine grid i jrt = j * nlst(did)%AGGFACTRT - aggfacyrt ! Define fine grid j #ifdef MPP_LAND ! if(left_id.ge.0) irt = irt + 1 ! if(down_id.ge.0) jrt = jrt + 1 tmpArr(irt,jrt) = lowres_grid(i,j) #else highres_grid(irt,jrt) = lowres_grid(i,j) #endif end do end do end do end do #ifdef MPP_LAND else allocate(tmpArr(1,1)) endif call decompose_RT_real(tmpArr, highres_grid, global_rt_nx, global_rt_ny, ixrt, jxrt) deallocate(tmpArr) #endif end subroutine regrid_lowres_to_highres subroutine read_channel_only (olddateIn, hgrid, indir, dtbl) !use module_HYDRO_io, only: read_rst_crt_reach_nc use module_RT_data, only: rt_domain use module_mpp_land,only: mpp_land_bcast_int1, my_id, io_id use Module_Date_utilities_rt, only: geth_newdate use config_base, only: nlst implicit none integer :: iret, did, len, ncid integer :: dtbl character :: hgrid character(len=*):: olddateIn,indir character(len=19) :: olddate character(len=256):: fileName real*8, allocatable, dimension(:):: accBucket_in, accSfcLatRunoff_in real , allocatable, dimension(:):: qBucket_in, qSfcLatRunoff_in integer, parameter :: r8 = selected_real_kind(8) real*8, parameter :: zeroDbl=0.0000000000000000000_r8 integer :: ovrtswcrt_in, noah_timestep_in, channel_only_in, channelBucket_only_in character(len=86) :: attNotInFileMsg did = 1 len = size(rt_domain(did)%QLATERAL,1) !! if len is .le. 0, this whole thing is pointless. huh? if(my_id .eq. io_id) then call geth_newdate(olddate,olddateIn,dtbl) fileName = trim(indir)//"/"//& olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& olddate(15:16)//".CHRTOUT_DOMAIN"//hgrid #ifdef HYDRO_D print*, " Channel only input forcing file: ",trim(fileName) #endif /* HYDRO_D */ iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid) endif call mpp_land_bcast_int1(iret) if (iret .ne. 0) then call hydro_stop( "FATAL ERROR: read forcing data for CHANNEL_ONLY failed. ") endif !! --------------------------------------------------------------------------- !! Consistency checks - global att checking. if(my_id .eq. io_id) then attNotInFileMsg=& !! lenght fixed above 'Fatal error for channel only: the following global attribute not in the forcing file: ' !! 1) overland routing v squeegee?? !!if(nlst_rt(did)%OVRTSWCRT .eq. 1) then iret = nf90_get_att(ncid, NF90_GLOBAL, 'OVRTSWCRT', ovrtswcrt_in) if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_OVRTSWCRT', ovrtswcrt_in) if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'OVRTSWCRT & dev_OVRTSWCRT not in ' // trim(fileName) ) if(nlst(1)%ovrtswcrt .ne. ovrtswcrt_in) & call hydro_stop('Channel only: OVRTSWCRT or dev_OVRSWCRT in forcing file does not match run config.') !! 2) NOAH_TIMESTEP same? iret = nf90_get_att(ncid, NF90_GLOBAL, 'NOAH_TIMESTEP', noah_timestep_in) if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_NOAH_TIMESTEP', noah_timestep_in) if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'NOAH_TIMESTEP & dev_NOAH_TIMESTEP not in ' // trim(fileName) ) if(nlst(1)%dt .ne. noah_timestep_in) & call hydro_stop('Channel only: NOAH_TIMESTEP or dev_NOAH_TIMESTEP in forcing file does not match run config.') !! 3) channel_only or channelBucket_only? iret = nf90_get_att(ncid, NF90_GLOBAL, "channel_only", channel_only_in) if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, "dev_channel_only", channel_only_in) if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'channel_only not in ' // trim(fileName) ) iret = nf90_get_att(ncid, NF90_GLOBAL, "channelBucket_only", channelBucket_only_in) if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, "dev_channelBucket_only", channel_only_in) if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'channelBucket_only not in ' // trim(fileName) ) !! See table of fatal combinations on wiki: https://wiki.ucar.edu/display/wrfhydro/Channel+Only !! First row: Can it even get to this combination? NO. !if( (nlst_rt(did)%channel_only .eq. 0 .and. nlst_rt(did)%channelBucket_only .eq. 0) .and. & ! (channel_only_in .eq. 1 .or. channelBucket_only_in .eq. 1) ) & ! call hydro_stop('Channel Only: Forcing files in consistent with forcing type.') !! Second row: if(nlst(did)%channel_only .eq. 1 .and. channelBucket_only_in .eq. 1) & write(6,*) "Warning: channelBucket_only output forcing channel_only run" end if !! --------------------------------------------------------------------------- !! FLUXES or accumulations? NOT SUPPORTING accumulations to be read in. !! FLUXES if(nlst(did)%channel_only .eq. 1 .or. & nlst(did)%channelBucket_only .eq. 1 ) then allocate(qBucket_in(len)) allocate(qSfcLatRunoff_in(len)) qBucket_in = 0.0 qSfcLatRunoff_in = 0.0 !! Surface Lateral Fluxes (currenly include exfiltration from subsurface) call read_rst_crt_reach_nc(ncid, qSfcLatRunoff_in, "qSfcLatRunoff", & rt_domain(did)%GNLINKSL, fatalErr=.true. ) !! Fluxes from (channel only) or to (channelBucket only) bucket? !! Fluxes from bucket. if(nlst(did)%channel_only .eq. 1) then call read_rst_crt_reach_nc(ncid, qBucket_in, "qBucket", & rt_domain(did)%GNLINKSL, fatalErr=.true.) rt_domain(did)%qout_gwsubbas = qBucket_in rt_domain(did)%QLateral = qBucket_in + qSfcLatRunoff_in endif !! Fluxes to bucket if(nlst(did)%channelBucket_only .eq. 1) then call read_rst_crt_reach_nc(ncid, qBucket_in, "qBtmVertRunoff", & rt_domain(did)%GNLINKSL, fatalErr=.true.) rt_domain(did)%qin_gwsubbas = qBucket_in rt_domain(did)%QLateral = qSfcLatRunoff_in end if deallocate(qBucket_in, qSfcLatRunoff_in) end if !! Accumulations - NOT SUPPORTED, MAY NEVER BE. !! How to figure out if fluxes or accums force?? if(.FALSE.) then allocate(accBucket_in(len)) allocate(accSfcLatRunoff_in(len)) accBucket_in = zeroDbl accSfcLatRunoff_in = zeroDbl call read_rst_crt_reach_nc(ncid, accSfcLatRunoff_in, "accSfcLatRunoff", & rt_domain(did)%GNLINKSL, fatalErr=.true.) !! Could worry about bucket being off or not output... call read_rst_crt_reach_nc(ncid, accBucket_in, "accBucket", & rt_domain(did)%GNLINKSL, fatalErr=.true.) !! Calculate the current if(len .gt. 0) then !! would the length be zero on some images? rt_domain(did)%qout_gwsubbas = & real( (accBucket_in - rt_domain(did)%accBucket)/nlst(did)%DT ) rt_domain(did)%QLateral = & real( rt_domain(did)%qout_gwsubbas + & (accSfcLatRunoff_in - rt_domain(did)%accSfcLatRunoff)/nlst(did)%DT ) !! Negative accumulations imply accumulations were zeroed, e.g. the code was restarted if(any(rt_domain(did)%QLateral .lt. 0)) & rt_domain(did)%QLateral = real( (accSfcLatRunoff_in)/nlst(did)%DT ) if(any(rt_domain(did)%qout_gwsubbas .lt. 0)) & rt_domain(did)%qout_gwsubbas = real( (accBucket_in)/nlst(did)%DT ) !! /\ ORDER MATTERS \/ because the pre-input accumulations are needed above. !! else below would be zero. rt_domain(did)%accBucket = accBucket_in rt_domain(did)%accSfcLatRunoff = accSfcLatRunoff_in end if deallocate(accBucket_in, accSfcLatRunoff_in) end if if(my_id .eq. io_id) then iret = nf90_close(ncid) #ifdef HYDRO_D print*, "finish read channel only forcing " #endif /* HYDRO_D */ endif call flush(6) end subroutine read_channel_only !--------------------------------------------------------------------------- end module module_HYDRO_io