hydro/Routing/module_HYDRO_io.F90

   1 !  Program Name:
   2 !  Author(s)/Contact(s):
   3 !  Abstract:
   4 !  History Log:
   5 !
   6 !  Usage:
   7 !  Parameters: <Specify typical arguments passed>
   8 !  Input Files:
   9 !        <list file names and briefly describe the data they include>
  10 !  Output Files:
  11 !        <list file names and briefly describe the information they include>
  12 !
  13 !  Condition codes:
  14 !        <list exit condition or error codes returned >
  15 !        If appropriate, descriptive troubleshooting instructions or
  16 !        likely causes for failures could be mentioned here with the
  17 !        appropriate error code
  18 !
  19 !  User controllable options: <if applicable>
  20 !
  21
  22 module module_HYDRO_io
  23 #ifdef MPP_LAND
  24      use module_mpp_land
  25      use module_mpp_reachls,  only: ReachLS_decomp, reachls_wreal, ReachLS_write_io, &
  26                                     ReachLS_wInt, reachls_wreal2, TONODE2RSL, TONODE2RSL8, gbcastvalue
  27      use MODULE_mpp_GWBUCKET, only: gw_write_io_real, gw_write_io_int
  28 #endif
  29    use Module_Date_utilities_rt, only: geth_newdate
  30    use module_HYDRO_utils, only: get_dist_ll
  31    use config_base, only: nlst
  32    use module_RT_data, only: rt_domain
  33    use module_gw_gw2d_data, only: gw2d
  34    use module_reservoir_utilities, only: read_reservoir_type
  35    use netcdf
  36    use module_hydro_stop, only:HYDRO_stop
  37    use hashtable
  38    use iso_fortran_env, only: int64, compiler_version
  39
  40    implicit none
  41
  42    interface w_rst_crt_reach
  43       module procedure w_rst_crt_reach_real
  44       module procedure w_rst_crt_reach_real8
  45    end interface
  46
  47    interface read_rst_crt_reach_nc
  48       module procedure read_rst_crt_reach_nc_real
  49       module procedure read_rst_crt_reach_nc_real8
  50    end interface
  51
  52    integer, parameter :: did=1
  53    integer :: logUnit
  54
  55      contains
  56
  57         integer function get2d_real(var_name,out_buff,ix,jx,fileName, fatalErr)
  58           implicit none
  59           integer :: ivar, iret,varid,ncid,ix,jx
  60           real out_buff(ix,jx)
  61           character(len=*), intent(in) :: var_name
  62           character(len=*), intent(in) :: fileName
  63           logical, optional, intent(in) :: fatalErr
  64           logical :: fatalErr_local
  65           character(len=256) :: errMsg
  66
  67           fatalErr_local = .false.
  68           if(present(fatalErr)) fatalErr_local=fatalErr
  69
  70           get2d_real = -1
  71
  72           iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid)
  73           if (iret .ne. 0) then
  74              errMsg = "get2d_real: failed to open the netcdf file: " // trim(fileName)
  75              print*, trim(errMsg)
  76              if(fatalErr_local) call hydro_stop(trim(errMsg))
  77              out_buff = -9999.
  78              return
  79           endif
  80
  81           ivar = nf90_inq_varid(ncid,trim(var_name),  varid)
  82           if(ivar .ne. 0) then
  83              ivar = nf90_inq_varid(ncid,trim(var_name//"_M"),  varid)
  84              if(ivar .ne. 0) then
  85                 errMsg = "WARNING: get2d_real: failed to find the variables: " //      &
  86                          trim(var_name) // ' and ' // trim(var_name//"_M") // &
  87                          ' in ' // trim(fileName)
  88                 write(6,*) errMsg
  89                 if(fatalErr_local) call hydro_stop(errMsg)
  90                 return
  91              endif
  92           end if
  93
  94           iret = nf90_get_var(ncid, varid, out_buff)
  95           if(iret .ne. 0) then
  96              errMsg = "WARNING: get2d_real: failed to read the variable: " // &
  97                       trim(var_name) // ' or ' // trim(var_name//"_M") // &
  98                       ' in ' // trim(fileName)
  99              print*,trim(errMsg)
 100              if(fatalErr_local) call hydro_stop(trim(errMsg))
 101              return
 102           endif
 103
 104           iret = nf90_close(ncid)
 105           if(iret .ne. 0) then
 106              errMsg = "WARNING: get2d_real: failed to close the file: " // &
 107                       trim(fileName)
 108              print*,trim(errMsg)
 109              if(fatalErr_local) call hydro_stop(trim(errMsg))
 110           endif
 111
 112           get2d_real =  ivar
 113       end function get2d_real
 114
 115
 116      subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName)
 117          implicit none
 118          integer ix,jx, status
 119          character (len=*),intent(in) :: var_name, fileName
 120          real,dimension(ix,jx):: out_buff
 121
 122
 123 #ifdef MPP_LAND
 124 #ifdef PARALLELIO
 125          status = get2d_real(var_name,out_buff,ix,jx,fileName)
 126 #else
 127          real,allocatable, dimension(:,:) :: buff_g
 128
 129
 130 #ifdef HYDRO_D
 131          write(6,*) "start to read variable ", var_name
 132 #endif
 133          if(my_id .eq. IO_id) then
 134             allocate(buff_g (global_nx,global_ny) )
 135             status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName)
 136          else
 137             allocate(buff_g (1,1) )
 138          end if
 139          call decompose_data_real(buff_g,out_buff)
 140          if(allocated(buff_g)) deallocate(buff_g)
 141 #endif
 142 #else
 143          status = get2d_real(var_name,out_buff,ix,jx,fileName)
 144 #endif
 145 #ifdef HYDRO_D
 146          write(6,*) "finish reading variable ", var_name
 147 #endif
 148      end subroutine get2d_lsm_real
 149
 150      subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName)
 151          implicit none
 152          integer ix,jx, status,land_cat, iret, dimid,ncid
 153          character (len=*),intent(in) :: fileName
 154          character (len=256) units
 155          integer,dimension(ix,jx):: out_buff
 156          real, dimension(ix,jx) :: xdum
 157 #ifdef MPP_LAND
 158          real,allocatable, dimension(:,:) :: buff_g
 159
 160
 161 #ifndef PARALLELIO
 162          if(my_id .eq. IO_id) then
 163             allocate(buff_g (global_nx,global_ny) )
 164          else
 165             allocate(buff_g (1,1) )
 166          endif
 167          if(my_id .eq. IO_id) then
 168 #endif
 169 #endif
 170                 ! Open the NetCDF file.
 171               iret = nf90_open(fileName, NF90_NOWRITE, ncid)
 172               if (iret /= 0) then
 173                  write(*,'("Problem opening geo_static file: ''", A, "''")') &
 174                       trim(fileName)
 175                  call hydro_stop("In get2d_lsm_vegtyp() - Problem opening geo_static file")
 176               endif
 177
 178             iret = nf90_inq_dimid(ncid, "land_cat", dimid)
 179             if (iret /= 0) then
 180               call hydro_stop("In get2d_lsm_vegtyp() - nf90_inq_dimid:  land_cat problem ")
 181              endif
 182
 183             iret = nf90_inquire_dimension(ncid, dimid, len = land_cat)
 184             if (iret /= 0) then
 185                call hydro_stop("In get2d_lsm_vegtyp() - nf90_inquire_dimension:  land_cat problem")
 186             endif
 187
 188 #ifdef MPP_LAND
 189 #ifndef PARALLELIO
 190             call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat)
 191          end if
 192          call decompose_data_real(buff_g,xdum)
 193          if(allocated(buff_g)) deallocate(buff_g)
 194 #else
 195           call get_landuse_netcdf(ncid, xdum,   units, ix, jx, land_cat)
 196 #endif
 197           iret = nf90_close(ncid)
 198
 199 #else
 200           call get_landuse_netcdf(ncid, xdum,   units, ix, jx, land_cat)
 201           iret = nf90_close(ncid)
 202 #endif
 203          out_buff = nint(xdum)
 204      end subroutine get2d_lsm_vegtyp
 205
 206
 207
 208      subroutine get_file_dimension(fileName, ix,jx)
 209             implicit none
 210             character(len=*) fileName
 211             integer ncid , iret, ix,jx, dimid
 212 #ifdef MPP_LAND
 213 #ifndef PARALLELIO
 214             if(my_id .eq. IO_id) then
 215 #endif
 216 #endif
 217             iret = nf90_open(fileName, NF90_NOWRITE, ncid)
 218             if (iret /= 0) then
 219                write(*,'("Problem opening geo_static file: ''", A, "''")') &
 220                     trim(fileName)
 221                call hydro_stop("In get_file_dimension() - Problem opening geo_static file")
 222             endif
 223
 224             iret = nf90_inq_dimid(ncid, "west_east", dimid)
 225
 226             if (iret /= 0) then
 227                call hydro_stop("In get_file_dimension() - nf90_inq_dimid:  west_east problem")
 228             endif
 229
 230             iret = nf90_inquire_dimension(ncid, dimid, len = ix)
 231             if (iret /= 0) then
 232                call hydro_stop("In get_file_dimension() - nf90_inquire_dimension:  west_east problem")
 233             endif
 234
 235             iret = nf90_inq_dimid(ncid, "south_north", dimid)
 236             if (iret /= 0) then
 237                call hydro_stop("In get_file_dimension() - nf90_inq_dimid:  south_north problem.")
 238             endif
 239
 240             iret = nf90_inquire_dimension(ncid, dimid, len = jx)
 241             if (iret /= 0) then
 242                call hydro_stop("In get_file_dimension() - nf90_inquire_dimension:  south_north problem")
 243             endif
 244             iret = nf90_close(ncid)
 245 #ifdef MPP_LAND
 246 #ifndef PARALLELIO
 247             endif
 248             call mpp_land_bcast_int1(ix)
 249             call mpp_land_bcast_int1(jx)
 250 #endif
 251 #endif
 252
 253      end subroutine get_file_dimension
 254
 255 subroutine get_file_globalatts(fileName, iswater, islake, isurban, isoilwater)
 256   implicit none
 257   character(len=*) fileName
 258   integer iswater, islake, isurban, isoilwater
 259   integer ncid, iret, istmp
 260 #ifdef MPP_LAND
 261 #ifndef PARALLELIO
 262 if (my_id .eq. IO_id) then
 263 #endif
 264 #endif
 265
 266   iret = nf90_open(fileName, nf90_nowrite, ncid)
 267   if (iret /= NF90_NOERR) then
 268     write(*,'("Problem opening geo file: ''", A, "''")') trim(fileName)
 269     write(*,*) "Using default (USGS) values for urban and water land use types."
 270   else
 271     iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISWATER', istmp)
 272     if (iret .eq. NF90_NOERR) then
 273       iswater = istmp
 274     else
 275       write(*,*) "Using default (USGS) values for water land use types."
 276       iswater = 16
 277     endif
 278     iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISLAKE', istmp)
 279     if (iret .eq. NF90_NOERR) then
 280       islake = istmp
 281     else
 282       write(*,*) "Using default (USGS) values for lake land use types."
 283       islake = -1
 284     endif
 285     iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISURBAN', istmp)
 286     if (iret .eq. NF90_NOERR) then
 287       isurban = istmp
 288     else
 289       write(*,*) "Using default (USGS) values for urban land use types."
 290       isurban = 1
 291     endif
 292     iret = nf90_get_att(ncid, NF90_GLOBAL, 'ISOILWATER', istmp)
 293     if (iret .eq. NF90_NOERR) then
 294       isoilwater = istmp
 295     else
 296       write(*,*) "Using default (USGS) values for water soil types."
 297       isoilwater = 14
 298     endif
 299     iret = nf90_close(ncid)
 300   endif
 301
 302 #ifdef HYDRO_D
 303 #ifndef NCEP_WCOSS
 304   write(6, *) "get_file_globalatts: ISWATER ISLAKE ISURBAN ISOILWATER", iswater, islake, isurban, isoilwater
 305 #endif
 306 #endif
 307
 308 #ifdef MPP_LAND
 309 #ifndef PARALLELIO
 310 endif
 311 call mpp_land_bcast_int1(iswater)
 312 call mpp_land_bcast_int1(islake)
 313 call mpp_land_bcast_int1(isurban)
 314 call mpp_land_bcast_int1(isoilwater)
 315 #endif
 316 #endif
 317
 318 end subroutine get_file_globalatts
 319
 320
 321      subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName)
 322          implicit none
 323          integer ix,jx, status,land_cat, iret, dimid,ncid
 324          character (len=*),intent(in) :: fileName
 325          character (len=256) units
 326          integer,dimension(ix,jx):: out_buff
 327          real, dimension(ix,jx) :: xdum
 328 #ifdef MPP_LAND
 329 #ifndef PARALLELIO
 330          real,allocatable, dimension(:,:) :: buff_g
 331
 332
 333          if(my_id .eq. IO_id) then
 334               allocate(buff_g (global_nx,global_ny) )
 335 #endif
 336 #endif
 337                 ! Open the NetCDF file.
 338             iret = nf90_open(fileName, NF90_NOWRITE, ncid)
 339               if (iret /= 0) then
 340                  write(*,'("Problem opening geo_static file: ''", A, "''")') &
 341                       trim(fileName)
 342                  call hydro_stop("In get2d_lsm_soltyp() - problem to open geo_static file.")
 343               endif
 344
 345             iret = nf90_inq_dimid(ncid, "soil_cat", dimid)
 346             if (iret /= 0) then
 347                 call hydro_stop("In get2d_lsm_soltyp() - nf90_inq_dimid:  soil_cat problem")
 348             endif
 349
 350             iret = nf90_inquire_dimension(ncid, dimid, len = land_cat)
 351             if (iret /= 0) then
 352                call hydro_stop("In get2d_lsm_soltyp() - nf90_inquire_dimension:  soil_cat problem")
 353             endif
 354
 355 #ifdef MPP_LAND
 356 #ifndef PARALLELIO
 357             call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat)
 358          end if
 359          call decompose_data_real(buff_g,xdum)
 360          if(my_id .eq. io_id) then
 361            if(allocated(buff_g)) deallocate(buff_g)
 362          endif
 363 #else
 364           call get_soilcat_netcdf(ncid, xdum,   units, ix, jx, land_cat)
 365 #endif
 366           iret = nf90_close(ncid)
 367 #else
 368           call get_soilcat_netcdf(ncid, xdum,   units, ix, jx, land_cat)
 369           iret = nf90_close(ncid)
 370 #endif
 371           out_buff = nint(xdum)
 372      end subroutine get2d_lsm_soltyp
 373
 374
 375   subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim)
 376     implicit none
 377     integer, intent(in) :: ncid
 378     integer, intent(in) :: idim, jdim, ldim
 379     real, dimension(idim,jdim), intent(out) :: array
 380     character(len=256), intent(out) :: units
 381     integer :: iret, varid
 382 !    real, dimension(idim,jdim,ldim) :: xtmp
 383 !    integer, dimension(1) :: mp
 384 !    integer :: i, j, l
 385 !    character(len=24), parameter :: name = "LANDUSEF"
 386     character(len=24), parameter :: name = "LU_INDEX"
 387
 388     units = ""
 389
 390 !    iret = nf90_inq_varid(ncid,  trim(name),  varid)
 391 !    if (iret /= 0) then
 392 !       print*, 'name = "', trim(name)//'"'
 393 !       call hydro_stop("In get_landuse_netcdf() - nf90_inq_varid problem")
 394 !    endif
 395
 396 !    iret = nf90_get_var(ncid, varid, xtp)
 397 !    if (iret /= 0) then
 398 !       print*, 'name = "', trim(name)//'"'
 399 !       call hydro_stop("In get_landuse_netcdf() - nf90_get_var problem")
 400 !    endif
 401 !
 402 !    do i = 1, idim
 403 !       do j = 1, jdim
 404 !          mp = maxloc(xtmp(i,j,:))
 405 !          array(i,j) = mp(1)
 406 !          do l = 1,ldim
 407 !            if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0
 408 !          enddo
 409 !       enddo
 410 !    enddo
 411
 412 !!! START AD_CHANGE
 413 ! Using LU_INDEX direct from WPS for consistency with the LSMs
 414     iret = nf90_inq_varid(ncid,  name,  varid)
 415     if (iret /= 0) then
 416        print*, 'name = "', trim(name)//'"'
 417        call hydro_stop("In get_landuse_netcdf() - nf90_inq_varid problem")
 418     endif
 419
 420     iret = nf90_get_var(ncid, varid, array)
 421     if (iret /= 0) then
 422        print*, 'name = "', trim(name)//'"'
 423        call hydro_stop("In get_landuse_netcdf() - nf90_get_var problem")
 424     endif
 425 !!! END AD_CHANGE
 426
 427   end subroutine get_landuse_netcdf
 428
 429
 430   subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim)
 431     implicit none
 432
 433     integer, intent(in) :: ncid
 434     integer, intent(in) :: idim, jdim, ldim
 435     real, dimension(idim,jdim), intent(out) :: array
 436     character(len=256), intent(out) :: units
 437     integer :: iret, varid
 438 !    real, dimension(idim,jdim,ldim) :: xtmp
 439 !    integer, dimension(1) :: mp
 440 !    integer :: i, j, did
 441 !    character(len=24), parameter :: name = "SOILCTOP"
 442     character(len=24), parameter :: name = "SCT_DOM"
 443
 444 !    did = 1
 445     units = ""
 446
 447 !    iret = nf90_inq_varid(ncid,  trim(name),  varid)
 448 !    if (iret /= 0) then
 449 !       print*, 'name = "', trim(name)//'"'
 450 !       call hydro_stop("In get_soilcat_netcdf() - nf90_inq_varid problem")
 451 !    endif
 452 !
 453 !    iret = nf90_get_var(ncid, varid, xtmp)
 454 !    if (iret /= 0) then
 455 !       print*, 'name = "', trim(name)//'"'
 456 !       call hydro_stop("In get_soilcat_netcdf() - nf90_get_var problem")
 457 !    endif
 458 !
 459 !    do i = 1, idim
 460 !       do j = 1, jdim
 461 !          mp = maxloc(xtmp(i,j,:))
 462 !          array(i,j) = mp(1)
 463 !       enddo
 464 !    enddo
 465
 466 !     if(nlst_rt(did)%GWBASESWCRT .ne. 3) then
 467 !        where (array == 14) array = 1   ! DJG remove all 'water' soils...
 468 !     endif
 469
 470 !!! START AD_CHANGE
 471 ! Using SCT_DOM direct from WPS for consistency with the LSMs
 472     iret = nf90_inq_varid(ncid,  name,  varid)
 473     if (iret /= 0) then
 474        print*, 'name = "', trim(name)//'"'
 475        call hydro_stop("In get_soilcat_netcdf() - nf90_inq_varid problem")
 476     endif
 477
 478     iret = nf90_get_var(ncid, varid, array)
 479     if (iret /= 0) then
 480        print*, 'name = "', trim(name)//'"'
 481        call hydro_stop("In get_soilcat_netcdf() - nf90_get_var problem")
 482     endif
 483  !!! END AD_CHANGE
 484
 485   end subroutine get_soilcat_netcdf
 486
 487
 488 subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd)
 489     implicit none
 490     integer, intent(in) :: ncid,mm,dd
 491     integer, intent(in) :: idim, jdim, ldim
 492     real, dimension(idim,jdim) :: array
 493     real, dimension(idim,jdim) :: array2
 494     real, dimension(idim,jdim) :: diff
 495     real, dimension(idim,jdim), intent(out) :: array3
 496     character(len=256), intent(out) :: units
 497     integer :: iret, varid
 498     real, dimension(idim,jdim,ldim) :: xtmp
 499     integer, dimension(1) :: mp
 500     integer :: i, j, mm2,daytot
 501     real :: ddfrac
 502     character(len=24), parameter :: name = "GREENFRAC"
 503
 504     units = "fraction"
 505
 506     iret = nf90_inq_varid(ncid,  trim(name),  varid)
 507     if (iret /= 0) then
 508        print*, 'name = "', trim(name)//'"'
 509        call hydro_stop("In get_greenfrac_netcdf() - nf90_inq_varid problem")
 510     endif
 511
 512     iret = nf90_get_var(ncid, varid, xtmp)
 513     if (iret /= 0) then
 514        print*, 'name = "', trim(name)//'"'
 515        call hydro_stop("In get_greenfrac_netcdf() - nf90_get_var problem")
 516     endif
 517
 518
 519     if (mm.lt.12) then
 520       mm2 = mm+1
 521     else
 522       mm2 = 1
 523     end if
 524
 525 !DJG_DES Set up dates for daily interpolation...
 526           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
 527              daytot = 31
 528           else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then
 529              daytot = 30
 530           else if (mm.eq.2) then
 531              daytot = 28
 532           end if
 533           ddfrac = float(dd)/float(daytot)
 534           if (ddfrac.gt.1.0) ddfrac = 1.0   ! Assumes Feb. 29th change is same as Feb 28th
 535
 536 #ifdef HYDRO_D
 537     print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac
 538
 539 #endif
 540     do i = 1, idim
 541        do j = 1, jdim
 542           array(i,j) = xtmp(i,j,mm)   !GREENFRAC in geogrid in units of fraction from month 1
 543           array2(i,j) = xtmp(i,j,mm2)   !GREENFRAC in geogrid in units of fraction from month 1
 544           diff(i,j) = array2(i,j) - array(i,j)
 545           array3(i,j) = array(i,j) + ddfrac * diff(i,j)
 546        enddo
 547     enddo
 548
 549 end subroutine get_greenfrac_netcdf
 550
 551
 552
 553 subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd)
 554     implicit none
 555     integer, intent(in) :: ncid,mm,dd
 556     integer, intent(in) :: idim, jdim, ldim
 557     real, dimension(idim,jdim) :: array
 558     real, dimension(idim,jdim) :: array2
 559     real, dimension(idim,jdim) :: diff
 560     real, dimension(idim,jdim), intent(out) :: array3
 561     character(len=256), intent(out) :: units
 562     integer :: iret, varid
 563     real, dimension(idim,jdim,ldim) :: xtmp
 564     integer, dimension(1) :: mp
 565     integer :: i, j, mm2,daytot
 566     real :: ddfrac
 567     character(len=24), parameter :: name = "ALBEDO12M"
 568
 569
 570     units = "fraction"
 571
 572     iret = nf90_inq_varid(ncid,  trim(name),  varid)
 573     if (iret /= 0) then
 574        print*, 'name = "', trim(name)//'"'
 575        call hydro_stop("In get_albedo12m_netcdf() - nf90_inq_varid problem")
 576     endif
 577
 578     iret = nf90_get_var(ncid, varid, xtmp)
 579     if (iret /= 0) then
 580        print*, 'name = "', trim(name)//'"'
 581        call hydro_stop("In get_albedo12m_netcdf() - nf90_get_var problem")
 582     endif
 583
 584     if (mm.lt.12) then
 585       mm2 = mm+1
 586     else
 587       mm2 = 1
 588     end if
 589
 590 !DJG_DES Set up dates for daily interpolation...
 591           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
 592              daytot = 31
 593           else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then
 594              daytot = 30
 595           else if (mm.eq.2) then
 596              daytot = 28
 597           end if
 598           ddfrac = float(dd)/float(daytot)
 599           if (ddfrac.gt.1.0) ddfrac = 1.0   ! Assumes Feb. 29th change is same as Feb 28th
 600
 601 #ifdef HYDRO_D
 602     print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac
 603 #endif
 604
 605     do i = 1, idim
 606        do j = 1, jdim
 607           array(i,j) = xtmp(i,j,mm) / 100.0   !Convert ALBEDO12M from % to fraction...month 1
 608           array2(i,j) = xtmp(i,j,mm2) / 100.0   !Convert ALBEDO12M from % to fraction... month 2
 609           diff(i,j) = array2(i,j) - array(i,j)
 610           array3(i,j) = array(i,j) + ddfrac * diff(i,j)
 611        enddo
 612     enddo
 613
 614 end subroutine get_albedo12m_netcdf
 615
 616
 617
 618
 619   subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, &
 620        fatal_if_error, ierr)
 621
 622     implicit none
 623
 624     character(len=*), intent(in) :: name
 625     integer, intent(in) :: ncid
 626     integer, intent(in) :: idim, jdim
 627     real, dimension(idim,jdim), intent(inout) :: array
 628     character(len=256), intent(out) :: units
 629     ! fatal_IF_ERROR:  an input code value:
 630     !      .TRUE. if an error in reading the data should stop the program.
 631     !      Otherwise the, IERR error flag is set, but the program continues.
 632     logical, intent(in) :: fatal_if_error
 633     integer, intent(out) :: ierr
 634
 635     integer :: iret, varid
 636     real    :: scale_factor,   add_offset
 637
 638     units = ""
 639
 640     iret = nf90_inq_varid(ncid,  name,  varid)
 641     if (iret /= 0) then
 642        if (fatal_IF_ERROR) then
 643           print*, 'name = "', trim(name)//'"'
 644           call hydro_stop("In get_2d_netcdf() - nf90_inq_varid problem")
 645        else
 646           ierr = iret
 647           return
 648        endif
 649     endif
 650
 651     iret = nf90_get_var(ncid, varid, array)
 652     if (iret /= 0) then
 653        if (fatal_IF_ERROR) then
 654           print*, 'name = "', trim(name)//'"'
 655           call hydro_stop("In get_2d_netcdf() - nf90_get_var problem")
 656        else
 657           ierr = iret
 658           return
 659        endif
 660     endif
 661
 662     iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor)
 663     if(iret .eq. 0) array = array * scale_factor
 664     iret = nf90_get_att(ncid, varid, 'add_offset', add_offset)
 665     if(iret .eq. 0) array = array + add_offset
 666
 667     ierr = 0;
 668
 669   end subroutine get_2d_netcdf
 670
 671
 672       subroutine get_2d_netcdf_cows(var_name,ncid,var, &
 673             ix,jx,tlevel,fatal_if_error,ierr)
 674           character(len=*), intent(in) :: var_name
 675           integer,intent(in) ::  ncid,ix,jx,tlevel
 676           real, intent(out):: var(ix,jx)
 677           logical, intent(in) :: fatal_if_error
 678           integer ierr, iret
 679           integer varid
 680           integer start(4),count(4)
 681           data count /1,1,1,1/
 682           data start /1,1,1,1/
 683           count(1) = ix
 684           count(2) = jx
 685           start(4) = tlevel
 686       iret = nf90_inq_varid(ncid,  var_name,  varid)
 687
 688       if (iret /= 0) then
 689         if (fatal_IF_ERROR) then
 690            call hydro_stop("In get_2d_netcdf_cows() - nf90_inq_varid problem")
 691         else
 692           ierr = iret
 693           return
 694         endif
 695       endif
 696       iret = nf90_get_var(ncid, varid, var, start, count)
 697
 698       return
 699       end subroutine get_2d_netcdf_cows
 700
 701 !---------------------------------------------------------
 702 !DJG Subroutinesfor inputting routing fields...
 703 !DNY   first reads the files to get the size of the
 704 !DNY   LINKS arrays
 705 !DJG   - Currently only hi-res topo is read
 706 !DJG   - At a future time, use this routine to input
 707 !DJG     subgrid land-use classification or routing
 708 !DJG     parameters 'overland roughness' and 'retention
 709 !DJG     depth'
 710 !
 711 !DJG,DNY - Update this subroutine to read in channel and lake
 712 !           parameters if activated       11.20.2005
 713 !---------------------------------------------------------
 714
 715        SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, &
 716             route_direction_f, NLINKS, &
 717             CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT,NLAKES)
 718
 719          implicit none
 720         INTEGER                                      :: I,J,channel_option,jj
 721         INTEGER, INTENT(INOUT)                       :: NLINKS, NLINKSL
 722         INTEGER, INTENT(IN)                          :: IXRT,JXRT
 723         INTEGER                                      :: CHNID,cnt
 724         INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT   !- binary channel mask
 725         INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK  !- each node gets unique id
 726         INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION  !- flow direction
 727         INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT
 728         REAL, DIMENSION(IXRT,JXRT)                   :: LAT, LON
 729         INTEGER(kind=int64), DIMENSION(IXRT,JXRT)                :: CH_LNKRT   !- link routing ID
 730         integer, INTENT(IN)                          :: UDMP_OPT
 731         integer                                      :: NLAKES
 732
 733
 734 !!Dummy read in grids for inverted y-axis
 735
 736
 737         CHARACTER(len=*)         :: route_chan_f, route_link_f,route_direction_f
 738         CHARACTER(len=*)       :: geo_finegrid_flnm
 739         CHARACTER(len=256)       :: var_name
 740
 741         ! variables for handling netcdf dimensions
 742         integer :: iRet, ncid, dimId
 743         logical :: routeLinkNetcdf
 744
 745         NLINKS = 0
 746         CH_NETRT = -9999
 747         CH_NETLNK = -9999
 748
 749         NLINKSL   = 0
 750         CH_LNKRT  = -9999
 751
 752
 753
 754         cnt = 0
 755 #ifdef HYDRO_D
 756        print *, "Channel Option in Routedim is ", channel_option
 757 #endif
 758
 759
 760         if (channel_option .eq. 4) return  ! it will run Rapid
 761
 762
 763 !-- will always read channel grid       IF(channel_option.eq.3) then  !get maxnodes and links from grid
 764
 765          var_name = "CHANNELGRID"
 766          call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,&
 767                    trim(geo_finegrid_flnm))
 768
 769
 770 !-- new link id variable to handle link routing
 771          var_name = "LINKID"
 772 #ifdef MPP_LAND
 773 #ifdef HYDRO_D
 774     write(6,*) "read LINKID for CH_LNKRT from ", trim(geo_finegrid_flnm)
 775 #endif
 776 #endif
 777 !!!! LINKID is used for reach based method.  ?
 778      IF(channel_option.ne.3 .and. UDMP_OPT.ne.1) then  !get maxnodes and links from grid
 779          call readRT2d_int8(var_name,CH_LNKRT,ixrt,jxrt,&
 780                    trim(geo_finegrid_flnm), fatalErr=.TRUE.)
 781      endif
 782
 783
 784
 785          var_name = "FLOWDIRECTION"
 786          call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,&
 787                    trim(geo_finegrid_flnm))
 788
 789 !note that this is not used for link routing
 790          var_name = "LAKEGRID"
 791          call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,&
 792                    trim(geo_finegrid_flnm))
 793
 794
 795         var_name = "LATITUDE"
 796         call readRT2d_real(var_name,LAT,ixrt,jxrt,&
 797                      trim(geo_finegrid_flnm))
 798         var_name = "LONGITUDE"
 799         call readRT2d_real(var_name,LON,ixrt,jxrt,&
 800                      trim(geo_finegrid_flnm))
 801
 802 ! temp fix for buggy Arc export...
 803         do j=1,jxrt
 804           do i=1,ixrt
 805             if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128
 806           end do
 807         end do
 808
 809 !DJG inv         do j=jxrt,1,-1
 810          do j=1,jxrt
 811              do i = 1, ixrt
 812 !               if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then
 813                 if (CH_NETRT(i,j) .ge.0) then
 814                  NLINKS = NLINKS + 1
 815                  if( UDMP_OPT .eq. 1) CH_NETLNK(i,j) = 2
 816                endif
 817             end do
 818          end do
 819 #ifdef HYDRO_D
 820          print *, "NLINKS IS ", NLINKS
 821 #endif
 822      if( UDMP_OPT .eq. 1) then
 823          return
 824      endif
 825
 826 !DJG inv         DO j = JXRT,1,-1  !rows
 827          DO j = 1,JXRT  !rows
 828           DO i = 1 ,IXRT   !colsumns
 829            If (CH_NETRT(i, j) .ge. 0) then !get its direction
 830             If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT) ) then !North
 831                if(CH_NETRT(i,j+1) .ge.0) then
 832                   cnt = cnt + 1
 833                   CH_NETLNK(i,j) = cnt
 834                 endif
 835             else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) &
 836                .AND. (j + 1 .LE. JXRT) ) then !North East
 837                 if(CH_NETRT(i+1,j+1) .ge.0) then
 838                    cnt = cnt + 1
 839                    CH_NETLNK(i,j) = cnt
 840                 endif
 841             else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT)) then !East
 842                 if(CH_NETRT(i+1,j) .ge. 0) then
 843                    cnt = cnt + 1
 844                    CH_NETLNK(i,j) = cnt
 845                 endif
 846             else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) &
 847                     .AND. (j - 1 .NE. 0)) then !south east
 848                  if(CH_NETRT(i+1,j-1).ge.0) then
 849                      cnt = cnt + 1
 850                      CH_NETLNK(i,j) = cnt
 851                  endif
 852             else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0)) then !due south
 853                  if(CH_NETRT(i,j-1).ge.0) then
 854                          cnt = cnt + 1
 855                          CH_NETLNK(i,j) = cnt
 856                  endif
 857             else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) &
 858                     .AND. (j - 1 .NE. 0)  ) then !south west
 859                 if(CH_NETRT(i-1,j-1).ge.0) then
 860                      cnt = cnt + 1
 861                      CH_NETLNK(i,j) = cnt
 862                 endif
 863             else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0)) then !West
 864                  if(CH_NETRT(i-1,j).ge.0) then
 865                        cnt = cnt + 1
 866                        CH_NETLNK(i,j) = cnt
 867                  endif
 868             else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) &
 869                     .AND. (j + 1 .LE. JXRT) ) then !North West
 870                  if(CH_NETRT(i-1,j+1).ge.0) then
 871                         cnt = cnt + 1
 872                         CH_NETLNK(i,j) = cnt
 873                  endif
 874            else
 875 #ifdef HYDRO_D
 876              write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j
 877 #endif
 878 135             FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4)
 879              if (DIRECTION(i,j) .eq. 0) then
 880 #ifdef HYDRO_D
 881                print *, "Direction i,j ",i,j," of point ", cnt, "is invalid"
 882 #endif
 883              endif
 884
 885            End If
 886          End If !CH_NETRT check for this node
 887         END DO
 888        END DO
 889 #ifdef HYDRO_D
 890        print *, "found type 0 nodes", cnt
 891 #endif
 892 !Find out if the boundaries are on an edge or flow into a lake
 893 !DJG inv       DO j = JXRT,1,-1
 894        DO j = 1,JXRT
 895          DO i = 1 ,IXRT
 896           If (CH_NETRT(i, j) .ge. 0) then !get its direction
 897
 898            If ( (DIRECTION(i, j).EQ. 64) )then
 899               if( j + 1 .GT. JXRT) then           !-- 64's can only flow north
 900                  cnt = cnt + 1
 901                  CH_NETLNK(i,j) = cnt
 902               elseif(CH_NETRT(i,j+1) .lt. 0) then !North
 903                  cnt = cnt + 1
 904                  CH_NETLNK(i,j) = cnt
 905 #ifdef HYDRO_D
 906                   print *, "Boundary Pour Point N", cnt,CH_NETRT(i,j), i,j
 907 #endif
 908               endif
 909            else if ( DIRECTION(i, j) .EQ. 128) then
 910                if ((i + 1 .GT. IXRT) .or. (j + 1 .GT. JXRT))  then    !-- 128's can flow out of the North or East edge
 911                    cnt = cnt + 1
 912                    CH_NETLNK(i,j) = cnt
 913                                                                       !   this is due north edge
 914                elseif(CH_NETRT(i + 1, j + 1).lt.0) then !North East
 915                    cnt = cnt + 1
 916                    CH_NETLNK(i,j) = cnt
 917 #ifdef HYDRO_D
 918               print *, "Boundary Pour Point NE", cnt, CH_NETRT(i,j),i,j
 919 #endif
 920                endif
 921            else if (DIRECTION(i, j) .EQ. 1) then
 922                 if (i + 1 .GT. IXRT) then      !-- 1's can only flow due east
 923                    cnt = cnt + 1
 924                    CH_NETLNK(i,j) = cnt
 925                 elseif(CH_NETRT(i + 1, j) .lt. 0) then !East
 926                    cnt = cnt + 1
 927                    CH_NETLNK(i,j) = cnt
 928 #ifdef HYDRO_D
 929               print *, "Boundary Pour Point E", cnt,CH_NETRT(i,j), i,j
 930 #endif
 931                 endif
 932            else if (DIRECTION(i, j) .EQ. 2) then
 933                !-- 2's can flow out of east or south edge
 934               if( (i + 1 .GT. IXRT) .OR.  (j - 1 .EQ. 0)) then            !-- this is the south edge
 935                   cnt = cnt + 1
 936                   CH_NETLNK(i,j) = cnt
 937               elseif(CH_NETRT(i + 1, j - 1) .lt.0) then !south east
 938                   cnt = cnt + 1
 939                   CH_NETLNK(i,j) = cnt
 940 #ifdef HYDRO_D
 941                   print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j
 942 #endif
 943               endif
 944            else if ( DIRECTION(i, j) .EQ. 4) then
 945               if( (j - 1 .EQ. 0))  then            !-- 4's can only flow due south
 946                  cnt = cnt + 1
 947                  CH_NETLNK(i,j) = cnt
 948               elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south
 949                  cnt = cnt + 1
 950                  CH_NETLNK(i,j) = cnt
 951 #ifdef HYDRO_D
 952                  print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j
 953 #endif
 954               endif
 955            else if ( DIRECTION(i, j) .EQ. 8) then
 956           !-- 8's can flow south or west
 957               if( (i - 1 .eq. 0) .OR. ( j - 1 .EQ. 0)) then             !-- this is the south edge
 958                   cnt = cnt + 1
 959                   CH_NETLNK(i,j) = cnt
 960               elseif  (CH_NETRT(i - 1, j - 1).lt.0) then !south west
 961                   cnt = cnt + 1
 962                   CH_NETLNK(i,j) = cnt
 963 #ifdef HYDRO_D
 964                   print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j
 965 #endif
 966               endif
 967            else if ( DIRECTION(i, j) .EQ. 16) then
 968               if(i - 1 .eq. 0) then              !-- 16's can only flow due west
 969                   cnt = cnt + 1
 970                   CH_NETLNK(i,j) = cnt
 971               elseif (CH_NETRT(i - 1, j).lt.0) then !West
 972                   cnt = cnt + 1
 973                   CH_NETLNK(i,j) = cnt
 974 #ifdef HYDRO_D
 975               print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j
 976 #endif
 977               endif
 978            else if ( DIRECTION(i, j) .EQ. 32)  then
 979               if ( (i - 1 .eq. 0)      &      !-- 32's can flow either west or north
 980                .OR.   (j .eq. JXRT))  then         !-- this is the north edge
 981                   cnt = cnt + 1
 982                   CH_NETLNK(i,j) = cnt
 983               elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West
 984                   cnt = cnt + 1
 985                   CH_NETLNK(i,j) = cnt
 986 #ifdef HYDRO_D
 987                   print *, "Boundary Pour Point NW", cnt,CH_NETRT(i,j), i,j
 988 #endif
 989               endif
 990            endif
 991           endif !CH_NETRT check for this node
 992          END DO
 993        END DO
 994
 995 #ifdef HYDRO_D
 996        print *, "total number of channel elements", cnt
 997        print *, "total number of NLINKS          ", NLINKS
 998 #endif
 999
1000
1001
1002       !-- get the number of lakes
1003        if (cnt .ne. NLINKS) then
1004          print *, "Apparent error in network topology", cnt, NLINKS
1005          print* , "ixrt =", ixrt, "jxrt =", jxrt
1006          call hydro_stop("READ_ROUTEDIM")
1007        endif
1008
1009 !!-- no longer find the lakes from the 2-d hi res grid
1010 !DJG inv       do j=jxrt,1,-1
1011 ! follwoing is modified by Wei Yu 03/24/2017
1012      if(UDMP_OPT .eq. 0) then
1013         NLAKES = 0
1014         do j=1,jxrt
1015            do i = 1,ixrt
1016             if (LAKE_MSKRT(i,j) .gt. NLAKES) then
1017               NLAKES = LAKE_MSKRT(i,j)
1018             endif
1019          end do
1020         end do
1021 #ifdef HYDRO_D
1022         write(6,*) "finish read_red ..  Total Number of Lakes in Domain = ", NLAKES
1023 #endif
1024      endif
1025
1026
1027 !-- don't return here--!  return
1028
1029      END SUBROUTINE READ_ROUTEDIM
1030
1031 !!! This subroutine gets the NLINKSL
1032      subroutine get_NLINKSL(NLINKSL, channel_option, route_link_f)
1033         implicit none
1034         CHARACTER(len=*)         :: route_link_f
1035         integer :: NLINKSL, channel_option
1036         CHARACTER(len=256)         :: route_link_f_r
1037         integer :: lenRouteLinkFR
1038         logical :: routeLinkNetcdf
1039         CHARACTER(len=256)       :: InputLine
1040         if (channel_option.ne.3) then  ! overwrite the NLINKS
1041 !-IF is now commented above   else  ! get nlinks from the ascii file of links
1042 #ifdef HYDRO_D
1043            write(6,*) "read file to get NLINKSL from", trim(route_link_f)
1044            call flush(6)
1045 #endif
1046        !! is RouteLink file netcdf (*.nc) or csv (*.csv)
1047            route_link_f_r = adjustr(route_link_f)
1048            lenRouteLinkFR = len(route_link_f_r)
1049            routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq.  '.nc'
1050
1051            if(routeLinkNetcdf) then
1052               NLINKSL = -99
1053               NLINKSL = get_netcdf_dim(trim(route_link_f), 'feature_id',  &
1054                                    'READ_ROUTEDIM', fatalErr=.false.)
1055               if(NLINKSL .eq. -99) then
1056                  ! We were unsucessful in getting feature_id, try linkDim
1057                  NLINKSL = get_netcdf_dim(trim(route_link_f), 'linkDim',  &
1058                                          'READ_ROUTEDIM', fatalErr=.false.)
1059               endif
1060               if(NLINKSL .eq. -99) then
1061                  ! Neither the feature_id or linkDim dimensions were found in
1062                  ! the RouteLink file. Throw an error...
1063                  call hydro_stop("Could not find either feature_id or linkDim in RouteLink file.")
1064               endif
1065            else
1066               open(unit=17,file=trim(route_link_f),          & !link
1067                    form='formatted',status='old')
1068
1069 1011          read(17,*,end= 1999) InputLine
1070               NLINKSL = NLINKSL + 1
1071               goto 1011
1072 1999          continue
1073               NLINKSL = NLINKSL - 1 !-- first line is a comment
1074               close(17)
1075            end if ! routeLinkNetcdf
1076
1077 #ifdef HYDRO_D
1078             print *, "Number of Segments or Links on sparse network", NLINKSL
1079             write(6,*) "NLINKSL = ", NLINKSL
1080             call flush(6)
1081 #endif
1082
1083       end if !end-if is now for channel_option just above, not IF from further up
1084
1085           return
1086      end subroutine get_NLINKSL
1087
1088      subroutine nreadRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr)
1089          implicit none
1090          INTEGER :: iret
1091          INTEGER, INTENT(IN) :: ixrt,jxrt
1092          INTEGER :: i, j, ii,jj
1093          CHARACTER(len=*):: var_name,fileName
1094          real, INTENT(OUT), dimension(ixrt,jxrt) :: inv
1095 #ifndef MPP_LAND
1096          real, dimension(ixrt,jxrt) :: inv_tmp
1097 #endif
1098          logical, optional, intent(in) :: fatalErr
1099          logical :: fatalErr_local
1100 #ifdef MPP_LAND
1101          real, allocatable,dimension(:,:) :: g_inv_tmp, g_inv
1102 #endif
1103          fatalErr_local = .FALSE.
1104          if(present(fatalErr)) fatalErr_local=fatalErr
1105
1106 #ifdef MPP_LAND
1107          if(my_id .eq. io_id) then
1108
1109               allocate(g_inv_tmp(global_rt_nx,global_rt_ny))
1110               allocate(g_inv(global_rt_nx,global_rt_ny))
1111
1112               g_inv_tmp = -9999.9
1113               iret =  get2d_real(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,&
1114                      trim(fileName), fatalErr=fatalErr_local)
1115
1116               jj = global_rt_ny
1117               do j = 1, global_rt_ny
1118                  g_inv(:,j) = g_inv_tmp(:,jj)
1119                  jj = global_rt_ny - j
1120               end do
1121
1122               if(allocated(g_inv_tmp)) deallocate(g_inv_tmp)
1123          else
1124               allocate(g_inv(1,1))
1125          endif
1126          call decompose_RT_real(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT)
1127          if(allocated(g_inv)) deallocate(g_inv)
1128 #else
1129          inv_tmp = -9999.9
1130          iret =  get2d_real(var_name,inv_tmp,ixrt,jxrt,&
1131                      trim(fileName), fatalErr=fatalErr_local)
1132          do i=1,ixrt
1133             jj=jxrt
1134          do j=1,jxrt
1135            inv(i,j)=inv_tmp(i,jj)
1136            jj=jxrt-j
1137          end do
1138         end do
1139 #endif
1140
1141
1142      end SUBROUTINE nreadRT2d_real
1143
1144      subroutine nreadRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr)
1145          implicit none
1146          INTEGER, INTENT(IN) :: ixrt,jxrt
1147          INTEGER :: i, j, ii,jj, iret
1148          CHARACTER(len=*):: var_name,fileName
1149          integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv
1150          integer, dimension(ixrt,jxrt) :: inv_tmp
1151          logical, optional, intent(in) :: fatalErr
1152          logical :: fatalErr_local
1153 #ifdef MPP_LAND
1154          integer, allocatable,dimension(:,:) :: g_inv_tmp, g_inv
1155 #endif
1156          fatalErr_local = .FALSE.
1157          if(present(fatalErr)) fatalErr_local=fatalErr
1158
1159 #ifdef MPP_LAND
1160          if(my_id .eq. io_id) then
1161               allocate(g_inv_tmp(global_rt_nx,global_rt_ny))
1162               allocate(g_inv(global_rt_nx,global_rt_ny))
1163               g_inv_tmp = -9999.9
1164               call  get2d_int(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,&
1165                      trim(fileName), fatalErr=fatalErr_local)
1166
1167               jj = global_rt_ny
1168               do j = 1, global_rt_ny
1169                  g_inv(:,j) = g_inv_tmp(:,jj)
1170                  jj = global_rt_ny - j
1171               end do
1172          else
1173               allocate(g_inv_tmp(1,1))
1174               allocate(g_inv(1,1))
1175          endif
1176          call decompose_RT_int(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT)
1177          if(allocated(g_inv_tmp)) deallocate(g_inv_tmp)
1178          if(allocated(g_inv)) deallocate(g_inv)
1179 #else
1180          call  get2d_int(var_name,inv_tmp,ixrt,jxrt,&
1181                      trim(fileName), fatalErr=fatalErr_local)
1182          do i=1,ixrt
1183             jj=jxrt
1184          do j=1,jxrt
1185            inv(i,j)=inv_tmp(i,jj)
1186            jj=jxrt-j
1187          end do
1188         end do
1189 #endif
1190      end SUBROUTINE nreadRT2d_int
1191
1192
1193      subroutine nreadRT2d_int8(var_name, inv, ixrt, jxrt, fileName, fatalErr)
1194          implicit none
1195          INTEGER, INTENT(IN) :: ixrt,jxrt
1196          INTEGER :: i, j, ii,jj, iret
1197          CHARACTER(len=*):: var_name,fileName
1198          integer(kind=int64), INTENT(OUT), dimension(ixrt,jxrt) :: inv
1199          integer(kind=int64), dimension(ixrt,jxrt) :: inv_tmp
1200          logical, optional, intent(in) :: fatalErr
1201          logical :: fatalErr_local
1202 #ifdef MPP_LAND
1203      integer(kind=int64), allocatable,dimension(:,:) :: g_inv_tmp, g_inv
1204 #endif
1205          fatalErr_local = .FALSE.
1206          if(present(fatalErr)) fatalErr_local=fatalErr
1207
1208 #ifdef MPP_LAND
1209      if(my_id .eq. io_id) then
1210           allocate(g_inv_tmp(global_rt_nx,global_rt_ny))
1211           allocate(g_inv(global_rt_nx,global_rt_ny))
1212           g_inv_tmp = -9999.9
1213           call  get2d_int8(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,&
1214                  trim(fileName), fatalErr=fatalErr_local)
1215
1216           jj = global_rt_ny
1217           do j = 1, global_rt_ny
1218              g_inv(:,j) = g_inv_tmp(:,jj)
1219              jj = global_rt_ny - j
1220           end do
1221      else
1222           allocate(g_inv_tmp(1,1))
1223           allocate(g_inv(1,1))
1224      endif
1225      call decompose_RT_int8(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT)
1226      if(allocated(g_inv_tmp)) deallocate(g_inv_tmp)
1227      if(allocated(g_inv)) deallocate(g_inv)
1228 #else
1229          call  get2d_int(var_name,inv_tmp,ixrt,jxrt,&
1230                  trim(fileName), fatalErr=fatalErr_local)
1231          do i=1,ixrt
1232              jj=jxrt
1233              do j=1,jxrt
1234                  inv(i,j)=inv_tmp(i,jj)
1235                  jj=jxrt-j
1236              end do
1237          end do
1238 #endif
1239      end SUBROUTINE nreadRT2d_int8
1240
1241          !---------------------------------------------------------
1242 !DJG -----------------------------------------------------
1243
1244      subroutine readRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr)
1245          implicit none
1246          INTEGER :: iret
1247          INTEGER, INTENT(IN) :: ixrt,jxrt
1248          INTEGER :: i, j, ii,jj
1249          CHARACTER(len=*):: var_name,fileName
1250          real, INTENT(OUT), dimension(ixrt,jxrt) :: inv
1251          real, dimension(ixrt,jxrt) :: inv_tmp
1252          logical, optional, intent(in) :: fatalErr
1253          logical :: fatalErr_local
1254          fatalErr_local = .FALSE.
1255          if(present(fatalErr)) fatalErr_local=fatalErr
1256          inv_tmp = -9999.9
1257          iret =  get2d_real(var_name,inv_tmp,ixrt,jxrt,&
1258                      trim(fileName), fatalErr=fatalErr_local)
1259
1260          jj = jxrt
1261          do j = 1, jxrt
1262             inv(:,j) = inv_tmp(:,jj)
1263             jj = jxrt - j
1264          end do
1265
1266      end SUBROUTINE readRT2d_real
1267
1268      subroutine readRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr)
1269          implicit none
1270          INTEGER, INTENT(IN) :: ixrt,jxrt
1271          INTEGER :: i, j, ii,jj
1272          CHARACTER(len=*):: var_name,fileName
1273          integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv
1274          integer, dimension(ixrt,jxrt) :: inv_tmp
1275          logical, optional, intent(in) :: fatalErr
1276          logical :: fatalErr_local
1277          fatalErr_local = .FALSE.
1278          if(present(fatalErr)) fatalErr_local=fatalErr
1279          call  get2d_int(var_name,inv_tmp,ixrt,jxrt,&
1280                      trim(fileName), fatalErr=fatalErr_local)
1281
1282          jj = jxrt
1283          do j = 1, jxrt
1284             inv(:,j) = inv_tmp(:,jj)
1285             jj = jxrt - j
1286          end do
1287
1288      end SUBROUTINE readRT2d_int
1289
1290      subroutine readRT2d_int8(var_name, inv, ixrt, jxrt, fileName, fatalErr)
1291          implicit none
1292          INTEGER, INTENT(IN) :: ixrt,jxrt
1293          INTEGER :: i, j, ii,jj
1294          CHARACTER(len=*):: var_name,fileName
1295          integer(kind=int64), INTENT(OUT), dimension(ixrt,jxrt) :: inv
1296          integer(kind=int64), dimension(ixrt,jxrt) :: inv_tmp
1297          logical, optional, intent(in) :: fatalErr
1298          logical :: fatalErr_local
1299          fatalErr_local = .FALSE.
1300          if(present(fatalErr)) fatalErr_local=fatalErr
1301          call  get2d_int8(var_name,inv_tmp,ixrt,jxrt,&
1302                  trim(fileName), fatalErr=fatalErr_local)
1303
1304          jj = jxrt
1305          do j = 1, jxrt
1306              inv(:,j) = inv_tmp(:,jj)
1307              jj = jxrt - j
1308          end do
1309
1310      end SUBROUTINE readRT2d_int8
1311
1312 !---------------------------------------------------------
1313 !DJG -----------------------------------------------------
1314
1315 #ifdef MPP_LAND
1316   subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,&
1317           gw_strm_msk,numbasns,ch_netrt,AGGFACTRT)
1318
1319    USE module_mpp_land
1320
1321     integer, intent(in)                     :: IX,JX,IXRT,JXRT,AGGFACTRT
1322     integer, intent(out)                    :: numbasns
1323     integer, intent(out), dimension(IX,JX)  :: GWSUBBASMSK
1324     integer, intent(out), dimension(IXRT,JXRT)  :: gw_strm_msk
1325     integer, intent(in), dimension(IXRT,JXRT)  :: ch_netrt
1326     character(len=*)                      :: gwbasmskfil
1327     !integer,dimension(global_nX,global_ny) ::  g_GWSUBBASMSK
1328     !yw integer,dimension(global_rt_nx, global_rt_ny) ::  g_gw_strm_msk,g_ch_netrt
1329
1330     integer,allocatable,dimension(:,:) ::  g_GWSUBBASMSK
1331     integer,allocatable,dimension(:, :) ::  g_gw_strm_msk,g_ch_netrt
1332
1333      if(my_id .eq. IO_id) then
1334           allocate(g_gw_strm_msk(global_rt_nx, global_rt_ny))
1335           allocate(g_ch_netrt(global_rt_nx, global_rt_ny))
1336           allocate(g_GWSUBBASMSK(global_nX,global_ny))
1337      else
1338           allocate(g_gw_strm_msk(1,1))
1339           allocate(g_ch_netrt(1,1))
1340           allocate(g_GWSUBBASMSK(1,1))
1341      endif
1342
1343
1344      call write_IO_rt_int(ch_netrt,g_ch_netrt)
1345
1346      if(my_id .eq. IO_id) then
1347        call READ_SIMP_GW(global_nX,global_ny,global_rt_nx,global_rt_ny,&
1348              g_GWSUBBASMSK,gwbasmskfil,g_gw_strm_msk,numbasns,&
1349              g_ch_netrt,AGGFACTRT)
1350      endif
1351      call decompose_data_int(g_GWSUBBASMSK,GWSUBBASMSK)
1352      call decompose_RT_int(g_gw_strm_msk,gw_strm_msk,  &
1353           global_rt_nx, global_rt_ny,ixrt,jxrt)
1354      call mpp_land_bcast_int1(numbasns)
1355
1356      if(allocated(g_gw_strm_msk))  deallocate(g_gw_strm_msk)
1357      if(allocated(g_ch_netrt)) deallocate(g_ch_netrt)
1358      if(allocated(g_GWSUBBASMSK))  deallocate(g_GWSUBBASMSK)
1359
1360   return
1361   end subroutine MPP_READ_SIMP_GW
1362 #endif
1363
1364 !DJG -----------------------------------------------------
1365 !   SUBROUTINE READ_SIMP_GW
1366 !DJG -----------------------------------------------------
1367
1368   subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,&
1369           gw_strm_msk,numbasns,ch_netrt,AGGFACTRT)
1370     implicit none
1371
1372     integer, intent(in)                     :: IX,JX,IXRT,JXRT,AGGFACTRT
1373     integer, intent(in), dimension(IXRT,JXRT)  :: ch_netrt
1374     integer, intent(out)                    :: numbasns
1375     integer, intent(out), dimension(IX,JX)  :: GWSUBBASMSK
1376     integer, intent(out), dimension(IXRT,JXRT)  :: gw_strm_msk
1377     character(len=*)                      :: gwbasmskfil
1378     integer                                 :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt
1379     integer :: iret, ncid
1380     logical :: fexist
1381     integer, allocatable, dimension(:,:)  :: GWSUBBASMSK_tmp
1382
1383     numbasns = 0
1384     gw_strm_msk = -9999
1385
1386     inquire (file=trim(gwbasmskfil), exist=fexist)
1387     if(.not. fexist) then
1388         call hydro_stop("Cound not find file : "//trim(gwbasmskfil))
1389     endif
1390
1391     iret = nf90_open(trim(gwbasmskfil), NF90_NOWRITE, ncid)
1392     if( iret .eq. 0 ) then
1393        iret = nf90_close(ncid)
1394        print*, "read gwbasmskfil as nc format: ", trim(gwbasmskfil)
1395          allocate(GWSUBBASMSK_tmp(ix,jx))
1396          call get2d_int("BASIN",GWSUBBASMSK_tmp,ix,jx,trim(gwbasmskfil), .true.)
1397          do j = jx, 1, -1
1398               GWSUBBASMSK(:,j) = GWSUBBASMSK_tmp (:,jx-j+1)
1399          end do
1400          deallocate(GWSUBBASMSK_tmp)
1401     else
1402        print*, "read gwbasmskfil as txt format: ", trim(gwbasmskfil)
1403        open(unit=18,file=trim(gwbasmskfil),          &
1404             form='formatted',status='old')
1405        do j=jx,1,-1
1406              read (18,*) (GWSUBBASMSK(i,j),i=1,ix)
1407        end do
1408        close(18)
1409     endif
1410
1411 !Loop through to count number of basins and assign basin indices to chan grid
1412         do J=1,JX
1413           do I=1,IX
1414 !Determine max number of basins...(assumes basins are numbered
1415 !   sequentially from 1 to max number of basins...)
1416            if (GWSUBBASMSK(i,j).gt.numbasns) then
1417              numbasns = GWSUBBASMSK(i,j)   ! get count of basins...
1418            end if
1419
1420 !Assign gw basin index values to channel grid...
1421            do AGGFACYRT=AGGFACTRT-1,0,-1
1422              do AGGFACXRT=AGGFACTRT-1,0,-1
1423
1424                 IXXRT=I*AGGFACTRT-AGGFACXRT
1425                 JYYRT=J*AGGFACTRT-AGGFACYRT
1426                 IF(ch_netrt(IXXRT,JYYRT).ge.0) then  !If channel grid cell
1427                   gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j)  ! assign coarse grid basn indx to chan grid
1428                 END IF
1429
1430               end do !AGGFACXRT
1431             end do !AGGFACYRT
1432
1433          end do   !I-ix
1434        end do    !J-jx
1435
1436 #ifdef HYDRO_D
1437       write(6,*) "numbasns = ", numbasns
1438 #endif
1439
1440     return
1441
1442 !DJG -----------------------------------------------------
1443    END SUBROUTINE READ_SIMP_GW
1444 !DJG -----------------------------------------------------
1445
1446 !Wei Yu
1447   subroutine get_gw_strm_msk_lind (ixrt,jxrt,gw_strm_msk,numbasns,basnsInd,gw_strm_msk_lind)
1448       implicit none
1449       integer, intent(in) :: ixrt,jxrt, numbasns
1450       integer, dimension(:,:) :: gw_strm_msk, gw_strm_msk_lind
1451       integer(kind=int64), dimension(:) :: basnsInd
1452       integer:: i,j,k,bas
1453       gw_strm_msk_lind = -999
1454       do j = 1, jxrt
1455          do i = 1, ixrt
1456              if(gw_strm_msk(i,j) .gt. 0) then
1457                   do k = 1, numbasns
1458                      if(gw_strm_msk(i,j) .eq. basnsInd(k)) then
1459                           gw_strm_msk_lind(i,j) = k
1460                      endif
1461                   end do
1462              end if
1463          end do
1464       end do
1465
1466   end subroutine get_gw_strm_msk_lind
1467
1468   subroutine SIMP_GW_IND(ix,jx,GWSUBBASMSK,numbasns,gnumbasns,basnsInd)
1469 ! create an index of basin mask so that it is faster for parallel computation.
1470      implicit none
1471      integer, intent(in) ::  ix,jx
1472      integer, intent(in),dimension(ix,jx) ::  GWSUBBASMSK
1473      integer, intent(out):: gnumbasns
1474      integer, intent(inout):: numbasns
1475      integer(kind=int64), intent(inout),allocatable,dimension(:):: basnsInd
1476
1477      integer,dimension(numbasns):: tmpbuf
1478
1479      integer :: i,j,k
1480
1481
1482      gnumbasns = numbasns
1483      numbasns = 0
1484      tmpbuf = -999.
1485
1486      do j = 1,jx
1487         do i = 1, ix
1488            if(GWSUBBASMSK(i,j) .gt.0) then
1489                 tmpbuf(GWSUBBASMSK(i,j)) = GWSUBBASMSK(i,j)
1490            endif
1491         end do
1492      end do
1493      do k = 1, gnumbasns
1494          if(tmpbuf(k) .gt. 0) numbasns = numbasns + 1
1495      end do
1496
1497      allocate(basnsInd(numbasns))
1498
1499      i = 1
1500      do k = 1, gnumbasns
1501          if(tmpbuf(k) .gt. 0) then
1502              basnsInd(i) = tmpbuf(k)
1503              i = i + 1
1504          endif
1505      end do
1506 #ifdef HYDRO_D
1507      write(6,*) "check numbasns, gnumbasns : ", numbasns, gnumbasns
1508 #endif
1509
1510      return
1511   end subroutine SIMP_GW_IND
1512
1513   subroutine read_GWBUCKPARM (inFile, numbasns, gnumbasns, basnsInd, &
1514                  gw_buck_coeff, gw_buck_exp, gw_buck_loss, &
1515                  z_max, z_gwsubbas, bas_id, basns_area)
1516 ! read GWBUCKPARM file
1517
1518    implicit none
1519    integer, intent(in) :: gnumbasns, numbasns
1520    integer(kind=int64), intent(in),  dimension(numbasns) :: basnsInd
1521    real,    intent(out), dimension(numbasns) :: gw_buck_coeff, gw_buck_exp
1522    real,    intent(out), dimension(:), allocatable :: gw_buck_loss
1523    real,    intent(out), dimension(numbasns) :: z_max, z_gwsubbas, basns_area
1524    integer, intent(out), dimension(numbasns) :: bas_id
1525    real, dimension(gnumbasns) :: tmp_buck_coeff, tmp_buck_exp, tmp_buck_loss
1526    real, dimension(gnumbasns) :: tmp_z_max, tmp_z_gwsubbas,  tmp_basns_area
1527    integer, dimension(gnumbasns) :: tmp_bas_id
1528    CHARACTER(len=100)                     :: header
1529    CHARACTER(len=1)                       :: jnk
1530    character(len=*) :: inFile
1531    integer :: bas,k
1532    integer :: iret, ncid
1533    logical :: fexist
1534
1535 #ifdef MPP_LAND
1536    if(my_id .eq. IO_id) then
1537 #endif
1538      inquire (file=trim(inFile), exist=fexist)
1539      if(.not. fexist) then
1540         call hydro_stop("Cound not find file : "//trim(inFile))
1541      endif
1542      iret = nf90_open(trim(inFile), NF90_NOWRITE, ncid)
1543      if(iret .eq. 0 ) then
1544         print*, "read GWBUCKPARM file as nc format: " , trim(inFile)
1545         call get_1d_netcdf_int(ncid, "Basin", tmp_bas_id, "read GWBUCKPARM", .true.)
1546         call get_1d_netcdf_real(ncid, "Coeff",tmp_buck_coeff , "read GWBUCKPARM", .true.)
1547         call get_1d_netcdf_real(ncid, "Expon",tmp_buck_exp   , "read GWBUCKPARM", .true.)
1548         if(nlst(did)%bucket_loss .eq. 1) then
1549            call get_1d_netcdf_real(ncid, "Loss",tmp_buck_loss, "read GWBUCKPARM", .true.)
1550         endif
1551         call get_1d_netcdf_real(ncid, "Zmax" ,tmp_z_max      , "read GWBUCKPARM", .true.)
1552         call get_1d_netcdf_real(ncid, "Zinit",tmp_z_gwsubbas , "read GWBUCKPARM", .true.)
1553         call get_1d_netcdf_real(ncid, "Area_sqkm",tmp_basns_area , "read GWBUCKPARM", .true.)
1554         iret = nf90_close(ncid)
1555      else
1556         !iret = nf90_close(ncid)
1557         print*, "read GWBUCKPARM file as TBL format : "
1558 #ifndef NCEP_WCOSS
1559 !yw        OPEN(81, FILE='GWBUCKPARM.TBL',FORM='FORMATTED',STATUS='OLD')
1560         OPEN(81, FILE=trim(inFile),FORM='FORMATTED',STATUS='OLD')
1561         read(81,811) header
1562 #else
1563         OPEN(24, FORM='FORMATTED',STATUS='OLD')
1564         read(24,811) header
1565 #endif
1566 811      FORMAT(A19)
1567
1568
1569 #ifndef NCEP_WCOSS
1570         do bas = 1,gnumbasns
1571            read(81,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , &
1572                  jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas)
1573
1574         end do
1575 812       FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4)
1576         close(81)
1577 #else
1578         do bas = 1,gnumbasns
1579             read(24,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , &
1580                 jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas)
1581         end do
1582 812      FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4)
1583         close(24)
1584 #endif
1585      endif
1586 #ifdef MPP_LAND
1587    endif
1588
1589    if(gnumbasns .gt. 0 ) then
1590       call mpp_land_bcast_real(gnumbasns,tmp_buck_coeff)
1591       call mpp_land_bcast_real(gnumbasns,tmp_buck_exp  )
1592       if(nlst(did)%bucket_loss .eq. 1) then
1593          call mpp_land_bcast_real(gnumbasns,tmp_buck_loss   )
1594       endif
1595       call mpp_land_bcast_real(gnumbasns,tmp_z_max   )
1596       call mpp_land_bcast_real(gnumbasns,tmp_z_gwsubbas   )
1597       call mpp_land_bcast_real(gnumbasns,tmp_basns_area   )
1598       call mpp_land_bcast_int(gnumbasns,tmp_bas_id)
1599    endif
1600 #endif
1601
1602     do k = 1, numbasns
1603        bas = basnsInd(k)
1604        gw_buck_coeff(k) = tmp_buck_coeff(bas)
1605        gw_buck_exp(k) = tmp_buck_exp(bas)
1606        if(nlst(did)%bucket_loss .eq. 1) then
1607           gw_buck_loss(k) = tmp_buck_loss(bas)
1608        endif
1609        z_max(k) = tmp_z_max(bas)
1610        z_gwsubbas(k) = tmp_z_gwsubbas(bas)
1611        basns_area(k) = tmp_basns_area(bas)
1612        bas_id(k) = tmp_bas_id(bas)
1613     end do
1614   end subroutine read_GWBUCKPARM
1615
1616
1617
1618   ! BF read the static input fields needed for the 2D GW scheme
1619   subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype, ihShift)
1620   implicit none
1621   integer, intent(in) :: ix, jx
1622   real, intent(in) :: ihShift
1623   integer, dimension(ix,jx), intent(inout)::   ltype
1624   real, dimension(ix,jx), intent(inout)   ::   hc, ihead, botelv, por
1625
1626 #ifdef MPP_LAND
1627   integer, dimension(:,:), allocatable ::  gLtype
1628   real, dimension(:,:), allocatable    ::  gHC, gIHEAD, gBOTELV, gPOR
1629 #endif
1630   integer :: i
1631
1632
1633 #ifdef MPP_LAND
1634   if(my_id .eq. IO_id) then
1635       allocate(gHC(global_rt_nx, global_rt_ny))
1636       allocate(gIHEAD(global_rt_nx, global_rt_ny))
1637       allocate(gBOTELV(global_rt_nx, global_rt_ny))
1638       allocate(gPOR(global_rt_nx, global_rt_ny))
1639       allocate(gLtype(global_rt_nx, global_rt_ny))
1640   else
1641       allocate(gHC(1, 1))
1642       allocate(gIHEAD(1, 1))
1643       allocate(gBOTELV(1, 1))
1644       allocate(gPOR(1, 1))
1645       allocate(gLtype(1, 1))
1646   endif
1647
1648 #ifndef PARALLELIO
1649   if(my_id .eq. IO_id) then
1650 #endif
1651 #ifdef HYDRO_D
1652   print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..."
1653 #endif
1654 #endif
1655
1656
1657         ! hydraulic conductivity
1658         i = get2d_real("HC", &
1659 #ifdef MPP_LAND
1660 #ifndef PARALLELIO
1661                        gHC, global_nx, global_ny,  &
1662 #else
1663                        hc, ix, jx,  &
1664 #endif
1665 #else
1666                        hc, ix, jx,  &
1667 #endif
1668                        trim("./gwhires.nc"))
1669
1670         ! initial head
1671         i = get2d_real("IHEAD", &
1672 #ifdef MPP_LAND
1673                        gIHEAD, global_nx, global_ny, &
1674 #else
1675                        ihead,  ix, jx, &
1676 #endif
1677                        trim("./gwhires.nc"))
1678
1679         ! aquifer bottom elevation
1680         i = get2d_real("BOTELV", &
1681 #ifdef MPP_LAND
1682 #ifndef PARALLELIO
1683                        gBOTELV, global_nx, global_ny, &
1684 #else
1685                        botelv, ix, jx,  &
1686 #endif
1687 #else
1688                        botelv, ix, jx,  &
1689 #endif
1690                        trim("./gwhires.nc"))
1691
1692         ! aquifer porosity
1693         i = get2d_real("POR", &
1694 #ifdef MPP_LAND
1695 #ifndef PARALLELIO
1696                        gPOR, global_nx, global_ny, &
1697 #else
1698                        por, ix, jx,  &
1699 #endif
1700 #else
1701                        por, ix, jx,  &
1702 #endif
1703                        trim("./gwhires.nc"))
1704
1705
1706         ! groundwater model mask (0 no aquifer, aquifer > 0
1707         call get2d_int("LTYPE", &
1708 #ifdef MPP_LAND
1709 #ifndef PARALLELIO
1710                        gLtype, global_nx, global_ny, &
1711 #else
1712                        ltype, ix, jx, &
1713 #endif
1714 #else
1715                        ltype, ix, jx,  &
1716 #endif
1717                        trim("./gwhires.nc"))
1718
1719
1720 #ifdef MPP_LAND
1721 #ifndef PARALLELIO
1722        gLtype(1,:) = 2
1723        gLtype(:,1) = 2
1724        gLtype(global_rt_nx,:) = 2
1725        gLtype(:,global_rt_ny) = 2
1726 #else
1727 ! BF TODO parallel io for gw ltype
1728 #endif
1729 #else
1730        ltype(1,:) = 2
1731        ltype(:,1) = 2
1732        ltype(ix,:)= 2
1733        ltype(:,jx)= 2
1734 #endif
1735
1736 #ifdef MPP_LAND
1737 #ifndef PARALLELIO
1738   endif
1739      call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx)
1740      call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx)
1741      call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx)
1742      call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx)
1743      call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx)
1744      if(allocated(gLtype)) deallocate(gLtype)
1745      if(allocated(gHC)) deallocate(gHC)
1746      if(allocated(gIHEAD)) deallocate(gIHEAD)
1747      if(allocated(gBOTELV)) deallocate(gBOTELV)
1748      if(allocated(gPOR)) deallocate(gPOR)
1749 #endif
1750 #endif
1751
1752
1753   ihead = ihead + ihShift
1754
1755   where(ltype .eq. 0)
1756    hc = 0.
1757 !yw   por = 10**21
1758    por = 10E21
1759   end where
1760
1761
1762   !bftodo: make filename accessible in namelist
1763   return
1764   end subroutine readGW2d
1765   !BF
1766
1767   subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, &
1768        startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID,       &
1769        q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, &
1770        geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,CHRTOUT_GRID,  &
1771        QBDRYRT,  &
1772        io_config_outputs &
1773        )
1774
1775 !output the routing variables over routing grid.
1776     implicit none
1777
1778     integer,                                  intent(in) :: igrid
1779
1780     integer,                                  intent(in) :: io_config_outputs
1781     integer,                                  intent(in) :: split_output_count
1782     integer,                                  intent(in) :: ixrt,jxrt
1783     real,                                     intent(in) :: dt
1784     real,                                     intent(in) :: dist(ixrt,jxrt,9)
1785     integer,                                  intent(in) :: nsoil
1786     integer,                                  intent(in) :: CHRTOUT_GRID
1787     character(len=*),                         intent(in) :: startdate
1788     character(len=*),                         intent(in) :: date
1789     character(len=*),          intent(in)                :: geo_finegrid_flnm
1790     real,             dimension(nsoil),       intent(in) :: sldpth
1791     real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
1792     real*8, allocatable, DIMENSION(:)                   :: xcoord_d
1793     real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
1794
1795     integer, save :: ncid,ncstatic
1796     integer, save :: output_count
1797     real,    dimension(nsoil) :: asldpth
1798
1799     integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
1800     integer :: iret, dimid_soil, i,j,ii,jj
1801     character(len=256) :: output_flnm
1802     character(len=19)  :: date19
1803     character(len=32)  :: convention
1804     character(len=34)  :: sec_since_date
1805     character(len=34)  :: sec_valid_date
1806
1807     character(len=30)  :: soilm
1808
1809     real                                :: long_cm,lat_po,fe,fn, chan_in
1810     real, dimension(2)                  :: sp
1811
1812     real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID
1813     real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y
1814     real, dimension(ixrt,jxrt) :: QSTRMVOLRT
1815     real, dimension(ixrt,jxrt) :: SFCHEADSUBRT
1816     real, dimension(ixrt,jxrt) :: soxrt,soyrt
1817     real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT
1818     real, dimension(ixrt,jxrt,nsoil) :: SMCRT
1819
1820     character(len=2) :: strTmp
1821
1822     integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
1823     sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
1824     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
1825     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
1826                   //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
1827
1828     decimation = 1 !-- decimation factor
1829 #ifdef MPP_LAND
1830     ixrtd = int(global_rt_nx/decimation)
1831     jxrtd = int(global_rt_ny/decimation)
1832 #else
1833     ixrtd = int(ixrt/decimation)
1834     jxrtd = int(jxrt/decimation)
1835 #endif
1836
1837 #ifdef MPP_LAND
1838     if(my_id .eq. io_id) then
1839 #endif
1840        allocate(xdumd(ixrtd,jxrtd))
1841        allocate(xcoord_d(ixrtd))
1842        allocate(ycoord_d(jxrtd))
1843        allocate(ycoord(jxrtd))
1844
1845        xdumd = -999
1846        xcoord_d = -999
1847        ycoord_d = -999
1848        ycoord = -999
1849 #ifdef MPP_LAND
1850     else
1851        allocate(xdumd(1,1))
1852        allocate(xcoord_d(1))
1853        allocate(ycoord_d(1))
1854        allocate(ycoord(1))
1855     endif
1856 #endif
1857     ii = 0
1858
1859 !DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09)
1860     chan_in = 0.0
1861     do j=1,jxrt
1862       do i=1,ixrt
1863         chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9))  !(units m^3)
1864       enddo
1865     enddo
1866 #ifdef MPP_LAND
1867       call sum_real1(chan_in)
1868 #endif
1869 #ifdef MPP_LAND
1870     if(my_id .eq. io_id) then
1871 #endif
1872 #ifdef NCEP_WCOSS
1873        open (unit=54, form='formatted', status='unknown', position='append')
1874         write (54,713) chan_in
1875        close (54)
1876 #else
1877        if (io_config_outputs .le. 0) then
1878          open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',&
1879              status='unknown',position='append')
1880          write (46,713) chan_in
1881          close (46)
1882        endif
1883 #endif
1884 #ifdef MPP_LAND
1885     endif
1886 #endif
1887 713 FORMAT (F20.7)
1888 !    return
1889 !DJG end dump of channel inflow for calibration....
1890
1891     if (CHRTOUT_GRID.eq.0) return  ! return if hires flag eq 1, if =2 output full grid
1892
1893     if (output_count == 0) then
1894
1895    !-- Open the  finemesh static files to obtain projection information
1896 #ifdef HYDRO_D
1897       write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
1898 #endif
1899
1900 #ifdef MPP_LAND
1901    if(my_id .eq. io_id) then
1902 #endif
1903       iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic)
1904 #ifdef MPP_LAND
1905    endif
1906    call mpp_land_bcast_int1(iret)
1907 #endif
1908
1909       if (iret /= 0) then
1910          write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
1911          trim(geo_finegrid_flnm)
1912          write(*,*) "HIRES_OUTPUT will not be georeferenced..."
1913         hires_flag = 0
1914       else
1915         hires_flag = 1
1916       endif
1917
1918 #ifdef MPP_LAND
1919    if(my_id .eq. io_id) then
1920 #endif
1921
1922      if(hires_flag.eq.1) then !if/then hires_georef
1923       ! Get Latitude (X)
1924       iret = NF90_INQ_VARID(ncstatic,'x',varid)
1925       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord_d)
1926       ! Get Longitude (Y)
1927       iret = NF90_INQ_VARID(ncstatic,'y',varid)
1928       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord)
1929      else
1930       ycoord_d = 0.
1931       xcoord_d = 0.
1932      end if  !endif hires_georef
1933
1934      jj = 0
1935 #ifdef MPP_LAND
1936      do j=global_rt_ny,1,-1*decimation
1937 #else
1938      do j=jxrt,1,-1*decimation
1939 #endif
1940         jj = jj+1
1941         if (jj<= jxrtd) then
1942          ycoord_d(jj) = ycoord(j)
1943         endif
1944      enddo
1945
1946    if (io_config_outputs .le. 0) then
1947      if(hires_flag.eq.1) then !if/then hires_georef
1948       ! Get projection information from finegrid netcdf file
1949       iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
1950       if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
1951       iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
1952       iret = nf90_get_att(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
1953       iret = nf90_get_att(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
1954       iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
1955      end if  !endif hires_georef
1956       iret = nf90_close(ncstatic)
1957    endif
1958
1959 !-- create the fine grid routing file
1960        write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
1961 #ifdef HYDRO_D
1962        print*, 'output_flnm = "'//trim(output_flnm)//'"'
1963 #endif
1964        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
1965        if (iret /= 0) then
1966          call hydro_stop("In output_rt() - Problem nf90_create")
1967        endif
1968
1969        iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times)
1970        iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
1971        iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx)
1972      if (io_config_outputs .le. 0) then
1973        iret = nf90_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
1974      endif
1975
1976 !--- define variables
1977 !     !- time definition, timeObs
1978          iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid)
1979          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
1980          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
1981
1982 if (io_config_outputs .le. 0) then
1983        !- x-coordinate in cartesian system
1984         iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid)
1985         iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
1986         iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
1987         iret = nf90_put_att(ncid, varid, 'units', 'Meter')
1988
1989        !- y-coordinate in cartesian ssystem
1990           iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid)
1991           iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
1992           iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
1993           iret = nf90_put_att(ncid, varid, 'units', 'Meter')
1994
1995        !- LATITUDE
1996         iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
1997         iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE')
1998         iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE')
1999         iret = nf90_put_att(ncid, varid, 'units', 'deg North')
2000
2001        !- LONGITUDE
2002           iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2003           iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE')
2004           iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE')
2005           iret = nf90_put_att(ncid, varid, 'units', 'deg east')
2006
2007        !-- z-level is soil
2008         iret = nf90_def_var(ncid, "depth", NF90_FLOAT, (/dimid_soil/), varid)
2009         iret = nf90_put_att(ncid, varid, 'units', 'cm')
2010         iret = nf90_put_att(ncid, varid, 'long_name', 'depth of soil layer')
2011
2012          do n = 1, NSOIL
2013              write(strTmp,'(I2)') n
2014              iret = nf90_def_var(ncid, "SOIL_M"//trim(strTmp), NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2015          end do
2016             iret = nf90_put_att(ncid, varid, 'units', 'm^3/m^3')
2017             iret = nf90_put_att(ncid, varid, 'description', 'moisture content')
2018             iret = nf90_put_att(ncid, varid, 'long_name', soilm)
2019 !           iret = nf90_put_att(ncid, varid, 'coordinates', 'x y z')
2020             iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2021             iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2022
2023 !      iret = nf90_def_var(ncid, "ESNOW2D", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2024
2025 !       iret = nf90_def_var(ncid, "QSUBRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2026 !       iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2027 !       iret = nf90_put_att(ncid, varid, 'long_name', 'subsurface flow')
2028 !       iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2029 !       iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2030 !       iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2031 endif
2032
2033 ! All but long range
2034 if ( io_config_outputs .ne. 4 ) then
2035
2036    iret = nf90_def_var(ncid, "zwattablrt", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2037    iret = nf90_put_att(ncid, varid, 'units', 'm')
2038    iret = nf90_put_att(ncid, varid, 'long_name', 'water table depth')
2039    iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2040    iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2041    iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2042
2043    !iret = nf90_def_var(ncid, "Q_SFCFLX_X", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2044    !iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2045    !iret = nf90_put_att(ncid, varid, 'long_name', 'surface flux x')
2046    !iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2047    !iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2048    !iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2049
2050    !iret = nf90_def_var(ncid, "Q_SFCFLX_Y", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2051    !iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2052    !iret = nf90_put_att(ncid, varid, 'long_name', 'surface flux y')
2053    !iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2054    !iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2055    !iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2056
2057    iret = nf90_def_var(ncid, "sfcheadsubrt", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2058    iret = nf90_put_att(ncid, varid, 'units', 'mm')
2059    iret = nf90_put_att(ncid, varid, 'long_name', 'surface head')
2060    iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2061    iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2062    iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2063
2064 endif
2065
2066 if (io_config_outputs .le. 0) then
2067        iret = nf90_def_var(ncid, "QSTRMVOLRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2068        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2069        iret = nf90_put_att(ncid, varid, 'long_name', 'accum channel inflow')
2070        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2071        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2072        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2073
2074 !      iret = nf90_def_var(ncid, "SOXRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2075 !      iret = nf90_put_att(ncid, varid, 'units', '1')
2076 !      iret = nf90_put_att(ncid, varid, 'long_name', 'slope x')
2077 !      iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2078 !      iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2079 !      iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2080
2081 !      iret = nf90_def_var(ncid, "SOYRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2082 !      iret = nf90_put_att(ncid, varid, 'units', '1')
2083 !      iret = nf90_put_att(ncid, varid, 'long_name', 'slope 7')
2084 !      iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2085 !      iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2086 !      iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2087
2088 !       iret = nf90_def_var(ncid, "SUB_RESID", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2089
2090        iret = nf90_def_var(ncid, "QBDRYRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2091        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2092        iret = nf90_put_att(ncid,varid,'long_name',&
2093           'accumulated value of the boundary flux, + into domain, - out of domain')
2094        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2095        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2096        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2097
2098 !-- place projection information
2099      if(hires_flag.eq.1) then !if/then hires_georef
2100       iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid)
2101       iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic')
2102       iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm)
2103       iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po)
2104       iret = nf90_put_att(ncid, varid, 'false_easting', fe)
2105       iret = nf90_put_att(ncid, varid, 'false_northing', fn)
2106       iret = nf90_put_att(ncid, varid, 'standard_parallel', sp)
2107      end if   !endif hires_georef
2108 endif
2109
2110 !      iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid)
2111
2112       date19(1:19) = "0000-00-00_00:00:00"
2113       date19(1:len_trim(startdate)) = startdate
2114       convention(1:32) = "CF-1.0"
2115       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
2116       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
2117       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
2118       iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation)
2119
2120        ! iret = nf90_redef(ncid)
2121        iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
2122        ! iret = nf90_enddef(ncid)
2123
2124       iret = nf90_enddef(ncid)
2125
2126 if (io_config_outputs .le. 0) then
2127 !!-- write latitude and longitude locations
2128          iret = nf90_inq_varid(ncid,"x", varid)
2129          iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array
2130
2131          iret = nf90_inq_varid(ncid,"y", varid)
2132          iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array
2133 endif
2134
2135 #ifdef MPP_LAND
2136     endif
2137 #endif
2138
2139 iret = nf90_inq_varid(ncid,"time", varid)
2140 iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
2141
2142 if (io_config_outputs .le. 0) then
2143 #ifdef MPP_LAND
2144         call write_IO_rt_real(LATVAL,xdumd)
2145     if( my_id .eq. io_id) then
2146 #else
2147         xdumd = LATVAL
2148 #endif
2149         iret = nf90_inq_varid(ncid,"LATITUDE", varid)
2150         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2151
2152
2153 #ifdef MPP_LAND
2154     endif   !!! end if block of my_id .eq. io_id
2155
2156         call write_IO_rt_real(LONVAL,xdumd)
2157
2158     if( my_id .eq. io_id) then
2159 #else
2160         xdumd = LONVAL
2161 #endif
2162         iret = nf90_inq_varid(ncid,"LONGITUDE", varid)
2163         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2164
2165 #ifdef MPP_LAND
2166     endif
2167
2168     if( my_id .eq. io_id) then
2169 #endif
2170
2171        do n = 1,nsoil
2172         if(n == 1) then
2173          asldpth(n) = -sldpth(n)
2174         else
2175          asldpth(n) = asldpth(n-1) - sldpth(n)
2176         endif
2177        enddo
2178
2179        iret = nf90_inq_varid(ncid,"depth", varid)
2180        iret = nf90_put_var(ncid, varid, asldpth, (/1/), (/nsoil/))
2181 !yw       iret = nf90_close(ncstatic)
2182 #ifdef MPP_LAND
2183     endif  ! end of my_id .eq. io_id
2184 #endif
2185 endif
2186
2187    endif !!! end of if block output_count == 0
2188     output_count = output_count + 1
2189
2190 if (io_config_outputs .le. 0) then
2191 !-- 3-d soils
2192      do n = 1, nsoil
2193 #ifdef MPP_LAND
2194           call write_IO_rt_real(smcrt(:,:,n),xdumd)
2195 #else
2196           xdumd(:,:) = smcrt(:,:,n)
2197 #endif
2198 #ifdef MPP_LAND
2199     if(my_id .eq. io_id) then
2200 #endif
2201           write(strTmp,'(I2)') n
2202           iret = nf90_inq_varid(ncid,  "SOIL_M"//trim(strTmp), varid)
2203           iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2204 #ifdef MPP_LAND
2205     endif
2206 #endif
2207     enddo !-n soils
2208 endif
2209
2210 ! All but long range
2211 if ( (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then
2212 #ifdef MPP_LAND
2213    call write_IO_rt_real(ZWATTABLRT,xdumd)
2214 #else
2215    xdumd(:,:) = ZWATTABLRT(:,:)
2216 #endif
2217 #ifdef MPP_LAND
2218    if (my_id .eq. io_id) then
2219 #endif
2220       iret = nf90_inq_varid(ncid,  "zwattablrt", varid)
2221       iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2222 #ifdef MPP_LAND
2223    endif
2224 #endif
2225 endif
2226
2227 if (io_config_outputs .le. 0) then
2228 #ifdef MPP_LAND
2229           call write_IO_rt_real(QBDRYRT,xdumd)
2230 #else
2231           xdumd(:,:) = QBDRYRT(:,:)
2232 #endif
2233 #ifdef MPP_LAND
2234     if(my_id .eq. io_id) then
2235 #endif
2236      iret = nf90_inq_varid(ncid,  "QBDRYRT", varid)
2237      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2238 #ifdef MPP_LAND
2239      endif
2240 #endif
2241
2242 #ifdef MPP_LAND
2243           call write_IO_rt_real(QSTRMVOLRT,xdumd)
2244 #else
2245           xdumd(:,:) = QSTRMVOLRT(:,:)
2246 #endif
2247 #ifdef MPP_LAND
2248     if(my_id .eq. io_id) then
2249 #endif
2250      iret = nf90_inq_varid(ncid,  "QSTRMVOLRT", varid)
2251      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2252 #ifdef MPP_LAND
2253      endif
2254 #endif
2255 endif
2256
2257 ! All but long range
2258 if ( io_config_outputs .ne. 4 ) then
2259 #ifdef MPP_LAND
2260    call write_IO_rt_real(SFCHEADSUBRT,xdumd)
2261 #else
2262    xdumd(:,:) = SFCHEADSUBRT(:,:)
2263 #endif
2264 #ifdef MPP_LAND
2265    if (my_id .eq. io_id) then
2266 #endif
2267       iret = nf90_inq_varid(ncid,  "sfcheadsubrt", varid)
2268       iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2269 #ifdef MPP_LAND
2270    endif
2271 #endif
2272 endif
2273
2274 #ifdef MPP_LAND
2275     if(my_id .eq. io_id) then
2276 #endif
2277
2278
2279 !yw      iret = nf90_sync(ncid)
2280       if (output_count == split_output_count) then
2281         output_count = 0
2282         iret = nf90_close(ncid)
2283       endif
2284 #ifdef MPP_LAND
2285      endif
2286      call mpp_land_bcast_int1(output_count)
2287 #endif
2288
2289      if(allocated(xdumd))  deallocate(xdumd)
2290      if(allocated(xcoord_d))  deallocate(xcoord_d)
2291      if(allocated(ycoord_d)) deallocate(ycoord_d)
2292      if(allocated(ycoord))  deallocate(ycoord)
2293
2294 #ifdef HYDRO_D
2295      write(6,*) "end of output_rt"
2296 #endif
2297
2298   end subroutine output_rt
2299
2300
2301 !BF output section for gw2d model
2302 !bftodo: clean up an customize for GW usage
2303
2304   subroutine output_gw_spinup(igrid, split_output_count, ixrt, jxrt, &
2305        startdate, date, HEAD, convgw, excess, &
2306        geo_finegrid_flnm,dt,LATVAL,LONVAL,dist,output_gw)
2307
2308 #ifdef MPP_LAND
2309        USE module_mpp_land
2310 #endif
2311 !output the routing variables over routing grid.
2312     implicit none
2313
2314     integer,                                  intent(in) :: igrid
2315     integer,                                  intent(in) :: split_output_count
2316     integer,                                  intent(in) :: ixrt,jxrt
2317     real,                                     intent(in) :: dt
2318     real,                                     intent(in) :: dist(ixrt,jxrt,9)
2319     integer,                                  intent(in) ::  output_gw
2320     character(len=*),                         intent(in) :: startdate
2321     character(len=*),                         intent(in) :: date
2322     character(len=*),          intent(in)                :: geo_finegrid_flnm
2323     real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
2324     real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
2325     real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
2326
2327     integer, save :: ncid,ncstatic
2328     integer, save :: output_count
2329
2330     integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
2331     integer :: iret, dimid_soil, i,j,ii,jj
2332     character(len=256) :: output_flnm
2333     character(len=19)  :: date19
2334     character(len=32)  :: convention
2335     character(len=34)  :: sec_since_date
2336     character(len=34)  :: sec_valid_date
2337
2338     character(len=30)  :: soilm
2339
2340     real                                :: long_cm,lat_po,fe,fn, chan_in
2341     real, dimension(2)                  :: sp
2342
2343     real, dimension(ixrt,jxrt) :: head, convgw, excess, &
2344                                   latval, lonval
2345
2346     integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
2347
2348 #ifdef MPP_LAND
2349     real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gExcess
2350     real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval
2351 #endif
2352
2353 #ifdef MPP_LAND
2354     call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99)
2355     call write_IO_rt_real(latval,gLatval)
2356     call write_IO_rt_real(lonval,gLonval)
2357     call write_IO_rt_real(head,gHead)
2358     call write_IO_rt_real(convgw,gConvgw)
2359     call write_IO_rt_real(excess,gExcess)
2360
2361
2362    if(my_id.eq.IO_id) then
2363
2364
2365 #endif
2366     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
2367     sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
2368     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
2369                   //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
2370
2371     decimation = 1 !-- decimation factor
2372 #ifdef MPP_LAND
2373     ixrtd = int(global_rt_nx/decimation)
2374     jxrtd = int(global_rt_ny/decimation)
2375 #else
2376     ixrtd = int(ixrt/decimation)
2377     jxrtd = int(jxrt/decimation)
2378 #endif
2379     allocate(xdumd(ixrtd,jxrtd))
2380     allocate(xcoord_d(ixrtd))
2381     allocate(ycoord_d(jxrtd))
2382     allocate(xcoord(ixrtd))
2383     allocate(ycoord(jxrtd))
2384     ii = 0
2385     jj = 0
2386
2387     if (output_gw.eq.0) return  ! return if hires flag eq 0, if =1 output full grid
2388
2389     if (output_count == 0) then
2390
2391    !-- Open the  finemesh static files to obtain projection information
2392 #ifdef HYDRO_D
2393       write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
2394
2395 #endif
2396       iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic)
2397
2398       if (iret /= 0) then
2399 #ifdef HYDRO_D
2400          write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
2401          trim(geo_finegrid_flnm)
2402          write(*,*) "HIRES_OUTPUT will not be georeferenced..."
2403 #endif
2404         hires_flag = 0
2405       else
2406         hires_flag = 1
2407       endif
2408
2409      if(hires_flag.eq.1) then !if/then hires_georef
2410       ! Get Latitude (X)
2411       iret = NF90_INQ_VARID(ncstatic,'x',varid)
2412       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord)
2413       ! Get Longitude (Y)
2414       iret = NF90_INQ_VARID(ncstatic,'y',varid)
2415       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord)
2416      else
2417       xcoord_d = 0.
2418       ycoord_d = 0.
2419      end if  !endif hires_georef
2420
2421      do j=jxrtd,1,-1*decimation
2422         jj = jj+1
2423         if (jj<= jxrtd) then
2424          ycoord_d(jj) = ycoord(j)
2425         endif
2426      enddo
2427
2428 !yw     do i = 1,ixrt,decimation
2429 !yw        ii = ii + 1
2430 !yw        if (ii <= ixrtd) then
2431 !yw         xcoord_d(ii) = xcoord(i)
2432          xcoord_d = xcoord
2433 !yw        endif
2434 !yw     enddo
2435
2436
2437      if(hires_flag.eq.1) then !if/then hires_georef
2438       ! Get projection information from finegrid netcdf file
2439       iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
2440       if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
2441       iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
2442       iret = nf90_get_att(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
2443       iret = nf90_get_att(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
2444       iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
2445      end if  !endif hires_georef
2446       iret = nf90_close(ncstatic)
2447
2448 !-- create the fine grid routing file
2449        write(output_flnm, '(A12,".GW_SPINUP",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
2450 #ifdef HYDRO_D
2451        print*, 'output_flnm = "'//trim(output_flnm)//'"'
2452 #endif
2453
2454
2455        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
2456        if (iret /= 0) then
2457          call hydro_stop("In output_gw_spinup() - Problem nf90_create")
2458        endif
2459
2460        iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times)
2461        iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
2462        iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx)
2463
2464 !--- define variables
2465        !- time definition, timeObs
2466        iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid)
2467        iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
2468
2469        !- x-coordinate in cartesian system
2470        iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid)
2471        iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
2472        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
2473        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2474
2475        !- y-coordinate in cartesian ssystem
2476        iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid)
2477        iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
2478        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
2479        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2480
2481        !- LATITUDE
2482        iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2483        iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE')
2484        iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE')
2485        iret = nf90_put_att(ncid, varid, 'units', 'deg North')
2486
2487        !- LONGITUDE
2488        iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2489        iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE')
2490        iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE')
2491        iret = nf90_put_att(ncid, varid, 'units', 'deg east')
2492
2493
2494        iret = nf90_def_var(ncid, "GwHead", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2495        iret = nf90_put_att(ncid, varid, 'units', 'm')
2496        iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater head')
2497        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2498        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2499        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2500
2501        iret = nf90_def_var(ncid, "GwConv", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2502        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2503        iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater convergence')
2504        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2505        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2506        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2507
2508        iret = nf90_def_var(ncid, "GwExcess", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2509        iret = nf90_put_att(ncid, varid, 'units', 'm')
2510        iret = nf90_put_att(ncid, varid, 'long_name', 'surface excess groundwater')
2511        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2512        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2513        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2514
2515 !-- place projection information
2516      if(hires_flag.eq.1) then !if/then hires_georef
2517       iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid)
2518       iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic')
2519       iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm)
2520       iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po)
2521       iret = nf90_put_att(ncid, varid, 'false_easting', fe)
2522       iret = nf90_put_att(ncid, varid, 'false_northing', fn)
2523       iret = nf90_put_att(ncid, varid, 'standard_parallel', sp)
2524      end if   !endif hires_georef
2525
2526 !      iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid)
2527
2528       date19(1:19) = "0000-00-00_00:00:00"
2529       date19(1:len_trim(startdate)) = startdate
2530       convention(1:32) = "CF-1.0"
2531       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
2532       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
2533       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
2534       iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation)
2535
2536       iret = nf90_enddef(ncid)
2537
2538 !!-- write latitude and longitude locations
2539 !       xdumd = LATVAL
2540         iret = nf90_inq_varid(ncid,"x", varid)
2541 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2542         iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array
2543
2544 !       xdumd = LONVAL
2545         iret = nf90_inq_varid(ncid,"y", varid)
2546 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2547         iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array
2548
2549 #ifdef MPP_LAND
2550         xdumd = gLATVAL
2551 #else
2552         xdumd = LATVAL
2553 #endif
2554         iret = nf90_inq_varid(ncid,"LATITUDE", varid)
2555         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2556
2557 #ifdef MPP_LAND
2558         xdumd = gLONVAL
2559 #else
2560         xdumd = LONVAL
2561 #endif
2562         iret = nf90_inq_varid(ncid,"LONGITUDE", varid)
2563         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2564
2565
2566     endif
2567
2568     output_count = output_count + 1
2569
2570 !!-- time
2571         iret = nf90_inq_varid(ncid,"time", varid)
2572         iret = nf90_put_var(ncid, varid, seconds_since, (/output_count/))
2573
2574
2575 #ifdef MPP_LAND
2576         xdumd = gHead
2577 #else
2578         xdumd = head
2579 #endif
2580
2581      iret = nf90_inq_varid(ncid,  "GwHead", varid)
2582      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2583
2584 #ifdef MPP_LAND
2585         xdumd = gConvgw
2586 #else
2587         xdumd = convgw
2588 #endif
2589      iret = nf90_inq_varid(ncid,  "GwConv", varid)
2590      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2591
2592
2593 #ifdef MPP_LAND
2594      xdumd = gExcess
2595 #else
2596      xdumd = excess
2597 #endif
2598      iret = nf90_inq_varid(ncid,  "GwExcess", varid)
2599      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2600
2601
2602 !!time in seconds since startdate
2603
2604      iret = nf90_redef(ncid)
2605      date19(1:len_trim(date)) = date
2606      iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
2607      iret = nf90_enddef(ncid)
2608      iret = nf90_sync(ncid)
2609      if (output_count == split_output_count) then
2610         output_count = 0
2611         iret = nf90_close(ncid)
2612      endif
2613
2614      if(allocated(xdumd))  deallocate(xdumd)
2615      if(allocated(xcoord_d)) deallocate(xcoord_d)
2616      if(allocated(xcoord)) deallocate(xcoord)
2617      if(allocated(ycoord_d)) deallocate(ycoord_d)
2618      if(allocated(ycoord)) deallocate(ycoord)
2619
2620 #ifdef MPP_LAND
2621     endif
2622 #endif
2623
2624   end subroutine output_gw_spinup
2625
2626
2627 subroutine sub_output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, &
2628        startdate, date, HEAD, SMCRT, convgw, excess, qsgwrt, qgw_chanrt, &
2629        geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,output_gw)
2630
2631 #ifdef MPP_LAND
2632        USE module_mpp_land
2633 #endif
2634 !output the routing variables over routing grid.
2635     implicit none
2636
2637     integer,                                  intent(in) :: igrid
2638     integer,                                  intent(in) :: split_output_count
2639     integer,                                  intent(in) :: ixrt,jxrt
2640     real,                                     intent(in) :: dt
2641     real,                                     intent(in) :: dist(ixrt,jxrt,9)
2642     integer,                                  intent(in) :: nsoil
2643     integer,                                  intent(in) ::  output_gw
2644     character(len=*),                         intent(in) :: startdate
2645     character(len=*),                         intent(in) :: date
2646     character(len=*),          intent(in)                :: geo_finegrid_flnm
2647     real,             dimension(nsoil),       intent(in) :: sldpth
2648     real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
2649     real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
2650     real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
2651
2652     integer, save :: ncid,ncstatic
2653     integer, save :: output_count
2654     real,    dimension(nsoil) :: asldpth
2655
2656     integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
2657     integer :: iret, dimid_soil, i,j,ii,jj
2658     character(len=256) :: output_flnm
2659     character(len=19)  :: date19
2660     character(len=32)  :: convention
2661     character(len=34)  :: sec_since_date
2662     character(len=34)  :: sec_valid_date
2663
2664     character(len=30)  :: soilm
2665
2666     real                                :: long_cm,lat_po,fe,fn, chan_in
2667     real, dimension(2)                  :: sp
2668
2669     real, dimension(ixrt,jxrt) :: head, convgw, excess, &
2670                                   qsgwrt, qgw_chanrt, &
2671                                   latval, lonval
2672     real, dimension(ixrt,jxrt,nsoil) :: SMCRT
2673
2674     integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
2675
2676 #ifdef MPP_LAND
2677     real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gqsgwrt, gExcess, &
2678                                                   gQgw_chanrt
2679     real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval
2680     real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT
2681 #endif
2682
2683 #ifdef MPP_LAND
2684     call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99)
2685     call MPP_LAND_COM_REAL(qsgwrt, ixrt, jxrt, 99)
2686     call MPP_LAND_COM_REAL(qgw_chanrt, ixrt, jxrt, 99)
2687     call write_IO_rt_real(latval,gLatval)
2688     call write_IO_rt_real(lonval,gLonval)
2689     call write_IO_rt_real(qsgwrt,gqsgwrt)
2690     call write_IO_rt_real(qgw_chanrt,gQgw_chanrt)
2691     call write_IO_rt_real(head,gHead)
2692     call write_IO_rt_real(convgw,gConvgw)
2693     call write_IO_rt_real(excess,gExcess)
2694
2695     do i = 1, NSOIL
2696      call MPP_LAND_COM_REAL(smcrt(:,:,i), ixrt, jxrt, 99)
2697      call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i))
2698     end do
2699
2700    if(my_id.eq.IO_id) then
2701
2702
2703 #endif
2704     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
2705     sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
2706     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
2707                   //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
2708
2709     decimation = 1 !-- decimation factor
2710 #ifdef MPP_LAND
2711     ixrtd = int(global_rt_nx/decimation)
2712     jxrtd = int(global_rt_ny/decimation)
2713 #else
2714     ixrtd = int(ixrt/decimation)
2715     jxrtd = int(jxrt/decimation)
2716 #endif
2717     allocate(xdumd(ixrtd,jxrtd))
2718     allocate(xcoord_d(ixrtd))
2719     allocate(ycoord_d(jxrtd))
2720     allocate(xcoord(ixrtd))
2721     allocate(ycoord(jxrtd))
2722     ii = 0
2723     jj = 0
2724
2725     if (output_gw.eq.0) return  ! return if hires flag eq 0, if =1 output full grid
2726
2727     if (output_count == 0) then
2728
2729    !-- Open the  finemesh static files to obtain projection information
2730 #ifdef HYDRO_D
2731       write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
2732
2733 #endif
2734       iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic)
2735
2736       if (iret /= 0) then
2737 #ifdef HYDRO_D
2738          write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
2739          trim(geo_finegrid_flnm)
2740          write(*,*) "HIRES_OUTPUT will not be georeferenced..."
2741 #endif
2742         hires_flag = 0
2743       else
2744         hires_flag = 1
2745       endif
2746
2747      if(hires_flag.eq.1) then !if/then hires_georef
2748       ! Get Latitude (X)
2749       iret = NF90_INQ_VARID(ncstatic,'x',varid)
2750       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord)
2751       ! Get Longitude (Y)
2752       iret = NF90_INQ_VARID(ncstatic,'y',varid)
2753       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord)
2754      else
2755       xcoord_d = 0.
2756       ycoord_d = 0.
2757      end if  !endif hires_georef
2758
2759      do j=jxrtd,1,-1*decimation
2760         jj = jj+1
2761         if (jj<= jxrtd) then
2762          ycoord_d(jj) = ycoord(j)
2763         endif
2764      enddo
2765
2766 !yw     do i = 1,ixrt,decimation
2767 !yw        ii = ii + 1
2768 !yw        if (ii <= ixrtd) then
2769 !yw         xcoord_d(ii) = xcoord(i)
2770          xcoord_d = xcoord
2771 !yw        endif
2772 !yw     enddo
2773
2774
2775      if(hires_flag.eq.1) then !if/then hires_georef
2776       ! Get projection information from finegrid netcdf file
2777       iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
2778       if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
2779       iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
2780       iret = nf90_get_att(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
2781       iret = nf90_get_att(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
2782       iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
2783      end if  !endif hires_georef
2784       iret = nf90_close(ncstatic)
2785
2786 !-- create the fine grid routing file
2787        write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
2788 #ifdef HYDRO_D
2789        print*, 'output_flnm = "'//trim(output_flnm)//'"'
2790 #endif
2791
2792
2793        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
2794        if (iret /= 0) then
2795          call hydro_stop("In output_gw_spinup() - Problem nf90_create")
2796        endif
2797
2798        iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times)
2799        iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
2800        iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx)
2801        iret = nf90_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
2802
2803 !--- define variables
2804        !- time definition, timeObs
2805        iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid)
2806        iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
2807
2808        !- x-coordinate in cartesian system
2809        iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid)
2810        iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
2811        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
2812        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2813
2814        !- y-coordinate in cartesian ssystem
2815        iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid)
2816        iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
2817        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
2818        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2819
2820        !- LATITUDE
2821        iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2822        iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE')
2823        iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE')
2824        iret = nf90_put_att(ncid, varid, 'units', 'deg North')
2825
2826        !- LONGITUDE
2827        iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2828        iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE')
2829        iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE')
2830        iret = nf90_put_att(ncid, varid, 'units', 'deg east')
2831
2832        !-- z-level is soil
2833        iret = nf90_def_var(ncid, "depth", NF90_FLOAT, (/dimid_soil/), varid)
2834        iret = nf90_put_att(ncid, varid, 'units', 'cm')
2835        iret = nf90_put_att(ncid, varid, 'long_name', 'depth of soil layer')
2836
2837        iret = nf90_def_var(ncid, "SOIL_M", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid)
2838        iret = nf90_put_att(ncid, varid, 'units', 'kg m-2')
2839        iret = nf90_put_att(ncid, varid, 'description', 'moisture content')
2840        iret = nf90_put_att(ncid, varid, 'long_name', soilm)
2841 !      iret = nf90_put_att(ncid, varid, 'coordinates', 'x y z')
2842        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2843        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2844
2845        iret = nf90_def_var(ncid, "HEAD", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2846        iret = nf90_put_att(ncid, varid, 'units', 'm')
2847        iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater head')
2848        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2849        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2850        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2851
2852        iret = nf90_def_var(ncid, "CONVGW", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2853        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2854        iret = nf90_put_att(ncid, varid, 'long_name', 'channel flux')
2855        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2856        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2857        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2858
2859        iret = nf90_def_var(ncid, "GwExcess", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2860        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2861        iret = nf90_put_att(ncid, varid, 'long_name', 'surface excess groundwater')
2862        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2863        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2864        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2865
2866        iret = nf90_def_var(ncid, "QSGWRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2867        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2868        iret = nf90_put_att(ncid, varid, 'long_name', 'surface head')
2869        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2870        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2871        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2872
2873        iret = nf90_def_var(ncid, "QGW_CHANRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2874        iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2875        iret = nf90_put_att(ncid, varid, 'long_name', 'surface head')
2876        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2877        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2878        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2879 !-- place projection information
2880      if(hires_flag.eq.1) then !if/then hires_georef
2881       iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid)
2882       iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic')
2883       iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm)
2884       iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po)
2885       iret = nf90_put_att(ncid, varid, 'false_easting', fe)
2886       iret = nf90_put_att(ncid, varid, 'false_northing', fn)
2887       iret = nf90_put_att(ncid, varid, 'standard_parallel', sp)
2888      end if   !endif hires_georef
2889
2890 !      iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid)
2891
2892       date19(1:19) = "0000-00-00_00:00:00"
2893       date19(1:len_trim(startdate)) = startdate
2894       convention(1:32) = "CF-1.0"
2895       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
2896       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
2897       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
2898       iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation)
2899
2900       iret = nf90_enddef(ncid)
2901
2902 !!-- write latitude and longitude locations
2903 !       xdumd = LATVAL
2904         iret = nf90_inq_varid(ncid,"x", varid)
2905 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2906         iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array
2907
2908 !       xdumd = LONVAL
2909         iret = nf90_inq_varid(ncid,"y", varid)
2910 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2911         iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array
2912
2913 #ifdef MPP_LAND
2914         xdumd = gLATVAL
2915 #else
2916         xdumd = LATVAL
2917 #endif
2918         iret = nf90_inq_varid(ncid,"LATITUDE", varid)
2919         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2920
2921 #ifdef MPP_LAND
2922         xdumd = gLONVAL
2923 #else
2924         xdumd = LONVAL
2925 #endif
2926         iret = nf90_inq_varid(ncid,"LONGITUDE", varid)
2927         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2928
2929        do n = 1,nsoil
2930         if(n == 1) then
2931          asldpth(n) = -sldpth(n)
2932         else
2933          asldpth(n) = asldpth(n-1) - sldpth(n)
2934         endif
2935        enddo
2936
2937        iret = nf90_inq_varid(ncid,"depth", varid)
2938        iret = nf90_put_var(ncid, varid, asldpth, (/1/), (/nsoil/))
2939 !yw       iret = nf90_close(ncstatic)
2940
2941     endif
2942
2943     output_count = output_count + 1
2944
2945 !!-- time
2946         iret = nf90_inq_varid(ncid,"time", varid)
2947         iret = nf90_put_var(ncid, varid, seconds_since, (/output_count/))
2948
2949 !-- 3-d soils
2950      do n = 1, nsoil
2951 #ifdef MPP_LAND
2952         xdumd = gSMCRT(:,:,n)
2953 #else
2954         xdumd = SMCRT(:,:,n)
2955 #endif
2956 ! !DJG inv      jj = int(jxrt/decimation)
2957 !       jj = 1
2958 !       ii = 0
2959 ! !DJG inv      do j = jxrt,1,-decimation
2960 !        do j = 1,jxrt,decimation
2961 !        do i = 1,ixrt,decimation
2962 !         ii = ii + 1
2963 !         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
2964 !          xdumd(ii,jj) = smcrt(i,j,n)
2965 !         endif
2966 !       enddo
2967 !        ii = 0
2968 ! !DJG inv       jj = jj -1
2969 !        jj = jj + 1
2970 !      enddo
2971 !       where (vegtyp(:,:) == 16) xdum = -1.E33
2972           iret = nf90_inq_varid(ncid,  "SOIL_M", varid)
2973           iret = nf90_put_var(ncid, varid, xdumd, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/))
2974     enddo !-n soils
2975
2976 #ifdef MPP_LAND
2977         xdumd = gHead
2978 #else
2979         xdumd = head
2980 #endif
2981
2982      iret = nf90_inq_varid(ncid,  "HEAD", varid)
2983      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2984
2985 #ifdef MPP_LAND
2986         xdumd = gConvgw
2987 #else
2988         xdumd = convgw
2989 #endif
2990      iret = nf90_inq_varid(ncid,  "CONVGW", varid)
2991      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2992
2993
2994 #ifdef MPP_LAND
2995         xdumd = gExcess
2996 #else
2997         xdumd = excess
2998 #endif
2999      iret = nf90_inq_varid(ncid,  "GwExcess", varid)
3000      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
3001
3002
3003 #ifdef MPP_LAND
3004         xdumd = gqsgwrt
3005 #else
3006         xdumd = qsgwrt
3007 #endif
3008
3009      iret = nf90_inq_varid(ncid,  "QSGWRT", varid)
3010      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
3011
3012 #ifdef MPP_LAND
3013         xdumd = gQgw_chanrt
3014 #else
3015         xdumd = qgw_chanrt
3016 #endif
3017
3018      iret = nf90_inq_varid(ncid,  "QGW_CHANRT", varid)
3019      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
3020
3021
3022 !!time in seconds since startdate
3023
3024      iret = nf90_redef(ncid)
3025      date19(1:len_trim(date)) = date
3026      iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
3027      iret = nf90_enddef(ncid)
3028      iret = nf90_sync(ncid)
3029      if (output_count == split_output_count) then
3030         output_count = 0
3031         iret = nf90_close(ncid)
3032      endif
3033
3034      if(allocated(xdumd)) deallocate(xdumd)
3035      if(allocated(xcoord_d)) deallocate(xcoord_d)
3036      if(allocated(xcoord)) deallocate(xcoord)
3037      if(allocated(ycoord_d)) deallocate(ycoord_d)
3038      if(allocated(ycoord)) deallocate(ycoord)
3039
3040 #ifdef HYDRO_D
3041      write(6,*) "end of output_ge"
3042 #endif
3043 #ifdef MPP_LAND
3044     endif
3045 #endif
3046
3047   end subroutine sub_output_gw
3048
3049 !NOte: output_chrt is the old version comparing to "output_chrt_bak".
3050
3051    subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER,             &
3052         startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
3053         STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, &
3054         lsmDt                                       &
3055 #ifdef WRF_HYDRO_NUDGING
3056         , nudge                                     &
3057 #endif
3058         , accSfcLatRunoff, accBucket                      &
3059         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff      &
3060         ,        UDMP_OPT                                 &
3061         )
3062
3063      implicit none
3064 !!output the routing variables over just channel
3065      integer,                                  intent(in) :: igrid,K,channel_option
3066      integer,                                  intent(in) :: split_output_count
3067      integer,                                  intent(in) :: NLINKS, NLINKSL
3068      real, dimension(:),                  intent(in) :: chlon,chlat
3069      real, dimension(:),                  intent(in) :: hlink,zelev
3070      integer, dimension(:),               intent(in) :: ORDER
3071      integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
3072      character(len=15), dimension(:),     intent(inout) :: gages
3073      character(len=15),                        intent(in) :: gageMiss
3074      real,                                     intent(in) :: lsmDt
3075
3076      real,                                     intent(in) :: dtrt_ch
3077      real, dimension(:,:),                intent(in) :: qlink
3078 #ifdef WRF_HYDRO_NUDGING
3079      real, dimension(:),                  intent(in) :: nudge
3080 #endif
3081
3082      integer, intent(in)  :: UDMP_OPT
3083
3084      character(len=*),                         intent(in) :: startdate
3085      character(len=*),                         intent(in) :: date
3086
3087      real, allocatable, DIMENSION(:)            :: chanlat,chanlon
3088      real, allocatable, DIMENSION(:)            :: chanlatO,chanlonO
3089
3090      real, allocatable, DIMENSION(:)            :: elevation
3091      real, allocatable, DIMENSION(:)            :: elevationO
3092
3093      integer, allocatable, DIMENSION(:)         :: station_id
3094      integer, allocatable, DIMENSION(:)         :: station_idO
3095
3096      integer, allocatable, DIMENSION(:)         :: rec_num_of_station
3097      integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
3098
3099      integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
3100      integer, allocatable, DIMENSION(:)         :: lOrderO !- local stream order
3101
3102      integer, save  :: output_count
3103      integer, save  :: ncid,ncid2
3104
3105      integer :: stationdim, dimdata, varid, charid, n
3106      integer :: obsdim, dimdataO, charidO
3107      integer :: timedim, timedim2
3108      character(len=34) :: sec_valid_date
3109
3110      integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output
3111      integer :: start_posO, prev_posO, nlk
3112
3113      integer :: previous_pos  !-- used for the station model
3114      character(len=256) :: output_flnm,output_flnm2
3115      character(len=19)  :: date19,date19start, hydroTime
3116      character(len=34)  :: sec_since_date
3117      integer :: seconds_since,nstations,cnt,ObsStation,nobs
3118      character(len=32)  :: convention
3119      character(len=11),allocatable, DIMENSION(:)  :: stname
3120      character(len=15),allocatable, DIMENSION(:)  :: stnameO
3121
3122     !--- all this for writing the station id string
3123      INTEGER   TDIMS, TXLEN
3124      PARAMETER (TDIMS=2)    ! number of TX dimensions
3125      PARAMETER (TXLEN = 11) ! length of example string
3126      INTEGER  TIMEID        ! record dimension id
3127      INTEGER  TXID          ! variable ID
3128      INTEGER  TXDIMS(TDIMS) ! variable shape
3129      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
3130
3131      !--  observation point  ids
3132      INTEGER   OTDIMS, OTXLEN
3133      PARAMETER (OTDIMS=2)    ! number of TX dimensions
3134      PARAMETER (OTXLEN = 15) ! length of example string
3135      INTEGER  OTIMEID        ! record dimension id
3136      INTEGER  OTXID          ! variable ID
3137      INTEGER  OTXDIMS(OTDIMS) ! variable shape
3138      INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
3139
3140      real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket
3141      real,   dimension(:), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
3142
3143      !! currently, this is the time of the hydro model, it's
3144      !! lsm time (olddate) plus one lsm timestep
3145      !call geth_newdate(hydroTime, date, nint(lsmDt))
3146      hydroTime=date
3147
3148      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
3149      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
3150                    //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
3151
3152 !    order_to_write = 2  !-- 1 all; 6 fewest
3153       nstations = 0  ! total number of channel points to display
3154       nobs      = 0  ! number of observation points
3155
3156      if(channel_option .ne. 3) then
3157         nlk = NLINKSL
3158      else
3159         nlk = NLINKS
3160      endif
3161
3162
3163 !-- output only the higher oder streamflows  and only observation points
3164      do i=1,nlk
3165         if(ORDER(i) .ge. order_to_write) nstations = nstations + 1
3166         if(channel_option .ne. 3) then
3167            if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1
3168         else
3169            if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1
3170         endif
3171      enddo
3172
3173      if (nobs .eq. 0) then ! let's at least make one obs point
3174         nobs = 1
3175         if(channel_option .ne. 3) then
3176            !           123456789012345
3177            gages(1) = '          dummy'
3178         else
3179            STRMFRXSTPTS(1) = 1
3180         endif
3181      endif
3182
3183        allocate(chanlat(nstations))
3184        allocate(chanlon(nstations))
3185        allocate(elevation(nstations))
3186        allocate(lOrder(nstations))
3187        allocate(stname(nstations))
3188        allocate(station_id(nstations))
3189        allocate(rec_num_of_station(nstations))
3190
3191        allocate(chanlatO(nobs))
3192        allocate(chanlonO(nobs))
3193        allocate(elevationO(nobs))
3194        allocate(lOrderO(nobs))
3195        allocate(stnameO(nobs))
3196        allocate(station_idO(nobs))
3197        allocate(rec_num_of_stationO(nobs))
3198
3199        if(output_count == 0) then
3200 !-- have moved sec_since_date from above here..
3201         sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
3202                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
3203
3204         date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
3205                   //startdate(12:13)//':'//startdate(15:16)//':00'
3206
3207         nstations = 0
3208         nobs = 0
3209
3210         write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3211         write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3212
3213 #ifdef HYDRO_D
3214         print*, 'output_flnm = "'//trim(output_flnm)//'"'
3215 #endif
3216
3217         iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
3218         if (iret /= 0) then
3219            call hydro_stop("In output_chrt() - Problem nf90_create points")
3220         endif
3221
3222         iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2)
3223         if (iret /= 0) then
3224            call hydro_stop("In output_chrt() - Problem nf90_create observation")
3225         endif
3226
3227        do i=1,nlk
3228         if(ORDER(i) .ge. order_to_write) then
3229          nstations = nstations + 1
3230          chanlat(nstations) = chlat(i)
3231          chanlon(nstations) = chlon(i)
3232          elevation(nstations) = zelev(i)
3233          lOrder(nstations) = ORDER(i)
3234          station_id(nstations) = i
3235          if(STRMFRXSTPTS(nstations) .eq. -9999) then
3236            ObsStation = 0
3237          else
3238            ObsStation = 1
3239          endif
3240          write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation
3241         endif
3242        enddo
3243
3244
3245        do i=1,nlk
3246           if(channel_option .ne. 3) then
3247              if(trim(gages(i)) .ne. trim(gageMiss)) then
3248                 nobs = nobs + 1
3249                 chanlatO(nobs) = chlat(i)
3250                 chanlonO(nobs) = chlon(i)
3251                 elevationO(nobs) = zelev(i)
3252                 lOrderO(nobs) = ORDER(i)
3253                 station_idO(nobs) = i
3254                 stnameO(nobs) = gages(i)
3255              endif
3256           else
3257              if(STRMFRXSTPTS(i) .ne. -9999) then
3258                 nobs = nobs + 1
3259                 chanlatO(nobs) = chlat(i)
3260                 chanlonO(nobs) = chlon(i)
3261                 elevationO(nobs) = zelev(i)
3262                 lOrderO(nobs) = ORDER(i)
3263                 station_idO(nobs) = i
3264                 write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs)
3265 #ifdef HYDRO_D
3266                 !        print *,"stationobservation name",  stnameO(nobs)
3267 #endif
3268              endif
3269           endif
3270        enddo
3271
3272        iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata)  !--for linked list approach
3273        iret = nf90_def_dim(ncid, "station", nstations, stationdim)
3274        iret = nf90_def_dim(ncid, "time", 1, timedim)
3275
3276
3277        iret = nf90_def_dim(ncid2, "recNum", NF90_UNLIMITED, dimdataO)  !--for linked list approach
3278        iret = nf90_def_dim(ncid2, "station", nobs, obsdim)
3279        iret = nf90_def_dim(ncid2, "time", 1, timedim2)
3280
3281       !- station location definition all,  lat
3282         iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
3283 #ifdef HYDRO_D
3284        write(6,*) "iret 2.1,  ", iret, stationdim
3285 #endif
3286         iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude')
3287 #ifdef HYDRO_D
3288        write(6,*) "iret 2.2", iret
3289 #endif
3290         iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
3291 #ifdef HYDRO_D
3292        write(6,*) "iret 2.3", iret
3293 #endif
3294
3295
3296       !- station location definition obs,  lat
3297         iret = nf90_def_var(ncid2, "latitude", NF90_FLOAT, (/obsdim/), varid)
3298         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation latitude')
3299         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_north')
3300
3301
3302       !- station location definition,  long
3303         iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
3304         iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude')
3305         iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
3306
3307
3308       !- station location definition, obs long
3309         iret = nf90_def_var(ncid2, "longitude", NF90_FLOAT, (/obsdim/), varid)
3310         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation longitude')
3311         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_east')
3312
3313
3314 !     !-- elevation is ZELEV
3315         iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
3316         iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude')
3317         iret = nf90_put_att(ncid, varid, 'units', 'meters')
3318
3319
3320 !     !-- elevation is obs ZELEV
3321         iret = nf90_def_var(ncid2, "altitude", NF90_FLOAT, (/obsdim/), varid)
3322         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation altitude')
3323         iret = nf90_put_att(ncid2, varid, 'units', 'meters')
3324
3325
3326 !     !--  gage observation
3327 !       iret = nf90_def_var(ncid, "gages", NF90_FLOAT, (/stationdim/), varid)
3328 !       iret = nf90_put_att(ncid, varid, 'long_name', 'Stream Gage Location')
3329 !       iret = nf90_put_att(ncid, varid, 'units', 'none')
3330
3331 !-- parent index
3332         iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid)
3333         iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record')
3334
3335         iret = nf90_def_var(ncid2, "parent_index", NF90_INT, (/dimdataO/), varid)
3336         iret = nf90_put_att(ncid2, varid, 'long_name', 'index of the station for this record')
3337
3338      !-- prevChild
3339         iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid)
3340         iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station')
3341 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3342         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3343
3344         iret = nf90_def_var(ncid2, "prevChild", NF90_INT, (/dimdataO/), varid)
3345         iret = nf90_put_att(ncid2, varid, 'long_name', 'record number of the previous record for the same station')
3346 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3347         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3348
3349      !-- lastChild
3350         iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
3351         iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station')
3352 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3353         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3354
3355         iret = nf90_def_var(ncid2, "lastChild", NF90_INT, (/obsdim/), varid)
3356         iret = nf90_put_att(ncid2, varid, 'long_name', 'latest report for this station')
3357 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3358         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3359
3360 !     !- flow definition, var
3361
3362         if(UDMP_OPT .eq. 1) then
3363
3364            !! FLUXES to channel
3365            if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
3366               nlst(did)%output_channelBucket_influx .eq. 2      ) then
3367               iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/dimdata/), varid)
3368               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
3369               if(nlst(did)%OVRTSWCRT .eq. 1) then              !123456789112345678921234567
3370                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing')
3371               else
3372                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff')
3373               end if
3374               iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/dimdata/), varid)
3375               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
3376               iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket')
3377            end if
3378
3379            !! Bucket influx
3380            if(nlst(did)%output_channelBucket_influx .eq. 2) then
3381               iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/dimdata/), varid)
3382               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
3383               iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket')
3384            end if
3385
3386            !! ACCUMULATIONS
3387            if(nlst(did)%output_channelBucket_influx .eq. 3) then
3388                  iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimdata/), varid)
3389                  iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
3390                  if(nlst(did)%OVRTSWCRT .eq. 1) then
3391                     iret = nf90_put_att(ncid,varid,'long_name',&
3392                                            'ACCUMULATED runoff from terrain routing')
3393                  else
3394                     iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land')
3395                  end if
3396               iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimdata/), varid)
3397               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
3398               iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from gw bucket')
3399            endif
3400         endif
3401
3402         iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/dimdata/), varid)
3403         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
3404         iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow')
3405
3406         iret = nf90_def_var(ncid2, "streamflow", NF90_FLOAT, (/dimdataO/), varid)
3407         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
3408         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Flow')
3409
3410 #ifdef WRF_HYDRO_NUDGING
3411         iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/dimdata/), varid)
3412         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
3413         iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration')
3414
3415         iret = nf90_def_var(ncid2, "nudge", NF90_FLOAT, (/dimdataO/), varid)
3416         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
3417         iret = nf90_put_att(ncid2, varid, 'long_name', 'Amount of stream flow alteration')
3418 #endif
3419
3420 !     !- flow definition, var
3421 !       iret = nf90_def_var(ncid, "pos_streamflow", NF90_FLOAT, (/dimdata/), varid)
3422 !       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
3423 !       iret = nf90_put_att(ncid, varid, 'long_name', 'abs streamflow')
3424
3425 !     !- head definition, var
3426         iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/dimdata/), varid)
3427         iret = nf90_put_att(ncid, varid, 'units', 'meter')
3428         iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
3429
3430         iret = nf90_def_var(ncid2, "head", NF90_FLOAT, (/dimdataO/), varid)
3431         iret = nf90_put_att(ncid2, varid, 'units', 'meter')
3432         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Stage')
3433
3434 !     !- order definition, var
3435         iret = nf90_def_var(ncid, "order", NF90_INT, (/dimdata/), varid)
3436         iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order')
3437         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3438
3439         iret = nf90_def_var(ncid2, "order", NF90_INT, (/dimdataO/), varid)
3440         iret = nf90_put_att(ncid2, varid, 'long_name', 'Strahler Stream Order')
3441         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3442
3443      !-- station  id
3444      ! define character-position dimension for strings of max length 11
3445          iret = NF90_DEF_DIM(ncid, "id_len", 11, charid)
3446          TXDIMS(1) = charid   ! define char-string variable and position dimension first
3447          TXDIMS(2) = stationdim
3448          iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid)
3449          iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
3450
3451
3452          iret = NF90_DEF_DIM(ncid2, "id_len", 15, charidO)
3453          OTXDIMS(1) = charidO   ! define char-string variable and position dimension first
3454          OTXDIMS(2) = obsdim
3455          iret = nf90_def_var(ncid2, "station_id", NF90_CHAR, OTXDIMS, varid)
3456          iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation id')
3457
3458
3459 !     !- time definition, timeObs
3460          iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
3461          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
3462          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
3463
3464          iret = nf90_def_var(ncid2, "time", NF90_INT, (/timedim2/), varid)
3465          iret = nf90_put_att(ncid2, varid, 'units', sec_valid_date)
3466          iret = nf90_put_att(ncid2, varid, 'long_name', 'valid output time')
3467
3468          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
3469          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
3470
3471          convention(1:32) = "Unidata Observation Dataset v1.0"
3472          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
3473          iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
3474
3475          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
3476          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
3477          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
3478          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
3479
3480          iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
3481          iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
3482          iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
3483          iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", order_to_write)
3484
3485          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
3486          iret = nf90_put_att(ncid2, NF90_GLOBAL, "cdm_datatype", "Station")
3487
3488          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_max", "90.0")
3489          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
3490          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_max", "180.0")
3491          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
3492
3493          iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
3494          iret = nf90_put_att(ncid2, NF90_GLOBAL, "station_dimension", "station")
3495          iret = nf90_put_att(ncid2, NF90_GLOBAL, "missing_value", -9E15)
3496          iret = nf90_put_att(ncid2, NF90_GLOBAL, "stream_order_output", order_to_write)
3497
3498          iret = nf90_enddef(ncid)
3499          iret = nf90_enddef(ncid2)
3500
3501         !-- write latitudes
3502          iret = nf90_inq_varid(ncid,"latitude", varid)
3503          iret = nf90_put_var(ncid, varid, chanlat, (/1/), (/nstations/))
3504
3505          iret = nf90_inq_varid(ncid2,"latitude", varid)
3506          iret = nf90_put_var(ncid2, varid, chanlatO, (/1/), (/nobs/))
3507
3508         !-- write longitudes
3509          iret = nf90_inq_varid(ncid,"longitude", varid)
3510          iret = nf90_put_var(ncid, varid, chanlon, (/1/), (/nstations/))
3511
3512          iret = nf90_inq_varid(ncid2,"longitude", varid)
3513          iret = nf90_put_var(ncid2, varid, chanlonO, (/1/), (/nobs/))
3514
3515         !-- write elevations
3516          iret = nf90_inq_varid(ncid,"altitude", varid)
3517          iret = nf90_put_var(ncid, varid, elevation, (/1/), (/nstations/))
3518
3519          iret = nf90_inq_varid(ncid2,"altitude", varid)
3520          iret = nf90_put_var(ncid2, varid, elevationO, (/1/), (/nobs/))
3521
3522       !-- write gage location
3523 !      iret = nf90_inq_varid(ncid,"gages", varid)
3524 !      iret = nf90_put_var(ncid, varid, STRMFRXSTPTS, (/1/), (/nstations/))
3525
3526         !-- write number_of_stations, OPTIONAL
3527       !!  iret = nf90_inq_varid(ncid,"number_stations", varid)
3528       !!  iret = nf90_put_var_int(ncid, varid, nstations)
3529
3530         !-- write station id's
3531          do i=1,nstations
3532           TSTART(1) = 1
3533           TSTART(2) = i
3534           TCOUNT(1) = TXLEN
3535           TCOUNT(2) = 1
3536           iret = nf90_inq_varid(ncid,"station_id", varid)
3537           iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT)
3538          enddo
3539
3540         !-- write observation id's
3541          do i=1, nobs
3542           OTSTART(1) = 1
3543           OTSTART(2) = i
3544           OTCOUNT(1) = OTXLEN
3545           OTCOUNT(2) = 1
3546           iret = nf90_inq_varid(ncid2,"station_id", varid)
3547           iret = nf90_put_var(ncid2, varid, stnameO(i), OTSTART, OTCOUNT)
3548          enddo
3549
3550      endif
3551
3552      output_count = output_count + 1
3553
3554      open (unit=55, &
3555 #ifndef NCEP_WCOSS
3556      file='frxst_pts_out.txt', &
3557 #endif
3558      status='unknown',position='append')
3559
3560      cnt=0
3561      do i=1,nlk
3562
3563        if(ORDER(i) .ge. order_to_write) then
3564          start_pos = (cnt+1)+(nstations*(output_count-1))
3565
3566          !!--time in seconds since startdate
3567           iret = nf90_inq_varid(ncid,"time", varid)
3568           iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
3569
3570          if(UDMP_OPT .eq. 1) then
3571             !! FLUXES to channel
3572              if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
3573                 nlst(did)%output_channelBucket_influx .eq. 2      ) then
3574                 iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid)
3575                 iret = nf90_put_var(ncid, varid, qSfcLatRunoff(i), (/start_pos/))
3576
3577                 iret = nf90_inq_varid(ncid,"qBucket", varid)
3578                 iret = nf90_put_var(ncid, varid, qBucket(i), (/start_pos/))
3579              end if
3580
3581              !! FLUXES to bucket
3582              if(nlst(did)%output_channelBucket_influx .eq. 2) then
3583                 iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid)
3584                 iret = nf90_put_var(ncid, varid, qBtmVertRunoff(i), (/start_pos/))
3585              end if
3586
3587             !! ACCUMULATIONS
3588              if(nlst(did)%output_channelBucket_influx .eq. 3) then
3589                 iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid)
3590                 iret = nf90_put_var(ncid, varid, accSfcLatRunoff(i), (/start_pos/))
3591
3592                 iret = nf90_inq_varid(ncid,"accBucket", varid)
3593                 iret = nf90_put_var(ncid, varid, accBucket(i), (/start_pos/))
3594              end if
3595           endif
3596
3597          iret = nf90_inq_varid(ncid,"streamflow", varid)
3598          iret = nf90_put_var(ncid, varid, qlink(i,1), (/start_pos/))
3599
3600 #ifdef WRF_HYDRO_NUDGING
3601          iret = nf90_inq_varid(ncid,"nudge", varid)
3602          iret = nf90_put_var(ncid, varid, nudge(i), (/start_pos/))
3603 #endif
3604
3605 !        iret = nf90_inq_varid(ncid,"pos_streamflow", varid)
3606 !        iret = nf90_put_var(ncid, varid, abs(qlink(i,1), (/start_pos/)))
3607
3608          iret = nf90_inq_varid(ncid,"head", varid)
3609          iret = nf90_put_var(ncid, varid, hlink(i), (/start_pos/))
3610
3611          iret = nf90_inq_varid(ncid,"order", varid)
3612          iret = nf90_put_var(ncid, varid, ORDER(i), (/start_pos/))
3613
3614          !-- station index.. will repeat for every timesstep
3615          iret = nf90_inq_varid(ncid,"parent_index", varid)
3616          iret = nf90_put_var(ncid, varid, cnt, (/start_pos/))
3617
3618           !--record number of previous record for same station
3619 !obsolete format         prev_pos = cnt+(nstations*(output_count-1))
3620          prev_pos = cnt+(nobs*(output_count-2))
3621          if(output_count.ne.1) then !-- only write next set of records
3622            iret = nf90_inq_varid(ncid,"prevChild", varid)
3623            iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/))
3624          endif
3625          cnt=cnt+1  !--indices are 0 based
3626          rec_num_of_station(cnt) = start_pos-1  !-- save position for last child, 0-based!!
3627
3628
3629        endif
3630     enddo
3631 !    close(999)
3632
3633     !-- output  only observation points
3634     cnt=0
3635     do i=1,nlk
3636        if(channel_option .ne. 3) then
3637           ! jlm this verry repetitiuos, oh well.
3638           if(trim(gages(i)) .ne. trim(gageMiss)) then
3639
3640              start_posO = (cnt+1)+(nobs * (output_count-1))
3641              !Write frxst_pts to text file...
3642              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
3643 118          FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
3644              !write(55,118) seconds_since, date(1:10), date(12:19), &
3645
3646              write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), &
3647                   gages(i), chlon(i), chlat(i),                               &
3648                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
3649
3650              !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
3651              !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)
3652
3653              !!--time in seconds since startdate
3654              iret = nf90_inq_varid(ncid2,"time", varid)
3655              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
3656
3657              iret = nf90_inq_varid(ncid2,"streamflow", varid)
3658              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
3659
3660 #ifdef WRF_HYDRO_NUDGING
3661              iret = nf90_inq_varid(ncid2,"nudge", varid)
3662              iret = nf90_put_var(ncid2, varid, nudge(i), (/start_posO/))
3663 #endif
3664
3665              iret = nf90_inq_varid(ncid2,"head", varid)
3666              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
3667
3668              iret = nf90_inq_varid(ncid,"order", varid)
3669              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
3670
3671              !-- station index.. will repeat for every timesstep
3672              iret = nf90_inq_varid(ncid2,"parent_index", varid)
3673              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
3674
3675              !--record number of previous record for same station
3676              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
3677              prev_posO = cnt+(nobs*(output_count-2))
3678              if(output_count.ne.1) then !-- only write next set of records
3679                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
3680                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3681
3682                 !IF block to add -1 to last element of prevChild array to designate end of list...
3683                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
3684                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
3685                 !           else
3686                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3687                 !           endif
3688
3689              endif
3690              cnt=cnt+1  !--indices are 0 based
3691              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
3692           endif
3693
3694
3695        else !! channel options 3 below
3696
3697           if(STRMFRXSTPTS(i) .ne. -9999) then
3698              start_posO = (cnt+1)+(nobs * (output_count-1))
3699              !Write frxst_pts to text file...
3700              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
3701 117          FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
3702              !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), &
3703              !     qlink(i,1), qlink(i,1)*35.315,hlink(i)
3704              ! JLM: makes more sense to output the value in frxstpts incase they have meaning,
3705              ! as below, but I'm not going to make this change until I'm working with gridded
3706              ! streamflow again.
3707              write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), &
3708                   strmfrxstpts(i), chlon(i), chlat(i),                        &
3709                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
3710
3711              !!--time in seconds since startdate
3712              iret = nf90_inq_varid(ncid2,"time", varid)
3713              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
3714
3715              iret = nf90_inq_varid(ncid2,"streamflow", varid)
3716              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
3717
3718              iret = nf90_inq_varid(ncid2,"head", varid)
3719              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
3720
3721              iret = nf90_inq_varid(ncid,"order", varid)
3722              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
3723
3724              !-- station index.. will repeat for every timesstep
3725              iret = nf90_inq_varid(ncid2,"parent_index", varid)
3726              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
3727
3728              !--record number of previous record for same station
3729              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
3730              prev_posO = cnt+(nobs*(output_count-2))
3731              if(output_count.ne.1) then !-- only write next set of records
3732                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
3733                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3734
3735                 !IF block to add -1 to last element of prevChild array to designate end of list...
3736                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
3737                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
3738                 !           else
3739                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3740                 !           endif
3741
3742              endif
3743              cnt=cnt+1  !--indices are 0 based
3744              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
3745           endif
3746
3747        endif
3748
3749     enddo
3750     close(55)
3751
3752       !-- lastChild variable gives the record number of the most recent report for the station
3753       iret = nf90_inq_varid(ncid,"lastChild", varid)
3754       iret = nf90_put_var(ncid, varid, rec_num_of_station, (/1/), (/nstations/))
3755
3756       !-- lastChild variable gives the record number of the most recent report for the station
3757       iret = nf90_inq_varid(ncid2,"lastChild", varid)
3758       iret = nf90_put_var(ncid2, varid, rec_num_of_stationO, (/1/), (/nobs/))
3759
3760       iret = nf90_redef(ncid)
3761       date19(1:19) = "0000-00-00_00:00:00"
3762       date19(1:len_trim(date)) = date
3763       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
3764
3765       iret = nf90_redef(ncid2)
3766       iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
3767
3768       iret = nf90_enddef(ncid)
3769       iret = nf90_sync(ncid)
3770
3771       iret = nf90_enddef(ncid2)
3772       iret = nf90_sync(ncid2)
3773
3774       if (output_count == split_output_count) then
3775         output_count = 0
3776         iret = nf90_close(ncid)
3777         iret = nf90_close(ncid2)
3778      endif
3779
3780      deallocate(chanlat)
3781      deallocate(chanlon)
3782      deallocate(elevation)
3783      deallocate(station_id)
3784      deallocate(lOrder)
3785      deallocate(rec_num_of_station)
3786      deallocate(stname)
3787
3788      deallocate(chanlatO)
3789      deallocate(chanlonO)
3790      deallocate(elevationO)
3791      deallocate(station_idO)
3792      deallocate(lOrderO)
3793      deallocate(rec_num_of_stationO)
3794      deallocate(stnameO)
3795 #ifdef HYDRO_D
3796      print *, "Exited Subroutine output_chrt"
3797 #endif
3798      close(16)
3799
3800 20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3)
3801
3802 end subroutine output_chrt
3803 !-- output the channel route in an IDV 'station' compatible format
3804 !Note: This version has pool output performance need to be
3805 !solved. We renamed it from output_chrt to be output_chrt_bak.
3806    subroutine output_chrt_bak(igrid, split_output_count, NLINKS, ORDER,             &
3807         startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
3808         STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, &
3809         lsmDt                                       &
3810 #ifdef WRF_HYDRO_NUDGING
3811         , nudge                                     &
3812 #endif
3813         , accSfcLatRunoff, accBucket                      &
3814         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff      &
3815         ,        UDMP_OPT                                 &
3816         )
3817
3818      implicit none
3819 !!output the routing variables over just channel
3820      integer,                                  intent(in) :: igrid,K,channel_option
3821      integer,                                  intent(in) :: split_output_count
3822      integer,                                  intent(in) :: NLINKS, NLINKSL
3823      real, dimension(:),                  intent(in) :: chlon,chlat
3824      real, dimension(:),                  intent(in) :: hlink,zelev
3825      integer, dimension(:),               intent(in) :: ORDER
3826      integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
3827      character(len=15), dimension(:),     intent(inout) :: gages
3828      character(len=15),                        intent(in) :: gageMiss
3829      real,                                     intent(in) :: lsmDt
3830
3831      real,                                     intent(in) :: dtrt_ch
3832      real, dimension(:,:),                intent(in) :: qlink
3833 #ifdef WRF_HYDRO_NUDGING
3834      real, dimension(:),                  intent(in) :: nudge
3835 #endif
3836
3837      integer, intent(in)  :: UDMP_OPT
3838
3839      character(len=*),                         intent(in) :: startdate
3840      character(len=*),                         intent(in) :: date
3841
3842      real, allocatable, DIMENSION(:)            :: chanlat,chanlon
3843      real, allocatable, DIMENSION(:)            :: chanlatO,chanlonO
3844
3845      real, allocatable, DIMENSION(:)            :: elevation
3846      real, allocatable, DIMENSION(:)            :: elevationO
3847
3848      integer, allocatable, DIMENSION(:)         :: station_id
3849      integer, allocatable, DIMENSION(:)         :: station_idO
3850
3851      integer, allocatable, DIMENSION(:)         :: rec_num_of_station
3852      integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
3853
3854      integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
3855      integer, allocatable, DIMENSION(:)         :: lOrderO !- local stream order
3856
3857      integer, save  :: output_count
3858      integer, save  :: ncid,ncid2
3859
3860      integer :: stationdim, dimdata, varid, charid, n
3861      integer :: obsdim, dimdataO, charidO
3862      integer :: timedim, timedim2
3863      character(len=34) :: sec_valid_date
3864
3865      integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output
3866      integer :: start_posO, prev_posO, nlk
3867
3868      integer :: previous_pos  !-- used for the station model
3869      character(len=256) :: output_flnm,output_flnm2
3870      character(len=19)  :: date19,date19start, hydroTime
3871      character(len=34)  :: sec_since_date
3872      integer :: seconds_since,nstations,cnt,ObsStation,nobs
3873      character(len=32)  :: convention
3874      character(len=11),allocatable, DIMENSION(:)  :: stname
3875      character(len=15),allocatable, DIMENSION(:)  :: stnameO
3876
3877     !--- all this for writing the station id string
3878      INTEGER   TDIMS, TXLEN
3879      PARAMETER (TDIMS=2)    ! number of TX dimensions
3880      PARAMETER (TXLEN = 11) ! length of example string
3881      INTEGER  TIMEID        ! record dimension id
3882      INTEGER  TXID          ! variable ID
3883      INTEGER  TXDIMS(TDIMS) ! variable shape
3884      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
3885
3886      !--  observation point  ids
3887      INTEGER   OTDIMS, OTXLEN
3888      PARAMETER (OTDIMS=2)    ! number of TX dimensions
3889      PARAMETER (OTXLEN = 15) ! length of example string
3890      INTEGER  OTIMEID        ! record dimension id
3891      INTEGER  OTXID          ! variable ID
3892      INTEGER  OTXDIMS(OTDIMS) ! variable shape
3893      INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
3894
3895      real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket
3896      real,   dimension(:), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
3897
3898      !! currently, this is the time of the hydro model, it's
3899      !! lsm time (olddate) plus one lsm timestep
3900      !call geth_newdate(hydroTime, date, nint(lsmDt))
3901      hydroTime=date
3902
3903      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
3904      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
3905                    //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
3906
3907 !    order_to_write = 2  !-- 1 all; 6 fewest
3908       nstations = 0  ! total number of channel points to display
3909       nobs      = 0  ! number of observation points
3910
3911      if(channel_option .ne. 3) then
3912         nlk = NLINKSL
3913      else
3914         nlk = NLINKS
3915      endif
3916
3917
3918 !-- output only the higher oder streamflows  and only observation points
3919      do i=1,nlk
3920         if(ORDER(i) .ge. order_to_write) nstations = nstations + 1
3921         if(channel_option .ne. 3) then
3922            if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1
3923         else
3924            if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1
3925         endif
3926      enddo
3927
3928      if (nobs .eq. 0) then ! let's at least make one obs point
3929         nobs = 1
3930         if(channel_option .ne. 3) then
3931            !           123456789012345
3932            gages(1) = '          dummy'
3933         else
3934            STRMFRXSTPTS(1) = 1
3935         endif
3936      endif
3937
3938        allocate(chanlat(nstations))
3939        allocate(chanlon(nstations))
3940        allocate(elevation(nstations))
3941        allocate(lOrder(nstations))
3942        allocate(stname(nstations))
3943        allocate(station_id(nstations))
3944        allocate(rec_num_of_station(nstations))
3945
3946        allocate(chanlatO(nobs))
3947        allocate(chanlonO(nobs))
3948        allocate(elevationO(nobs))
3949        allocate(lOrderO(nobs))
3950        allocate(stnameO(nobs))
3951        allocate(station_idO(nobs))
3952        allocate(rec_num_of_stationO(nobs))
3953
3954        if(output_count == 0) then
3955 !-- have moved sec_since_date from above here..
3956         sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
3957                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
3958
3959         date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
3960                   //startdate(12:13)//':'//startdate(15:16)//':00'
3961
3962         nstations = 0
3963         nobs = 0
3964
3965         write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3966         write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3967
3968 #ifdef HYDRO_D
3969         print*, 'output_flnm = "'//trim(output_flnm)//'"'
3970 #endif
3971
3972        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
3973        if (iret /= 0) then
3974            call hydro_stop("In output_chrt() - Problem nf90_create points")
3975        endif
3976
3977        iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2)
3978        if (iret /= 0) then
3979            call hydro_stop("In output_chrt() - Problem nf90_create observation")
3980        endif
3981
3982        do i=1,nlk
3983         if(ORDER(i) .ge. order_to_write) then
3984          nstations = nstations + 1
3985          chanlat(nstations) = chlat(i)
3986          chanlon(nstations) = chlon(i)
3987          elevation(nstations) = zelev(i)
3988          lOrder(nstations) = ORDER(i)
3989          station_id(nstations) = i
3990          if(STRMFRXSTPTS(nstations) .eq. -9999) then
3991            ObsStation = 0
3992          else
3993            ObsStation = 1
3994          endif
3995          write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation
3996         endif
3997        enddo
3998
3999
4000        do i=1,nlk
4001           if(channel_option .ne. 3) then
4002              if(trim(gages(i)) .ne. trim(gageMiss)) then
4003                 nobs = nobs + 1
4004                 chanlatO(nobs) = chlat(i)
4005                 chanlonO(nobs) = chlon(i)
4006                 elevationO(nobs) = zelev(i)
4007                 lOrderO(nobs) = ORDER(i)
4008                 station_idO(nobs) = i
4009                 stnameO(nobs) = gages(i)
4010              endif
4011           else
4012              if(STRMFRXSTPTS(i) .ne. -9999) then
4013                 nobs = nobs + 1
4014                 chanlatO(nobs) = chlat(i)
4015                 chanlonO(nobs) = chlon(i)
4016                 elevationO(nobs) = zelev(i)
4017                 lOrderO(nobs) = ORDER(i)
4018                 station_idO(nobs) = i
4019                 write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs)
4020 #ifdef HYDRO_D
4021                 !        print *,"stationobservation name",  stnameO(nobs)
4022 #endif
4023              endif
4024           endif
4025        enddo
4026
4027        iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata)  !--for linked list approach
4028        iret = nf90_def_dim(ncid, "station", nstations, stationdim)
4029        iret = nf90_def_dim(ncid, "time", 1, timedim)
4030
4031
4032        iret = nf90_def_dim(ncid2, "recNum", NF90_UNLIMITED, dimdataO)  !--for linked list approach
4033        iret = nf90_def_dim(ncid2, "station", nobs, obsdim)
4034        iret = nf90_def_dim(ncid2, "time", 1, timedim2)
4035
4036       !- station location definition all,  lat
4037         iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
4038         iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude')
4039         iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
4040
4041       !- station location definition obs,  lat
4042         iret = nf90_def_var(ncid2, "latitude", NF90_FLOAT, (/obsdim/), varid)
4043         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation latitude')
4044         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_north')
4045
4046
4047       !- station location definition,  long
4048         iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
4049         iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude')
4050         iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
4051
4052
4053       !- station location definition, obs long
4054         iret = nf90_def_var(ncid2, "longitude", NF90_FLOAT, (/obsdim/), varid)
4055         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation longitude')
4056         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_east')
4057
4058
4059 !     !-- elevation is ZELEV
4060         iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
4061         iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude')
4062         iret = nf90_put_att(ncid, varid, 'units', 'meters')
4063
4064
4065 !     !-- elevation is obs ZELEV
4066         iret = nf90_def_var(ncid2, "altitude", NF90_FLOAT, (/obsdim/), varid)
4067         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation altitude')
4068         iret = nf90_put_att(ncid2, varid, 'units', 'meters')
4069
4070
4071 !     !--  gage observation
4072 !       iret = nf90_def_var(ncid, "gages", NF90_FLOAT, (/stationdim/), varid)
4073 !       iret = nf90_put_att(ncid, varid, 'long_name', 'Stream Gage Location')
4074 !       iret = nf90_put_att(ncid, varid, 'units', 'none')
4075
4076 !-- parent index
4077         iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid)
4078         iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record')
4079
4080         iret = nf90_def_var(ncid2, "parent_index", NF90_INT, (/dimdataO/), varid)
4081         iret = nf90_put_att(ncid2, varid, 'long_name', 'index of the station for this record')
4082
4083      !-- prevChild
4084         iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid)
4085         iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station')
4086 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4087         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4088
4089         iret = nf90_def_var(ncid2, "prevChild", NF90_INT, (/dimdataO/), varid)
4090         iret = nf90_put_att(ncid2, varid, 'long_name', 'record number of the previous record for the same station')
4091 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4092         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4093
4094      !-- lastChild
4095         iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
4096         iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station')
4097 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4098         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4099
4100         iret = nf90_def_var(ncid2, "lastChild", NF90_INT, (/obsdim/), varid)
4101         iret = nf90_put_att(ncid2, varid, 'long_name', 'latest report for this station')
4102 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4103         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4104
4105 !     !- flow definition, var
4106
4107         if(UDMP_OPT .eq. 1) then
4108
4109            !! FLUXES to channel
4110            if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4111               nlst(did)%output_channelBucket_influx .eq. 2      ) then
4112               iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/dimdata/), varid)
4113               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
4114               if(nlst(did)%OVRTSWCRT .eq. 1) then              !123456789112345678921234567
4115                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing')
4116               else
4117                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff')
4118               end if
4119               iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/dimdata/), varid)
4120               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
4121               iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket')
4122            end if
4123
4124            !! Bucket influx
4125            if(nlst(did)%output_channelBucket_influx .eq. 2) then
4126               iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/dimdata/), varid)
4127               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
4128               iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket')
4129            end if
4130
4131            !! ACCUMULATIONS
4132            if(nlst(did)%output_channelBucket_influx .eq. 3) then
4133                  iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimdata/), varid)
4134                  iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
4135                  if(nlst(did)%OVRTSWCRT .eq. 1) then
4136                     iret = nf90_put_att(ncid,varid,'long_name', &
4137                                            'ACCUMULATED runoff from terrain routing')
4138                  else
4139                     iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land')
4140                  end if
4141               iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimdata/), varid)
4142               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
4143               iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from gw bucket')
4144            endif
4145         endif
4146
4147         iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/dimdata/), varid)
4148         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4149         iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow')
4150
4151         iret = nf90_def_var(ncid2, "streamflow", NF90_FLOAT, (/dimdataO/), varid)
4152         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
4153         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Flow')
4154
4155 #ifdef WRF_HYDRO_NUDGING
4156         iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/dimdata/), varid)
4157         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4158         iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration')
4159
4160         iret = nf90_def_var(ncid2, "nudge", NF90_FLOAT, (/dimdataO/), varid)
4161         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
4162         iret = nf90_put_att(ncid2, varid, 'long_name', 'Amount of stream flow alteration')
4163 #endif
4164
4165 !     !- flow definition, var
4166 !       iret = nf90_def_var(ncid, "pos_streamflow", NF90_FLOAT, (/dimdata/), varid)
4167 !       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4168 !       iret = nf90_put_att(ncid, varid, 'long_name', 'abs streamflow')
4169
4170 !     !- head definition, var
4171         iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/dimdata/), varid)
4172         iret = nf90_put_att(ncid, varid, 'units', 'meter')
4173         iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
4174
4175         iret = nf90_def_var(ncid2, "head", NF90_FLOAT, (/dimdataO/), varid)
4176         iret = nf90_put_att(ncid2, varid, 'units', 'meter')
4177         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Stage')
4178
4179 !     !- order definition, var
4180         iret = nf90_def_var(ncid, "order", NF90_INT, (/dimdata/), varid)
4181         iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order')
4182         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4183
4184         iret = nf90_def_var(ncid2, "order", NF90_INT, (/dimdataO/), varid)
4185         iret = nf90_put_att(ncid2, varid, 'long_name', 'Strahler Stream Order')
4186         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4187
4188      !-- station  id
4189      ! define character-position dimension for strings of max length 11
4190          iret = NF90_DEF_DIM(ncid, "id_len", 11, charid)
4191          TXDIMS(1) = charid   ! define char-string variable and position dimension first
4192          TXDIMS(2) = stationdim
4193          iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid)
4194          iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
4195
4196
4197          iret = NF90_DEF_DIM(ncid2, "id_len", 15, charidO)
4198          OTXDIMS(1) = charidO   ! define char-string variable and position dimension first
4199          OTXDIMS(2) = obsdim
4200          iret = nf90_def_var(ncid2, "station_id", NF90_CHAR, OTXDIMS, varid)
4201          iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation id')
4202
4203
4204 !     !- time definition, timeObs
4205          iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
4206          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
4207          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
4208
4209          iret = nf90_def_var(ncid2, "time", NF90_INT, (/timedim2/), varid)
4210          iret = nf90_put_att(ncid2, varid, 'units', sec_valid_date)
4211          iret = nf90_put_att(ncid2, varid, 'long_name', 'valid output time')
4212
4213          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4214          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
4215
4216          convention(1:32) = "Unidata Observation Dataset v1.0"
4217          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4218          iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
4219
4220          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
4221          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
4222          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
4223          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
4224          iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
4225          iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
4226          iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
4227          iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", order_to_write)
4228
4229          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
4230          iret = nf90_put_att(ncid2, NF90_GLOBAL, "cdm_datatype", "Station")
4231
4232          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_max", "90.0")
4233          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
4234          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_max", "180.0")
4235          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
4236
4237          iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
4238          iret = nf90_put_att(ncid2, NF90_GLOBAL, "station_dimension", "station")
4239          iret = nf90_put_att(ncid2, NF90_GLOBAL, "missing_value", -9E15)
4240          iret = nf90_put_att(ncid2, NF90_GLOBAL, "stream_order_output", order_to_write)
4241
4242          iret = nf90_enddef(ncid)
4243          iret = nf90_enddef(ncid2)
4244
4245         !-- write latitudes
4246          iret = nf90_inq_varid(ncid,"latitude", varid)
4247          iret = nf90_put_var(ncid, varid, chanlat, (/1/), (/nstations/))
4248
4249          iret = nf90_inq_varid(ncid2,"latitude", varid)
4250          iret = nf90_put_var(ncid2, varid, chanlatO, (/1/), (/nobs/))
4251
4252         !-- write longitudes
4253          iret = nf90_inq_varid(ncid,"longitude", varid)
4254          iret = nf90_put_var(ncid, varid, chanlon, (/1/), (/nstations/))
4255
4256          iret = nf90_inq_varid(ncid2,"longitude", varid)
4257          iret = nf90_put_var(ncid2, varid, chanlonO, (/1/), (/nobs/))
4258
4259         !-- write elevations
4260          iret = nf90_inq_varid(ncid,"altitude", varid)
4261          iret = nf90_put_var(ncid, varid, elevation, (/1/), (/nstations/))
4262
4263          iret = nf90_inq_varid(ncid2,"altitude", varid)
4264          iret = nf90_put_var(ncid2, varid, elevationO, (/1/), (/nobs/))
4265
4266       !-- write gage location
4267 !      iret = nf90_inq_varid(ncid,"gages", varid)
4268 !      iret = nf90_put_var(ncid, varid, STRMFRXSTPTS, (/1/), (/nstations/))
4269
4270         !-- write number_of_stations, OPTIONAL
4271       !!  iret = nf90_inq_varid(ncid,"number_stations", varid)
4272       !!  iret = nf90_put_var_int(ncid, varid, nstations)
4273
4274         !-- write station id's
4275          do i=1,nstations
4276           TSTART(1) = 1
4277           TSTART(2) = i
4278           TCOUNT(1) = TXLEN
4279           TCOUNT(2) = 1
4280           iret = nf90_inq_varid(ncid,"station_id", varid)
4281           iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT)
4282          enddo
4283
4284         !-- write observation id's
4285          do i=1, nobs
4286           OTSTART(1) = 1
4287           OTSTART(2) = i
4288           OTCOUNT(1) = OTXLEN
4289           OTCOUNT(2) = 1
4290           iret = nf90_inq_varid(ncid2,"station_id", varid)
4291           iret = nf90_put_var(ncid2, varid, stnameO(i), OTSTART, OTCOUNT)
4292          enddo
4293
4294      endif
4295
4296      output_count = output_count + 1
4297
4298      open (unit=55, &
4299 #ifndef NCEP_WCOSS
4300      file='frxst_pts_out.txt', &
4301 #endif
4302      status='unknown',position='append')
4303
4304      cnt=0
4305      do i=1,nlk
4306
4307        if(ORDER(i) .ge. order_to_write) then
4308          start_pos = (cnt+1)+(nstations*(output_count-1))
4309
4310          !!--time in seconds since startdate
4311           iret = nf90_inq_varid(ncid,"time", varid)
4312           iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
4313
4314          if(UDMP_OPT .eq. 1) then
4315             !! FLUXES to channel
4316              if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4317                 nlst(did)%output_channelBucket_influx .eq. 2      ) then
4318                 iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid)
4319                 iret = nf90_put_var(ncid, varid, qSfcLatRunoff(i), (/start_pos/))
4320
4321                 iret = nf90_inq_varid(ncid,"qBucket", varid)
4322                 iret = nf90_put_var(ncid, varid, qBucket(i), (/start_pos/))
4323              end if
4324
4325              !! FLUXES to bucket
4326              if(nlst(did)%output_channelBucket_influx .eq. 2) then
4327                 iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid)
4328                 iret = nf90_put_var(ncid, varid, qBtmVertRunoff(i), (/start_pos/))
4329              end if
4330
4331             !! ACCUMULATIONS
4332              if(nlst(did)%output_channelBucket_influx .eq. 3) then
4333                 iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid)
4334                 iret = nf90_put_var(ncid, varid, accSfcLatRunoff(i), (/start_pos/))
4335
4336                 iret = nf90_inq_varid(ncid,"accBucket", varid)
4337                 iret = nf90_put_var(ncid, varid, accBucket(i), (/start_pos/))
4338              end if
4339           endif
4340
4341          iret = nf90_inq_varid(ncid,"streamflow", varid)
4342          iret = nf90_put_var(ncid, varid, qlink(i,1), (/start_pos/))
4343
4344 #ifdef WRF_HYDRO_NUDGING
4345          iret = nf90_inq_varid(ncid,"nudge", varid)
4346          iret = nf90_put_var(ncid, varid, nudge(i), (/start_pos/))
4347 #endif
4348
4349 !        iret = nf90_inq_varid(ncid,"pos_streamflow", varid)
4350 !        iret = nf90_put_var(ncid, varid, abs(qlink(i,1), (/start_pos/)))
4351
4352          iret = nf90_inq_varid(ncid,"head", varid)
4353          iret = nf90_put_var(ncid, varid, hlink(i), (/start_pos/))
4354
4355          iret = nf90_inq_varid(ncid,"order", varid)
4356          iret = nf90_put_var(ncid, varid, ORDER(i), (/start_pos/))
4357
4358          !-- station index.. will repeat for every timesstep
4359          iret = nf90_inq_varid(ncid,"parent_index", varid)
4360          iret = nf90_put_var(ncid, varid, cnt, (/start_pos/))
4361
4362           !--record number of previous record for same station
4363 !obsolete format         prev_pos = cnt+(nstations*(output_count-1))
4364          prev_pos = cnt+(nobs*(output_count-2))
4365          if(output_count.ne.1) then !-- only write next set of records
4366            iret = nf90_inq_varid(ncid,"prevChild", varid)
4367            iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/))
4368          endif
4369          cnt=cnt+1  !--indices are 0 based
4370          rec_num_of_station(cnt) = start_pos-1  !-- save position for last child, 0-based!!
4371
4372
4373        endif
4374     enddo
4375 !    close(999)
4376
4377     !-- output  only observation points
4378     cnt=0
4379     do i=1,nlk
4380        if(channel_option .ne. 3) then
4381           ! jlm this verry repetitiuos, oh well.
4382           if(trim(gages(i)) .ne. trim(gageMiss)) then
4383
4384              start_posO = (cnt+1)+(nobs * (output_count-1))
4385              !Write frxst_pts to text file...
4386              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
4387 118          FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
4388              !write(55,118) seconds_since, date(1:10), date(12:19), &
4389
4390              write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), &
4391                   gages(i), chlon(i), chlat(i),                               &
4392                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
4393
4394              !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
4395              !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)
4396
4397              !!--time in seconds since startdate
4398              iret = nf90_inq_varid(ncid2,"time", varid)
4399              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
4400
4401              iret = nf90_inq_varid(ncid2,"streamflow", varid)
4402              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
4403
4404 #ifdef WRF_HYDRO_NUDGING
4405              iret = nf90_inq_varid(ncid2,"nudge", varid)
4406              iret = nf90_put_var(ncid2, varid, nudge(i), (/start_posO/))
4407 #endif
4408
4409              iret = nf90_inq_varid(ncid2,"head", varid)
4410              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
4411
4412              iret = nf90_inq_varid(ncid,"order", varid)
4413              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
4414
4415              !-- station index.. will repeat for every timesstep
4416              iret = nf90_inq_varid(ncid2,"parent_index", varid)
4417              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
4418
4419              !--record number of previous record for same station
4420              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
4421              prev_posO = cnt+(nobs*(output_count-2))
4422              if(output_count.ne.1) then !-- only write next set of records
4423                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
4424                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4425
4426                 !IF block to add -1 to last element of prevChild array to designate end of list...
4427                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
4428                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
4429                 !           else
4430                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4431                 !           endif
4432
4433              endif
4434              cnt=cnt+1  !--indices are 0 based
4435              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
4436           endif
4437
4438
4439        else !! channel options 3 below
4440
4441           if(STRMFRXSTPTS(i) .ne. -9999) then
4442              start_posO = (cnt+1)+(nobs * (output_count-1))
4443              !Write frxst_pts to text file...
4444              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
4445 117          FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
4446              !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), &
4447              !     qlink(i,1), qlink(i,1)*35.315,hlink(i)
4448              ! JLM: makes more sense to output the value in frxstpts incase they have meaning,
4449              ! as below, but I'm not going to make this change until I'm working with gridded
4450              ! streamflow again.
4451              write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), &
4452                   strmfrxstpts(i), chlon(i), chlat(i),                        &
4453                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
4454
4455              !!--time in seconds since startdate
4456              iret = nf90_inq_varid(ncid2,"time", varid)
4457              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
4458
4459              iret = nf90_inq_varid(ncid2,"streamflow", varid)
4460              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
4461
4462              iret = nf90_inq_varid(ncid2,"head", varid)
4463              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
4464
4465              iret = nf90_inq_varid(ncid,"order", varid)
4466              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
4467
4468              !-- station index.. will repeat for every timesstep
4469              iret = nf90_inq_varid(ncid2,"parent_index", varid)
4470              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
4471
4472              !--record number of previous record for same station
4473              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
4474              prev_posO = cnt+(nobs*(output_count-2))
4475              if(output_count.ne.1) then !-- only write next set of records
4476                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
4477                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4478
4479                 !IF block to add -1 to last element of prevChild array to designate end of list...
4480                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
4481                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
4482                 !           else
4483                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4484                 !           endif
4485
4486              endif
4487              cnt=cnt+1  !--indices are 0 based
4488              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
4489           endif
4490
4491        endif
4492
4493     enddo
4494     close(55)
4495
4496       !-- lastChild variable gives the record number of the most recent report for the station
4497       iret = nf90_inq_varid(ncid,"lastChild", varid)
4498       iret = nf90_put_var(ncid, varid, rec_num_of_station, (/1/), (/nstations/))
4499
4500       !-- lastChild variable gives the record number of the most recent report for the station
4501       iret = nf90_inq_varid(ncid2,"lastChild", varid)
4502       iret = nf90_put_var(ncid2, varid, rec_num_of_stationO, (/1/), (/nobs/))
4503
4504       iret = nf90_redef(ncid)
4505       date19(1:19) = "0000-00-00_00:00:00"
4506       date19(1:len_trim(date)) = date
4507       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
4508
4509       iret = nf90_redef(ncid2)
4510       iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
4511
4512       iret = nf90_enddef(ncid)
4513       iret = nf90_sync(ncid)
4514
4515       iret = nf90_enddef(ncid2)
4516       iret = nf90_sync(ncid2)
4517
4518       if (output_count == split_output_count) then
4519         output_count = 0
4520         iret = nf90_close(ncid)
4521         iret = nf90_close(ncid2)
4522      endif
4523
4524      if(allocated(chanlat))  deallocate(chanlat)
4525      if(allocated(chanlon))  deallocate(chanlon)
4526      if(allocated(elevation))  deallocate(elevation)
4527      if(allocated(station_id))  deallocate(station_id)
4528      if(allocated(lOrder))  deallocate(lOrder)
4529      if(allocated(rec_num_of_station))  deallocate(rec_num_of_station)
4530      if(allocated(stname))  deallocate(stname)
4531
4532      if(allocated(chanlatO))  deallocate(chanlatO)
4533      if(allocated(chanlonO))  deallocate(chanlonO)
4534      if(allocated(elevationO))  deallocate(elevationO)
4535      if(allocated(station_idO))  deallocate(station_idO)
4536      if(allocated(lOrderO))  deallocate(lOrderO)
4537      if(allocated(rec_num_of_stationO))  deallocate(rec_num_of_stationO)
4538      if(allocated(stnameO))  deallocate(stnameO)
4539 #ifdef HYDRO_D
4540      print *, "Exited Subroutine output_chrt"
4541 #endif
4542      close(16)
4543
4544 20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3)
4545
4546 end subroutine output_chrt_bak
4547
4548 #ifdef MPP_LAND
4549 !-- output the channel route in an IDV 'station' compatible format
4550    subroutine mpp_output_chrt(gnlinks,gnlinksl,map_l2g,igrid,                  &
4551         split_output_count, NLINKS, ORDER,                                     &
4552         startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch,              &
4553         K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, &
4554         lsmDt                                       &
4555 #ifdef WRF_HYDRO_NUDGING
4556         , nudge                                     &
4557 #endif
4558         , accSfcLatRunoff, accBucket                 &
4559         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff &
4560         ,        UDMP_OPT                            &
4561         )
4562
4563        USE module_mpp_land
4564
4565        implicit none
4566
4567 !!output the routing variables over just channel
4568      integer,                                  intent(in) :: igrid,K,channel_option,NLINKSL
4569      integer,                                  intent(in) :: split_output_count
4570      integer,                                  intent(in) :: NLINKS
4571      real, dimension(:),               intent(in) :: chlon,chlat
4572      real, dimension(:),                  intent(in) :: hlink,zelev
4573
4574      integer, dimension(:),               intent(in) :: ORDER
4575      integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
4576      character(len=15), dimension(:),     intent(inout) :: gages
4577      character(len=15),                   intent(in) :: gageMiss
4578      real,                                intent(in) :: lsmDt
4579
4580      real,                                     intent(in) :: dtrt_ch
4581      real, dimension(:,:),                intent(in) :: qlink
4582 #ifdef WRF_HYDRO_NUDGING
4583      real, dimension(:),                  intent(in) :: nudge
4584 #endif
4585
4586      integer, intent(in) :: UDMP_OPT
4587
4588      character(len=*),                         intent(in) :: startdate
4589      character(len=*),                         intent(in) :: date
4590
4591       integer  :: gnlinks, map_l2g(nlinks), order_to_write, gnlinksl
4592       real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev
4593 #ifdef WRF_HYDRO_NUDGING
4594       real, allocatable,dimension(:) :: g_nudge
4595 #endif
4596       integer, allocatable,dimension(:) :: g_order,g_STRMFRXSTPTS
4597       real,allocatable,dimension(:,:) :: g_qlink
4598       integer  :: gsize
4599       character(len=15),allocatable,dimension(:) :: g_gages
4600       real*8, dimension(:), intent(in) ::   accSfcLatRunoff,   accBucket
4601       real  , dimension(:), intent(in) ::     qSfcLatRunoff,     qBucket, qBtmVertRunoff
4602       real*8,allocatable,dimension(:)  :: g_accSfcLatRunoff, g_accBucket
4603       real  ,allocatable,dimension(:)  ::   g_qSfcLatRunoff,   g_qBucket, g_qBtmVertRunoff
4604
4605         gsize = gNLINKS
4606         if(gnlinksl .gt. gsize) gsize = gnlinksl
4607      if(my_id .eq. io_id ) then
4608         allocate(g_chlon(gsize  ))
4609         allocate(g_chlat(gsize  ))
4610         allocate(g_hlink(gsize  ))
4611         allocate(g_zelev(gsize  ))
4612         allocate(g_qlink(gsize  ,2))
4613 #ifdef WRF_HYDRO_NUDGING
4614         allocate(g_nudge(gsize))
4615 #endif
4616         allocate(g_order(gsize  ))
4617         allocate(g_STRMFRXSTPTS(gsize  ))
4618         allocate(g_gages(gsize))
4619
4620         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4621            nlst(did)%output_channelBucket_influx .eq. 2      ) then
4622            allocate(g_qSfcLatRunoff(  gsize ))
4623            allocate(g_qBucket(        gsize ))
4624         endif
4625
4626         if(nlst(did)%output_channelBucket_influx .eq. 2) &
4627              allocate(g_qBtmVertRunoff(  gsize ))
4628
4629         if(nlst(did)%output_channelBucket_influx .eq. 3) then
4630            allocate(g_accSfcLatRunoff(gsize ))
4631            allocate(g_accBucket(      gsize ))
4632         endif
4633
4634      else
4635
4636         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4637            nlst(did)%output_channelBucket_influx .eq. 2      ) then
4638            allocate(g_qSfcLatRunoff(  1))
4639            allocate(g_qBucket(        1))
4640         end if
4641
4642         if(nlst(did)%output_channelBucket_influx .eq. 2) &
4643              allocate(g_qBtmVertRunoff(  1))
4644
4645         if(nlst(did)%output_channelBucket_influx .eq. 3) then
4646            allocate(g_accSfcLatRunoff(1))
4647            allocate(g_accBucket(      1))
4648         end if
4649
4650         allocate(g_chlon(1))
4651         allocate(g_chlat(1))
4652         allocate(g_hlink(1))
4653         allocate(g_zelev(1))
4654         allocate(g_qlink(1,2))
4655 #ifdef WRF_HYDRO_NUDGING
4656         allocate(g_nudge(1))
4657 #endif
4658         allocate(g_order(1))
4659         allocate(g_STRMFRXSTPTS(1))
4660         allocate(g_gages(1))
4661      endif
4662
4663      call mpp_land_sync()
4664
4665      if(channel_option .eq. 1 .or. channel_option .eq. 2) then
4666         g_qlink = 0
4667         g_gages = gageMiss
4668         call ReachLS_write_io(qlink(:,1), g_qlink(:,1))
4669         call ReachLS_write_io(qlink(:,2), g_qlink(:,2))
4670 #ifdef WRF_HYDRO_NUDGING
4671         g_nudge=0
4672         call ReachLS_write_io(nudge,g_nudge)
4673 #endif
4674         call ReachLS_write_io(order, g_order)
4675         call ReachLS_write_io(chlon, g_chlon)
4676         call ReachLS_write_io(chlat, g_chlat)
4677         call ReachLS_write_io(zelev, g_zelev)
4678
4679         call ReachLS_write_io(gages, g_gages)
4680         call ReachLS_write_io(STRMFRXSTPTS, g_STRMFRXSTPTS)
4681         call ReachLS_write_io(hlink, g_hlink)
4682
4683         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4684            nlst(did)%output_channelBucket_influx .eq. 2      ) then
4685            call ReachLS_write_io(qSfcLatRunoff, g_qSfcLatRunoff)
4686            call ReachLS_write_io(qBucket, g_qBucket)
4687         end if
4688
4689         if(nlst(did)%output_channelBucket_influx .eq. 2) &
4690              call ReachLS_write_io(qBtmVertRunoff, g_qBtmVertRunoff)
4691
4692         if(nlst(did)%output_channelBucket_influx .eq. 3) then
4693            call ReachLS_write_io(accSfcLatRunoff, g_accSfcLatRunoff)
4694            call ReachLS_write_io(accBucket, g_accBucket)
4695         end if
4696
4697      else
4698         call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
4699         call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
4700         call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order)
4701         call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon)
4702         call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat)
4703         call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev)
4704         call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS)
4705         call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
4706      endif
4707
4708
4709      if(my_id .eq. IO_id) then
4710        call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER,                &
4711           startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K,     &
4712           g_STRMFRXSTPTS,order_to_write,gNLINKSL,channel_option, g_gages, gageMiss, &
4713           lsmDt                                                                     &
4714 #ifdef WRF_HYDRO_NUDGING
4715           , g_nudge                                     &
4716 #endif
4717           , g_accSfcLatRunoff, g_accBucket                   &
4718           , g_qSfcLatRunoff,   g_qBucket,   g_qBtmVertRunoff &
4719           , UDMP_OPT                                         &
4720           )
4721
4722     end if
4723      call mpp_land_sync()
4724     if(allocated(g_order)) deallocate(g_order)
4725     if(allocated(g_STRMFRXSTPTS)) deallocate(g_STRMFRXSTPTS)
4726     if(allocated(g_chlon)) deallocate(g_chlon)
4727     if(allocated(g_chlat)) deallocate(g_chlat)
4728     if(allocated(g_hlink)) deallocate(g_hlink)
4729     if(allocated(g_zelev)) deallocate(g_zelev)
4730     if(allocated(g_qlink)) deallocate(g_qlink)
4731     if(allocated(g_gages)) deallocate(g_gages)
4732 #ifdef WRF_HYDRO_NUDGING
4733     if(allocated(g_nudge)) deallocate(g_nudge)
4734 #endif
4735     if(allocated(g_qSfcLatRunoff))   deallocate(g_qSfcLatRunoff)
4736     if(allocated(g_qBucket))         deallocate(g_qBucket)
4737     if(allocated(g_qBtmVertRunoff))  deallocate(g_qBtmVertRunoff)
4738     if(allocated(g_accSfcLatRunoff)) deallocate(g_accSfcLatRunoff)
4739     if(allocated(g_accBucket))       deallocate(g_accBucket)
4740
4741 end subroutine mpp_output_chrt
4742
4743 !---------  lake netcdf output -----------------------------------------
4744 !-- output the ilake info an IDV 'station' compatible format -----------
4745    subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, &
4746         startdate, date, latlake, lonlake, elevlake, &
4747         qlakei,qlakeo, resht,dtrt_ch,K)
4748
4749    USE module_mpp_land
4750
4751 !!output the routing variables over just channel
4752      integer,                                  intent(in) :: igrid, K
4753      integer,                                  intent(in) :: split_output_count
4754      integer,                                  intent(in) :: NLAKES
4755      real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
4756      real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
4757      real,                                     intent(in) :: dtrt_ch
4758
4759      character(len=*),                         intent(in) :: startdate
4760      character(len=*),                         intent(in) :: date
4761      integer lake_index(nlakes)
4762
4763
4764      call write_lake_real(latlake,lake_index,nlakes)
4765      call write_lake_real(lonlake,lake_index,nlakes)
4766      call write_lake_real(elevlake,lake_index,nlakes)
4767      call write_lake_real(resht,lake_index,nlakes)
4768      call write_lake_real(qlakei,lake_index,nlakes)
4769      call write_lake_real(qlakeo,lake_index,nlakes)
4770      if(my_id.eq. IO_id) then
4771         call output_lakes(igrid, split_output_count, NLAKES, &
4772            startdate, date, latlake, lonlake, elevlake, &
4773            qlakei,qlakeo, resht,dtrt_ch,K)
4774      end if
4775      call mpp_land_sync()
4776      return
4777      end subroutine mpp_output_lakes
4778
4779    subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, &
4780         startdate, date, latlake, lonlake, elevlake, &
4781         qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM)
4782
4783    USE module_mpp_land
4784
4785 !!output the routing variables over just channel
4786      integer,                                  intent(in) :: igrid, K
4787      integer,                                  intent(in) :: split_output_count
4788      integer,                                  intent(in) :: NLAKES
4789      real, dimension(NLAKES),                  intent(inout) :: latlake,lonlake,elevlake,resht
4790      real, dimension(NLAKES),                  intent(inout) :: qlakei,qlakeo  !-- inflow and outflow of lake
4791      real,                                     intent(in) :: dtrt_ch
4792      integer(kind=int64), dimension(NLAKES),   intent(in) :: LAKEIDM     ! lake id
4793
4794      character(len=*),                         intent(in) :: startdate
4795      character(len=*),                         intent(in) :: date
4796      integer lake_index(nlakes)
4797
4798      call write_lake_real(latlake,lake_index,nlakes)
4799      call write_lake_real(lonlake,lake_index,nlakes)
4800      call write_lake_real(elevlake,lake_index,nlakes)
4801      call write_lake_real(resht,lake_index,nlakes)
4802      call write_lake_real(qlakei,lake_index,nlakes)
4803      call write_lake_real(qlakeo,lake_index,nlakes)
4804
4805      if(my_id.eq. IO_id) then
4806         call output_lakes2(igrid, split_output_count, NLAKES, &
4807            startdate, date, latlake, lonlake, elevlake, &
4808            qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM)
4809      end if
4810      call mpp_land_sync()
4811      return
4812      end subroutine mpp_output_lakes2
4813 #endif
4814
4815 !----------------------------------- lake netcdf output
4816 !-- output the ilake info an IDV 'station' compatible format
4817    subroutine output_lakes(igrid, split_output_count, NLAKES, &
4818         startdate, date, latlake, lonlake, elevlake, &
4819         qlakei,qlakeo, resht,dtrt_ch,K)
4820
4821 !!output the routing variables over just channel
4822      integer,                                  intent(in) :: igrid, K
4823      integer,                                  intent(in) :: split_output_count
4824      integer,                                  intent(in) :: NLAKES
4825      real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
4826      real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
4827      real,                                     intent(in) :: dtrt_ch
4828
4829      character(len=*),                         intent(in) :: startdate
4830      character(len=*),                         intent(in) :: date
4831
4832      integer, allocatable, DIMENSION(:)                   :: station_id
4833      integer, allocatable, DIMENSION(:)                   :: rec_num_of_lake
4834
4835      integer, save  :: output_count
4836      integer, save :: ncid
4837
4838      integer :: stationdim, dimdata, varid, charid, n
4839      integer :: iret,i, start_pos, prev_pos  !--
4840      integer :: previous_pos        !-- used for the station model
4841      character(len=256) :: output_flnm
4842      character(len=19)  :: date19, date19start
4843      character(len=34)  :: sec_since_date
4844      integer :: seconds_since,cnt
4845      character(len=32)  :: convention
4846      character(len=6),allocatable, DIMENSION(:)  :: stname
4847      integer :: timedim
4848      character(len=34) :: sec_valid_date
4849
4850     !--- all this for writing the station id string
4851      INTEGER   TDIMS, TXLEN
4852      PARAMETER (TDIMS=2)    ! number of TX dimensions
4853      PARAMETER (TXLEN = 6) ! length of example string
4854      INTEGER  TIMEID        ! record dimension id
4855      INTEGER  TXID          ! variable ID
4856      INTEGER  TXDIMS(TDIMS) ! variable shape
4857      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
4858
4859 !    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
4860 !    seconds_since = int(dtrt_ch)*output_count
4861      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
4862      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
4863                      //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
4864
4865
4866      allocate(station_id(NLAKES))
4867      allocate(rec_num_of_lake(NLAKES))
4868      allocate(stname(NLAKES))
4869
4870      if (output_count == 0) then
4871
4872 !-- have moved sec_since_date from above here..
4873       sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
4874                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
4875
4876       date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
4877                   //startdate(12:13)//':'//startdate(15:16)//':00'
4878
4879       write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
4880 #ifdef HYDRO_D
4881       print*, 'output_flnm = "'//trim(output_flnm)//'"'
4882 #endif
4883
4884       iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
4885       if (iret /= 0) then
4886          call hydro_stop("In output_lakes() - Problem nf90_create")
4887       endif
4888
4889       do i=1,NLAKES
4890          station_id(i) = i
4891          write(stname(i),'(I6)') i
4892       enddo
4893
4894       iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata)  !--for linked list approach
4895       iret = nf90_def_dim(ncid, "station", nlakes, stationdim)
4896       iret = nf90_def_dim(ncid, "time", 1, timedim)
4897
4898 !#ifndef HYDRO_REALTIME
4899       !- station location definition,  lat
4900       iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
4901       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake latitude')
4902       iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
4903
4904       !- station location definition,  long
4905       iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
4906       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake longitude')
4907       iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
4908
4909 !     !-- lake's phyical elevation
4910 !     iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
4911 !     iret = nf90_put_att(ncid, varid, 'long_name', 'Lake altitude')
4912 !     iret = nf90_put_att(ncid, varid, 'units', 'meters')
4913 !#endif
4914
4915      !-- parent index
4916 !     iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid)
4917 !     iret = nf90_put_att(ncid, varid, 'long_name', 'index of the lake for this record')
4918
4919      !-- prevChild
4920 !     iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid)
4921 !     iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same lake')
4922 !ywtmp      iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4923 !     iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4924
4925      !-- lastChild
4926 !     iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
4927 !     iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this lake')
4928 !ywtmp      iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4929 !     iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4930
4931 !     !- water surface elevation
4932       iret = nf90_def_var(ncid, "wse", NF90_FLOAT, (/dimdata/), varid)
4933       iret = nf90_put_att(ncid, varid, 'units', 'meters')
4934       iret = nf90_put_att(ncid, varid, 'long_name', 'Water Surface Elevation')
4935
4936 !     !- inflow to lake
4937       iret = nf90_def_var(ncid, "inflow", NF90_FLOAT, (/dimdata/), varid)
4938       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4939
4940 !     !- outflow to lake
4941       iret = nf90_def_var(ncid, "outflow", NF90_FLOAT, (/dimdata/), varid)
4942       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4943
4944      !-- station  id
4945      ! define character-position dimension for strings of max length 6
4946          iret = NF90_DEF_DIM(ncid, "id_len", 6, charid)
4947          TXDIMS(1) = charid   ! define char-string variable and position dimension first
4948          TXDIMS(2) = stationdim
4949          iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid)
4950          iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
4951
4952 !     !- time definition, timeObs
4953          iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
4954          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
4955          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
4956
4957 !       date19(1:19) = "0000-00-00_00:00:00"
4958 !       date19(1:len_trim(startdate)) = startdate
4959 !       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4960 !
4961         date19(1:19) = "0000-00-00_00:00:00"
4962         date19(1:len_trim(startdate)) = startdate
4963         convention(1:32) = "Unidata Observation Dataset v1.0"
4964         iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4965         iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
4966 !#ifndef HYDRO_REALTIME
4967         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
4968         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
4969         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
4970         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
4971 !#endif
4972         iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
4973         iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
4974 !!       iret = nf90_put_att(ncid, NF90_GLOBAL, "observation_dimension", "recNum")
4975 !!        iret = nf90_put_att(ncid, NF90_GLOBAL, "time_coordinate", "time_observation")
4976         iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
4977         iret = nf90_enddef(ncid)
4978
4979 !#ifndef HYDRO_REALTIME
4980         !-- write latitudes
4981         iret = nf90_inq_varid(ncid,"latitude", varid)
4982         iret = nf90_put_var(ncid, varid, LATLAKE, (/1/), (/NLAKES/))
4983
4984         !-- write longitudes
4985         iret = nf90_inq_varid(ncid,"longitude", varid)
4986         iret = nf90_put_var(ncid, varid, LONLAKE, (/1/), (/NLAKES/))
4987
4988         !-- write physical height of lake
4989 !       iret = nf90_inq_varid(ncid,"altitude", varid)
4990 !       iret = nf90_put_var(ncid, varid, elevlake, (/1/), (/NLAKES/))
4991 !#endif
4992
4993         !-- write station id's
4994          do i=1,nlakes
4995           TSTART(1) = 1
4996           TSTART(2) = i
4997           TCOUNT(1) = TXLEN
4998           TCOUNT(2) = 1
4999           iret = nf90_inq_varid(ncid,"station_id", varid)
5000           iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT)
5001          enddo
5002
5003      endif
5004
5005      iret = nf90_inq_varid(ncid,"time", varid)
5006      iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
5007
5008      output_count = output_count + 1
5009
5010      cnt=0
5011      do i=1,NLAKES
5012
5013          start_pos = (cnt+1)+(nlakes*(output_count-1))
5014
5015          !!--time in seconds since startdate
5016          iret = nf90_inq_varid(ncid,"time_observation", varid)
5017          iret = nf90_put_var(ncid, varid, seconds_since, (/start_pos/))
5018
5019          iret = nf90_inq_varid(ncid,"wse", varid)
5020          iret = nf90_put_var(ncid, varid, resht(i), (/start_pos/))
5021
5022          iret = nf90_inq_varid(ncid,"inflow", varid)
5023          iret = nf90_put_var(ncid, varid, qlakei(i), (/start_pos/))
5024
5025          iret = nf90_inq_varid(ncid,"outflow", varid)
5026          iret = nf90_put_var(ncid, varid, qlakeo(i), (/start_pos/))
5027
5028          !-- station index.. will repeat for every timesstep
5029 !        iret = nf90_inq_varid(ncid,"parent_index", varid)
5030 !        iret = nf90_put_var(ncid, varid, cnt, (/start_pos/))
5031
5032           !--record number of previous record for same station
5033 !        prev_pos = cnt+(nlakes*(output_count-1))
5034 !        if(output_count.ne.1) then !-- only write next set of records
5035 !          iret = nf90_inq_varid(ncid,"prevChild", varid)
5036 !          iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/))
5037 !        endif
5038
5039          cnt=cnt+1  !--indices are 0 based
5040          rec_num_of_lake(cnt) = start_pos-1  !-- save position for last child, 0-based!!
5041
5042     enddo
5043
5044       !-- lastChild variable gives the record number of the most recent report for the station
5045       iret = nf90_inq_varid(ncid,"lastChild", varid)
5046       iret = nf90_put_var(ncid, varid, rec_num_of_lake, (/1/), (/nlakes/))
5047
5048      !-- number of children reported for this station, OPTIONAL
5049      !--  iret = nf90_inq_varid(ncid,"numChildren", varid)
5050      !--  iret = nf90_put_var(ncid, varid, rec_num_of_lake, (/1/), (/nlakes/))
5051
5052     iret = nf90_redef(ncid)
5053     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
5054     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5055     iret = nf90_enddef(ncid)
5056
5057     iret = nf90_sync(ncid)
5058      if (output_count == split_output_count) then
5059         output_count = 0
5060         iret = nf90_close(ncid)
5061      endif
5062
5063      if(allocated(station_id)) deallocate(station_id)
5064      if(allocated(rec_num_of_lake)) deallocate(rec_num_of_lake)
5065      if(allocated(stname)) deallocate(stname)
5066 #ifdef HYDRO_D
5067      print *, "Exited Subroutine output_lakes"
5068 #endif
5069      close(16)
5070
5071  end subroutine output_lakes
5072
5073 !----------------------------------- lake netcdf output
5074 !-- output the lake as regular netcdf file format for better performance than point netcdf file.
5075    subroutine output_lakes2(igrid, split_output_count, NLAKES, &
5076         startdate, date, latlake, lonlake, elevlake, &
5077         qlakei,qlakeo, resht,dtrt_ch,K,LAKEIDM)
5078
5079 !!output the routing variables over just channel
5080      integer,                                  intent(in) :: igrid, K
5081      integer,                                  intent(in) :: split_output_count
5082      integer,                                  intent(in) :: NLAKES
5083      real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
5084      real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
5085      integer(kind=int64), dimension(NLAKES),       intent(in) :: LAKEIDM        !-- LAKE ID
5086      real,                                     intent(in) :: dtrt_ch
5087
5088      character(len=*),                         intent(in) :: startdate
5089      character(len=*),                         intent(in) :: date
5090
5091
5092      integer, save  :: output_count
5093      integer, save :: ncid
5094
5095      integer :: stationdim, varid,  n
5096      integer :: iret,i    !--
5097      character(len=256) :: output_flnm
5098      character(len=19)  :: date19, date19start
5099      character(len=32)  :: convention
5100      integer :: timedim
5101      integer :: seconds_since
5102      character(len=34) :: sec_valid_date
5103      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
5104                          //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
5105
5106      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
5107
5108      if (output_count == 0) then
5109
5110       date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
5111                   //startdate(12:13)//':'//startdate(15:16)//':00'
5112
5113       write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
5114 #ifdef HYDRO_D
5115       print*, 'output_flnm = "'//trim(output_flnm)//'"'
5116 #endif
5117
5118       iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5119       if (iret /= 0) then
5120          call hydro_stop("In output_lakes() - Problem nf90_create")
5121       endif
5122
5123       iret = nf90_def_dim(ncid, "station", nlakes, stationdim)
5124
5125       iret = nf90_def_dim(ncid, "time", 1, timedim)
5126
5127 !#ifndef HYDRO_REALTIME
5128       !- station location definition,  lat
5129       iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
5130       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake latitude')
5131       iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
5132 !#endif
5133
5134       !- station location definition,  LAKEIDM
5135       iret = nf90_def_var(ncid, "lake_id", NF90_INT, (/stationdim/), varid)
5136       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake COMMON ID')
5137
5138 !#ifndef HYDRO_REALTIME
5139       !- station location definition,  long
5140       iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
5141       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake longitude')
5142       iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
5143
5144 !     !-- lake's phyical elevation
5145 !     iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
5146 !     iret = nf90_put_att(ncid, varid, 'long_name', 'Lake altitude')
5147 !     iret = nf90_put_att(ncid, varid, 'units', 'meters')
5148 !#endif
5149
5150 !     !- water surface elevation
5151       iret = nf90_def_var(ncid, "wse", NF90_FLOAT, (/stationdim/), varid)
5152       iret = nf90_put_att(ncid, varid, 'units', 'meters')
5153       iret = nf90_put_att(ncid, varid, 'long_name', 'Water Surface Elevation')
5154
5155 !     !- inflow to lake
5156       iret = nf90_def_var(ncid, "inflow", NF90_FLOAT, (/stationdim/), varid)
5157       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
5158
5159 !     !- outflow to lake
5160       iret = nf90_def_var(ncid, "outflow", NF90_FLOAT, (/stationdim/), varid)
5161       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
5162
5163       ! Time variable
5164       iret = nf90_def_var(ncid, "time", NF90_INT, (/timeDim/), varid)
5165       iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
5166       iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
5167
5168         date19(1:19) = "0000-00-00_00:00:00"
5169         date19(1:len_trim(startdate)) = startdate
5170 !#ifndef HYDRO_REALTIME
5171         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
5172         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
5173         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
5174         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
5175 !#endif
5176         iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5177         iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
5178         iret = nf90_enddef(ncid)
5179
5180         iret = nf90_inq_varid(ncid,"time", varid)
5181         iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
5182
5183 !#ifndef HYDRO_REALTIME
5184         !-- write latitudes
5185         iret = nf90_inq_varid(ncid,"latitude", varid)
5186         iret = nf90_put_var(ncid, varid, LATLAKE, (/1/), (/NLAKES/))
5187
5188         !-- write longitudes
5189         iret = nf90_inq_varid(ncid,"longitude", varid)
5190         iret = nf90_put_var(ncid, varid, LONLAKE, (/1/), (/NLAKES/))
5191
5192         !-- write physical height of lake
5193 !       iret = nf90_inq_varid(ncid,"altitude", varid)
5194 !       iret = nf90_put_var(ncid, varid, elevlake, (/1/), (/NLAKES/))
5195 !#endif
5196
5197         !-- write elevation  of lake
5198         iret = nf90_inq_varid(ncid,"wse", varid)
5199         iret = nf90_put_var(ncid, varid, resht, (/1/), (/NLAKES/))
5200
5201         !-- write elevation  of inflow
5202         iret = nf90_inq_varid(ncid,"inflow", varid)
5203         iret = nf90_put_var(ncid, varid, qlakei, (/1/), (/NLAKES/))
5204
5205         !-- write elevation  of inflow
5206         iret = nf90_inq_varid(ncid,"outflow", varid)
5207         iret = nf90_put_var(ncid, varid, qlakeo, (/1/), (/NLAKES/))
5208
5209         !-- write lake id
5210         iret = nf90_inq_varid(ncid,"lake_id", varid)
5211         iret = nf90_put_var(ncid, varid, LAKEIDM, (/1/), (/NLAKES/))
5212
5213      endif
5214
5215      output_count = output_count + 1
5216
5217     iret = nf90_redef(ncid)
5218     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5219     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
5220     iret = nf90_enddef(ncid)
5221
5222     iret = nf90_sync(ncid)
5223      if (output_count == split_output_count) then
5224         output_count = 0
5225         iret = nf90_close(ncid)
5226      endif
5227
5228  end subroutine output_lakes2
5229 !----------------------------------- lake netcdf output
5230
5231 #ifdef MPP_LAND
5232
5233 !-- output the channel route in an IDV 'grid' compatible format
5234    subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
5235         NLINKS,CH_NETLNK_in, startdate, date, &
5236         qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt )
5237
5238    USE module_mpp_land
5239
5240      implicit none
5241      integer g_ixrt,g_jxrt
5242      integer,                                  intent(in) :: igrid
5243      integer,                                  intent(in) :: split_output_count
5244      integer,                                  intent(in) :: NLINKS,ixrt,jxrt
5245      real,                                     intent(in) :: dt
5246      real, dimension(:,:),                intent(in) :: qlink
5247      integer(kind=int64), dimension(IXRT,JXRT),            intent(in) :: CH_NETLNK_in
5248      character(len=*),          intent(in)     :: geo_finegrid_flnm
5249      character(len=*),                         intent(in) :: startdate
5250      character(len=*),                         intent(in) :: date
5251
5252      integer::  gnlinks , map_l2g(nlinks)
5253
5254      integer(kind=int64), allocatable,dimension(:,:)         :: CH_NETLNK
5255      real, allocatable,dimension(:,:)                :: g_qlink
5256
5257      if(my_id .eq. io_id) then
5258         allocate(CH_NETLNK(g_IXRT,g_JXRT))
5259         allocate(g_qlink(gNLINKS,2) )
5260      else
5261         allocate(CH_NETLNK(1,1))
5262         allocate(g_qlink(1,2) )
5263      endif
5264
5265      call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
5266      call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
5267
5268      call write_IO_rt_int8(CH_NETLNK_in, CH_NETLNK)
5269
5270     if(my_id.eq.IO_id) then
5271         call  output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, &
5272            GNLINKS, CH_NETLNK, startdate, date, &
5273            g_qlink, dt, geo_finegrid_flnm)
5274     endif
5275
5276      if(allocated(g_qlink)) deallocate(g_qlink)
5277      if(allocated(CH_NETLNK)) deallocate(CH_NETLNK)
5278      return
5279      end subroutine mpp_output_chrtgrd
5280 #endif
5281
5282 !-- output the channel route in an IDV 'grid' compatible format
5283    subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
5284         NLINKS, CH_NETLNK, startdate, date, &
5285         qlink, dt, geo_finegrid_flnm)
5286
5287      integer,                                  intent(in) :: igrid
5288      integer,                                  intent(in) :: split_output_count
5289      integer,                                  intent(in) :: NLINKS,ixrt,jxrt
5290      real,                                     intent(in) :: dt
5291      real, dimension(:,:),                intent(in) :: qlink
5292      integer(kind=int64), dimension(IXRT,JXRT), intent(in) :: CH_NETLNK
5293      character(len=*),          intent(in)     :: geo_finegrid_flnm
5294      character(len=*),                         intent(in) :: startdate
5295      character(len=*),                         intent(in) :: date
5296      character(len=32)  :: convention
5297      integer,save  :: output_count
5298      integer, save :: ncid,ncstatic
5299      real, dimension(IXRT,JXRT)          :: tmpflow
5300      real, dimension(IXRT)            :: xcoord
5301      real, dimension(JXRT)            :: ycoord
5302      real                                :: long_cm,lat_po,fe,fn
5303      real, dimension(2)                  :: sp
5304
5305     integer :: varid, n
5306     integer :: jxlatdim,ixlondim,timedim !-- dimension ids
5307     integer :: timedim2
5308     character(len=34) :: sec_valid_date
5309
5310     integer :: iret,i,j
5311     character(len=256) :: output_flnm
5312     character(len=19)  :: date19
5313     character(len=34)  :: sec_since_date
5314
5315
5316     integer :: seconds_since
5317
5318     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
5319     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
5320                  //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
5321
5322
5323       tmpflow = -9E15
5324
5325
5326         write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
5327 #ifdef HYDRO_D
5328         print*, 'output_flnm = "'//trim(output_flnm)//'"'
5329 #endif
5330
5331
5332 !--- define dimension
5333         iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5334         if (iret /= 0) then
5335            call hydro_stop("In output_chrtgrd() - Problem nf90_create")
5336         endif
5337
5338         iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, timedim)
5339         iret = nf90_def_dim(ncid, "x", ixrt, ixlondim)
5340         iret = nf90_def_dim(ncid, "y", jxrt, jxlatdim)
5341
5342 !--- define variables
5343 !     !- time definition, timeObs
5344
5345        !- x-coordinate in cartesian system
5346 !yw         iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/ixlondim/), varid)
5347 !yw         iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
5348 !yw         iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
5349 !yw         iret = nf90_put_att(ncid, varid, 'units', 'Meter')
5350
5351        !- y-coordinate in cartesian ssystem
5352 !yw         iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/jxlatdim/), varid)
5353 !yw         iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
5354 !yw         iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
5355 !yw         iret = nf90_put_att(ncid, varid, 'units', 'Meter')
5356
5357 !     !- flow definition, var
5358         iret = nf90_def_var(ncid, "streamflow", NF90_REAL, (/ixlondim,jxlatdim,timedim/), varid)
5359         iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
5360         iret = nf90_put_att(ncid, varid, 'long_name', 'water flow rate')
5361         iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
5362         iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
5363         iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
5364         iret = nf90_def_var(ncid, "index", NF90_INT, (/ixlondim,jxlatdim/), varid)
5365         iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
5366         iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
5367         iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
5368
5369
5370 !-- place prjection information
5371
5372
5373       date19(1:19) = "0000-00-00_00:00:00"
5374       date19(1:len_trim(startdate)) = startdate
5375       convention(1:32) = "CF-1.0"
5376       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
5377       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
5378       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5379       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
5380       iret = nf90_enddef(ncid)
5381
5382       iret = nf90_inq_varid(ncid,"time", varid)
5383       iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
5384
5385 !!-- write latitude and longitude locations
5386
5387 !DJG inv    do j=jxrt,1,-1
5388     do j=1,jxrt
5389      do i=1,ixrt
5390        if(CH_NETLNK(i,j).GE.0) then
5391          tmpflow(i,j) = qlink(CH_NETLNK(i,j),1)
5392        else
5393          tmpflow(i,j) = -9E15
5394        endif
5395      enddo
5396     enddo
5397
5398 !!time in seconds since startdate
5399     iret = nf90_inq_varid(ncid,"index", varid)
5400     iret = nf90_put_var(ncid, varid, CH_NETLNK, (/1,1/), (/ixrt,jxrt/))
5401
5402     iret = nf90_inq_varid(ncid,"streamflow", varid)
5403     iret = nf90_put_var(ncid, varid, tmpflow, (/1,1,1/), (/ixrt,jxrt,1/))
5404
5405     iret = nf90_close(ncid)
5406
5407
5408
5409  end subroutine output_chrtgrd
5410
5411
5412  subroutine read_chan_forcing( &
5413        indir,olddate,startdate,hgrid,&
5414        ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT)
5415 ! This subrouting is going to read channel forcing for
5416 !  the old, channel-only simulations (ie when CHANRTSWCRT = 2)
5417 !  forced by RTOUT_DOMAIN files.
5418
5419    implicit none
5420    ! in variable
5421    character(len=*) :: olddate,hgrid,indir,startdate
5422    character(len=256) :: filename
5423    integer :: ixrt,jxrt
5424    real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT
5425    ! tmp variable
5426    character(len=256) :: inflnm, product
5427    integer  :: i,j,mmflag
5428    character(len=256) :: units
5429    integer :: ierr
5430    integer :: ncid
5431
5432
5433 !DJG Create filename...
5434         inflnm = trim(indir)//"/"//&
5435              olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
5436              olddate(15:16)//".RTOUT_DOMAIN"//hgrid
5437 #ifdef HYDRO_D
5438         print *, "Channel forcing file...",inflnm
5439 #endif
5440
5441
5442 !DJG Open NetCDF file...
5443     ierr = nf90_open(inflnm, NF90_NOWRITE, ncid)
5444     if (ierr /= 0) then
5445        write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm)
5446        call hydro_stop("In read_chan_forcing() - Problem opening netcdf file")
5447     endif
5448
5449 !DJG read data...
5450     call get_2d_netcdf("QSTRMVOLRT",  ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr)
5451 !DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
5452 !DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
5453
5454     ierr = nf90_close(ncid)
5455
5456  end subroutine read_chan_forcing
5457
5458
5459
5460  subroutine get2d_int(var_name,out_buff,ix,jx,fileName, fatalErr)
5461     implicit none
5462     integer :: iret,varid,ncid,ix,jx
5463     integer out_buff(ix,jx)
5464     character(len=*), intent(in) :: var_name
5465     character(len=*), intent(in) :: fileName
5466     logical, optional, intent(in) :: fatalErr
5467     logical :: fatalErr_local
5468     character(len=256) :: errMsg
5469
5470     fatalErr_local = .false.
5471     if(present(fatalErr)) fatalErr_local=fatalErr
5472
5473     iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid)
5474     if (iret .ne. 0) then
5475        errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName)
5476        print*, trim(errMsg)
5477        if(fatalErr_local) call hydro_stop(trim(errMsg))
5478     endif
5479
5480     iret = nf90_inq_varid(ncid,trim(var_name),  varid)
5481     if(iret .ne. 0) then
5482        errMsg = "get2d_int: failed to find the variable: " // &
5483                  trim(var_name) // ' in ' // trim(fileName)
5484        print*, trim(errMsg)
5485        if(fatalErr_local) call hydro_stop(errMsg)
5486     endif
5487
5488     iret = nf90_get_var(ncid, varid, out_buff)
5489     if(iret .ne. 0) then
5490        errMsg = "get2d_int: failed to read the variable: " // &
5491                 trim(var_name) // " in " //trim(fileName)
5492        print*,trim(errMsg)
5493        if(fatalErr_local) call hydro_stop(trim(errMsg))
5494     endif
5495
5496     iret = nf90_close(ncid)
5497     if(iret .ne. 0) then
5498        errMsg = "get2d_int: failed to close the file: " // &
5499                 trim(fileName)
5500        print*,trim(errMsg)
5501        if(fatalErr_local) call hydro_stop(trim(errMsg))
5502     endif
5503
5504     return
5505   end subroutine get2d_int
5506
5507     subroutine get2d_int8(var_name,out_buff,ix,jx,fileName, fatalErr)
5508         implicit none
5509         integer :: iret,varid,ncid,ix,jx
5510         integer(kind=int64) out_buff(ix,jx)
5511         character(len=*), intent(in) :: var_name
5512         character(len=*), intent(in) :: fileName
5513         logical, optional, intent(in) :: fatalErr
5514         logical :: fatalErr_local
5515         character(len=256) :: errMsg
5516
5517         fatalErr_local = .false.
5518         if(present(fatalErr)) fatalErr_local=fatalErr
5519
5520         iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid)
5521         if (iret .ne. 0) then
5522             errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName)
5523             print*, trim(errMsg)
5524             if(fatalErr_local) call hydro_stop(trim(errMsg))
5525         endif
5526
5527         iret = nf90_inq_varid(ncid,trim(var_name),  varid)
5528         if(iret .ne. 0) then
5529             errMsg = "get2d_int: failed to find the variable: " // &
5530                     trim(var_name) // ' in ' // trim(fileName)
5531             print*, trim(errMsg)
5532             if(fatalErr_local) call hydro_stop(errMsg)
5533         endif
5534
5535         iret = nf90_get_var(ncid, varid, out_buff)
5536         if(iret .ne. 0) then
5537             errMsg = "get2d_int: failed to read the variable: " // &
5538                     trim(var_name) // " in " //trim(fileName)
5539             print*,trim(errMsg)
5540             if(fatalErr_local) call hydro_stop(trim(errMsg))
5541         endif
5542
5543         iret = nf90_close(ncid)
5544         if(iret .ne. 0) then
5545             errMsg = "get2d_int: failed to close the file: " // &
5546                     trim(fileName)
5547             print*,trim(errMsg)
5548             if(fatalErr_local) call hydro_stop(trim(errMsg))
5549         endif
5550
5551         return
5552     end subroutine get2d_int8
5553
5554 #ifdef MPP_LAND
5555       SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, &
5556             route_chan_f,route_link_f, &
5557             route_direction_f, NLINKS, &
5558             CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT,NLAKES)
5559
5560          USE module_mpp_land
5561
5562          implicit none
5563         INTEGER                                      :: channel_option, did
5564         INTEGER                                      :: g_IXRT,g_JXRT
5565         INTEGER, INTENT(INOUT)                       :: NLINKS, GNLINKS,NLINKSL
5566         INTEGER, INTENT(IN)                          :: IXRT,JXRT
5567         INTEGER                                      :: CHNID,cnt
5568         INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT   !- binary channel mask
5569         INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK  !- each node gets unique id
5570         INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK  !- each node gets unique id based on global domain
5571         ! INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK  ! temp array
5572         INTEGER, allocatable,DIMENSION(:,:) :: g_CH_NETLNK  ! temp array
5573         INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION  !- flow direction
5574         INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT
5575         REAL, DIMENSION(IXRT,JXRT)                   :: LAT, LON
5576         INTEGER, INTENT(IN)                          :: UDMP_OPT
5577         integer:: i,j, NLAKES
5578
5579         CHARACTER(len=*)       :: route_chan_f, route_link_f,route_direction_f
5580         CHARACTER(len=*)       :: geo_finegrid_flnm
5581 !       CHARACTER(len=*)       :: geo_finegrid_flnm
5582
5583 !       integer, allocatable, dimension(:) :: tmp_int
5584         integer :: ywcount
5585
5586
5587
5588         if(my_id .eq. IO_id) then
5589            allocate(g_CH_NETLNK(g_IXRT,g_JXRT))
5590            g_CH_NETLNK = -9999
5591            CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, &
5592               route_direction_f, GNLINKS, &
5593               g_CH_NETLNK, channel_option,geo_finegrid_flnm,NLINKSL, UDMP_OPT,nlakes)
5594            call get_NLINKSL(NLINKSL, channel_option, route_link_f)
5595         else
5596            allocate(g_CH_NETLNK(1,1))
5597         endif
5598
5599         call mpp_land_bcast_int1(GNLINKS)
5600         call mpp_land_bcast_int1(NLINKSL)
5601         call mpp_land_bcast_int1(NLAKES)
5602
5603
5604         call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt)
5605         if(allocated(g_CH_NETLNK)) deallocate(g_CH_NETLNK)
5606         ywcount = 0
5607         CH_NETLNK = -9999
5608         do j = 1, jxrt
5609            do i = 1, ixrt
5610                   if(GCH_NETLNK(i,j) .gt. 0) then
5611                        ywcount = ywcount + 1
5612                        CH_NETLNK(i,j) = ywcount
5613                   endif
5614            end do
5615         end do
5616         NLINKS = ywcount
5617
5618
5619 !ywcheck
5620 !        CH_NETLNK = GCH_NETLNK
5621
5622
5623         allocate(rt_domain(did)%map_l2g(NLINKS))
5624
5625         rt_domain(did)%map_l2g = -1
5626         do j = 1, jxrt
5627            do i = 1, ixrt
5628               if(CH_NETLNK(i,j) .gt. 0) then
5629                   rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j)
5630               endif
5631            end do
5632         end do
5633
5634         call mpp_chrt_nlinks_collect(NLINKS)
5635         return
5636
5637       end SUBROUTINE MPP_READ_ROUTEDIM
5638
5639
5640
5641
5642 #endif
5643
5644       SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo_f,    &
5645             route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC,IMPERVFRAC, &
5646             channel_option, UDMP_OPT, imperv_adj)
5647
5648
5649         INTEGER, INTENT(IN) :: IXRT,JXRT
5650         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC
5651         INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT
5652         INTEGER(kind=int64), INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_LNKRT
5653 !Dummy inverted grids
5654         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC
5655         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC
5656         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: IMPERVFRAC
5657
5658         integer         :: I,J, iret, jj, channel_option, UDMP_OPT, imperv_adj
5659         CHARACTER(len=256)        :: var_name
5660         CHARACTER(len=*  )       :: route_topo_f
5661         CHARACTER(len=*  )       :: route_chan_f
5662         CHARACTER(len=*  )       :: geo_finegrid_flnm
5663
5664         var_name = "TOPOGRAPHY"
5665
5666         call nreadRT2d_real(var_name,ELRT,ixrt,jxrt,&
5667                      trim(geo_finegrid_flnm))
5668
5669      IF(channel_option .ne. 3 .and. UDMP_OPT .ne. 1) then  !get maxnodes and links from grid
5670         var_name = "LINKID"
5671         call nreadRT2d_int8(var_name,CH_LNKRT,ixrt,jxrt,&
5672                trim(geo_finegrid_flnm), fatalErr=.true.)
5673      endif
5674
5675
5676
5677 #ifdef HYDRO_D
5678         write(6,*) "read linkid grid CH_LNKRT ",var_name
5679 #endif
5680
5681 !!!DY to be fixed ... 6/27/08
5682 !        var_name = "BED_ELEVATION"
5683 !        iret = get2d_real(var_name,ELRT,ixrt,jxrt,&
5684 !                     trim(geo_finegrid_flnm))
5685
5686         var_name = "CHANNELGRID"
5687         call nreadRT2d_int(var_name,CH_NETRT,ixrt,jxrt,&
5688                trim(geo_finegrid_flnm))
5689
5690 #ifdef HYDRO_D
5691         write(6,*) "read ",var_name
5692 #endif
5693
5694         var_name = "LKSATFAC"
5695         LKSATFAC = -9999.9
5696         call nreadRT2d_real(var_name,LKSATFAC,ixrt,jxrt,&
5697                trim(geo_finegrid_flnm))
5698
5699 #ifdef HYDRO_D
5700         write(6,*) "read ",var_name
5701 #endif
5702
5703            where (LKSATFAC == -9999.9) LKSATFAC = 1000.0  !specify LKSAFAC if no term avail...
5704
5705
5706 !1.12.2012...Read in routing calibration factors...
5707         var_name = "RETDEPRTFAC"
5708         call nreadRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,&
5709                      trim(geo_finegrid_flnm))
5710         where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0  ! reset grid to = 1.0 if non-valid value exists
5711
5712         var_name = "OVROUGHRTFAC"
5713         call nreadRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,&
5714                      trim(geo_finegrid_flnm))
5715         where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists
5716
5717 !Read in new optional impervious layer
5718         var_name = "IMPERVFRAC"
5719         IMPERVFRAC = -9999.9
5720         if (imperv_adj > 0) then
5721           call nreadRT2d_real(var_name,IMPERVFRAC,ixrt,jxrt,&
5722                      trim(geo_finegrid_flnm), fatalErr=.true.)
5723           where (IMPERVFRAC < 0.) IMPERVFRAC = 0.0  ! reset grid to = 0.0 if non-valid value exists
5724         else
5725           IMPERVFRAC = 0.0
5726         endif
5727
5728 #ifdef HYDRO_D
5729         write(6,*) "finish READ_ROUTING_seq"
5730 #endif
5731
5732         return
5733
5734 !DJG -----------------------------------------------------
5735    END SUBROUTINE READ_ROUTING_seq
5736
5737 !DJG _____________________________
5738    subroutine output_lsm(outFile,did)
5739
5740
5741    implicit none
5742
5743    integer did
5744
5745    character(len=*) outFile
5746
5747     integer :: ncid,irt, dimid_ix, dimid_jx,  &
5748              dimid_ixrt, dimid_jxrt, varid, &
5749              dimid_links, dimid_basns, dimid_soil
5750     integer :: iret, n
5751     character(len=2) tmpStr
5752
5753
5754
5755 #ifdef MPP_LAND
5756      if(IO_id.eq.my_id) &
5757 #endif
5758
5759        iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5760
5761 #ifdef MPP_LAND
5762        call mpp_land_bcast_int1(iret)
5763 #endif
5764
5765        if (iret /= 0) then
5766           call hydro_stop("In output_lsm() - Problem nf90_create")
5767        endif
5768
5769
5770 #ifdef MPP_LAND
5771      if(IO_id.eq.my_id) then
5772 #endif
5773 #ifdef HYDRO_D
5774          write(6,*) "output file ", outFile
5775 #endif
5776 ! define dimension for variables
5777           iret = nf90_def_dim(ncid, "depth", nlst(did)%nsoil, dimid_soil)  !-- 3-d soils
5778 #ifdef MPP_LAND
5779           iret = nf90_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
5780           iret = nf90_def_dim(ncid, "iy", global_ny, dimid_jx)
5781 #else
5782           iret = nf90_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
5783           iret = nf90_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
5784 #endif
5785
5786 !define variables
5787           do n = 1, nlst(did)%nsoil
5788              if( n .lt. 10) then
5789                 write(tmpStr, '(i1)') n
5790              else
5791                 write(tmpStr, '(i2)') n
5792              endif
5793              iret = nf90_def_var(ncid, "stc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5794              iret = nf90_def_var(ncid, "smc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5795              iret = nf90_def_var(ncid, "sh2ox"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5796           end do
5797
5798           !iret = nf90_def_var(ncid, "smcmax1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5799           !iret = nf90_def_var(ncid, "smcref1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5800           !iret = nf90_def_var(ncid, "smcwlt1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5801           iret = nf90_def_var(ncid, "infxsrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5802           iret = nf90_def_var(ncid, "sfcheadrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5803
5804           iret = nf90_enddef(ncid)
5805
5806 #ifdef MPP_LAND
5807     endif
5808 #endif
5809         call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc")
5810         call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc")
5811         call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
5812         !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
5813         !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
5814         !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  )
5815         call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  )
5816         call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt" )
5817
5818
5819 #ifdef MPP_LAND
5820      if(IO_id.eq.my_id) then
5821 #endif
5822
5823         iret = nf90_close(ncid)
5824 #ifdef HYDRO_D
5825         write(6,*) "finish writing outFile : ", outFile
5826 #endif
5827
5828 #ifdef MPP_LAND
5829     endif
5830 #endif
5831
5832         return
5833         end subroutine output_lsm
5834
5835
5836    subroutine RESTART_OUT_nc(outFile,did)
5837
5838
5839    implicit none
5840
5841    integer did
5842    integer :: n
5843    character(len=2) :: tmpStr
5844    character(len=*) outFile
5845
5846     integer :: ncid,irt, dimid_ix, dimid_jx,  &
5847              dimid_ixrt, dimid_jxrt, varid, &
5848              dimid_links, dimid_basns, dimid_soil, dimid_lakes
5849     integer :: iret
5850
5851
5852 #ifdef MPP_LAND
5853      if(IO_id.eq.my_id) &
5854 #endif
5855
5856        iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5857
5858 #ifdef MPP_LAND
5859        call mpp_land_bcast_int1(iret)
5860 #endif
5861
5862        if (iret /= 0) then
5863           call hydro_stop("In RESTART_OUT_nc() - Problem nf90_create")
5864        endif
5865
5866 #ifdef MPP_LAND
5867      if(IO_id.eq.my_id) then
5868 #endif
5869
5870    if( nlst(did)%channel_only       .eq. 0 .and. &
5871        nlst(did)%channelBucket_only .eq. 0         ) then
5872
5873 ! define dimension for variables
5874           iret = nf90_def_dim(ncid, "depth", nlst(did)%nsoil, dimid_soil)  !-- 3-d soils
5875 #ifdef MPP_LAND
5876           iret = nf90_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
5877           iret = nf90_def_dim(ncid, "iy", global_ny, dimid_jx)
5878           iret = nf90_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt)  !-- make a decimated grid
5879           iret = nf90_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt)
5880 #else
5881           iret = nf90_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
5882           iret = nf90_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
5883           iret = nf90_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt)  !-- make a decimated grid
5884           iret = nf90_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt)
5885 #endif
5886
5887        endif ! neither channel_only nor channelBucket_only
5888
5889        if(nlst(did)%channel_option .eq. 3) then
5890           iret = nf90_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links)
5891        else
5892           iret = nf90_def_dim(ncid, "links", rt_domain(did)%gnlinksl, dimid_links)
5893        endif
5894        iret = nf90_def_dim(ncid, "basns", rt_domain(did)%gnumbasns, dimid_basns)
5895        if(rt_domain(did)%nlakes .gt. 0) then
5896           iret = nf90_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes)
5897        endif
5898
5899        !define variables
5900        if( nlst(did)%channel_only       .eq. 0 .and. &
5901             nlst(did)%channelBucket_only .eq. 0         ) then
5902
5903           do n = 1, nlst(did)%nsoil
5904              if( n .lt. 10) then
5905                 write(tmpStr, '(i1)') n
5906              else
5907                 write(tmpStr, '(i2)') n
5908              endif
5909              iret = nf90_def_var(ncid, "stc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5910              iret = nf90_def_var(ncid, "smc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5911              iret = nf90_def_var(ncid, "sh2ox"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5912           end do
5913
5914           !iret = nf90_def_var(ncid, "smcmax1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5915           !iret = nf90_def_var(ncid, "smcref1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5916           !iret = nf90_def_var(ncid, "smcwlt1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5917           iret = nf90_def_var(ncid, "infxsrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5918           iret = nf90_def_var(ncid, "soldrain", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5919           iret = nf90_def_var(ncid, "sfcheadrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5920
5921        end if  ! neither channel_only nor channelBucket_only
5922
5923    if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
5924       nlst(did)%OVRTSWCRT   .eq. 1 .or. &
5925       nlst(did)%GWBASESWCRT .ne. 0       ) then
5926
5927       if( nlst(did)%channel_only       .eq. 0 .and. &
5928            nlst(did)%channelBucket_only .eq. 0         ) then
5929
5930             iret = nf90_def_var(ncid, "QBDRYRT", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5931             iret = nf90_def_var(ncid, "infxswgt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5932             iret = nf90_def_var(ncid, "sfcheadsubrt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5933           do n = 1, nlst(did)%nsoil
5934              if( n .lt. 10) then
5935                 write(tmpStr, '(i1)') n
5936              else
5937                 write(tmpStr, '(i2)') n
5938              endif
5939              iret = nf90_def_var(ncid, "sh2owgt"//trim(tmpStr), NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5940           end do
5941             iret = nf90_def_var(ncid, "qstrmvolrt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5942             !AD_CHANGE: Not needed in RESTART
5943             !iret = nf90_def_var(ncid, "RETDEPRT", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5944
5945       end if  ! neither channel_only nor channelBucket_only
5946
5947       if(nlst(did)%CHANRTSWCRT.eq.1) then
5948
5949 !yw based on Laura request, hlink will do the restart for reach method.
5950 !         if(nlst(did)%channel_option .eq. 3) &
5951          iret = nf90_def_var(ncid, "hlink", NF90_FLOAT, (/dimid_links/), varid)
5952          iret = nf90_def_var(ncid, "qlink1", NF90_FLOAT, (/dimid_links/), varid)
5953          iret = nf90_def_var(ncid, "qlink2", NF90_FLOAT, (/dimid_links/), varid)
5954          if(nlst(did)%channel_option .eq. 3) &
5955               iret = nf90_def_var(ncid, "cvol", NF90_FLOAT, (/dimid_links/), varid)
5956          if(rt_domain(did)%nlakes .gt. 0) then
5957             iret = nf90_def_var(ncid, "resht", NF90_FLOAT, (/dimid_lakes/), varid)
5958             iret = nf90_def_var(ncid, "qlakeo", NF90_FLOAT, (/dimid_lakes/), varid)
5959             iret = nf90_def_var(ncid, "qlakei", NF90_FLOAT, (/dimid_lakes/), varid)
5960          endif
5961
5962          if( nlst(did)%channel_only       .eq. 0 .and. &
5963              nlst(did)%channelBucket_only .eq. 0         ) &
5964              iret = nf90_def_var(ncid, "lake_inflort", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5965
5966          !! JLM: who wants these? They can be put back if someone cares.
5967          !! But just calculate accQLateral locally so the redundant variable isnt held in
5968          !! memory with all the other variables
5969          !if(nlst_rt(did)%UDMP_OPT .eq. 1) then
5970          !       iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimid_links/), varid)
5971          !       iret = nf90_def_var(ncid, "accQLateral", NF90_DOUBLE, (/dimid_links/), varid)
5972          !       iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_DOUBLE, (/dimid_links/), varid)
5973          !       iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimid_links/), varid)
5974          !endif
5975
5976       end if ! CHANRTSWCRT .eq. 1
5977
5978       if(nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.ge.4) then
5979
5980          if( nlst(did)%channel_only .eq. 0) then
5981
5982             if(nlst(did)%UDMP_OPT .eq. 1) then
5983                iret = nf90_def_var(ncid, "z_gwsubbas", NF90_FLOAT, (/dimid_links/), varid)
5984             else
5985                iret = nf90_def_var(ncid, "z_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid)
5986             endif
5987
5988          end if ! not channel_only : dont use buckets in channel only runs
5989
5990 !yw test bucket model
5991 !             iret = nf90_def_var(ncid, "gwbas_pix_ct", NF90_FLOAT, (/dimid_basns/), varid)
5992 !             iret = nf90_def_var(ncid, "gw_buck_exp", NF90_FLOAT, (/dimid_basns/), varid)
5993 !             iret = nf90_def_var(ncid, "z_max", NF90_FLOAT, (/dimid_basns/), varid)
5994 !             iret = nf90_def_var(ncid, "gw_buck_coeff", NF90_FLOAT, (/dimid_basns/), varid)
5995 !             iret = nf90_def_var(ncid, "qin_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid)
5996 !             iret = nf90_def_var(ncid, "qinflowbase", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5997 !             iret = nf90_def_var(ncid, "qout_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid)
5998       end if ! GWBASESWCRT .eq.1 .or. GWBASESWCRT .ge. 4
5999
6000       !! What is this option??
6001       if(nlst(did)%gwBaseSwCRT .eq. 3)then
6002          iret = nf90_def_var(ncid, "HEAD", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
6003       end if
6004
6005    end if  !  end if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
6006 !                    nlst(did)%OVRTSWCRT   .eq. 1 .or. &
6007 !                    nlst(did)%GWBASESWCRT .ne. 0       )
6008
6009    !         put global attribute
6010    iret = nf90_put_att(ncid, NF90_GLOBAL, "compiler_version", compiler_version())
6011    iret = nf90_put_att(ncid, NF90_GLOBAL, "his_out_counts", rt_domain(did)%his_out_counts)
6012    iret = nf90_put_att(ncid, NF90_GLOBAL, "Restart_Time", nlst(did)%olddate(1:19))
6013    iret = nf90_put_att(ncid, NF90_GLOBAL, "Since_Date", nlst(did)%sincedate(1:19))
6014    iret = nf90_put_att(ncid, NF90_GLOBAL, "DTCT", nlst(did)%DTCT)
6015    iret = nf90_put_att(ncid, NF90_GLOBAL, "channel_only", nlst(did)%channel_only)
6016    iret = nf90_put_att(ncid, NF90_GLOBAL, "channelBucket_only", nlst(did)%channelBucket_only)
6017
6018    !! end definition
6019    iret = nf90_enddef(ncid)
6020
6021
6022 #ifdef MPP_LAND
6023 endif  ! my_id .eq. io_id
6024 #endif
6025
6026 if( nlst(did)%channel_only       .eq. 0 .and. &
6027      nlst(did)%channelBucket_only .eq. 0         ) then
6028
6029    call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc")
6030    call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc")
6031    call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
6032
6033    !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
6034    !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
6035    !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  )
6036    call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  )
6037    call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain"  )
6038    call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt"  )
6039
6040 end if ! neither channel_only nor channelBucket_only
6041
6042 if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
6043    nlst(did)%OVRTSWCRT   .eq. 1 .or. &
6044    nlst(did)%GWBASESWCRT .ne. 0       ) then
6045
6046    if( nlst(did)%channel_only       .eq. 0 .and. &
6047        nlst(did)%channelBucket_only .eq. 0         ) then
6048       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%boundary_flux, "QBDRYRT" )
6049       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" )
6050       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%surface_water_head_routing, "sfcheadsubrt" )
6051       call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" )
6052       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT_ACC, "qstrmvolrt" )
6053       !AD_CHANGE: Not needed in RESTART
6054       !call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%properties%retention_depth, "RETDEPRT" )
6055    end if ! neither channel_only nor channelBucket_only
6056
6057    if(nlst(did)%CHANRTSWCRT.eq.1) then
6058
6059
6060       if(nlst(did)%channel_option .eq. 3) then
6061          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" &
6062 #ifdef MPP_LAND
6063               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6064 #endif
6065               )
6066       else
6067          call w_rst_crt_reach(ncid,rt_domain(did)%HLINK, "hlink"  &
6068 #ifdef MPP_LAND
6069               ,rt_domain(did)%gnlinksl&
6070 #endif
6071               )
6072         !call checkReach(99,rt_domain(did)%HLINK)
6073       endif
6074
6075       if(nlst(did)%channel_option .eq. 3) then
6076          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" &
6077 #ifdef MPP_LAND
6078               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6079 #endif
6080               )
6081       else
6082          call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,1), "qlink1"  &
6083 #ifdef MPP_LAND
6084               ,rt_domain(did)%gnlinksl &
6085 #endif
6086               )
6087       endif
6088
6089       if(nlst(did)%channel_option .eq. 3) then
6090          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" &
6091 #ifdef MPP_LAND
6092               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6093 #endif
6094               )
6095       else
6096          call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,2), "qlink2"  &
6097 #ifdef MPP_LAND
6098               ,rt_domain(did)%gnlinksl &
6099 #endif
6100               )
6101
6102 !! JLM If someone really wants the accumulated fluxes in the restart file, you can add them back.
6103 !! But Calculate accQLateral locally
6104 !                    if(nlst_rt(did)%UDMP_OPT .eq. 1) then
6105 !                        call w_rst_crt_reach(ncid,rt_domain(did)%accSfcLatRunoff, "accSfcLatRunoff"  &
6106 !#ifdef MPP_LAND
6107 !                                ,rt_domain(did)%gnlinksl &
6108 !#endif
6109 !                              )
6110 !                        call w_rst_crt_reach(ncid,rt_domain(did)%accQLateral, "accQLateral"  &
6111 !#ifdef MPP_LAND
6112 !                                ,rt_domain(did)%gnlinksl &
6113 !#endif
6114 !                              )
6115 !                        call w_rst_crt_reach(ncid,rt_domain(did)%qSfcLatRunoff, "qSfcLatRunoff"  &
6116 !#ifdef MPP_LAND
6117 !                                ,rt_domain(did)%gnlinksl &
6118 !#endif
6119 !                              )
6120 !                        call w_rst_crt_reach(ncid,rt_domain(did)%accBucket, "accBucket"  &
6121 !#ifdef MPP_LAND
6122 !                                ,rt_domain(did)%gnlinksl &
6123 !#endif
6124 !                              )
6125 !                    endif   ! end if of UDMP_OPT .eq. 1
6126       endif  ! channel_option .eq. 3
6127
6128
6129       !! Cvol is not prognostic for Musk-cunge.
6130       if(nlst(did)%channel_option .eq. 3) then
6131          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" &
6132 #ifdef MPP_LAND
6133               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6134 #endif
6135               )
6136 !      else
6137 !         call w_rst_crt_reach(ncid,rt_domain(did)%cvol, "cvol"  &
6138 !#ifdef MPP_LAND
6139 !              ,rt_domain(did)%gnlinksl &
6140 !#endif
6141 !              )
6142       endif
6143
6144
6145 !              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" &
6146 !#ifdef MPP_LAND
6147 !                 ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6148 !#endif
6149 !                  )
6150
6151
6152       call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" &
6153 #ifdef MPP_LAND
6154            ,rt_domain(did)%lake_index  &
6155 #endif
6156            )
6157
6158       call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" &
6159 #ifdef MPP_LAND
6160            ,rt_domain(did)%lake_index  &
6161 #endif
6162            )
6163
6164       call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakei,"qlakei" &
6165 #ifdef MPP_LAND
6166            ,rt_domain(did)%lake_index  &
6167 #endif
6168            )
6169
6170       if( nlst(did)%channel_only       .eq. 0 .and. &
6171           nlst(did)%channelBucket_only .eq. 0         ) &
6172
6173           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")
6174
6175    end if  !    if(nlst_rt(did)%CHANRTSWCRT.eq.1)
6176
6177    if(nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.ge.4) then
6178
6179       !call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" )
6180       if( nlst(did)%channel_only .eq. 0) then
6181
6182          if(nlst(did)%UDMP_OPT .eq. 1) then
6183
6184             call w_rst_crt_reach(ncid,rt_domain(did)%z_gwsubbas, "z_gwsubbas"  &
6185 #ifdef MPP_LAND
6186                  ,rt_domain(did)%gnlinksl  &
6187 #endif
6188                  )
6189          else
6190             call w_rst_gwbucket_real(ncid,rt_domain(did)%numbasns,rt_domain(did)%gnumbasns, &
6191                  rt_domain(did)%basnsInd, rt_domain(did)%z_gwsubbas,"z_gwsubbas" )
6192          endif
6193
6194       end if ! not channel_only : dont use buckets in channel only runs
6195
6196 !yw test bucket model
6197 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" )
6198 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" )
6199 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" )
6200 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" )
6201 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" )
6202 !             call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase")
6203 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" )
6204    end if ! GWBASESWCRT .eq. 1 .or. GWBASESWCRT .ge. 4
6205
6206    if(nlst(did)%GWBASESWCRT.eq.3) then
6207       if( nlst(did)%channel_only       .eq. 0 .and. &
6208           nlst(did)%channelBucket_only .eq. 0         ) &
6209           call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho, "HEAD" )
6210    end if
6211
6212 end if  ! end if(nlst_rt(did)%SUBRTSWCRT  .eq. 1 .or. &
6213 !                nlst_rt(did)%OVRTSWCRT   .eq. 1 .or. &
6214 !                nlst_rt(did)%GWBASESWCRT .ne. 0       )
6215
6216
6217 #ifdef MPP_LAND
6218         if(IO_id.eq.my_id) &
6219 #endif
6220         iret = nf90_close(ncid)
6221
6222         return
6223         end subroutine RESTART_OUT_nc
6224
6225 #ifdef MPP_LAND
6226
6227    subroutine RESTART_OUT_bi(outFile,did)
6228
6229
6230    implicit none
6231
6232    integer did
6233
6234    character(len=*) outFile
6235
6236     integer :: iunit
6237     integer  :: i0,ie, i, istep, mkdirStatus
6238
6239
6240     call mpp_land_sync()
6241
6242     iunit = 81
6243  istep = 64
6244  i0 = 0
6245  ie = istep
6246  do i = 0, numprocs,istep
6247    if(my_id .ge. i0 .and. my_id .lt. ie) then
6248      open(iunit, file = "restart/"//trim(outFile), form="unformatted",ERR=101, access="sequential")
6249           write(iunit,ERR=101) rt_domain(did)%his_out_counts
6250 !         write(iunit,ERR=101) nlst(did)%olddate(1:19)
6251           write(iunit,ERR=101) nlst(did)%sincedate(1:19)
6252 !         write(iunit,ERR=101) nlst_rt(did)%DTCT
6253           write(iunit,ERR=101) rt_domain(did)%stc
6254           write(iunit,ERR=101) rt_domain(did)%smc
6255           write(iunit,ERR=101) rt_domain(did)%sh2ox
6256           write(iunit,ERR=101) rt_domain(did)%SMCMAX1
6257           write(iunit,ERR=101) rt_domain(did)%SMCREF1
6258           write(iunit,ERR=101) rt_domain(did)%SMCWLT1
6259           write(iunit,ERR=101) rt_domain(did)%INFXSRT
6260           write(iunit,ERR=101) rt_domain(did)%soldrain
6261           write(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_lsm
6262
6263           if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1 .or. nlst(did)%GWBASESWCRT .ne. 0) then
6264                 if(nlst(did)%CHANRTSWCRT.EQ.1) then
6265                    write(iunit,ERR=101) rt_domain(did)%HLINK
6266                    write(iunit,ERR=101) rt_domain(did)%QLINK(:,1)
6267                    write(iunit,ERR=101) rt_domain(did)%QLINK(:,2)
6268                    write(iunit,ERR=101) rt_domain(did)%cvol
6269                    write(iunit,ERR=101) rt_domain(did)%resht
6270                    write(iunit,ERR=101) rt_domain(did)%qlakeo
6271                    write(iunit,ERR=101) rt_domain(did)%qlakei
6272                    write(iunit,ERR=101) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake
6273                 end if
6274
6275                 if(nlst(did)%GWBASESWCRT.EQ.1.OR.nlst(did)%GWBASESWCRT.GE.4) then
6276                      write(iunit,ERR=101) rt_domain(did)%z_gwsubbas
6277                 end if
6278                 if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1) then
6279                     write(iunit,ERR=101) rt_domain(did)%overland%control%boundary_flux
6280                     write(iunit,ERR=101) rt_domain(did)%INFXSWGT
6281                     write(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_routing
6282                     write(iunit,ERR=101) rt_domain(did)%SH2OWGT
6283                     write(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT_ACC
6284                     !AD_CHANGE: Not needed in RESTART
6285                     !write(iunit,ERR=101) rt_domain(did)%RETDEPRT
6286                 endif
6287           end if
6288
6289         close(iunit)
6290     endif
6291     call mpp_land_sync()
6292     i0 = i0 + istep
6293     ie = ie + istep
6294   end do ! end do of i loop
6295
6296         return
6297 101     continue
6298         call hydro_stop("FATAL ERROR: failed to output the hydro restart file.")
6299         end subroutine RESTART_OUT_bi
6300
6301    subroutine RESTART_in_bi(inFileTmp,did)
6302
6303
6304    implicit none
6305
6306    integer did
6307
6308    character(len=*) inFileTmp
6309    character(len=256) inFile
6310    character(len=19) str_tmp
6311
6312     integer :: iunit
6313     logical :: fexist
6314     integer  :: i0,ie, i, istep
6315
6316     iunit = 81
6317
6318              if(my_id .lt. 10) then
6319                 write(str_tmp,'(I1)') my_id
6320              else if(my_id .lt. 100) then
6321                 write(str_tmp,'(I2)') my_id
6322              else if(my_id .lt. 1000) then
6323                 write(str_tmp,'(I3)') my_id
6324              else if(my_id .lt. 10000) then
6325                 write(str_tmp,'(I4)') my_id
6326              else if(my_id .lt. 100000) then
6327                 write(str_tmp,'(I5)') my_id
6328              endif
6329
6330     inFile = trim(inFileTmp)//"."//str_tmp
6331
6332     inquire (file=trim(inFile), exist=fexist)
6333     if(.not. fexist) then
6334         call hydro_stop("In RESTART_in_bi()- Could not find restart file "//trim(inFile))
6335     endif
6336
6337  istep = 64
6338  i0 = 0
6339  ie = istep
6340  do i = 0, numprocs,istep
6341    if(my_id .ge. i0 .and. my_id .lt. ie) then
6342     open(iunit, file = inFile, form="unformatted",ERR=101,access="sequential")
6343           read(iunit,ERR=101) rt_domain(did)%his_out_counts
6344 !         read(iunit,ERR=101) nlst_rt(did)%olddate(1:19)
6345           read(iunit,ERR=101) nlst(did)%sincedate(1:19)
6346 !         read(iunit,ERR=101) nlst_rt(did)%DTCT
6347           read(iunit,ERR=101) rt_domain(did)%stc
6348           read(iunit,ERR=101) rt_domain(did)%smc
6349           read(iunit,ERR=101) rt_domain(did)%sh2ox
6350           read(iunit,ERR=101) rt_domain(did)%SMCMAX1
6351           read(iunit,ERR=101) rt_domain(did)%SMCREF1
6352           read(iunit,ERR=101) rt_domain(did)%SMCWLT1
6353           read(iunit,ERR=101) rt_domain(did)%INFXSRT
6354           read(iunit,ERR=101) rt_domain(did)%soldrain
6355           read(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_lsm
6356           if(nlst(did)%SUBRTSWCRT.EQ.0.and.nlst(did)%OVRTSWCRT.EQ.0) rt_domain(did)%overland%control%surface_water_head_lsm = 0
6357
6358           if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1 .or. nlst(did)%GWBASESWCRT .ne. 0) then
6359                 if(nlst(did)%CHANRTSWCRT.EQ.1) then
6360                    read(iunit,ERR=101) rt_domain(did)%HLINK
6361                    read(iunit,ERR=101) rt_domain(did)%QLINK(:,1)
6362                    read(iunit,ERR=101) rt_domain(did)%QLINK(:,2)
6363                    read(iunit,ERR=101) rt_domain(did)%cvol
6364                    read(iunit,ERR=101) rt_domain(did)%resht
6365                    read(iunit,ERR=101) rt_domain(did)%qlakeo
6366                    read(iunit,ERR=101) rt_domain(did)%qlakei
6367                    read(iunit,ERR=101) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake
6368                 end if
6369
6370                 if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then
6371                      read(iunit,ERR=101) rt_domain(did)%z_gwsubbas
6372                 end if
6373                 if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1) then
6374                    read(iunit,ERR=101) rt_domain(did)%overland%control%boundary_flux
6375                    read(iunit,ERR=101) rt_domain(did)%INFXSWGT
6376                    read(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_routing
6377                    read(iunit,ERR=101) rt_domain(did)%SH2OWGT
6378                    read(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT_ACC
6379                    !AD_CHANGE: This is overwriting the RETDEPRTFAC version, so causes issues when changing that factor.
6380                    !No need to have in restart since live calculated.
6381                    !read(iunit,ERR=101) rt_domain(did)%RETDEPRT
6382                 endif
6383           end if
6384
6385         close(iunit)
6386     endif
6387     call mpp_land_sync()
6388     i0 = i0 + istep
6389     ie = ie + istep
6390   end do ! end do of i loop
6391
6392         return
6393 101     continue
6394         call hydro_stop("In RESTART_in_bi() - failed to read the hydro restart file "//trim(inFile))
6395         end subroutine RESTART_in_bi
6396 #endif
6397
6398         subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName)
6399            implicit none
6400            integer:: ncid,ix,jx,varid , iret
6401            character(len=*) varName
6402            real, dimension(ix,jx):: inVar
6403 #ifdef MPP_LAND
6404            real, allocatable, dimension(:,:) :: varTmp
6405            if(my_id .eq. io_id ) then
6406                allocate(varTmp(global_rt_nx, global_rt_ny))
6407            else
6408                allocate(varTmp(1,1))
6409            endif
6410            call write_IO_rt_real(inVar,varTmp)
6411            if(my_id .eq. IO_id) then
6412               iret = nf90_inq_varid(ncid,varName, varid)
6413               if(iret .eq. 0) then
6414                  iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_rt_nx,global_rt_ny/))
6415               else
6416                  write(6,*) "Error: variable not defined in rst file before write: ", varName
6417               endif
6418            endif
6419            if(allocated(varTmp))  deallocate(varTmp)
6420 #else
6421            iret = nf90_inq_varid(ncid,varName, varid)
6422            if(iret .eq. 0) then
6423               iret = nf90_put_var(ncid, varid, inVar, (/1,1/), (/ix,jx/))
6424            else
6425               write(6,*) "Error : variable not defined in rst file before write: ", varName
6426            endif
6427 #endif
6428
6429            return
6430         end subroutine w_rst_rt_nc2
6431
6432         subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName)
6433            implicit none
6434            integer:: ncid,ix,jx,varid , iret, nsoil
6435            character(len=*) varName
6436            real,dimension(ix,jx,nsoil):: inVar
6437            character(len=2) tmpStr
6438            integer k
6439 #ifdef MPP_LAND
6440            real varTmp(global_rt_nx,global_rt_ny)
6441            do k = 1, nsoil
6442               call write_IO_rt_real(inVar(:,:,k),varTmp(:,:))
6443               if(my_id .eq. IO_id) then
6444                  if( k .lt. 10) then
6445                     write(tmpStr, '(i1)') k
6446                  else
6447                     write(tmpStr, '(i2)') k
6448                  endif
6449                  iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6450                  iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_rt_nx,global_rt_ny/))
6451               endif
6452            end do
6453 #else
6454            do k = 1, nsoil
6455                  if( k .lt. 10) then
6456                     write(tmpStr, '(i1)') k
6457                  else
6458                     write(tmpStr, '(i2)') k
6459                  endif
6460               iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6461               iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/))
6462            end do
6463 #endif
6464            return
6465         end subroutine w_rst_rt_nc3
6466
6467         subroutine w_rst_nc2(ncid,ix,jx,inVar,varName)
6468            implicit none
6469            integer:: ncid,ix,jx,varid , iret
6470            character(len=*) varName
6471            real inVar(ix,jx)
6472
6473 #ifdef MPP_LAND
6474            real varTmp(global_nx,global_ny)
6475            call write_IO_real(inVar,varTmp)
6476            if(my_id .eq. IO_id) then
6477               iret = nf90_inq_varid(ncid,varName, varid)
6478               iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_nx,global_ny/))
6479            endif
6480 #else
6481            iret = nf90_inq_varid(ncid,varName, varid)
6482            iret = nf90_put_var(ncid, varid, invar, (/1,1/), (/ix,jx/))
6483 #endif
6484
6485            return
6486         end subroutine w_rst_nc2
6487
6488         subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName)
6489            implicit none
6490            integer:: ncid,ix,jx,varid , iret, nsoil
6491            character(len=*) varName
6492            real inVar(ix,jx,nsoil)
6493            integer k
6494            character(len=2) tmpStr
6495
6496 #ifdef MPP_LAND
6497            real varTmp(global_nx,global_ny)
6498            do k = 1, nsoil
6499               call write_IO_real(inVar(:,:,k),varTmp(:,:))
6500               if(my_id .eq. IO_id) then
6501                  if( k .lt. 10) then
6502                     write(tmpStr, '(i1)') k
6503                  else
6504                     write(tmpStr, '(i2)') k
6505                  endif
6506                 iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6507                 iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_nx,global_ny/))
6508               endif
6509            end do
6510 #else
6511            do k = 1, nsoil
6512                  if( k .lt. 10) then
6513                     write(tmpStr, '(i1)') k
6514                  else
6515                     write(tmpStr, '(i2)') k
6516                  endif
6517              iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6518              iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/))
6519            end do
6520 #endif
6521            return
6522         end subroutine w_rst_nc3
6523
6524         subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName &
6525 #ifdef MPP_LAND
6526                  ,nodelist     &
6527 #endif
6528                   )
6529            implicit none
6530            integer:: ncid,n,varid , iret
6531            character(len=*) varName
6532            real inVar(n)
6533 #ifdef MPP_LAND
6534            integer:: nodelist(n)
6535            if(n .eq. 0) return
6536
6537            call write_lake_real(inVar,nodelist,n)
6538            if(my_id .eq. IO_id) then
6539 #endif
6540               iret = nf90_inq_varid(ncid,varName, varid)
6541               iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6542 #ifdef MPP_LAND
6543            endif
6544 #endif
6545            return
6546         end subroutine w_rst_crt_nc1_lake
6547
6548         subroutine w_rst_crt_reach_real(ncid,inVar,varName &
6549 #ifdef MPP_LAND
6550                  , gnlinksl&
6551 #endif
6552                   )
6553            implicit none
6554            integer:: ncid,varid , iret, n
6555            character(len=*) varName
6556            real, dimension(:) :: inVar
6557
6558 #ifdef MPP_LAND
6559            integer:: gnlinksl
6560            real,allocatable,dimension(:) :: g_var
6561            if(my_id .eq. io_id) then
6562                 allocate(g_var(gnlinksl))
6563                 g_var  = 0
6564            else
6565                 allocate(g_var(1) )
6566            endif
6567
6568            call ReachLS_write_io(inVar, g_var)
6569            if(my_id .eq. IO_id) then
6570               iret = nf90_inq_varid(ncid,varName, varid)
6571               iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinksl/))
6572            endif
6573            if(allocated(g_var)) deallocate(g_var)
6574 #else
6575            n = size(inVar,1)
6576            iret = nf90_inq_varid(ncid,varName, varid)
6577            iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6578 #endif
6579            return
6580         end subroutine w_rst_crt_reach_real
6581
6582
6583         subroutine w_rst_crt_reach_real8(ncid,inVar,varName &
6584 #ifdef MPP_LAND
6585                  , gnlinksl&
6586 #endif
6587                   )
6588            implicit none
6589            integer:: ncid,varid , iret, n
6590            character(len=*) varName
6591            real*8, dimension(:) :: inVar
6592
6593 #ifdef MPP_LAND
6594            integer:: gnlinksl
6595            real*8,allocatable,dimension(:) :: g_var
6596            if(my_id .eq. io_id) then
6597                 allocate(g_var(gnlinksl))
6598                 g_var  = 0
6599            else
6600                 allocate(g_var(1) )
6601            endif
6602
6603            call ReachLS_write_io(inVar, g_var)
6604            if(my_id .eq. IO_id) then
6605               iret = nf90_inq_varid(ncid,varName, varid)
6606               iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinksl/))
6607            endif
6608            if(allocated(g_var)) deallocate(g_var)
6609 #else
6610            n = size(inVar,1)
6611            iret = nf90_inq_varid(ncid,varName, varid)
6612            iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6613 #endif
6614            return
6615         end subroutine w_rst_crt_reach_real8
6616
6617
6618
6619         subroutine w_rst_crt_nc1(ncid,n,inVar,varName &
6620 #ifdef MPP_LAND
6621                  ,map_l2g, gnlinks&
6622 #endif
6623                   )
6624            implicit none
6625            integer:: ncid,n,varid , iret
6626            character(len=*) varName
6627            real inVar(n)
6628 #ifdef MPP_LAND
6629            integer:: gnlinks, map_l2g(n)
6630            real g_var(gnlinks)
6631            call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var)
6632            if(my_id .eq. IO_id) then
6633               iret = nf90_inq_varid(ncid,varName, varid)
6634               iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinks/))
6635 #else
6636               iret = nf90_inq_varid(ncid,varName, varid)
6637               iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6638 #endif
6639 #ifdef MPP_LAND
6640            endif
6641 #endif
6642            return
6643         end subroutine w_rst_crt_nc1
6644
6645         subroutine w_rst_crt_nc1g(ncid,n,inVar,varName)
6646            implicit none
6647            integer:: ncid,n,varid , iret
6648            character(len=*) varName
6649            real,dimension(:) ::  inVar
6650 #ifdef MPP_LAND
6651            if(my_id .eq. IO_id) then
6652 #endif
6653               iret = nf90_inq_varid(ncid,varName, varid)
6654               iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6655 #ifdef MPP_LAND
6656            endif
6657 #endif
6658            return
6659         end subroutine w_rst_crt_nc1g
6660
6661    subroutine w_rst_gwbucket_real(ncid,numbasns,gnumbasns, &
6662                        basnsInd, inV,vName )
6663       implicit none
6664       integer :: ncid,numbasns,gnumbasns
6665       integer(kind=int64), dimension(:) :: basnsInd
6666       real, dimension(:) :: inV
6667       character(len=*) :: vName
6668       integer i, j, k
6669       real, allocatable,dimension(:) :: buf
6670 #ifdef MPP_LAND
6671       if (my_id .eq. IO_id) then
6672         allocate(buf(gnumbasns))
6673       else
6674         allocate(buf(1))
6675       endif
6676       call gw_write_io_real(numbasns,inV,basnsInd,buf)
6677 #else
6678       allocate(buf(gnumbasns))
6679       do k = 1, numbasns
6680         buf(basnsInd(k)) = inV(k)
6681       end do
6682 #endif
6683       call w_rst_crt_nc1g(ncid,gnumbasns,buf,vName)
6684       if(allocated(buf)) deallocate(buf)
6685    end subroutine w_rst_gwbucket_real
6686
6687    subroutine read_rst_gwbucket_real(ncid,outV,numbasns,&
6688                        gnumbasns,basnsInd, vName)
6689       implicit none
6690       integer :: ncid,numbasns,gnumbasns
6691       integer(kind=int64), dimension(:) :: basnsInd
6692       real, dimension(:) :: outV
6693       character(len=*) :: vName
6694       integer i, j,k
6695       real, dimension(gnumbasns) :: buf
6696       call read_rst_crt_nc(ncid,buf,gnumbasns,vName)
6697       do k = 1, numbasns
6698          outV(k) = buf(basnsInd(k))
6699       end do
6700    end subroutine read_rst_gwbucket_real
6701
6702
6703 subroutine RESTART_IN_NC(inFile,did)
6704
6705 implicit none
6706 character(len=*) inFile
6707 integer :: ierr, iret,ncid, did
6708 integer :: channel_only_in, channelBucket_only_in
6709 integer :: i, j
6710
6711
6712 #ifdef MPP_LAND
6713 if(IO_id .eq. my_id) then
6714 #endif
6715 !open a netcdf file
6716    iret = nf90_open(trim(inFile), NF90_NOWRITE, ncid)
6717 #ifdef MPP_LAND
6718 endif
6719 call mpp_land_bcast_int1(iret)
6720 #endif
6721 if (iret /= 0) then
6722    write(*,'("Problem opening file: ''", A, "''")') &
6723         trim(inFile)
6724    call hydro_stop("In RESTART_IN_NC() - Problem opening file")
6725 endif
6726
6727 #ifdef MPP_LAND
6728 if(IO_id .eq. my_id) then
6729 #endif
6730
6731    !! Dont use a restart from a channel_only run if you're not running channel_only
6732    iret = nf90_get_att(ncid, NF90_GLOBAL, "channel_only", channel_only_in)
6733    if(iret .eq. 0) then !! If channel_only attribute prsent, then proceed with this logic
6734
6735       iret = nf90_get_att(ncid, NF90_GLOBAL, "channelBucket_only", channelBucket_only_in)
6736
6737       iret=0 ! borrow the variable for our own error flagging
6738       !! Hierarchy of model restarting ability.
6739       !! 1) Full model restarts: all model runs (full, channel_only and channelBucket_only)
6740       !! No test needed here.
6741
6742       !! 2) channelBucket_only restarts: channelBucket_only and channel_only runs
6743       if(channelBucket_only_in .eq. 1) then
6744          if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) iret=1
6745       end if
6746
6747       !! 3) channel_only restarts: only channel_only runs
6748       if(channel_only_in .eq. 1) then
6749          if(nlst(did)%channel_only .eq. 0) iret=1
6750       end if
6751
6752       if(iret .eq. 1) then
6753
6754          !! JLM Why dont we adopt this strategy elsewhere, e.g. define logUnit as a module variable.
6755          !! JLM Would massively cut down on #ifdefs and repetitive code in certain parts of the code.
6756 #ifdef NCEP_WCOSS
6757          logUnit=78
6758 #else
6759          logUnit=6
6760 #endif
6761
6762          write(logUnit,*) 'Restart is not respecting the hierarchy of model restarting ability:'
6763          write(logUnit,*) '1) Full model restarts: all model runs (full, channel_only and channelBucket_only),'
6764          write(logUnit,*) '2) channelBucket_only restarts: channelBucket_only and channel_only runs,'
6765          write(logUnit,*) '3) channel_only restarts: only channel_only runs.'
6766          write(logUnit,*) 'Diagnostics:'
6767          write(logUnit,*) 'channel_only restart present:', channel_only_in
6768          write(logUnit,*) 'channel_only run:', nlst(did)%channel_only
6769          write(logUnit,*) 'channelBucket_only restart present:', channelBucket_only_in
6770          write(logUnit,*) 'channelBucket_only run:', nlst(did)%channelBucket_only
6771          call flush(logUnit)
6772          call hydro_stop('Channel Only: Restart file in consistent with forcing type.')
6773       end if
6774    end if
6775
6776    iret = nf90_get_att(ncid, NF90_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts)
6777    iret = nf90_get_att(ncid, NF90_GLOBAL, 'DTCT', nlst(did)%DTCT)
6778    iret = nf90_get_att(ncid,NF90_GLOBAL,"Since_Date",nlst(did)%sincedate(1:19))
6779 !   if( nlst(did)%channel_only       .eq. 1 .or. &
6780 !       nlst(did)%channelBucket_only .eq. 1         ) &
6781 !       iret = nf90_get_att(ncid,NF90_GLOBAL,"Restart_Time",nlst(did)%olddate(1:19))
6782    if(iret /= 0) nlst(did)%sincedate = nlst(did)%startdate
6783    if(nlst(did)%DTCT .gt. 0) then
6784       nlst(did)%DTCT = min(nlst(did)%DTCT, nlst(did)%DTRT_CH)
6785    else
6786       nlst(did)%DTCT = nlst(did)%DTRT_CH
6787    endif
6788
6789 #ifdef MPP_LAND
6790 endif
6791
6792 !yw call mpp_land_bcast_int1(rt_domain(did)%out_counts)
6793 ! Not sure what caused the problem. added out_counts = 1 as a temporary fix for the hydro output.
6794 rt_domain(did)%out_counts = 1
6795
6796 call mpp_land_bcast_real1(nlst(did)%DTCT)
6797 !if( nlst_rt(did)%channel_only       .eq. 1 .or. &
6798 !    nlst_rt(did)%channelBucket_only .eq. 1         ) &
6799 !    call mpp_land_bcast_char(19, nlst_rt(did)%olddate)
6800 !! call mpp_land_bcast_char(19, nlst_rt(did)%sincedate) ! why not? we read it in.
6801 #endif
6802
6803 #ifdef HYDRO_D
6804 write(6,*) "nlst(did)%nsoil=",nlst(did)%nsoil
6805 #endif
6806
6807 if( nlst(did)%channel_only       .eq. 0 .and. &
6808     nlst(did)%channelBucket_only .eq. 0         ) then
6809
6810    if(nlst(did)%rst_typ .eq. 1 ) then
6811       call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc")
6812       call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc")
6813       call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
6814       call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt")
6815       call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt")
6816       call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain")
6817
6818    end if ! rst_typ .eq. 1
6819    !yw check
6820
6821    !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
6822    !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1")
6823    !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1")
6824
6825 endif ! neither channel_only nor channelBucket_only
6826
6827 if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
6828    nlst(did)%OVRTSWCRT   .eq. 1 .or. &
6829    nlst(did)%GWBASESWCRT .ne. 0       ) then
6830    !! JLM ?? restarting channel depends on these options?
6831
6832    if( nlst(did)%channel_only       .eq. 0 .and. &
6833        nlst(did)%channelBucket_only .eq. 0         ) then
6834
6835       if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then
6836
6837          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt")
6838          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%surface_water_head_routing,"sfcheadsubrt")
6839          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%boundary_flux,"QBDRYRT")
6840          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT_ACC,"qstrmvolrt")
6841          !AD_CHANGE: This is overwriting the RETDEPRTFAC version, so causes issues when changing that factor.
6842          !No need to have in restart since live calculated.
6843          !call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%properties%retention_depth,"RETDEPRT")
6844          call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt")
6845       endif
6846
6847    end if ! neither channel_only nor channelBucket_only
6848
6849    if(nlst(did)%CHANRTSWCRT.eq.1) then
6850       if(nlst(did)%channel_option .eq. 3) then
6851          !! Have not setup channel_only for gridded routing YET
6852          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)
6853          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)
6854          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)
6855          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)
6856       else
6857          call read_rst_crt_reach_nc(ncid,rt_domain(did)%HLINK,"hlink",rt_domain(did)%GNLINKSL,fatalErr=.FALSE.)
6858          call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,1),"qlink1",rt_domain(did)%GNLINKSL)
6859          call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,2),"qlink2",rt_domain(did)%GNLINKSL)
6860          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%CVOL,"cvol",rt_domain(did)%GNLINKSL)
6861          !if(nlst_rt(did)%UDMP_OPT .eq. 1) then
6862          ! read in the statistic value
6863          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accSfcLatRunoff,"accSfcLatRunoff",rt_domain(did)%GNLINKSL)
6864          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accQLateral,"accQLateral",rt_domain(did)%GNLINKSL)
6865          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%qSfcLatRunoff,"qSfcLatRunoff",rt_domain(did)%GNLINKSL)
6866          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accBucket,"accBucket",rt_domain(did)%GNLINKS)
6867          !endif
6868       endif
6869
6870       if(rt_domain(did)%NLAKES .gt. 0) then
6871          call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht")
6872          call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo")
6873          call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEI,rt_domain(did)%NLAKES,"qlakei")
6874       endif
6875
6876       if( nlst(did)%channel_only       .eq. 0 .and. &
6877            nlst(did)%channelBucket_only .eq. 0         ) then
6878
6879          if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then
6880             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")
6881          endif
6882       end if
6883
6884    end if  !  end if(nlst_rt(did)%CHANRTSWCRT.eq.1)
6885
6886    if((nlst(did)%GWBASESWCRT .eq. 1 .or.  &
6887       nlst(did)%GWBASESWCRT .ge. 4) .and. &
6888       nlst(did)%GW_RESTART  .ne. 0 .and.  &
6889       rt_domain(did)%gnumbasns .gt. 0) then
6890
6891       if(nlst(did)%channel_only .eq. 0) then
6892          if(nlst(did)%UDMP_OPT .eq. 1) then
6893             call read_rst_crt_reach_nc(ncid,rt_domain(did)%z_gwsubbas,"z_gwsubbas",rt_domain(did)%GNLINKSL)
6894          else
6895             call read_rst_gwbucket_real(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,&
6896                  rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd, "z_gwsubbas")
6897          endif
6898
6899       end if !       if( nlst_rt(did)%channel_only .eq. 0 ) then
6900
6901    end if  ! end    if((nlst_rt(did)%GWBASESWCRT .eq. 1 .or. nlst_rt(did)%GWBASESWCRT .ge. 4) .and. &
6902 !                      nlst_rt(did)%GW_RESTART  .ne. 0 .and. &
6903 !                      rt_domain(did)%gnumbasns .gt. 0        )
6904
6905    !! JLM: WHat is this option??
6906    if(nlst(did)%GWBASESWCRT.eq.3) then
6907       if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then
6908          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho,"HEAD")
6909       endif
6910    end if
6911
6912 end if  !  end if(nlst_rt(did)%SUBRTSWCRT  .eq. 1 .or. &
6913 !                 nlst_rt(did)%OVRTSWCRT   .eq. 1 .or. &
6914 !                 nlst_rt(did)%GWBASESWCRT .ne. 0       )
6915
6916 !! Resetting these after writing the t=0 output file instead so that no information is
6917 !! lost.
6918 !if(nlst_rt(did)%rstrt_swc.eq.1) then  !Switch for rest of restart accum vars...
6919 !#ifdef HYDRO_D
6920 !            print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc
6921 !#endif
6922 !! JLM:
6923 !! Reset of accumulation variables move to end of subroutine
6924 !!   Routing/module_HYDRO_drv.F: HYDRO_ini
6925 !! See comments there.
6926 !! Conensed, commented code:
6927 !! rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake=0.!rt_domain(did)%surface_water_to_channel=0.
6928 !end if
6929
6930 #ifdef MPP_LAND
6931 if(my_id .eq. IO_id) &
6932 #endif
6933      iret =  nf90_close(ncid)
6934 #ifdef HYDRO_D
6935 write(6,*) "end of RESTART_IN"
6936 call flush(6)
6937 #endif
6938
6939 return
6940 end subroutine RESTART_IN_nc
6941
6942
6943       subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr)
6944          implicit none
6945          integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
6946          real,dimension(ix,jx,nsoil) ::  var
6947          character(len=*) :: varStr
6948          character(len=2) :: tmpStr
6949          integer :: n
6950          integer i
6951 #ifdef MPP_LAND
6952          real,dimension(global_nx,global_ny) :: xtmp
6953 #endif
6954
6955          do i = 1, nsoil
6956 #ifdef MPP_LAND
6957          if(my_id .eq. IO_id) then
6958 #endif
6959                  if( i .lt. 10) then
6960                     write(tmpStr, '(i1)') i
6961                  else
6962                     write(tmpStr, '(i2)') i
6963                  endif
6964            iret = nf90_inq_varid(ncid,  trim(varStr)//trim(tmpStr),  varid)
6965 #ifdef MPP_LAND
6966          endif
6967          call mpp_land_bcast_int1(iret)
6968 #endif
6969
6970          if (iret /= 0) then
6971 #ifdef HYDRO_D
6972             print*, 'variable not found: name = "', trim(varStr)//'"'
6973 #endif
6974             return
6975          endif
6976 #ifdef HYDRO_D
6977          print*, "read restart variable ", varStr//trim(tmpStr)
6978 #endif
6979 #ifdef MPP_LAND
6980          if(my_id .eq. IO_id) &
6981             iret = nf90_get_var(ncid, varid, xtmp)
6982
6983             call decompose_data_real(xtmp(:,:), var(:,:,i))
6984 #else
6985             iret = nf90_get_var(ncid, varid, var(:,:,i))
6986 #endif
6987          end do
6988
6989          return
6990       end subroutine read_rst_nc3
6991
6992       subroutine read_rst_nc2(ncid,ix,jx,var,varStr)
6993          implicit none
6994          integer ::  ix,jx,ireg, ncid, varid, iret
6995          real,dimension(ix,jx) ::  var
6996          character(len=*) :: varStr
6997 #ifdef MPP_LAND
6998          real,dimension(global_nx,global_ny) :: xtmp
6999          if(my_id .eq. IO_id) &
7000 #endif
7001            iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7002
7003 #ifdef MPP_LAND
7004          call mpp_land_bcast_int1(iret)
7005 #endif
7006
7007          if (iret /= 0) then
7008 #ifdef HYDRO_D
7009             print*, 'variable not found: name = "', trim(varStr)//'"'
7010 #endif
7011             return
7012          endif
7013 #ifdef HYDRO_D
7014          print*, "read restart variable ", varStr
7015 #endif
7016 #ifdef MPP_LAND
7017          if(my_id .eq. IO_id) &
7018             iret = nf90_get_var(ncid, varid, xtmp)
7019
7020          call decompose_data_real(xtmp, var)
7021 #else
7022             var = 0.0
7023             iret = nf90_get_var(ncid, varid, var)
7024 #endif
7025          return
7026       end subroutine read_rst_nc2
7027
7028       subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr)
7029          implicit none
7030          integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
7031          real,dimension(ix,jx,nsoil) ::  var
7032          character(len=*) :: varStr
7033          character(len=2) :: tmpStr
7034          integer i
7035 #ifdef MPP_LAND
7036          real,dimension(global_rt_nx,global_rt_ny) :: xtmp
7037 #endif
7038          do i = 1, nsoil
7039                  if( i .lt. 10) then
7040                     write(tmpStr, '(i1)') i
7041                  else
7042                     write(tmpStr, '(i2)') i
7043                  endif
7044 #ifdef MPP_LAND
7045          if(my_id .eq. IO_id) &
7046 #endif
7047             iret = nf90_inq_varid(ncid,  trim(varStr)//trim(tmpStr),  varid)
7048 #ifdef MPP_LAND
7049          call mpp_land_bcast_int1(iret)
7050 #endif
7051          if (iret /= 0) then
7052 #ifdef HYDRO_D
7053             print*, 'variable not found: name = "', trim(varStr)//'"'
7054 #endif
7055             return
7056          endif
7057 #ifdef HYDRO_D
7058          print*, "read restart variable ", varStr//trim(tmpStr)
7059 #endif
7060 #ifdef MPP_LAND
7061          iret = nf90_get_var(ncid, varid, xtmp)
7062             call decompose_RT_real(xtmp(:,:),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx)
7063 #else
7064          iret = nf90_get_var(ncid, varid, var(:,:,i))
7065 #endif
7066          end do
7067          return
7068       end subroutine read_rst_rt_nc3
7069
7070       subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr)
7071          implicit none
7072          integer ::  ix,jx,ireg, ncid, varid, iret
7073          real,dimension(ix,jx) ::  var
7074          character(len=*) :: varStr
7075 #ifdef MPP_LAND
7076          real,dimension(global_rt_nx,global_rt_ny) :: xtmp
7077 #endif
7078          iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7079 #ifdef MPP_LAND
7080          call mpp_land_bcast_int1(iret)
7081 #endif
7082          if (iret /= 0) then
7083 #ifdef HYDRO_D
7084             print*, 'variable not found: name = "', trim(varStr)//'"'
7085 #endif
7086             return
7087          endif
7088 #ifdef HYDRO_D
7089          print*, "read restart variable ", varStr
7090 #endif
7091 #ifdef MPP_LAND
7092          if(my_id .eq. IO_id) &
7093              iret = nf90_get_var(ncid, varid, xtmp)
7094          call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
7095 #else
7096             iret = nf90_get_var(ncid, varid, var)
7097 #endif
7098          return
7099       end subroutine read_rst_rt_nc2
7100
7101       subroutine read_rt_nc2(ncid,ix,jx,var,varStr)
7102          implicit none
7103          integer ::  ix,jx, ncid, varid, iret
7104          real,dimension(ix,jx) ::  var
7105          character(len=*) :: varStr
7106
7107 #ifdef MPP_LAND
7108          real,allocatable, dimension(:,:) :: xtmp
7109 !yw         real,dimension(global_rt_nx,global_rt_ny) :: xtmp
7110          if(my_id .eq. io_id ) then
7111              allocate(xtmp(global_rt_nx,global_rt_ny))
7112          else
7113              allocate(xtmp(1,1))
7114          endif
7115          xtmp = 0.0
7116 #endif
7117             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7118 #ifdef MPP_LAND
7119          call mpp_land_bcast_int1(iret)
7120 #endif
7121             if (iret /= 0) then
7122 #ifdef HYDRO_D
7123                print*, 'variable not found: name = "', trim(varStr)//'"'
7124 #endif
7125                return
7126             endif
7127 #ifdef HYDRO_D
7128          print*, "read restart variable ", varStr
7129 #endif
7130 #ifdef MPP_LAND
7131          if(my_id .eq. IO_id) then
7132             iret = nf90_get_var(ncid, varid, xtmp)
7133          endif
7134          call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
7135
7136          if(allocated(xtmp)) deallocate(xtmp)
7137
7138 #else
7139             iret = nf90_get_var(ncid, varid, var)
7140 #endif
7141          return
7142       end subroutine read_rt_nc2
7143
7144       subroutine read_rst_crt_nc(ncid,var,n,varStr)
7145          implicit none
7146          integer ::  ireg, ncid, varid, n, iret
7147          real,dimension(n) ::  var
7148          character(len=*) :: varStr
7149
7150          if( n .le. 0)  return
7151 #ifdef MPP_LAND
7152          if(my_id .eq. IO_id) &
7153 #endif
7154             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7155 #ifdef MPP_LAND
7156          call mpp_land_bcast_int1(iret)
7157 #endif
7158             if (iret /= 0) then
7159 #ifdef HYDRO_D
7160                print*, 'variable not found: name = "', trim(varStr)//'"'
7161 #endif
7162                return
7163             endif
7164 #ifdef HYDRO_D
7165          print*, "read restart variable ", varStr
7166 #endif
7167 #ifdef MPP_LAND
7168          if(my_id .eq. IO_id) then
7169 #endif
7170             iret = nf90_get_var(ncid, varid, var)
7171 #ifdef MPP_LAND
7172          endif
7173          if(n .gt. 0) then
7174              call mpp_land_bcast_real(n,var)
7175          endif
7176 #endif
7177          return
7178       end subroutine read_rst_crt_nc
7179
7180       subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g)
7181          implicit none
7182          integer ::  ncid, varid, n, iret, gnlinks
7183          integer, intent(in), dimension(:) :: map_l2g
7184          character(len=*) :: varStr
7185          integer :: l, g
7186          real,intent(out) , dimension(:) ::  var_out
7187 #ifdef MPP_LAND
7188          real,dimension(gnlinks) ::  var
7189 #else
7190          real,dimension(n) ::  var
7191 #endif
7192
7193
7194 #ifdef MPP_LAND
7195          if(my_id .eq. IO_id) &
7196 #endif
7197             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7198 #ifdef MPP_LAND
7199          call mpp_land_bcast_int1(iret)
7200 #endif
7201             if (iret /= 0) then
7202 #ifdef HYDRO_D
7203                print*, 'variable not found: name = "', trim(varStr)//'"'
7204 #endif
7205                return
7206             endif
7207 #ifdef HYDRO_D
7208          print*, "read restart variable ", varStr
7209 #endif
7210 #ifdef MPP_LAND
7211          if(my_id .eq. IO_id) then
7212 #endif
7213             var = 0.0
7214             iret = nf90_get_var(ncid, varid, var)
7215 #ifdef MPP_LAND
7216          endif
7217          if(gnlinks .gt. 0) then
7218             call mpp_land_bcast_real(gnlinks,var)
7219          endif
7220
7221          if(n .le. 0) return
7222          var_out = 0
7223
7224          do l = 1, n
7225             g = map_l2g(l)
7226             var_out(l) = var(g)
7227          end do
7228 #else
7229          var_out = var
7230 #endif
7231          return
7232       end subroutine read_rst_crt_stream_nc
7233
7234       subroutine read_rst_crt_reach_nc_real(ncid,var_out,varStr,gnlinksl, fatalErr)
7235          implicit none
7236          integer ::  ncid, varid, n, iret, gnlinksl
7237          character(len=*) :: varStr
7238          integer :: l, g
7239          real, dimension(:) ::  var_out
7240          logical, optional, intent(in) :: fatalErr
7241          logical :: fatalErr_local
7242          real :: scale_factor, add_offset
7243          integer :: ovrtswcrt_in, ss
7244          real,allocatable,dimension(:) ::  var, varTmp
7245
7246          fatalErr_local = .false.
7247          if(present(fatalErr)) fatalErr_local=fatalErr
7248
7249          n = size(var_out,1)
7250
7251 #ifdef MPP_LAND
7252          if(my_id .eq. IO_id) then
7253               allocate(var(gnlinksl))
7254          else
7255               allocate(var(1))
7256          endif
7257 #else
7258               allocate(var(n))
7259 #endif
7260
7261
7262 #ifdef MPP_LAND
7263          if(my_id .eq. IO_id) then
7264             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7265          endif
7266          call mpp_land_bcast_int1(iret)
7267          if (iret /= 0) then
7268 #ifdef HYDRO_D
7269             print*, 'read_rst_crt_reach_nc: variable not found: name = "', trim(varStr)//'"'
7270 #endif
7271
7272             if(allocated(var))  deallocate(var)
7273
7274             !! JLM: is this desirable?
7275             !! JLM I think so, maybe an option to this routine specifying if errors are fatal?
7276             if (fatalErr_local) &
7277                  call hydro_stop("read_rst_crt_reach_nc: variable not found: "//trim(varStr))
7278
7279             return
7280          endif
7281
7282          if(my_id .eq. IO_id) then
7283 #ifdef HYDRO_D
7284             print*, "read restart variable ", varStr
7285             call flush(6)
7286 #endif
7287
7288             var = 0.0
7289             iret = nf90_get_var(ncid, varid, var)
7290             !! JLM: need a check here.
7291
7292             iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor)
7293             if(iret .eq. 0) var = var * scale_factor
7294             iret = nf90_get_att(ncid, varid, 'add_offset', add_offset)
7295             if(iret .eq. 0) var = var + add_offset
7296
7297             !! NWM channel-only forcings have to be "decoded"/unshuffled.
7298             !! As of NWM1.2 the following global attribute is different/identifiable
7299             !! for files created when io_form_outputs=1,2 (not 0).
7300             iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_OVRTSWCRT', ovrtswcrt_in)
7301             if((nlst(did)%channel_only .eq. 1 .or. nlst(did)%channelBucket_only .eq. 1) .and. &
7302                iret .eq. 0) then
7303                allocate(varTmp(gnlinksl))
7304                do ss=1,gnlinksl
7305                   varTmp(rt_domain(did)%ascendIndex(ss)+1)=var(ss)
7306                end do
7307                var=varTmp
7308                deallocate(varTmp)
7309             end if
7310          endif
7311
7312          call ReachLS_decomp(var,   var_out)
7313          if(allocated(var)) deallocate(var)
7314 #else
7315             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7316            if (iret /= 0) then
7317 #ifdef HYDRO_D
7318                print*, 'variable not found: name = "', trim(varStr)//'"'
7319 #endif
7320                if(allocated(var)) deallocate(var)
7321                return
7322             endif
7323 #ifdef HYDRO_D
7324          print*, "read restart variable ", varStr
7325 #endif
7326          iret = nf90_get_var(ncid, varid, var_out)
7327          if(allocated(var)) deallocate(var)
7328 #endif
7329
7330          return
7331          end subroutine read_rst_crt_reach_nc_real
7332
7333
7334       subroutine read_rst_crt_reach_nc_real8(ncid, var_out, varStr, gnlinksl, fatalErr)
7335          implicit none
7336          integer, intent(in)          ::  ncid, gnlinksl
7337          real*8, dimension(:), intent(inout) ::  var_out
7338          character(len=*), intent(in) :: varStr
7339          logical, optional, intent(in)       ::  fatalErr
7340
7341          integer :: varid, n, iret, l, g
7342          logical :: fatalErr_local
7343          real*8,allocatable,dimension(:) ::  var
7344          real :: scale_factor, add_offset
7345
7346          fatalErr_local = .false.
7347          if(present(fatalErr)) fatalErr_local=fatalErr
7348
7349          n = size(var_out,1)
7350
7351 #ifdef MPP_LAND
7352          if(my_id .eq. IO_id) then
7353               allocate(var(gnlinksl))
7354          else
7355               allocate(var(1))
7356          endif
7357 #else
7358               allocate(var(n))
7359 #endif
7360 #ifdef MPP_LAND
7361          if(my_id .eq. IO_id) then
7362             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7363          endif
7364          call mpp_land_bcast_int1(iret)
7365          if (iret /= 0) then
7366 #ifdef HYDRO_D
7367             print*, 'read_rst_crt_reach_nc: variable not found: name = "', trim(varStr)//'"'
7368 #endif
7369
7370             if(allocated(var))  deallocate(var)
7371
7372             !! JLM: is this desirable?
7373             !! JLM I think so, maybe an option to this routine specifying if errors are fatal?
7374             if (fatalErr_local) &
7375                  call hydro_stop("read_rst_crt_reach_nc: variable not found: "//trim(varStr))
7376
7377             return
7378          endif
7379 #ifdef HYDRO_D
7380          print*, "read restart variable ", varStr
7381          call flush(6)
7382 #endif
7383          if(my_id .eq. IO_id) then
7384             var = 0.0
7385             iret = nf90_get_var(ncid, varid, var)
7386             !! JLM need a check here...
7387
7388             iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor)
7389             if(iret .eq. 0) var = var * scale_factor
7390             iret = nf90_get_att(ncid, varid, 'add_offset', add_offset)
7391             if(iret .eq. 0) var = var + add_offset
7392
7393          endif
7394          call ReachLS_decomp(var,   var_out)
7395          if(allocated(var)) deallocate(var)
7396 #else
7397             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7398            if (iret /= 0) then
7399 #ifdef HYDRO_D
7400                print*, 'variable not found: name = "', trim(varStr)//'"'
7401 #endif
7402                if(allocated(var)) deallocate(var)
7403                return
7404             endif
7405 #ifdef HYDRO_D
7406          print*, "read restart variable ", varStr
7407 #endif
7408          iret = nf90_get_var(ncid, varid, var_out)
7409          if(allocated(var)) deallocate(var)
7410 #endif
7411          return
7412          end subroutine read_rst_crt_reach_nc_real8
7413
7414
7415       subroutine hrldas_out()
7416       end subroutine hrldas_out
7417
7418
7419 subroutine READ_CHROUTING1( &
7420      IXRT,         JXRT,              fgDEM,        CH_NETRT, &
7421      CH_LNKRT,     LAKE_MSKRT,        FROM_NODE,    TO_NODE,  &
7422      TYPEL,        ORDER,             MAXORDER,     NLINKS,   &
7423      NLAKES,       CHANLEN,           MannN,        So,       &
7424      ChSSlp,       Bw,                Tw,                     &
7425      Tw_CC,        n_CC,              ChannK,       HRZAREA,      LAKEMAXH, &
7426      WEIRH,        WEIRC,             WEIRL,        DAML,     &
7427      ORIFICEC,     ORIFICEA,          ORIFICEE,               &
7428      reservoir_type_specified,        reservoir_type,         &
7429      reservoir_parameter_file,        LATLAKE,      LONLAKE,  &
7430      ELEVLAKE,     dist,              ZELEV,        LAKENODE, &
7431      CH_NETLNK,    CHANXI,            CHANYJ,       CHLAT,    &
7432      CHLON,        channel_option,    LATVAL,       LONVAL,   &
7433      STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f, LAKEIDM,  &
7434      UDMP_OPT                                                 & !! no comma at end
7435 #ifdef MPP_LAND
7436     ,Link_Location                                         &
7437 #endif
7438     )
7439
7440 #ifdef MPP_LAND
7441 use module_mpp_land, only:  my_id, io_id
7442 #endif
7443 integer, intent(IN)                          :: IXRT,JXRT, UDMP_OPT
7444 integer                                      :: CHANRTSWCRT, NLINKS, NLAKES
7445 real, intent(IN), dimension(IXRT,JXRT)       :: fgDEM
7446 integer, dimension(IXRT,JXRT)                :: DIRECTION
7447 integer, dimension(IXRT,JXRT)                :: GSTRMFRXSTPTS
7448 integer, intent(IN), dimension(IXRT,JXRT)    :: CH_NETRT
7449 integer(kind=int64), intent(IN), dimension(IXRT,JXRT)    :: CH_LNKRT
7450 integer, intent(INOUT), dimension(IXRT,JXRT) :: LAKE_MSKRT
7451 integer,                dimension(IXRT,JXRT) :: GORDER  !-- gridded stream orderk
7452 #ifdef MPP_LAND
7453 integer(kind=int64),    dimension(IXRT,JXRT) :: Link_Location !-- gridded stream orderk
7454 integer :: LNLINKSL
7455 #endif
7456 integer                                      :: I,J,K,channel_option
7457 real, intent(OUT), dimension(IXRT,JXRT)      :: LATVAL, LONVAL
7458 character(len=28)                            :: dir
7459 !Dummy inverted grids from arc
7460
7461 !----DJG,DNY New variables for channel and lake routing
7462 character(len=155)       :: header
7463 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: FROM_NODE
7464 real, intent(INOUT),  dimension(NLINKS)      :: ZELEV
7465 real, intent(INOUT),  dimension(NLINKS)      :: CHLAT,CHLON
7466
7467 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: TO_NODE
7468 integer, intent(INOUT),  dimension(NLINKS)   :: TYPEL
7469 integer, intent(INOUT),  dimension(NLINKS)   :: ORDER
7470 integer, intent(INOUT),  dimension(NLINKS)   :: STRMFRXSTPTS
7471
7472 integer, intent(INOUT)                       :: MAXORDER
7473 real, intent(INOUT),  dimension(NLINKS)      :: CHANLEN   !channel length
7474 real, intent(INOUT),  dimension(NLINKS)      :: MannN, So !mannings N
7475 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: LAKENODE !,LINKID   ! identifies which nodes pour into which lakes
7476 real, intent(IN)                             :: dist(ixrt,jxrt,9)
7477
7478 integer(kind=int64), intent(IN), dimension(IXRT,JXRT)    :: CH_NETLNK
7479 real,  dimension(IXRT,JXRT)                  :: ChSSlpG,BwG,TwG,MannNG  !channel properties
7480 real,  dimension(IXRT,JXRT)                  :: Tw_CCG,n_CCG            !channel properties of compound
7481 real,  dimension(IXRT,JXRT)                  :: ChannKG                 !Channel Infiltration
7482 real,  dimension(IXRT,JXRT)                  :: chanDepth, elrt
7483
7484
7485 !-- store the location x,y location of the channel element
7486 integer, intent(INOUT), dimension(NLINKS)   :: CHANXI, CHANYJ
7487 integer(kind=int64), dimension(:) ::  LAKEIDM
7488
7489 !--reservoir/lake attributes
7490 logical, intent(IN)                                 :: reservoir_type_specified
7491 real, intent(INOUT),  dimension(:)      :: HRZAREA
7492
7493 real, intent(INOUT),  dimension(:)      :: LAKEMAXH, WEIRH
7494 real, intent(INOUT),  dimension(:)      :: WEIRC
7495 real, intent(INOUT),  dimension(:)      :: WEIRL
7496 real, intent(INOUT),  dimension(:)      :: DAML
7497 real, intent(INOUT),  dimension(:)      :: ORIFICEC
7498 real, intent(INOUT),  dimension(:)      :: ORIFICEA
7499 real, intent(INOUT),  dimension(:)      :: ORIFICEE
7500 integer, intent(INOUT), dimension(:)    :: reservoir_type
7501 character(len=*), intent(in)            :: reservoir_parameter_file
7502 real, intent(INOUT),  dimension(:)      :: LATLAKE,LONLAKE,ELEVLAKE
7503 real, intent(INOUT),  dimension(:)      :: ChSSlp, Bw, Tw
7504 real, intent(INOUT),  dimension(:)      :: Tw_CC, n_CC, ChannK ! channel properties of compund
7505
7506
7507 character(len=*  )                           :: geo_finegrid_flnm, route_lake_f
7508 character(len=256)                           :: var_name
7509
7510 integer                                      :: tmp, cnt, ncid, iret, jj,ct
7511 integer                                      :: IOstatus
7512 integer(kind=int64)              :: OUTLAKEID
7513
7514 real                                         :: gc,n
7515 integer :: did
7516 logical :: fexist
7517
7518 did = 1
7519
7520 !---------------------------------------------------------
7521 ! End Declarations
7522 !---------------------------------------------------------
7523
7524
7525 !LAKEIDX  = -999
7526 !LAKELINKID = 0
7527 MAXORDER = -9999
7528 !initialize GSTRM
7529 GSTRMFRXSTPTS = -9999
7530
7531 !yw initialize the array.
7532 to_node =   MAXORDER
7533 from_node = MAXORDER
7534 #ifdef MPP_LAND
7535 Link_location = MAXORDER
7536 #endif
7537
7538 var_name = "LATITUDE"
7539 call nreadRT2d_real  (   &
7540      var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm))
7541
7542 var_name = "LONGITUDE"
7543 call nreadRT2d_real(   &
7544      var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm))
7545
7546 var_name = "LAKEGRID"
7547 call nreadRT2d_int(&
7548      var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm))
7549
7550 var_name = "FLOWDIRECTION"
7551 call nreadRT2d_int(&
7552      var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm))
7553
7554 var_name = "STREAMORDER"
7555 call nreadRT2d_int(&
7556      var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm))
7557
7558
7559 var_name = "frxst_pts"
7560 call nreadRT2d_int(&
7561      var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm))
7562
7563 !!!Flip y-dimension of highres grids from exported Arc files...
7564
7565 var_name = "CHAN_DEPTH"
7566 call nreadRT2d_real(   &
7567      var_name,chanDepth,ixrt,jxrt,trim(geo_finegrid_flnm))
7568
7569 if(nlst(did)%GWBASESWCRT .eq. 3) then
7570    elrt = fgDEM - chanDepth
7571 else
7572    elrt = fgDEM     !ywtmp
7573 endif
7574
7575 ct = 0
7576
7577 ! temp fix for buggy Arc export...
7578 do j=1,jxrt
7579    do i=1,ixrt
7580       if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128
7581    end do
7582 end do
7583
7584 cnt    = 0
7585 BwG    = 0.0
7586 TwG    = 0.0
7587 Tw_CCG = 0.0
7588 n_CCG  = 0.0
7589
7590
7591 ChSSlpG = 0.0
7592 MannNG  = 0.0
7593 TYPEL   = 0
7594 MannN   = 0.0
7595 Bw      = 0.0
7596 Tw      = 0.0
7597 Tw_CC   = 0.0
7598 n_CC    = 0.0
7599 ChSSlp  = 0.0
7600 ChannK  = 0.0
7601 ChannKG = 0.0
7602
7603
7604 if (channel_option .eq. 3) then
7605
7606 #ifdef MPP_LAND
7607   if(my_id .eq. IO_id) then
7608 #endif
7609
7610     if (NLAKES .gt. 0) then
7611       inquire (file=trim(route_lake_f), exist=fexist)
7612       if(fexist) then
7613         ! use netcdf lake file of LAKEPARM.nc
7614         iret = nf90_open(trim(route_lake_f), NF90_NOWRITE, ncid)
7615         if( iret .eq. 0 ) then
7616           iret = nf90_close(ncid)
7617           write(6,*) "Before read LAKEPARM from NetCDF ", trim(route_lake_f)
7618           write(6,*) "NLAKES = ", NLAKES
7619           call flush(6)
7620           call read_route_lake_netcdf(trim(route_lake_f),HRZAREA, &
7621                 LAKEMAXH, WEIRH, WEIRC,WEIRL, DAML, ORIFICEC,       &
7622                 ORIFICEA,  ORIFICEE, reservoir_type_specified, reservoir_type, &
7623                 reservoir_parameter_file, LAKEIDM, latlake, lonlake, ELEVLAKE, NLAKES)
7624         else
7625           open(unit=79,file=trim(route_lake_f), form='formatted',status='old')
7626           write(6,*) "Before read LAKEPARM from text ", trim(route_lake_f)
7627           write(6,*) "NLAKES = ", NLAKES
7628           call flush(6)
7629           read(79,*)  header  !-- read the lake file
7630           do i=1, NLAKES
7631             read (79,*,err=5101) tmp, HRZAREA(i),LAKEMAXH(i), &
7632             WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),&
7633             LATLAKE(i), LONLAKE(i),ELEVLAKE(i), WEIRH(i), reservoir_type(i)
7634           enddo
7635 5101      continue
7636           close(79)
7637         endif !endif for iret
7638       else ! lake parm files does not exist
7639         call hydro_stop("Fatal error: route_lake_f must be specified in the hydro.namelist")
7640         !write(6,*) "ERROR: route_lake_f required for lakes"
7641         !write(6,*) "NLAKES = ", NLAKES
7642         !call flush(6)
7643       endif !endif for fexist
7644     endif ! endif for nlakes
7645
7646 #ifdef MPP_LAND
7647    endif
7648
7649    if (NLAKES > 0) then
7650       call mpp_land_bcast_real(NLAKES,HRZAREA)
7651       call mpp_land_bcast_real(NLAKES,LAKEMAXH)
7652       call mpp_land_bcast_real(NLAKES,WEIRH  )
7653       call mpp_land_bcast_real(NLAKES,WEIRC  )
7654       call mpp_land_bcast_real(NLAKES,WEIRL  )
7655       call mpp_land_bcast_real(NLAKES,DAML)
7656       call mpp_land_bcast_real(NLAKES,ORIFICEC)
7657       call mpp_land_bcast_real(NLAKES,ORIFICEA)
7658       call mpp_land_bcast_real(NLAKES,ORIFICEE)
7659       call mpp_land_bcast_real(NLAKES,LATLAKE )
7660       call mpp_land_bcast_real(NLAKES,LONLAKE )
7661       call mpp_land_bcast_real(NLAKES,ELEVLAKE)
7662       call mpp_land_bcast_int(NLAKES, reservoir_type)
7663    endif
7664 #endif
7665 end if  !! channel_option .eq. 3
7666
7667 if (UDMP_OPT .eq. 1) return
7668
7669 !DJG inv       DO j = JXRT,1,-1  !rows
7670 do j = 1,JXRT  !rows
7671    do i = 1 ,IXRT   !colsumns
7672
7673       if (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order
7674
7675          if ((DIRECTION(i, j) .eq. 64) .and. (j + 1 .le. JXRT) ) then !North
7676             if(CH_NETRT(i,j+1).ge.0) then
7677 #ifdef MPP_LAND
7678                cnt = CH_NETLNK(i,j)
7679 #else
7680                cnt = cnt + 1
7681 #endif
7682                ORDER(cnt) = GORDER(i,j)
7683                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7684                ZELEV(cnt) = ELRT(i,j)
7685                MannN(cnt) = MannNG(i,j)
7686                ChSSlp(cnt) = ChSSlpG(i,j)
7687                Bw(cnt) = BwG(i,j)
7688                ChannK(cnt) = ChannKG(i,j)
7689                Tw(cnt) = TwG(i,j)
7690                Tw_CC(cnt) = Tw_CCG(i,j)
7691                n_CC(cnt) = n_CCG(i,j)
7692                CHLAT(cnt) = LATVAL(i,j)
7693                CHLON(cnt) = LONVAL(i,j)
7694                FROM_NODE(cnt) = CH_NETLNK(i, j)
7695                TO_NODE(cnt) = CH_NETLNK(i, j + 1)
7696                CHANLEN(cnt) = dist(i,j,1)
7697                CHANXI(cnt) = i
7698                CHANYJ(cnt) = j
7699 #ifdef MPP_LAND
7700                Link_Location(i,j) = cnt
7701 #endif
7702             endif
7703
7704          else if ((DIRECTION(i, j) .eq. 128) .and. (i + 1 .le. IXRT) &
7705               .and. (j + 1 .le. JXRT)  ) then !North East
7706
7707             if(CH_NETRT(i+1,j+1).ge.0) then
7708 #ifdef MPP_LAND
7709                cnt = CH_NETLNK(i,j)
7710 #else
7711                cnt = cnt + 1
7712 #endif
7713                ORDER(cnt) = GORDER(i,j)
7714                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7715                ZELEV(cnt) = ELRT(i,j)
7716                MannN(cnt) = MannNG(i,j)
7717                ChSSlp(cnt) = ChSSlpG(i,j)
7718                Bw(cnt) = BwG(i,j)
7719                ChannK(cnt) = ChannKG(i,j)
7720                Tw(cnt) = TwG(i,j)
7721                Tw_CC(cnt) = Tw_CCG(i,j)
7722                n_CC(cnt) = n_CCG(i,j)
7723                CHLAT(cnt) = LATVAL(i,j)
7724                CHLON(cnt) = LONVAL(i,j)
7725                FROM_NODE(cnt) = CH_NETLNK(i, j)
7726                TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1)
7727                CHANLEN(cnt) = dist(i,j,2)
7728                CHANXI(cnt) = i
7729                CHANYJ(cnt) = j
7730 #ifdef MPP_LAND
7731                Link_Location(i,j) = cnt
7732 #endif
7733             endif
7734
7735          else if ((DIRECTION(i, j) .eq. 1) .and. (i + 1 .le. IXRT) ) then !East
7736
7737             if(CH_NETRT(i+1,j).ge.0) then
7738 #ifdef MPP_LAND
7739                cnt = CH_NETLNK(i,j)
7740 #else
7741                cnt = cnt + 1
7742 #endif
7743                ORDER(cnt) = GORDER(i,j)
7744                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7745                ZELEV(cnt) = ELRT(i,j)
7746                MannN(cnt) = MannNG(i,j)
7747                ChSSlp(cnt) = ChSSlpG(i,j)
7748                Bw(cnt) = BwG(i,j)
7749                ChannK(cnt) = ChannKG(i,j)
7750                Tw(cnt) = TwG(i,j)
7751                Tw_CC(cnt) = Tw_CCG(i,j)
7752                n_CC(cnt) = n_CCG(i,j)
7753                CHLAT(cnt) = LATVAL(i,j)
7754                CHLON(cnt) = LONVAL(i,j)
7755                FROM_NODE(cnt) = CH_NETLNK(i, j)
7756                TO_NODE(cnt) = CH_NETLNK(i + 1, j)
7757                CHANLEN(cnt) = dist(i,j,3)
7758                CHANXI(cnt) = i
7759                CHANYJ(cnt) = j
7760 #ifdef MPP_LAND
7761                Link_Location(i,j) = cnt
7762 #endif
7763             endif
7764
7765          else if ((DIRECTION(i, j) .eq. 2) .and. (i + 1 .le. IXRT) &
7766               .and. (j - 1 .ne. 0)  ) then !south east
7767
7768             if(CH_NETRT(i+1,j-1).ge.0) then
7769 #ifdef MPP_LAND
7770                cnt = CH_NETLNK(i,j)
7771 #else
7772                cnt = cnt + 1
7773 #endif
7774                ORDER(cnt) = GORDER(i,j)
7775                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7776                ZELEV(cnt) = ELRT(i,j)
7777                MannN(cnt) = MannNG(i,j)
7778                ChSSlp(cnt) = ChSSlpG(i,j)
7779                Bw(cnt) = BwG(i,j)
7780                ChannK(cnt) = ChannKG(i,j)
7781                Tw(cnt) = TwG(i,j)
7782                Tw_CC(cnt) = Tw_CCG(i,j)
7783                n_CC(cnt) = n_CCG(i,j)
7784                CHLAT(cnt) = LATVAL(i,j)
7785                CHLON(cnt) = LONVAL(i,j)
7786                FROM_NODE(cnt) = CH_NETLNK(i, j)
7787                TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1)
7788                CHANLEN(cnt) = dist(i,j,4)
7789                CHANXI(cnt) = i
7790                CHANYJ(cnt) = j
7791 #ifdef MPP_LAND
7792                Link_Location(i,j) = cnt
7793 #endif
7794             endif
7795
7796          else if ((DIRECTION(i, j) .eq. 4) .and. (j - 1 .ne. 0) ) then !due south
7797
7798             if(CH_NETRT(i,j-1).ge.0) then
7799 #ifdef MPP_LAND
7800                cnt = CH_NETLNK(i,j)
7801 #else
7802                cnt = cnt + 1
7803 #endif
7804                ORDER(cnt) = GORDER(i,j)
7805                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7806                ZELEV(cnt) = ELRT(i,j)
7807                MannN(cnt) = MannNG(i,j)
7808                ChSSlp(cnt) = ChSSlpG(i,j)
7809                Bw(cnt) = BwG(i,j)
7810                ChannK(cnt) = ChannKG(i,j)
7811                Tw(cnt) = TwG(i,j)
7812                Tw_CC(cnt) = Tw_CCG(i,j)
7813                n_CC(cnt) = n_CCG(i,j)
7814                CHLAT(cnt) = LATVAL(i,j)
7815                CHLON(cnt) = LONVAL(i,j)
7816                FROM_NODE(cnt) = CH_NETLNK(i, j)
7817                TO_NODE(cnt) = CH_NETLNK(i, j - 1)
7818                CHANLEN(cnt) = dist(i,j,5)
7819                CHANXI(cnt) = i
7820                CHANYJ(cnt) = j
7821 #ifdef MPP_LAND
7822                Link_Location(i,j) = cnt
7823 #endif
7824             endif
7825
7826          else if ((DIRECTION(i, j) .eq. 8) .and. (i - 1 .gt. 0) &
7827               .and. (j - 1 .ne. 0) ) then !south west
7828
7829             if(CH_NETRT(i-1,j-1).ge.0) then
7830 #ifdef MPP_LAND
7831                cnt = CH_NETLNK(i,j)
7832 #else
7833                cnt = cnt + 1
7834 #endif
7835                ORDER(cnt) = GORDER(i,j)
7836                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7837                ZELEV(cnt) = ELRT(i,j)
7838                MannN(cnt) = MannNG(i,j)
7839                ChSSlp(cnt) = ChSSlpG(i,j)
7840                Bw(cnt) = BwG(i,j)
7841                ChannK(cnt) = ChannKG(i,j)
7842                Tw(cnt) = TwG(i,j)
7843                Tw_CC(cnt) = Tw_CCG(i,j)
7844                n_CC(cnt) = n_CCG(i,j)
7845                CHLAT(cnt) = LATVAL(i,j)
7846                CHLON(cnt) = LONVAL(i,j)
7847                FROM_NODE(cnt) = CH_NETLNK(i,j)
7848                TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1)
7849                CHANLEN(cnt) = dist(i,j,6)
7850                CHANXI(cnt) = i
7851                CHANYJ(cnt) = j
7852 #ifdef MPP_LAND
7853                Link_Location(i,j) = cnt
7854 #endif
7855             endif
7856
7857          else if ((DIRECTION(i, j) .eq. 16) .and. (i - 1 .gt. 0) ) then !West
7858
7859             if(CH_NETRT(i-1,j).ge.0) then
7860 #ifdef MPP_LAND
7861                cnt = CH_NETLNK(i,j)
7862 #else
7863                cnt = cnt + 1
7864 #endif
7865                FROM_NODE(cnt) = CH_NETLNK(i, j)
7866                ORDER(cnt) = GORDER(i,j)
7867                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7868                ZELEV(cnt) = ELRT(i,j)
7869                MannN(cnt) = MannNG(i,j)
7870                ChSSlp(cnt) = ChSSlpG(i,j)
7871                Bw(cnt) = BwG(i,j)
7872                ChannK(cnt) = ChannKG(i,j)
7873                Tw(cnt) = TwG(i,j)
7874                Tw_CC(cnt) = Tw_CCG(i,j)
7875                n_CC(cnt) = n_CCG(i,j)
7876                CHLAT(cnt) = LATVAL(i,j)
7877                CHLON(cnt) = LONVAL(i,j)
7878                TO_NODE(cnt) = CH_NETLNK(i - 1, j)
7879                CHANLEN(cnt) = dist(i,j,7)
7880                CHANXI(cnt) = i
7881                CHANYJ(cnt) = j
7882 #ifdef MPP_LAND
7883                Link_Location(i,j) = cnt
7884 #endif
7885             endif
7886
7887          else if ((DIRECTION(i, j) .eq. 32) .and. (i - 1 .gt. 0) &
7888               .and. (j + 1 .le. JXRT)  ) then !North West
7889
7890             if(CH_NETRT(i-1,j+1).ge.0) then
7891 #ifdef MPP_LAND
7892                cnt = CH_NETLNK(i,j)
7893 #else
7894                cnt = cnt + 1
7895 #endif
7896                ORDER(cnt) = GORDER(i,j)
7897                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7898                ZELEV(cnt) = ELRT(i,j)
7899                MannN(cnt) = MannNG(i,j)
7900                ChSSlp(cnt) = ChSSlpG(i,j)
7901                Bw(cnt) = BwG(i,j)
7902                ChannK(cnt) = ChannKG(i,j)
7903                Tw(cnt) = TwG(i,j)
7904                Tw_CC(cnt) = Tw_CCG(i,j)
7905                n_CC(cnt) = n_CCG(i,j)
7906                CHLAT(cnt) = LATVAL(i,j)
7907                CHLON(cnt) = LONVAL(i,j)
7908                FROM_NODE(cnt) = CH_NETLNK(i, j)
7909                TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1)
7910                CHANLEN(cnt) = dist(i,j,8)
7911                CHANXI(cnt) = i
7912                CHANYJ(cnt) = j
7913 #ifdef MPP_LAND
7914                Link_Location(i,j) = cnt
7915 #endif
7916             endif
7917          else
7918 #ifdef HYDRO_D
7919             !print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east
7920 #endif
7921          end if
7922
7923       end if !CH_NETRT check for this node
7924
7925    end do
7926 end do
7927
7928 #ifdef HYDRO_D
7929 print *, "after exiting the channel, this many nodes", cnt
7930 write(*,*) " "
7931 #endif
7932
7933
7934 !Find out if the boundaries are on an edge
7935 !DJG inv       DO j = JXRT,1,-1
7936 do j = 1,JXRT
7937    do i = 1 ,IXRT
7938       if (CH_NETRT(i, j) .ge. 0) then !get its direction
7939
7940          if (DIRECTION(i, j).eq. 64) then
7941             if( j + 1 .gt. JXRT)  then         !-- 64's can only flow north
7942                goto 101
7943
7944             elseif ( CH_NETRT(i,j+1) .lt. 0) then !North
7945
7946                goto 101
7947             endif
7948             goto 102
7949 101         continue
7950 #ifdef MPP_LAND
7951             cnt = CH_NETLNK(i,j)
7952 #else
7953             cnt = cnt + 1
7954 #endif
7955             ORDER(cnt) = GORDER(i,j)
7956             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7957             ZELEV(cnt) = ELRT(i,j)
7958             MannN(cnt) = MannNG(i,j)
7959             ChSSlp(cnt) = ChSSlpG(i,j)
7960             Bw(cnt) = BwG(i,j)
7961             ChannK(cnt) = ChannKG(i,j)
7962             Tw(cnt) = TwG(i,j)
7963             Tw_CC(cnt) = Tw_CCG(i,j)
7964             n_CC(cnt) = n_CCG(i,j)
7965             CHLAT(cnt) = LATVAL(i,j)
7966             CHLON(cnt) = LONVAL(i,j)
7967             if(j+1 .gt. JXRT) then !-- an edge
7968                TYPEL(cnt) = 1
7969             elseif(LAKE_MSKRT(i,j+1).gt.0) then
7970                TYPEL(cnt) = 2
7971                LAKENODE(cnt) = LAKE_MSKRT(i,j+1)
7972             else
7973                TYPEL(cnt) = 1
7974             endif
7975             FROM_NODE(cnt) = CH_NETLNK(i, j)
7976             CHANLEN(cnt) = dist(i,j,1)
7977             CHANXI(cnt) = i
7978             CHANYJ(cnt) = j
7979 #ifdef MPP_LAND
7980             Link_Location(i,j) = cnt
7981 #endif
7982 #ifdef HYDRO_D
7983             !                print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
7984 #endif
7985 102         continue
7986
7987          else if ( DIRECTION(i, j) .eq. 128) then
7988
7989             !-- 128's can flow out of the North or East edge
7990             if ((i + 1 .gt. IXRT)   .or.  (j + 1 .gt. JXRT))  then !   this is due north edge
7991                goto 201
7992             elseif (CH_NETRT(i + 1, j + 1).lt.0) then !North East
7993                goto 201
7994             endif
7995 !#endif
7996             goto 202
7997 201         continue
7998 #ifdef MPP_LAND
7999             cnt = CH_NETLNK(i,j)
8000 #else
8001             cnt = cnt + 1
8002 #endif
8003             ORDER(cnt) = GORDER(i,j)
8004             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8005             ZELEV(cnt) = ELRT(i,j)
8006             MannN(cnt) = MannNG(i,j)
8007             ChSSlp(cnt) = ChSSlpG(i,j)
8008             Bw(cnt) = BwG(i,j)
8009             ChannK(cnt) = ChannKG(i,j)
8010             Tw(cnt) = TwG(i,j)
8011             Tw_CC(cnt) = Tw_CCG(i,j)
8012             n_CC(cnt) = n_CCG(i,j)
8013             CHLAT(cnt) = LATVAL(i,j)
8014             CHLON(cnt) = LONVAL(i,j)
8015             if((i+1 .gt. IXRT) .or. (j+1 .gt. JXRT))  then ! an edge
8016                TYPEL(cnt) = 1
8017             elseif(LAKE_MSKRT(i+1,j+1).gt.0) then
8018                TYPEL(cnt) = 2
8019                LAKENODE(cnt) = LAKE_MSKRT(i+1,j+1)
8020             else
8021                TYPEL(cnt) = 1
8022             endif
8023             FROM_NODE(cnt) = CH_NETLNK(i, j)
8024             CHANLEN(cnt) = dist(i,j,2)
8025             CHANXI(cnt) = i
8026             CHANYJ(cnt) = j
8027 #ifdef MPP_LAND
8028             Link_Location(i,j) = cnt
8029 #endif
8030 #ifdef HYDRO_D
8031             !print *, "Pour Point NE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8032 #endif
8033 202         continue
8034
8035          else if (DIRECTION(i, j) .eq. 1) then
8036
8037             if(i + 1 .gt. IXRT) then     !-- 1's can only flow due east
8038                goto 301
8039             elseif(CH_NETRT(i + 1, j) .lt. 0) then !East
8040                goto 301
8041             endif
8042             goto 302
8043 301         continue
8044 #ifdef MPP_LAND
8045             cnt = CH_NETLNK(i,j)
8046 #else
8047             cnt = cnt + 1
8048 #endif
8049             ORDER(cnt) = GORDER(i,j)
8050             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8051             ZELEV(cnt) = ELRT(i,j)
8052             MannN(cnt) = MannNG(i,j)
8053             ChSSlp(cnt) = ChSSlpG(i,j)
8054             Bw(cnt) = BwG(i,j)
8055             ChannK(cnt) = ChannKG(i,j)
8056             Tw(cnt) = TwG(i,j)
8057             Tw_CC(cnt) = Tw_CCG(i,j)
8058             n_CC(cnt) = n_CCG(i,j)
8059             CHLAT(cnt) = LATVAL(i,j)
8060             CHLON(cnt) = LONVAL(i,j)
8061             if(i+1 .gt. IXRT) then  !an edge
8062                TYPEL(cnt) = 1
8063             elseif(LAKE_MSKRT(i+1,j).gt.0) then
8064                TYPEL(cnt) = 2
8065                LAKENODE(cnt) = LAKE_MSKRT(i+1,j)
8066             else
8067                TYPEL(cnt) = 1
8068             endif
8069             FROM_NODE(cnt) = CH_NETLNK(i, j)
8070             CHANLEN(cnt) = dist(i,j,3)
8071             CHANXI(cnt) = i
8072             CHANYJ(cnt) = j
8073 #ifdef MPP_LAND
8074             Link_Location(i,j) = cnt
8075 #endif
8076 #ifdef HYDRO_D
8077             !print *, "Pour Point E", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8078 #endif
8079 302         continue
8080
8081          else if (DIRECTION(i, j) .eq. 2) then
8082
8083             !-- 2's can flow out of east or south edge
8084             if((i + 1 .gt. IXRT) .or.  (j - 1 .eq. 0)) then     !-- this is the south edge
8085                goto 401
8086             elseif (CH_NETRT(i + 1, j - 1) .lt.0) then !south east
8087                goto 401
8088             endif
8089             goto 402
8090 401         continue
8091 #ifdef MPP_LAND
8092             cnt = CH_NETLNK(i,j)
8093 #else
8094             cnt = cnt + 1
8095 #endif
8096             ORDER(cnt) = GORDER(i,j)
8097             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8098             ZELEV(cnt) = ELRT(i,j)
8099             MannN(cnt) = MannNG(i,j)
8100             ChSSlp(cnt) = ChSSlpG(i,j)
8101             Bw(cnt) = BwG(i,j)
8102             ChannK(cnt) = ChannKG(i,j)
8103             Tw(cnt) = TwG(i,j)
8104             Tw_CC(cnt) = Tw_CCG(i,j)
8105             n_CC(cnt) = n_CCG(i,j)
8106             CHLAT(cnt) = LATVAL(i,j)
8107             CHLON(cnt) = LONVAL(i,j)
8108             if((i+1 .gt. IXRT) .or. (j-1 .eq. 0)) then !an edge
8109                TYPEL(cnt) = 1
8110             elseif(LAKE_MSKRT(i+1,j-1).gt.0) then
8111                TYPEL(cnt) = 2
8112                LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1)
8113             else
8114                TYPEL(cnt) = 1
8115             endif
8116             FROM_NODE(cnt) = CH_NETLNK(i, j)
8117             CHANLEN(cnt) = dist(i,j,4)
8118             CHANXI(cnt) = i
8119             CHANYJ(cnt) = j
8120 #ifdef MPP_LAND
8121             Link_Location(i,j) = cnt
8122 #endif
8123 #ifdef HYDRO_D
8124             !print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8125 #endif
8126 402         continue
8127
8128          else if (DIRECTION(i, j) .eq. 4)  then
8129
8130             if(j - 1 .eq. 0) then         !-- 4's can only flow due south
8131                goto 501
8132             elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south
8133                goto 501
8134             endif
8135             goto 502
8136 501         continue
8137 #ifdef MPP_LAND
8138             cnt = CH_NETLNK(i,j)
8139 #else
8140             cnt = cnt + 1
8141 #endif
8142             ORDER(cnt) = GORDER(i,j)
8143             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8144             ZELEV(cnt) = ELRT(i,j)
8145             MannN(cnt) = MannNG(i,j)
8146             ChSSlp(cnt) = ChSSlpG(i,j)
8147             Bw(cnt) = BwG(i,j)
8148             ChannK(cnt) = ChannKG(i,j)
8149             Tw(cnt) = TwG(i,j)
8150             Tw_CC(cnt) = Tw_CCG(i,j)
8151             n_CC(cnt) = n_CCG(i,j)
8152             CHLAT(cnt) = LATVAL(i,j)
8153             CHLON(cnt) = LONVAL(i,j)
8154             if(j-1 .eq. 0) then !- an edge
8155                TYPEL(cnt) =1
8156             elseif(LAKE_MSKRT(i,j-1).gt.0) then
8157                TYPEL(cnt) = 2
8158                LAKENODE(cnt) = LAKE_MSKRT(i,j-1)
8159             else
8160                TYPEL(cnt) = 1
8161             endif
8162             FROM_NODE(cnt) = CH_NETLNK(i, j)
8163             CHANLEN(cnt) = dist(i,j,5)
8164             CHANXI(cnt) = i
8165             CHANYJ(cnt) = j
8166 #ifdef MPP_LAND
8167             Link_Location(i,j) = cnt
8168 #endif
8169 #ifdef HYDRO_D
8170             !print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8171 #endif
8172 502         continue
8173
8174          else if ( DIRECTION(i, j) .eq. 8) then
8175
8176             !-- 8's can flow south or west
8177             if( (i - 1 .le. 0) .or.  (j - 1 .eq. 0)) then        !-- this is the south edge
8178                goto 601
8179             elseif (CH_NETRT(i - 1, j - 1).lt.0) then !south west
8180                goto 601
8181             endif
8182             goto 602
8183 601         continue
8184 #ifdef MPP_LAND
8185             cnt = CH_NETLNK(i,j)
8186 #else
8187             cnt = cnt + 1
8188 #endif
8189             ORDER(cnt) = GORDER(i,j)
8190             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8191             ZELEV(cnt) = ELRT(i,j)
8192             MannN(cnt) = MannNG(i,j)
8193             ChSSlp(cnt) = ChSSlpG(i,j)
8194             Bw(cnt) = BwG(i,j)
8195             ChannK(cnt) = ChannKG(i,j)
8196             Tw(cnt) = TwG(i,j)
8197             Tw_CC(cnt) = Tw_CCG(i,j)
8198             n_CC(cnt) = n_CCG(i,j)
8199             CHLAT(cnt) = LATVAL(i,j)
8200             CHLON(cnt) = LONVAL(i,j)
8201             if( (i-1 .eq. 0) .or. (j-1 .eq. 0) ) then !- an edge
8202                TYPEL(cnt) = 1
8203             elseif(LAKE_MSKRT(i-1,j-1).gt.0) then
8204                TYPEL(cnt) = 2
8205                LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1)
8206             else
8207                TYPEL(cnt) = 1
8208             endif
8209             FROM_NODE(cnt) = CH_NETLNK(i, j)
8210             CHANLEN(cnt) = dist(i,j,6)
8211             CHANXI(cnt) = i
8212             CHANYJ(cnt) = j
8213 #ifdef MPP_LAND
8214             Link_Location(i,j) = cnt
8215 #endif
8216 #ifdef HYDRO_D
8217             !print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8218 #endif
8219 602         continue
8220
8221          else if (DIRECTION(i, j) .eq. 16) then
8222
8223             if( i - 1 .le.0) then                 !16's can only flow due west
8224                goto 701
8225             elseif( CH_NETRT(i - 1, j).lt.0) then !West
8226                goto 701
8227             endif
8228             goto 702
8229 701         continue
8230 #ifdef MPP_LAND
8231             cnt = CH_NETLNK(i,j)
8232 #else
8233             cnt = cnt + 1
8234 #endif
8235             ORDER(cnt) = GORDER(i,j)
8236             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8237             ZELEV(cnt) = ELRT(i,j)
8238             MannN(cnt) = MannNG(i,j)
8239             ChSSlp(cnt) = ChSSlpG(i,j)
8240             Bw(cnt) = BwG(i,j)
8241             ChannK(cnt) = ChannKG(i,j)
8242             Tw(cnt) = TwG(i,j)
8243             Tw_CC(cnt) = Tw_CCG(i,j)
8244             n_CC(cnt) = n_CCG(i,j)
8245             CHLAT(cnt) = LATVAL(i,j)
8246             CHLON(cnt) = LONVAL(i,j)
8247             if(i-1 .eq. 0) then !-- an edge
8248                TYPEL(cnt) = 1
8249             elseif(LAKE_MSKRT(i-1,j).gt.0) then
8250                TYPEL(cnt) = 2
8251                LAKENODE(cnt) = LAKE_MSKRT(i-1,j)
8252             else
8253                TYPEL(cnt) = 1
8254             endif
8255             FROM_NODE(cnt) = CH_NETLNK(i, j)
8256             CHANLEN(cnt) = dist(i,j,7)
8257             CHANXI(cnt) = i
8258             CHANYJ(cnt) = j
8259 #ifdef MPP_LAND
8260             Link_Location(i,j) = cnt
8261 #endif
8262 #ifdef HYDRO_D
8263             !             print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8264 #endif
8265 702         continue
8266
8267          else if ( DIRECTION(i, j) .eq. 32) then
8268
8269             !-- 32's can flow either west or north
8270             if( (i - 1 .le. 0) .or.  (j + 1 .gt. JXRT)) then     !-- this is the north edge
8271                goto 801
8272             elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West
8273                goto 801
8274             endif
8275             goto 802
8276 801         continue
8277 #ifdef MPP_LAND
8278             cnt = CH_NETLNK(i,j)
8279 #else
8280             cnt = cnt + 1
8281 #endif
8282             ORDER(cnt) = GORDER(i,j)
8283             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8284             ZELEV(cnt) = ELRT(i,j)
8285             MannN(cnt) = MannNG(i,j)
8286             ChSSlp(cnt) = ChSSlpG(i,j)
8287             Bw(cnt) = BwG(i,j)
8288             ChannK(cnt) = ChannKG(i,j)
8289             Tw(cnt) = TwG(i,j)
8290             Tw_CC(cnt) = Tw_CCG(i,j)
8291             n_CC(cnt) = n_CCG(i,j)
8292             CHLAT(cnt) = LATVAL(i,j)
8293             CHLON(cnt) = LONVAL(i,j)
8294             if( (i-1 .eq. 0) .or. (j+1 .gt. JXRT)) then !-- an edge
8295                TYPEL(cnt) = 1
8296             elseif(LAKE_MSKRT(i-1,j+1).gt.0) then
8297                TYPEL(cnt) = 2
8298                LAKENODE(cnt) = LAKE_MSKRT(i-1,j+1)
8299             else
8300                TYPEL(cnt) = 1
8301             endif
8302             FROM_NODE(cnt) = CH_NETLNK(i, j)
8303             CHANLEN(cnt) = dist(i,j,8)
8304             CHANXI(cnt) = i
8305             CHANYJ(cnt) = j
8306 #ifdef MPP_LAND
8307             Link_Location(i,j) = cnt
8308 #endif
8309 #ifdef HYDRO_D
8310             !print *, "Pour Point NW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8311 #endif
8312 802         continue
8313
8314          endif
8315       endif !CH_NETRT check for this node
8316    end do
8317 end do
8318
8319 #ifdef MPP_LAND
8320 #ifdef HYDRO_D
8321 print*, "my_id=",my_id, "cnt = ", cnt
8322 #endif
8323 #endif
8324
8325 #ifdef MPP_LAND
8326 Link_location = CH_NETLNK
8327 call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,int(TYPEL, int64),NLINKS,99)
8328 call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,LAKENODE,NLINKS,99)
8329 #endif
8330
8331 end subroutine READ_CHROUTING1
8332
8333
8334 !! Author JLM.
8335 !! Separate the 2D channel routing memory from the vector/routelink channel routing memory.
8336 subroutine read_routelink(&
8337      TO_NODE,      TYPEL,        ORDER,    MAXORDER,   &
8338      NLAKES,       MUSK,         MUSX,                 &
8339      QLINK,        CHANLEN,      MannN,    So,         &
8340      ChSSlp,       Bw,           Tw,       Tw_CC,      &
8341      n_CC,         ChannK,       LAKEIDA,  HRZAREA,    &
8342      LAKEMAXH,     WEIRH,        WEIRC,   WEIRL, DAML, &
8343      ORIFICEC,     ORIFICEA,     ORIFICEE,             &
8344      reservoir_type_specified,   reservoir_type,       &
8345      reservoir_parameter_file,   LATLAKE,              &
8346      LONLAKE,      ELEVLAKE,     LAKEIDM,  LAKEIDX,    &
8347      route_link_f, route_lake_f, ZELEV,    CHLAT,      &
8348      CHLON,        NLINKSL,      LINKID,   GNLINKSL,   &
8349      NLINKS,       gages,        gageMiss               )
8350
8351 integer, intent(INOUT),  dimension(NLINKS) :: TYPEL, ORDER
8352 integer, intent(INOUT)                     :: MAXORDER
8353 integer                                    :: NLAKES
8354 real,    intent(INOUT),  dimension(NLINKS) :: MUSK, MUSX
8355 real,    intent(INOUT),  dimension(:,:)    :: QLINK  !channel flow
8356 real,    intent(INOUT),  dimension(NLINKS) :: CHANLEN, MannN, So
8357 real,    intent(INOUT),  dimension(:)      :: ChSSlp, Bw, Tw !added Top Width LKR/DY
8358 real,    intent(INOUT),  dimension(:)      :: Tw_CC, n_CC !compound chnannel params
8359 real,    intent(INOUT),  dimension(:)      :: ChannK !added ChanLoss
8360 real,    intent(INOUT),  dimension(:)      :: HRZAREA
8361 real,    intent(INOUT),  dimension(:)      :: LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML
8362 real,    intent(INOUT),  dimension(:)      :: ORIFICEC, ORIFICEA, ORIFICEE
8363 logical, intent(IN)                        :: reservoir_type_specified
8364 integer, intent(INOUT),  dimension(:)      :: reservoir_type
8365 character(len=*), intent(in)               :: reservoir_parameter_file
8366 real,    intent(INOUT),  dimension(:)      :: LATLAKE, LONLAKE, ELEVLAKE
8367 integer(kind=int64), intent(INOUT), dimension(:)  :: LAKEIDM !lake id in LAKEPARM table (.nc or .tbl)
8368 integer(kind=int64), intent(INOUT), dimension(:)  :: LAKEIDA !lake COMid 4all link on full nlinks database
8369 integer, intent(INOUT),  dimension(:)      :: LAKEIDX !seq index of lakes(1:Nlakes) mapped to COMID
8370 character(len=256)                         :: route_link_f, route_lake_f
8371 real,    intent(INOUT),  dimension(NLINKS) :: ZELEV, CHLAT, CHLON
8372 integer                                    :: NLINKS, NLINKSL
8373 integer(kind=int64), intent(INOUT),  dimension(NLINKS) :: TO_NODE, LINKID   !  which nodes pour into which lakes
8374 integer                                    :: GNLINKSL
8375 character(len=15), intent(inout), dimension(nlinks) :: gages  !! need to respect the default values
8376 character(len=15), intent(in)              :: gageMiss
8377 integer :: did
8378
8379 !! local variables
8380 integer(kind=int64), dimension(NLAKES)         :: LAKELINKID !temporarily store the outlet index for each modeled lake
8381
8382 did = 1
8383 LAKELINKID = 0
8384
8385 call readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f,maxorder, &
8386      LINKID, TO_NODE, TYPEL, ORDER , &
8387      QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, &
8388      MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, ChannK, LAKEIDA, HRZAREA,  &
8389      LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, ORIFICEC, &
8390      ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, &
8391      gages, gageMiss, LAKEIDM, NLAKES, latlake, lonlake,ELEVLAKE)
8392
8393 !--- get the lake configuration here.
8394 #ifdef MPP_LAND
8395 call nhdLakeMap_mpp(NLAKES,  NLINKSL, TYPEL,   LAKELINKID, LAKEIDX, &
8396                     TO_NODE, LINKID,  LAKEIDM, LAKEIDA,    GNLINKSL  )
8397 !call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA
8398 #else
8399 call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA)
8400 #endif
8401
8402 #ifdef MPP_LAND
8403 if (NLAKES > 0) then
8404    !         call mpp_land_bcast_int(NLINKSL,LAKEIDA)
8405    !         call mpp_land_bcast_int(NLINKSL,LAKEIDX)
8406    call mpp_land_bcast_real(NLAKES,HRZAREA)
8407    call mpp_land_bcast_int8(NLAKES,LAKEIDM)
8408    call mpp_land_bcast_real(NLAKES,LAKEMAXH)
8409    call mpp_land_bcast_real(NLAKES,WEIRH  )
8410    call mpp_land_bcast_real(NLAKES,WEIRC  )
8411    call mpp_land_bcast_real(NLAKES,WEIRL  )
8412    call mpp_land_bcast_real(NLAKES,DAML)
8413    call mpp_land_bcast_real(NLAKES,ORIFICEC)
8414    call mpp_land_bcast_real(NLAKES,ORIFICEA)
8415    call mpp_land_bcast_real(NLAKES,ORIFICEE)
8416    call mpp_land_bcast_real(NLAKES,LATLAKE )
8417    call mpp_land_bcast_real(NLAKES,LONLAKE )
8418    call mpp_land_bcast_real(NLAKES,ELEVLAKE)
8419    call mpp_land_bcast_int(NLAKES, reservoir_type)
8420 endif
8421 #endif
8422
8423 end subroutine read_routelink
8424
8425
8426
8427    subroutine readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f, maxorder, &
8428                    LINKID, TO_NODE, TYPEL, ORDER , &
8429                    QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, &
8430                    MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, ChannK, LAKEIDA, HRZAREA,  &
8431                    LAKEMAXH,WEIRH,  WEIRC, WEIRL, DAML, ORIFICEC, &
8432                    ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, &
8433                    gages, gageMiss, LAKEIDM,NLAKES, latlake, lonlake, ELEVLAKE)
8434
8435         implicit none
8436         character(len=*) :: route_link_f,route_lake_f
8437         integer  :: GNLINKSL, NLINKSL, tmp_from_node,NLAKES
8438
8439         INTEGER, INTENT(INOUT)                     :: MAXORDER
8440         integer(kind=int64), intent(out), dimension(:) :: LAKEIDA, LINKID, TO_NODE
8441         INTEGER, intent(out), dimension(:)         :: TYPEL, ORDER
8442
8443         real,dimension(:,:)  :: QLINK
8444         real, intent(out), dimension(:) ::  CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN
8445         real, intent(out), dimension(:) ::  MannN, So, ChSSlp, Bw, Tw, latlake, lonlake, Tw_CC, n_CC
8446         real, intent(out), dimension(:) ::  ChannK
8447
8448         character(len=15), dimension(:), intent(inout) :: gages
8449         character(len=15), intent(in) :: gageMiss
8450
8451 !NLAKES
8452         integer(kind=int64), intent(out), dimension(:)  ::  LAKEIDM
8453         integer, intent(out), dimension(:)  ::  reservoir_type
8454         logical, intent(in)                         ::  reservoir_type_specified
8455         character(len=*), intent(in)        ::  reservoir_parameter_file
8456         REAL, intent(out), dimension(:) :: HRZAREA,LAKEMAXH, WEIRC, WEIRL, DAML, ORIFICEC, WEIRH, &
8457                    ORIFICEA, ORIFICEE, ELEVLAKE
8458 !end NLAKES
8459
8460         INTEGER(kind=int64), dimension(GNLINKSL) ::  tmpLAKEIDA, tmpLINKID,  tmpTO_NODE
8461         INTEGER, dimension(GNLINKSL) ::  tmpTYPEL, tmpORDER
8462         character(len=15), dimension(gnlinksl) :: tmpGages
8463         CHARACTER(len=155)       :: header
8464         integer :: i
8465
8466         character(len=256) :: route_link_f_r,route_lake_f_r
8467         integer :: lenRouteLinkFR,lenRouteLakeFR ! so the preceeding chan be changed without changing code
8468         logical :: routeLinkNetcdf, routeLakeNetcdf
8469
8470 #ifdef MPP_LAND
8471         real :: tmpQLINK(GNLINKSL,2)
8472         real, allocatable, dimension(:) ::  tmpCHLON, tmpCHLAT, tmpZELEV, tmpMUSK, tmpMUSX, tmpCHANLEN
8473         real, allocatable, dimension(:) ::  tmpMannN, tmpSo, tmpChSSlp, tmpBw, tmpTw, tmpTw_CC, tmpn_CC
8474         real, allocatable, dimension(:) ::  tmpChannK
8475 #endif
8476
8477         !! is RouteLink file netcdf (*.nc) or csv (*.csv)
8478         route_link_f_r = adjustr(route_link_f)
8479         lenRouteLinkFR = len(route_link_f_r)
8480         routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq. '.nc'
8481
8482         !! is RouteLake file netcdf (*.nc) or .TBL
8483         route_lake_f_r = adjustr(route_lake_f)
8484         lenRouteLakeFR = len(route_lake_f_r)
8485         routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc'
8486
8487 #ifdef MPP_LAND
8488        tmpQLINK = 0
8489        tmpGages = gageMiss
8490
8491        if(my_id .eq. IO_id) then
8492
8493           allocate(tmpCHLON(GNLINKSL))
8494           allocate(tmpCHLAT(GNLINKSL))
8495           allocate(tmpZELEV(GNLINKSL))
8496           allocate(tmpMUSK(GNLINKSL))
8497           allocate(tmpMUSX(GNLINKSL))
8498           allocate(tmpCHANLEN(GNLINKSL))
8499           allocate(tmpMannN(GNLINKSL))
8500           allocate(tmpSo(GNLINKSL))
8501           allocate(tmpChSSlp(GNLINKSL))
8502           allocate(tmpBw(GNLINKSL))
8503           allocate(tmpTw(GNLINKSL))
8504           allocate(tmpTw_CC(GNLINKSL))
8505           allocate(tmpn_CC(GNLINKSL))
8506           allocate(tmpChannK(GNLINKSL))
8507
8508           if(routeLinkNetcdf) then
8509
8510              call read_route_link_netcdf(                                &
8511                   route_link_f,                                          &
8512                   tmpLINKID,     tmpTO_NODE,   tmpCHLON,                 &
8513                   tmpCHLAT,      tmpZELEV,     tmpTYPEL,    tmpORDER,    &
8514                   tmpQLINK(:,1), tmpMUSK,      tmpMUSX,     tmpCHANLEN,  &
8515                   tmpMannN,      tmpSo,        tmpChSSlp,   tmpBw,       &
8516                   tmpTw,         tmpTw_CC,     tmpn_CC,     tmpChannK,   &
8517                   tmpGages,      tmpLAKEIDA                         )
8518
8519           else
8520
8521              open(unit=17,file=trim(route_link_f),form='formatted',status='old')
8522              read(17,*)  header
8523 #ifdef HYDRO_D
8524              print *, "header ", header, "NLINKSL = ", NLINKSL, GNLINKSL
8525 #endif
8526              call flush(6)
8527              do i=1,GNLINKSL
8528                 read (17,*) tmpLINKID(i),   tmp_from_node,   tmpTO_NODE(i), tmpCHLON(i),    &
8529                             tmpCHLAT(i),    tmpZELEV(i),     tmpTYPEL(i),   tmpORDER(i),    &
8530                             tmpQLINK(i,1),  tmpMUSK(i),      tmpMUSX(i),    tmpCHANLEN(i),  &
8531                             tmpMannN(i),    tmpSo(i),        tmpChSSlp(i),  tmpBw(i),       &
8532                             tmpTw(i),       tmpTw_CC(i),     tmpn_CC(i),    tmpChannK(i)
8533
8534                 ! if (So(i).lt.0.005) So(i) = 0.005  !-- impose a minimum slope requireement
8535                 if (tmpORDER(i) .gt. MAXORDER) MAXORDER = tmpORDER(i)
8536              end do
8537              close(17)
8538
8539           end if  ! routeLinkNetcdf
8540
8541           if(routeLakeNetcdf) then
8542              call read_route_lake_netcdf(route_lake_f,HRZAREA, &
8543                 LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, ORIFICEC,       &
8544                 ORIFICEA,  ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, &
8545                 LAKEIDM, latlake, lonlake, ELEVLAKE, NLAKES)
8546           endif
8547
8548 !!- initialize channel  if missing in input
8549            do i=1,GNLINKSL
8550               if(tmpQLINK(i,1) .le. 1e-3) then
8551                  tmpQLINK(i,1) = 20.0 * (1.0/(float(MAXORDER+1) - float(tmpORDER(i))))**3
8552                 tmpQLINK(i,2) = tmpQLINK(i,1) !## initialize the current flow at each link
8553               endif
8554            end do
8555
8556        endif ! my_id .eq. IO_id
8557
8558         call ReachLS_decomp(tmpLINKID,  LINKID )
8559         call ReachLS_decomp(tmpLAKEIDA, LAKEIDA )
8560
8561         call ReachLS_decomp(tmpTO_NODE, TO_NODE)
8562         call ReachLS_decomp(tmpCHLON,    CHLON  )
8563         call ReachLS_decomp(tmpCHLAT,    CHLAT  )
8564         call ReachLS_decomp(tmpZELEV,    ZELEV  )
8565         call ReachLS_decomp(tmpTYPEL,   TYPEL  )
8566         call ReachLS_decomp(tmpORDER,   ORDER  )
8567         call ReachLS_decomp(tmpQLINK(:,1), QLINK(:,1))
8568         call ReachLS_decomp(tmpQLINK(:,2), QLINK(:,2))
8569         call ReachLS_decomp(tmpMUSK,    MUSK   )
8570         call ReachLS_decomp(tmpMUSX,     MUSX   )
8571         call ReachLS_decomp(tmpCHANLEN,  CHANLEN)
8572         call ReachLS_decomp(tmpMannN,    MannN  )
8573         call ReachLS_decomp(tmpSo,       So     )
8574         call ReachLS_decomp(tmpChSSlp,   ChSSlp )
8575         call ReachLS_decomp(tmpBw,       Bw     )
8576         call ReachLS_decomp(tmpTw,       Tw     )
8577         call ReachLS_decomp(tmpTw_CC,    Tw_CC  )
8578         call ReachLS_decomp(tmpn_CC,     n_CC   )
8579         call ReachLS_decomp(tmpChannK,   ChannK )
8580
8581 !       call ReachLS_decomp(tmpHRZAREA,  HRZAREA)
8582 !       call ReachLS_decomp(tmpLAKEMAXH, LAKEMAXH)
8583 !       call ReachLS_decomp(tmpWEIRC,    WEIRC  )
8584 !       call ReachLS_decomp(tmpWEIRL,    WEIRL  )
8585 !       call ReachLS_decomp(tmpORIFICEC, ORIFICEC)
8586 !       call ReachLS_decomp(tmpORIFICEA, ORIFICEA)
8587 !       call ReachLS_decomp(tmpORIFICEE, ORIFICEE)
8588
8589         call ReachLS_decomp(tmpGages,    gages)
8590         call mpp_land_bcast_int1(MAXORDER)
8591
8592         if (NLAKES > 0) then
8593            call mpp_land_bcast_real(NLAKES, HRZAREA)
8594            call mpp_land_bcast_real(NLAKES, LAKEMAXH)
8595            call mpp_land_bcast_real(NLAKES, WEIRH)
8596            call mpp_land_bcast_real(NLAKES, WEIRC)
8597            call mpp_land_bcast_real(NLAKES, WEIRL)
8598            call mpp_land_bcast_real(NLAKES, DAML)
8599            call mpp_land_bcast_real(NLAKES, ORIFICEC)
8600            call mpp_land_bcast_real(NLAKES, ORIFICEA)
8601            call mpp_land_bcast_real(NLAKES, ORIFICEE)
8602            call mpp_land_bcast_int8(NLAKES, LAKEIDM)
8603            call mpp_land_bcast_real(NLAKES, ELEVLAKE)
8604            call mpp_land_bcast_int(NLAKES, reservoir_type)
8605         endif
8606
8607
8608         if(my_id .eq. io_id ) then
8609            if(allocated(tmpCHLON)) deallocate(tmpCHLON)
8610            if(allocated(tmpCHLAT)) deallocate(tmpCHLAT)
8611            if(allocated(tmpZELEV)) deallocate(tmpZELEV)
8612            if(allocated(tmpMUSK)) deallocate(tmpMUSK)
8613            if(allocated(tmpMUSX)) deallocate(tmpMUSX)
8614            if(allocated(tmpCHANLEN)) deallocate(tmpCHANLEN)
8615            if(allocated(tmpMannN)) deallocate(tmpMannN)
8616            if(allocated(tmpSo)) deallocate(tmpSo)
8617            if(allocated(tmpChSSlp)) deallocate(tmpChSSlp)
8618            if(allocated(tmpBw)) deallocate(tmpBw)
8619            if(allocated(tmpTw)) deallocate(tmpTw)
8620            if(allocated(tmpTw_CC)) deallocate(tmpTw_CC)
8621            if(allocated(tmpn_CC)) deallocate(tmpn_CC)
8622            if(allocated(tmpChannK)) deallocate(tmpChannK)
8623 !, tmpHRZAREA,&
8624 !                  tmpLAKEMAXH, tmpWEIRC, tmpWEIRL, tmpORIFICEC, &
8625 !                  tmpORIFICEA,tmpORIFICEE)
8626         endif
8627
8628 #else
8629        QLINK = 0
8630         if(routeLinkNetcdf) then
8631
8632           call read_route_link_netcdf(                      &
8633                  route_link_f,                              &
8634                  LINKID,     TO_NODE, CHLON,                &
8635                  CHLAT,      ZELEV,     TYPEL,    ORDER,    &
8636                  QLINK(:,1), MUSK,      MUSX,     CHANLEN,  &
8637                  MannN,      So,        ChSSlp,   Bw,       &
8638                  Tw,         Tw_CC,     n_CC,     ChannK, gages,    &
8639                  LAKEIDA                                     )
8640
8641         else
8642
8643           open(unit=17,file=trim(route_link_f),form='formatted',status='old')
8644           read(17,*)  header
8645 #ifdef HYDRO_D
8646           print *, "header ", header, "NLINKSL = ", NLINKSL
8647 #endif
8648           do i=1,NLINKSL
8649               read (17,*) LINKID(i), tmp_from_node, TO_NODE(i), CHLON(i),CHLAT(i),ZELEV(i), &
8650                    TYPEL(i), ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), &
8651                    MannN(i), So(i), ChSSlp(i), Bw(i), Tw(i), Tw_CC(i), n_CC(i), ChannK(i)
8652
8653               ! if (So(i).lt.0.005) So(i) = 0.005  !-- impose a minimum slope requireement
8654               if (ORDER(i) .gt. MAXORDER) MAXORDER = ORDER(i)
8655           end do
8656           close(17)
8657
8658         end if  ! routeLinkNetcdf
8659
8660 !!- initialize channel according to order if missing in input
8661         do i=1,NLINKSL
8662             if(QLINK(i,1) .le. 1e-3) then
8663               QLINK(i,1) = 20.0 * (1/(float(MAXORDER+1) - float(ORDER(i))))**3
8664               QLINK(i,2) = QLINK(i,1) !## initialize the current flow at each link
8665             endif
8666         end do
8667
8668 !!================================
8669 !!! need to add the sequential lake read here
8670 !!=================================
8671
8672
8673 #endif
8674
8675         do i=1,NLINKSL
8676 !           if(So(i) .lt. 0.001) So(i) = 0.001
8677            So(i) = max(So(i), 0.00001)
8678         end do
8679
8680 #ifdef HYDRO_D
8681        write(6,*) "finish read readLinkSL "
8682        call flush(6)
8683
8684 #endif
8685    end subroutine readLinkSL
8686
8687
8688
8689
8690 #ifdef MPP_LAND
8691
8692 !yw continue
8693
8694 subroutine MPP_READ_CHROUTING_new(&
8695      IXRT,         JXRT,              ELRT,           CH_NETRT,  &
8696      CH_LNKRT,     LAKE_MSKRT,        FROM_NODE,      TO_NODE,   &
8697      TYPEL,        ORDER,             MAXORDER,       NLINKS,    &
8698      NLAKES,       CHANLEN,           MannN,          So,        &
8699      ChSSlp,       Bw,                Tw,             Tw_CC,     &
8700      n_CC,         ChannK,            HRZAREA,        LAKEMAXH,  &
8701      WEIRH,        WEIRC,             WEIRL,          DAML,      &
8702      ORIFICEC,     ORIFICEA,          ORIFICEE,                  &
8703      reservoir_type_specified,        reservoir_type,            &
8704      reservoir_parameter_file,        LATLAKE,        LONLAKE,   &
8705      ELEVLAKE,     dist,              ZELEV,          LAKENODE,  &
8706      CH_NETLNK,    CHANXI,            CHANYJ,         CHLAT,     &
8707      CHLON,        channel_option,    LATVAL,         LONVAL,    &
8708      STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f,   LAKEIDM,   &
8709      UDMP_OPT,     g_ixrt,            g_jxrt,         gnlinks,   &
8710      GCH_NETLNK,   map_l2g,           link_location,  yw_mpp_nlinks, &
8711      lake_index,   nlinks_index                                       )
8712
8713 implicit none
8714 integer, intent(IN)                          :: IXRT,JXRT,g_IXRT,g_JXRT, GNLINKS, UDMP_OPT
8715 integer                                      :: CHANRTSWCRT, NLINKS, NLAKES
8716 integer                                      :: I,J,channel_option
8717 character(len=28)                            :: dir
8718
8719 character(len=155)       :: header
8720 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: FROM_NODE
8721 real, intent(INOUT),  dimension(NLINKS)      :: ZELEV
8722 real, intent(INOUT),  dimension(NLINKS)      :: CHLAT,CHLON
8723
8724 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: TO_NODE
8725 integer, intent(INOUT),  dimension(NLINKS)   :: TYPEL
8726 integer, intent(INOUT),  dimension(NLINKS)   :: ORDER
8727 integer, intent(INOUT),  dimension(NLINKS)   :: STRMFRXSTPTS
8728
8729 integer, intent(INOUT)                       :: MAXORDER
8730 real, intent(INOUT),  dimension(NLINKS)      :: CHANLEN   !channel length
8731 real, intent(INOUT),  dimension(NLINKS)      :: MannN, So !mannings N
8732 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: LAKENODE  ! identifies which nodes pour into which lakes
8733 real, intent(IN)                             :: dist(ixrt,jxrt,9)
8734 integer, intent(INOUT),  dimension(NLINKS)   :: map_l2g
8735
8736 !-- store the location x,y location of the channel element
8737 integer, intent(INOUT), dimension(NLINKS)   :: CHANXI, CHANYJ
8738
8739 logical, intent(IN)                          :: reservoir_type_specified
8740 real, intent(INOUT),  dimension(NLAKES)      :: HRZAREA
8741 real, intent(INOUT),  dimension(NLAKES)      :: LAKEMAXH, WEIRH
8742 real, intent(INOUT),  dimension(NLAKES)      :: WEIRC
8743 real, intent(INOUT),  dimension(NLAKES)      :: WEIRL
8744 real, intent(INOUT),  dimension(NLAKES)      :: DAML
8745 real, intent(INOUT),  dimension(NLAKES)      :: ORIFICEC
8746 real, intent(INOUT),  dimension(NLAKES)      :: ORIFICEA
8747 real, intent(INOUT),  dimension(NLAKES)      :: ORIFICEE
8748 integer, intent(INOUT), dimension(NLAKES)    :: reservoir_type
8749 character(len=*), intent(in)                 :: reservoir_parameter_file
8750 real, intent(INOUT),  dimension(NLAKES)      :: LATLAKE,LONLAKE,ELEVLAKE
8751 real, intent(INOUT), dimension(NLINKS)       :: ChSSlp, Bw, Tw
8752 real, intent(INOUT), dimension(NLINKS)       :: Tw_CC, n_CC, ChannK
8753
8754 character(len=*  )                           :: geo_finegrid_flnm, route_lake_f
8755 character(len=256)                           :: var_name
8756
8757 integer                                      :: tmp, cnt, ncid
8758 real                                         :: gc,n
8759
8760 integer(kind=int64), intent(IN), dimension(IXRT,JXRT)    :: CH_NETLNK,GCH_NETLNK
8761 real, intent(IN), dimension(IXRT,JXRT)       :: ELRT
8762 integer, intent(IN), dimension(IXRT,JXRT)    :: CH_NETRT
8763 integer(kind=int64), intent(IN), dimension(IXRT,JXRT) :: CH_LNKRT
8764 integer, intent(OUT), dimension(IXRT,JXRT) :: LAKE_MSKRT
8765 integer(kind=int64), intent(OUT), dimension(IXRT,JXRT) :: link_location
8766 real, intent(OUT), dimension(IXRT,JXRT)    :: latval,lonval
8767 integer :: k
8768 integer, dimension(nlinks)            :: node_table, nlinks_index
8769 integer, dimension(nlakes)            :: lake_index
8770 integer(kind=int64), dimension(nlakes)    :: LAKEIDM
8771 integer :: yw_mpp_nlinks , l, mpp_nlinks
8772
8773
8774 call READ_CHROUTING1( &
8775      IXRT,         JXRT,              ELRT,      CH_NETRT,&
8776      CH_LNKRT,     LAKE_MSKRT,        FROM_NODE, TO_NODE, &
8777      TYPEL,        ORDER,             MAXORDER,  NLINKS,  &
8778      NLAKES,       CHANLEN,           MannN,     So,      &
8779      ChSSlp,       Bw,                Tw,        Tw_CC,   &
8780      n_CC,         ChannK,            HRZAREA,   LAKEMAXH, &
8781      WEIRH,        WEIRC,             WEIRL,     DAML,    &
8782      ORIFICEC,     ORIFICEA,          ORIFICEE,           &
8783      reservoir_type_specified,        reservoir_type,     &
8784      reservoir_parameter_file,        LATLAKE,   LONLAKE, &
8785      ELEVLAKE,     dist,              ZELEV,     LAKENODE,&
8786      CH_NETLNK,    CHANXI,            CHANYJ,    CHLAT,   &
8787      CHLON,        channel_option,    LATVAL,    LONVAL,  &
8788      STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f, LAKEIDM, UDMP_OPT            &
8789 #ifdef MPP_LAND
8790      ,Link_Location  &
8791 #endif
8792      )
8793
8794 call mpp_land_max_int1(MAXORDER)
8795
8796 if(MAXORDER .eq. 0)  MAXORDER = -9999
8797
8798 lake_index = -99
8799 if(channel_option .eq. 3) then
8800    do j = 1, jxrt
8801       do i = 1, ixrt
8802          if (LAKE_MSKRT(i,j) .gt. 0) then
8803             lake_index(LAKE_MSKRT(i,j)) = LAKE_MSKRT(i,j)
8804          endif
8805       enddo
8806    enddo
8807 endif
8808
8809
8810 CHANXI = 0
8811 CHANYj = 0
8812 do j = 1, jxrt
8813    do i = 1, ixrt
8814       if(CH_NETLNK(i,j) .gt. 0) then
8815          CHANXI(CH_NETLNK(i,j)) = i
8816          CHANYJ(CH_NETLNK(i,j)) = j
8817       endif
8818    end do
8819 end do
8820
8821 node_table = 0
8822 yw_mpp_nlinks = 0
8823 do j = 1, jxrt
8824    do i = 1, ixrt
8825       if(CH_NETLNK(i,j) .ge. 0) then
8826          if( (i.eq.1) .and. (left_id .ge. 0) ) then
8827             continue
8828          elseif ( (i.eq. ixrt) .and. (right_id .ge. 0) ) then
8829             continue
8830          elseif ( (j.eq. 1) .and. (down_id .ge. 0) ) then
8831             continue
8832          elseif ( (j.eq. jxrt) .and. (up_id .ge. 0) ) then
8833             continue
8834          else
8835             l = CH_NETLNK(i,j)
8836             ! if(from_node(l) .gt. 0 .and. to_node(l) .gt. 0) then
8837             yw_mpp_nlinks = yw_mpp_nlinks + 1
8838             nlinks_index(yw_mpp_nlinks) = l
8839             ! endif
8840          endif
8841       endif
8842    end do
8843 end do
8844
8845 #ifdef HYDRO_D
8846 write(6,*) "nlinks=", nlinks, " yw_mpp_nlinks=", yw_mpp_nlinks," nlakes=", nlakes
8847 call flush(6)
8848 #endif
8849 if (NLAKES > 0) then
8850    call mpp_land_bcast_real(NLAKES,HRZAREA)
8851    call mpp_land_bcast_real(NLAKES,LAKEMAXH)
8852    call mpp_land_bcast_real(NLAKES,WEIRC)
8853    call mpp_land_bcast_real(NLAKES,WEIRC)
8854    call mpp_land_bcast_real(NLAKES,WEIRL)
8855    call mpp_land_bcast_real(NLAKES,DAML)
8856    call mpp_land_bcast_real(NLAKES,ORIFICEC)
8857    call mpp_land_bcast_real(NLAKES,ORIFICEA)
8858    call mpp_land_bcast_real(NLAKES,ORIFICEE)
8859    call mpp_land_bcast_real(NLAKES,LATLAKE)
8860    call mpp_land_bcast_real(NLAKES,LONLAKE)
8861    call mpp_land_bcast_real(NLAKES,ELEVLAKE)
8862    call mpp_land_bcast_int(NLAKES, reservoir_type)
8863 endif
8864
8865 link_location = CH_NETLNK
8866
8867 return
8868
8869 end subroutine MPP_READ_CHROUTING_new
8870
8871 #endif
8872
8873
8874 #ifdef MPP_LAND
8875        subroutine out_day_crt(dayMean,outFile)
8876            implicit none
8877            integer :: did
8878            real ::  dayMean(:)
8879            character(len=*) :: outFile
8880            integer:: ywflag
8881            ywflag = -999
8882            did = 1
8883            if((nlst(did)%olddate(12:13) .eq. "00") .and. (nlst(did)%olddate(15:16) .eq. "00") ) ywflag = 99
8884            call mpp_land_bcast_int1(ywflag)
8885            if(ywflag <0) return
8886            ! output daily
8887            call out_obs_crt(did,dayMean,outFile)
8888        end subroutine out_day_crt
8889
8890        subroutine out_obs_crt(did,dayMean,outFile)
8891            implicit none
8892            integer did, i, cnt
8893            real ::  dayMean(:)
8894            character(len=*) :: outFile
8895            real,dimension(rt_domain(did)%gnlinks) :: g_dayMean, chlat, chlon
8896            integer,dimension(rt_domain(did)%gnlinks) :: STRMFRXSTPTS
8897
8898            g_dayMean = -999
8899            chlat = -999
8900            chlon = -999
8901            STRMFRXSTPTS = 0
8902
8903            call write_chanel_int(RT_DOMAIN(did)%STRMFRXSTPTS,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,STRMFRXSTPTS)
8904
8905            call write_chanel_real(dayMean,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,g_dayMean)
8906
8907            call write_chanel_real(RT_DOMAIN(did)%CHLON,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlon)
8908
8909            call write_chanel_real(RT_DOMAIN(did)%CHLAT,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlat)
8910
8911
8912            open (unit=75,file=outFile,status='unknown',position='append')
8913            cnt = 0
8914            do i = 1, rt_domain(did)%gnlinks
8915               if(STRMFRXSTPTS(i) .gt. 0) then
8916                    write(75,114) nlst(did)%olddate(1:4),nlst(did)%olddate(6:7),nlst(did)%olddate(9:10), nlst(did)%olddate(12:13), &
8917                          cnt,chlon(i),chlat(i),g_dayMean(i)
8918                    cnt = cnt + 1
8919               endif
8920            end do
8921            close(75)
8922 114 FORMAT(1x,A4,A2,A2,A2,",",I7,", ",F10.5,",",F10.5,",",F12.3)
8923        end subroutine out_obs_crt
8924 #endif
8925
8926     subroutine outPutChanInfo(fromNode,toNode,chlon,chlat)
8927         implicit none
8928         integer, dimension(:) :: fromNode,toNode
8929         real, dimension(:) :: chlat,chlon
8930         integer :: iret, nodes, i, ncid, dimid_n, varid
8931
8932         nodes = size(chlon,1)
8933
8934        iret = nf90_create("nodeInfor.nc", OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
8935        iret = nf90_def_dim(ncid, "node", nodes, dimid_n)  !-- make a decimated grid
8936 !  define the varialbes
8937        iret = nf90_def_var(ncid, "fromNode", NF90_INT, (/dimid_n/), varid)
8938        iret = nf90_def_var(ncid, "toNode", NF90_INT, (/dimid_n/), varid)
8939        iret = nf90_def_var(ncid, "chlat", NF90_FLOAT, (/dimid_n/), varid)
8940           iret = nf90_put_att(ncid, varid, 'long_name', 'node latitude')
8941        iret = nf90_def_var(ncid, "chlon", NF90_FLOAT, (/dimid_n/), varid)
8942           iret = nf90_put_att(ncid, varid, 'long_name', 'node longitude')
8943        iret = nf90_enddef(ncid)
8944 !write to the file
8945            iret = nf90_inq_varid(ncid,"fromNode", varid)
8946            iret = nf90_put_var(ncid, varid, fromNode, (/1/), (/nodes/))
8947            iret = nf90_inq_varid(ncid,"toNode", varid)
8948            iret = nf90_put_var(ncid, varid, toNode, (/1/), (/nodes/))
8949            iret = nf90_inq_varid(ncid,"chlat", varid)
8950            iret = nf90_put_var(ncid, varid, chlat, (/1/), (/nodes/))
8951            iret = nf90_inq_varid(ncid,"chlon", varid)
8952            iret = nf90_put_var(ncid, varid, chlon, (/1/), (/nodes/))
8953           iret = nf90_close(ncid)
8954     end subroutine outPutChanInfo
8955
8956
8957 !===================================================================================================
8958 ! Program Name: read_route_link_netcdf
8959 ! Author(s)/Contact(s): James L McCreight <jamesmcc><ucar><edu>
8960 ! Abstract: Read in the "RouteLink.nc" netcdf file specifing the channel topology.
8961 ! History Log:
8962 ! 7/17/15 -Created, JLM.
8963 ! Usage:
8964 ! Parameters: <Specify typical arguments passed>
8965 ! Input Files: netcdf file RouteLink.nc or other name.
8966 ! Output Files: None.
8967 ! Condition codes: Currently incomplete error handling.
8968 !
8969 ! If appropriate, descriptive troubleshooting instructions or
8970 ! likely causes for failures could be mentioned here with the
8971 ! appropriate error code
8972 !
8973 ! User controllable options: None.
8974
8975 subroutine read_route_link_netcdf( route_link_file,                         &
8976                                    LINKID,   TO_NODE,   CHLON,              &
8977                                    CHLAT,    ZELEV,     TYPEL,    ORDER,    &
8978                                    QLINK,    MUSK,      MUSX,     CHANLEN,  &
8979                                    MannN,    So,        ChSSlp,   Bw,       &
8980                                    Tw,       Tw_CC,     n_CC,     ChannK,   &
8981                                    gages,   LAKEIDA                         )
8982
8983 implicit none
8984 character(len=*),        intent(in)  :: route_link_file
8985 integer(kind=int64), dimension(:),   intent(out) :: LAKEIDA, LINKID, TO_NODE
8986 real,    dimension(:),   intent(out) :: CHLON, CHLAT, ZELEV
8987 integer, dimension(:),   intent(out) :: TYPEL, ORDER
8988 real,    dimension(:),   intent(out) :: QLINK
8989 real,    dimension(:),   intent(out) :: MUSK, MUSX, CHANLEN
8990 real,    dimension(:),   intent(out) :: MannN, So, ChSSlp, Bw, Tw
8991 real,    dimension(:),   intent(out) :: Tw_CC, n_CC, ChannK
8992
8993 character(len=15), dimension(:), intent(inout) :: gages
8994
8995 integer :: iRet, ncid, ii, varid
8996 logical :: fatal_if_error
8997 fatal_if_error = .TRUE.  !! was thinking this would be a global variable...could become an input.
8998
8999 #ifdef HYDRO_D
9000 print*,"start read_route_link_netcdf"
9001 #endif
9002
9003 iRet = nf90_open(trim(route_link_file), nf90_nowrite, ncid)
9004 if (iRet /= nf90_noErr) then
9005    write(*,'("read_route_link_netcdf: Problem opening: ''", A, "''")') trim(route_link_file)
9006    if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem opening file.")
9007 endif
9008
9009
9010 call get_1d_netcdf_int64(ncid,  'link',     LINKID,    'read_route_link_netcdf', .TRUE.)
9011 call get_1d_netcdf_int64(ncid,  'NHDWaterbodyComID',  LAKEIDA, 'read_route_link_netcdf', .FALSE.)
9012 call get_1d_netcdf_int64(ncid,  'to',       TO_NODE,   'read_route_link_netcdf', .TRUE.)
9013 call get_1d_netcdf_real(ncid, 'lon',      CHLON,     'read_route_link_netcdf', .TRUE.)
9014 call get_1d_netcdf_real(ncid, 'lat',      CHLAT,     'read_route_link_netcdf', .TRUE.)
9015 call get_1d_netcdf_real(ncid, 'alt',      ZELEV,     'read_route_link_netcdf', .TRUE.)
9016 !yw call get_1d_netcdf_int(ncid,  'type',     TYPEL,     'read_route_link_netcdf', .TRUE.)
9017 call get_1d_netcdf_int(ncid,  'order',    ORDER,     'read_route_link_netcdf', .TRUE.)
9018 call get_1d_netcdf_real(ncid, 'Qi',       QLINK,     'read_route_link_netcdf', .TRUE.)
9019 call get_1d_netcdf_real(ncid, 'MusK',     MUSK,      'read_route_link_netcdf', .TRUE.)
9020 call get_1d_netcdf_real(ncid, 'MusX',     MUSX,      'read_route_link_netcdf', .TRUE.)
9021 call get_1d_netcdf_real(ncid, 'Length',   CHANLEN,   'read_route_link_netcdf', .TRUE.)
9022 call get_1d_netcdf_real(ncid, 'n',        MannN,     'read_route_link_netcdf', .TRUE.)
9023 call get_1d_netcdf_real(ncid, 'So',       So,        'read_route_link_netcdf', .TRUE.)
9024 !! impose a minimum as this sometimes fails in the file.
9025 where(So .lt. 0.00001) So=0.00001
9026 call get_1d_netcdf_real(ncid, 'ChSlp',    ChSSlp,    'read_route_link_netcdf', .TRUE.)
9027 call get_1d_netcdf_real(ncid, 'BtmWdth',  Bw,        'read_route_link_netcdf', .TRUE.)
9028 !! Loads channel infiltration, by default is zero, my need to add namelist option in future
9029 call get_1d_netcdf_real(ncid, 'Kchan',  ChannK,     'read_route_link_netcdf', .TRUE.)
9030
9031 ! Compound channel variables, contingent on nlst_rt(did)%compound_channel option
9032 if(nlst(did)%compound_channel) then
9033    print*, "compound_channel is TRUE in hydro.namelist."
9034    print*, "Variables are all required in route link: TopWdth, TopWdthCC, nCC."
9035    ! the fatal_if_error option is tru for all of these. An error in any will be a fatal error.
9036    call get_1d_netcdf_real(ncid, 'TopWdth',   Tw,     'read_route_link_netcdf', .true.)
9037    call get_1d_netcdf_real(ncid, 'TopWdthCC', Tw_CC,  'read_route_link_netcdf', .true.)
9038    call get_1d_netcdf_real(ncid, 'nCC',       n_CC,   'read_route_link_netcdf', .true.)
9039 else
9040    print*, "compound_channel is FALSE in hydro.namelist."
9041    Tw = 0.0  !force top width to 0.0, this deactivates the compound channel formulation.
9042 end if
9043
9044
9045 ! gages is optional, only get it if it's defined in the file.
9046 iRet = nf90_inq_varid(ncid, 'gages', varid)
9047 if (iret .eq. nf90_NoErr) then
9048    call get_1d_netcdf_text(ncid, 'gages', gages,  'read_route_link_netcdf', .true.)
9049 end if
9050
9051 iRet = nf90_close(ncId)
9052 if (iRet /= nf90_noErr) then
9053    write(*,'("read_route_link_netcdf: Problem closing: ''", A, "''")') trim(route_link_file)
9054    if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem closing file.")
9055 end if
9056
9057 #ifdef HYDRO_D
9058 ii = size(LINKID)
9059 print*,'last index=',ii
9060 print*, 'CHLON', CHLON(ii), 'CHLAT', CHLAT(ii), 'ZELEV', ZELEV(ii)
9061 print*,'TYPEL', TYPEL(ii), 'ORDER', ORDER(ii), 'QLINK', QLINK(ii), 'MUSK', MUSK(ii)
9062 print*, 'MUSX', MUSX(ii), 'CHANLEN', CHANLEN(ii), 'MannN', MannN(ii)
9063 print*,'So', So(ii), 'ChSSlp', ChSSlp(ii), 'Bw', Bw(ii), 'Tw', Tw(ii)
9064 print*,'TwCompund', Tw_CC(ii), 'Mann Compund', n_CC(ii), 'ChannK', ChannK(ii)
9065
9066 print*,'gages(ii): ',trim(gages(ii))
9067 print*,"finish read_route_link_netcdf"
9068 #endif
9069
9070 end subroutine read_route_link_netcdf
9071
9072
9073 !===================================================================================================
9074 ! Program Name: read_route_lake_netcdf
9075 ! Abstract: Read in the "LAKEPARM.nc" netcdf file specifing the channel topology.
9076 ! History Log:
9077 ! 7/17/15 -Created, JLM., then used by DNY
9078 ! Usage:
9079 ! Parameters: <Specify typical arguments passed>
9080 ! Input Files: netcdf file RouteLink.nc or other name.
9081 ! Output Files: None.
9082 ! Condition codes: Currently incomplete error handling.
9083 !
9084 subroutine read_route_lake_netcdf(route_lake_file,                         &
9085                                    HRZAREA,  LAKEMAXH, WEIRH,  WEIRC,    WEIRL, DAML,   &
9086                                    ORIFICEC, ORIFICEA,  ORIFICEE,  reservoir_type_specified, &
9087                                    reservoir_type, reservoir_parameter_file, &
9088                                    LAKEIDM, lakelat, lakelon, ELEVLAKE, NLAKES)
9089
9090     implicit none
9091     character(len=*),              intent(in)  :: route_lake_file
9092     integer,                       intent(in)  :: NLAKES
9093     logical,                       intent(in)  :: reservoir_type_specified
9094     character(len=*),              intent(in)  :: reservoir_parameter_file
9095     integer(kind=int64), dimension(:), intent(out) :: LAKEIDM
9096     real,    dimension(:),         intent(out) :: HRZAREA,  LAKEMAXH, WEIRC,    WEIRL, WEIRH, DAML
9097     real,    dimension(:),         intent(out) :: ORIFICEC, ORIFICEA, ORIFICEE, lakelat, lakelon
9098     real,    dimension(:),         intent(out) :: ELEVLAKE
9099     integer, dimension(:),         intent(out) :: reservoir_type
9100
9101     integer :: iRet, ncid, ii, varid
9102     logical :: fatal_if_error
9103     fatal_if_error = .TRUE.  !! was thinking this would be a global variable...could become an input.
9104
9105 #ifdef HYDRO_D
9106     print*,"start read_route_lake_netcdf"
9107 #endif
9108
9109     iRet = nf90_open(trim(route_lake_file), nf90_nowrite, ncid)
9110     if (iRet /= nf90_noErr) then
9111        write(*,'("read_route_lake_netcdf: Problem opening: ''", A, "''")') trim(route_lake_file)
9112        if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem opening file.")
9113     endif
9114
9115     call get_1d_netcdf_int64(ncid,  'lake_id',  LAKEIDM, 'read_route_lake_netcdf', .TRUE.)
9116     call get_1d_netcdf_real(ncid, 'LkArea',   HRZAREA,   'read_route_lake_netcdf', .TRUE.)
9117     !rename the LAKEPARM input vars for Elev instead of Ht, 08/23/17 LKR/DY
9118     call get_1d_netcdf_real(ncid, 'LkMxE',    LAKEMAXH,  'read_route_lake_netcdf', .TRUE.)
9119     !rename WeirH to WeirE
9120     call get_1d_netcdf_real(ncid, 'WeirE',    WEIRH,     'read_route_lake_netcdf', .TRUE.)
9121     call get_1d_netcdf_real(ncid, 'WeirC',    WEIRC,     'read_route_lake_netcdf', .TRUE.)
9122     call get_1d_netcdf_real(ncid, 'WeirL',    WEIRL,     'read_route_lake_netcdf', .TRUE.)
9123     call get_1d_netcdf_real(ncid, 'Dam_Length', DAML,    'read_route_lake_netcdf', .TRUE.)
9124     call get_1d_netcdf_real(ncid, 'OrificeC', ORIFICEC,  'read_route_lake_netcdf', .TRUE.)
9125     call get_1d_netcdf_real(ncid, 'OrificeA', ORIFICEA,  'read_route_lake_netcdf', .TRUE.)
9126     call get_1d_netcdf_real(ncid, 'OrificeE', ORIFICEE,  'read_route_lake_netcdf', .TRUE.)
9127     call get_1d_netcdf_real(ncid, 'lat', lakelat,        'read_route_lake_netcdf', .TRUE.)
9128     call get_1d_netcdf_real(ncid, 'lon', lakelon,        'read_route_lake_netcdf', .TRUE.)
9129     !remove the alt var. and add initial fractional depth var. LKR/DY
9130     call get_1d_netcdf_real(ncid, 'ifd', ELEVLAKE,       'read_route_lake_netcdf', .FALSE.)
9131
9132     iRet = nf90_close(ncId)
9133     if (iRet /= nf90_noErr) then
9134        write(*,'("read_route_lake_netcdf: Problem closing: ''", A, "''")') trim(route_lake_file)
9135        if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem closing file.")
9136     end if
9137
9138    ! If reservoir_type_specified is set to true, then call function to read reservoir_type
9139    ! from the reservoir parameter file
9140    if (reservoir_type_specified) then
9141        call read_reservoir_type(reservoir_parameter_file, LAKEIDM, NLAKES, reservoir_type)
9142    end if
9143
9144 #ifdef HYDRO_D
9145     ii = size(LAKEIDM)
9146     print*,'last index=',ii
9147     print*,'HRZAREA', HRZAREA(ii)
9148     print*,'LAKEMAXH', LAKEMAXH(ii), 'WEIRC', WEIRC(ii), 'WEIRL', WEIRL(ii), 'DAML', DAML(ii)
9149     print*,'ORIFICEC', ORIFICEC(ii), 'ORIFICEA', ORIFICEA(ii), 'ORIFICEE', ORIFICEE(ii)
9150     print*,"finish read_route_lake_netcdf"
9151 #endif
9152
9153 end subroutine read_route_lake_netcdf
9154
9155 !===================================================================================================
9156 ! Program Names: get_1d_netcdf_real, get_1d_netcdf_int, get_1d_netcdf_text
9157 ! Author(s)/Contact(s): James L McCreight <jamesmcc><ucar><edu>
9158 ! Abstract: Read a variable of real or integer type from an open netcdf file, respectively.
9159 ! History Log:
9160 ! 7/17/15 -Created, JLM.
9161 ! Usage:
9162 ! Parameters: See definitions.
9163 ! Input Files: This file is refered to by it's "ncid" obtained from nc_open
9164 !              prior to calling this routine.
9165 ! Output Files: None.
9166 ! Condition codes: hydro_stop is passed "get_1d_netcdf".
9167 !
9168 ! If appropriate, descriptive troubleshooting instructions or
9169 ! likely causes for failures could be mentioned here with the
9170 ! appropriate error code
9171 !
9172 ! User controllable options: None.
9173
9174 !! could define an interface for these.
9175 subroutine get_1d_netcdf_int(ncid, varName, var, callingRoutine, fatal_if_error)
9176 integer,               intent(in)  :: ncid !! the file identifier
9177 character(len=*),      intent(in)  :: varName
9178 integer, dimension(:), intent(out) :: var
9179 character(len=*),      intent(in)  :: callingRoutine
9180 logical,               intent(in)  :: fatal_if_error
9181 integer :: varid, iret
9182 iRet = nf90_inq_varid(ncid, varName, varid)
9183 if (iret /= nf90_noErr) then
9184    if (fatal_IF_ERROR) then
9185       print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
9186       call hydro_stop("get_1d_netcdf")
9187    end if
9188 end if
9189 iRet = nf90_get_var(ncid, varid, var)
9190 if (iRet /= nf90_NoErr) then
9191    print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName)
9192    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int")
9193 end if
9194 end subroutine get_1d_netcdf_int
9195
9196     subroutine get_1d_netcdf_int64(ncid, varName, var, callingRoutine, fatal_if_error)
9197         integer,                       intent(in)  :: ncid !! the file identifier
9198         character(len=*),              intent(in)  :: varName
9199         integer(kind=int64), dimension(:), intent(out) :: var
9200         character(len=*),              intent(in)  :: callingRoutine
9201         logical,                       intent(in)  :: fatal_if_error
9202         integer :: varid, iret
9203         iRet = nf90_inq_varid(ncid, varName, varid)
9204         if (iret /= nf90_noErr) then
9205             if (fatal_IF_ERROR) then
9206                 print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
9207                 call hydro_stop("get_1d_netcdf")
9208             end if
9209         end if
9210         iRet = nf90_get_var(ncid, varid, var)
9211         if (iRet /= nf90_NoErr) then
9212             print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName)
9213             if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int")
9214         end if
9215     end subroutine get_1d_netcdf_int64
9216
9217 subroutine get_1d_netcdf_real(ncid, varName, var, callingRoutine, fatal_if_error)
9218 integer,            intent(in)  :: ncid !! the file identifier
9219 character(len=*),   intent(in)  :: varName
9220 real, dimension(:), intent(out) :: var
9221 character(len=*),   intent(in)  :: callingRoutine
9222 logical,            intent(in)  :: fatal_if_error
9223
9224 integer :: varid, iret
9225 iRet = nf90_inq_varid(ncid, varName, varid)
9226 if (iret /= nf90_noErr) then
9227    if (fatal_IF_ERROR) then
9228       print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
9229       call hydro_stop("get_1d_netcdf")
9230    end if
9231 end if
9232 iRet = nf90_get_var(ncid, varid, var)
9233 if (iRet /= nf90_NoErr) then
9234    print*, trim(callingRoutine) // ": get_1d_netcdf_real: values: " // trim(varName)
9235    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_real")
9236 end if
9237 end subroutine get_1d_netcdf_real
9238
9239 subroutine get_1d_netcdf_text(ncid, varName, var, callingRoutine, fatal_if_error)
9240 integer,                        intent(in)  :: ncid !! the file identifier
9241 character(len=*),               intent(in)  :: varName
9242 character(len=*), dimension(:), intent(out) :: var
9243 character(len=*),               intent(in)  :: callingRoutine
9244 logical,                        intent(in)  :: fatal_if_error
9245 integer :: varId, iRet
9246 iRet = nf90_inq_varid(ncid, varName, varid)
9247 if (iret /= nf90_NoErr) then
9248    print*, trim(callingRoutine) // ": get_1d_netcdf_text: variable: " // trim(varName)
9249    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text")
9250 end if
9251 iRet = nf90_get_var(ncid, varid, var)
9252 if (iret /= nf90_NoErr) then
9253    print*, trim(callingRoutine) // ": get_1d_netcdf_text: values: " // trim(varName)
9254    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text")
9255 end if
9256 end subroutine get_1d_netcdf_text
9257
9258 !===================================================================================================
9259 ! Program Names:
9260 !   get_netcdf_dim
9261 ! Author(s)/Contact(s):
9262 !   James L McCreight <jamesmcc><ucar><edu>
9263 ! Abstract:
9264 !   Get the length of a provided dimension.
9265 ! History Log:
9266 !   7/23/15 -Created, JLM.
9267 ! Usage:
9268 ! Parameters:
9269 !   file: character, the file to query
9270 !   dimName: character, the name of the dimension
9271 !   callingRoutine: character, the name of the calling routine for error messages
9272 !   fatalErr: Optional, Logical - all errors are fatal, calling hydro_stop()
9273 ! Input Files:
9274 !   Specified argument.
9275 ! Output Files:
9276 ! Condition codes:
9277 !   hydro_stop is called. .
9278 ! User controllable options:
9279 ! Notes:
9280
9281 function get_netcdf_dim(file, dimName, callingRoutine, fatalErr)
9282 implicit none
9283 integer :: get_netcdf_dim  !! return value
9284 character(len=*), intent(in)   :: file, dimName, callingRoutine
9285 integer :: ncId, dimId, iRet
9286 logical, optional, intent(in) :: fatalErr
9287 logical :: fatalErr_local
9288 character(len=256) :: errMsg
9289
9290 fatalErr_local = .false.
9291 if(present(fatalErr)) fatalErr_local=fatalErr
9292
9293 write(*,'("getting dimension from file: ", A)') trim(file)
9294 iRet = nf90_open(trim(file), nf90_NOWRITE, ncId)
9295 if (iret /= nf90_noerr) then
9296    write(*,'("Problem opening file: ", A)') trim(file)
9297    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9298    if(.not. fatalErr_local) get_netcdf_dim = -99
9299    if(.not. fatalErr_local) return
9300 endif
9301
9302 iRet = nf90_inq_dimid(ncId, trim(dimName), dimId)
9303 if (iret /= nf90_noerr) then
9304    write(*,'("Problem getting the dimension ID ", A)') &
9305         '"' // trim(dimName) // '" in file: ' // trim(file)
9306    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9307    if(.not. fatalErr_local) get_netcdf_dim = -99
9308    if(.not. fatalErr_local) return
9309 endif
9310
9311 iRet = nf90_inquire_dimension(ncId, dimId, len= get_netcdf_dim)
9312 if (iret /= nf90_noerr) then
9313    write(*,'("Problem getting the dimension length of ", A)') &
9314         '"' // trim(dimName) // '" in file: ' // trim(file)
9315    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9316    if(.not. fatalErr_local) get_netcdf_dim = -99
9317    if(.not. fatalErr_local) return
9318 endif
9319
9320 iRet = nf90_close(ncId)
9321 if (iret /= nf90_noerr) then
9322    write(*,'("Problem closing file: ", A)') trim(file)
9323    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9324    if(.not. fatalErr_local) get_netcdf_dim = -99
9325    if(.not. fatalErr_local) return
9326 endif
9327 end function get_netcdf_dim
9328
9329
9330 ! read the GWBUCKET Parm for NHDPlus
9331 subroutine readBucket_nhd(infile, numbasns, gw_buck_coeff, gw_buck_exp, &
9332                 gw_buck_loss, z_max, z_init, LINKID, nhdBuckMask)
9333     implicit none
9334     integer, intent(in) :: numbasns
9335     integer(kind=int64), dimension(numbasns) :: LINKID
9336     real, dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, gw_buck_loss
9337     real, dimension(numbasns) :: z_max, z_init
9338     integer, dimension(numbasns) :: nhdBuckMask
9339     character(len=*), intent(in) :: infile
9340 !   define temp array
9341     integer, volatile :: i,j,k, gnid, ncid, varid, ierr, dimid, iret
9342     integer(kind=int64), allocatable, dimension(:) :: tmpLinkid
9343     real, allocatable, dimension(:) :: tmpCoeff, tmpExp, tmpLoss
9344     real, allocatable, dimension(:) :: tmpz_max, tmpz_init
9345
9346 !   get gnid
9347     gnid = 0
9348 #ifdef MPP_LAND
9349     if(my_id .eq. io_id ) then
9350 #endif
9351        iret = nf90_open(trim(infile), NF90_NOWRITE, ncid)
9352 #ifdef MPP_LAND
9353        if(iret .ne. 0) then
9354            call hydro_stop("Failed to open GWBUCKET Parameter file.")
9355        endif
9356        iret = nf90_inq_dimid(ncid, "BasinDim", dimid)
9357        if (iret /= 0) then
9358                !print*, "nf90_inq_dimid:  BasinDim"
9359                call hydro_stop("Failed read GBUCKETPARM - nf90_inq_dimid:  BasinDim")
9360        endif
9361        iret = nf90_inquire_dimension(ncid, dimid, len=gnid)
9362     endif
9363     call mpp_land_bcast_int1(gnid)
9364 #endif
9365     allocate(tmpLinkid(gnid))
9366     allocate(tmpCoeff(gnid))
9367     allocate(tmpExp(gnid))
9368     allocate(tmpLoss(gnid))
9369     allocate(tmpz_max(gnid))
9370     allocate(tmpz_init(gnid))
9371 #ifdef MPP_LAND
9372     if(my_id .eq. io_id ) then
9373 #endif
9374 !      read the file data.
9375           iret = nf90_inq_varid(ncid,"Coeff",  varid)
9376           if(iret /= 0) then
9377                print * , "could not find Coeff from ", infile
9378                call hydro_stop("Failed to read BUCKETPARM")
9379           endif
9380           iret = nf90_get_var(ncid, varid, tmpCoeff)
9381
9382           iret = nf90_inq_varid(ncid,"Expon",  varid)
9383           if(iret /= 0) then
9384                print * , "could not find Expon from ", infile
9385                call hydro_stop("Failed to read BUCKETPARM")
9386           endif
9387           iret = nf90_get_var(ncid, varid, tmpExp)
9388
9389           if(nlst(did)%bucket_loss .eq. 1) then
9390                iret = nf90_inq_varid(ncid,"Loss",  varid)
9391                if(iret /= 0) then
9392                     print * , "could not find Loss from ", infile
9393                     call hydro_stop("Failed to read BUCKETPARM")
9394                endif
9395                iret = nf90_get_var(ncid, varid, tmpLoss)
9396           endif
9397
9398           iret = nf90_inq_varid(ncid,"Zmax",  varid)
9399           if(iret /= 0) then
9400                print * , "could not find Zmax from ", infile
9401                call hydro_stop("Failed to read BUCKETPARM")
9402           endif
9403           iret = nf90_get_var(ncid, varid, tmpz_max)
9404
9405           iret = nf90_inq_varid(ncid,"Zinit",  varid)
9406           if(iret /= 0) then
9407                print * , "could not find Zinit from ", infile
9408                call hydro_stop("Failed to read BUCKETPARM")
9409           endif
9410           iret = nf90_get_var(ncid, varid, tmpz_init)
9411
9412           iret = nf90_inq_varid(ncid, "ComID",  varid)
9413           if(iret /= 0) then
9414                print * , "could not find ComID from ", infile
9415                call hydro_stop("Failed to read BUCKETPARM")
9416           endif
9417           iret = nf90_get_var(ncid, varid, tmpLinkID)
9418 #ifdef MPP_LAND
9419     endif
9420        if(gnid .gt. 0) then
9421           call mpp_land_bcast_real_1d(tmpCoeff)
9422           call mpp_land_bcast_real_1d(tmpExp)
9423           if(nlst(did)%bucket_loss .eq. 1) then
9424              call mpp_land_bcast_real_1d(tmpLoss)
9425           endif
9426           call mpp_land_bcast_real_1d(tmpz_max)
9427           call mpp_land_bcast_real_1d(tmpz_init)
9428           call mpp_land_bcast_int8(gnid ,tmpLinkid)
9429        endif
9430 #endif
9431
9432        nhdBuckMask = -999
9433
9434        ! The following loops are replaced by a hashtable-based algorithm
9435        !   do k = 1, numbasns
9436        !         do i = 1, gnid
9437        !             if(LINKID(k) .eq. tmpLinkid(i)) then
9438        !                gw_buck_coeff(k) = tmpCoeff(i)
9439        !                gw_buck_exp(k) = tmpExp(i)
9440        !                z_max(k) = tmpz_max(i)
9441        !                z_init(k) = tmpz_init(i)
9442        !                nhdBuckMask(k) = 1
9443        !                goto 301
9444        !             endif
9445        !         end do
9446        ! 301     continue
9447        !     end do
9448
9449        block
9450          type(hash_t) :: hash_table
9451          integer(kind=int64) :: val,it
9452          logical :: found
9453
9454          call hash_table%set_all_idx(LINKID,numbasns)
9455          do it=1, gnid
9456             call hash_table%get(tmpLinkid(it), val, found)
9457             if((found .eqv. .true.)) then
9458                if((nhdBuckMask(val) == -999)) then
9459                   gw_buck_coeff(val) = tmpCoeff(it)
9460                   gw_buck_exp(val) = tmpExp(it)
9461                   if(nlst(did)%bucket_loss == 1) then
9462                      gw_buck_loss(val) = tmpLoss(it)
9463                   end if
9464                   z_max(val) = tmpz_max(it)
9465                   z_init(val) = tmpz_init(it)
9466                   nhdBuckMask(val) = 1
9467                end if
9468             end if
9469          end do
9470          call hash_table%clear()
9471        end block
9472
9473     if(allocated(tmpCoeff)) deallocate(tmpCoeff)
9474     if(allocated(tmpExp)) deallocate(tmpExp)
9475     if(allocated(tmpLoss)) deallocate(tmpLoss)
9476     if(allocated(tmpz_max)) deallocate(tmpz_max)
9477     if(allocated(tmpz_init)) deallocate(tmpz_init)
9478     if(allocated(tmpLinkid)) deallocate(tmpLinkid)
9479 end subroutine readBucket_nhd
9480
9481 !-- output the channel routine for fast output.
9482 !   subroutine mpp_output_chrt2(gnlinks,gnlinksl,map_l2g,igrid,                  &
9483 !        split_output_count, NLINKS, ORDER,                                     &
9484 !        startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch,              &
9485 !        K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, &
9486 !        lsmDt                                                                  &
9487 !        )
9488
9489 #ifdef MPP_LAND
9490    subroutine mpp_output_chrt2(                      &
9491         gnlinks,   gnlinksl,           map_l2g,      &
9492         igrid,     split_output_count,               &
9493         NLINKS,    ORDER,                            &
9494         startdate, date,                             &
9495         chlon,     chlat,                            &
9496         hlink,     zelev,                            &
9497         qlink,     dtrt_ch,  K,                      &
9498         NLINKSL,  channel_option,                    &
9499         linkid                                       &
9500 #ifdef WRF_HYDRO_NUDGING
9501         , nudge                                      &
9502 #endif
9503         ,         QLateral,    io_config_outputs               &
9504         ,                     velocity               &
9505         ,  accSfcLatRunoff,  accBucket               &
9506         ,    qSfcLatRunoff,    qBucket               &
9507         ,   qBtmVertRunoff,   UDMP_OPT               &
9508         )
9509
9510        USE module_mpp_land
9511
9512        implicit none
9513
9514 !!output the routing variables over just channel
9515      integer,                                  intent(in) :: igrid,K,NLINKSL
9516      integer,                                  intent(in) :: split_output_count
9517      integer,                                  intent(in) :: NLINKS
9518      real, dimension(:),               intent(in) :: chlon,chlat
9519      real, dimension(:),                  intent(in) :: hlink,zelev
9520
9521      integer, dimension(:),               intent(in) :: ORDER
9522      integer(kind=int64), dimension(:),       intent(in) :: linkid
9523
9524      real,                                     intent(in) :: dtrt_ch
9525      real, dimension(:,:),                intent(in) :: qlink
9526 #ifdef WRF_HYDRO_NUDGING
9527      real, dimension(:),                  intent(in) :: nudge
9528 #endif
9529      real, dimension(:), intent(in) :: QLateral, velocity
9530      integer, intent(in) :: io_config_outputs
9531      real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket
9532      real  , dimension(:), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
9533      integer, intent(in) :: UDMP_OPT
9534
9535      integer :: channel_option
9536
9537      character(len=*),                         intent(in) :: startdate
9538      character(len=*),                         intent(in) :: date
9539
9540       integer  :: gnlinks, map_l2g(nlinks),  gnlinksl
9541       real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev
9542 #ifdef WRF_HYDRO_NUDGING
9543       real, allocatable,dimension(:) :: g_nudge
9544 #endif
9545       integer, allocatable,dimension(:) :: g_order
9546       integer(kind=int64), allocatable, dimension(:) :: g_linkid
9547       real,allocatable,dimension(:,:) :: g_qlink
9548       integer  :: gsize
9549       real*8, allocatable, dimension(:) :: g_accSfcLatRunoff, g_accBucket
9550       real  , allocatable, dimension(:) ::    g_qSfcLatRunoff,  g_qBucket, g_qBtmVertRunoff
9551       real, allocatable, dimension(:)   :: g_QLateral, g_velocity
9552
9553         gsize = gNLINKS
9554         if(gnlinksl .gt. gsize) gsize = gnlinksl
9555
9556
9557      if(my_id .eq. io_id ) then
9558         allocate(g_chlon(gsize  ))
9559         allocate(g_chlat(gsize  ))
9560         allocate(g_hlink(gsize  ))
9561         allocate(g_zelev(gsize  ))
9562         allocate(g_qlink(gsize  ,2))
9563 #ifdef WRF_HYDRO_NUDGING
9564         allocate(g_nudge(gsize))
9565 #endif
9566         allocate(g_order(gsize  ))
9567         allocate(g_linkid(gsize  ))
9568
9569         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9570            nlst(did)%output_channelBucket_influx .eq. 2      ) then
9571            allocate(g_qSfcLatRunoff(  gsize  ))
9572            allocate(g_qBucket(        gsize  ))
9573         end if
9574
9575         if(nlst(did)%output_channelBucket_influx .eq. 2) &
9576              allocate(g_qBtmVertRunoff(  gsize  ))
9577
9578         if(nlst(did)%output_channelBucket_influx .eq. 3) then
9579            allocate(g_accSfcLatRunoff(gsize  ))
9580            allocate(g_accBucket(      gsize  ))
9581         end if
9582
9583         allocate(g_QLateral(gsize  ))
9584         allocate(g_velocity(gsize  ))
9585
9586      else
9587
9588         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9589            nlst(did)%output_channelBucket_influx .eq. 2      ) then
9590            allocate(g_qSfcLatRunoff(  1))
9591            allocate(g_qBucket(        1))
9592         end if
9593
9594         if(nlst(did)%output_channelBucket_influx .eq. 2) &
9595              allocate(g_qBtmVertRunoff(  1))
9596
9597         if(nlst(did)%output_channelBucket_influx .eq. 3) then
9598            allocate(g_accSfcLatRunoff(1))
9599            allocate(g_accBucket(      1))
9600         end if
9601
9602        allocate(g_QLateral(1))
9603        allocate(g_velocity(1))
9604
9605         allocate(g_chlon(1))
9606         allocate(g_chlat(1))
9607         allocate(g_hlink(1))
9608         allocate(g_zelev(1))
9609         allocate(g_qlink(1,2))
9610 #ifdef WRF_HYDRO_NUDGING
9611         allocate(g_nudge(1))
9612 #endif
9613         allocate(g_order(1))
9614         allocate(g_linkid(1))
9615      endif
9616
9617      call mpp_land_sync()
9618      if(channel_option .eq. 1 .or. channel_option .eq. 2) then
9619         g_qlink = 0
9620         call ReachLS_write_io(qlink(:,1), g_qlink(:,1))
9621         call ReachLS_write_io(qlink(:,2), g_qlink(:,2))
9622 #ifdef WRF_HYDRO_NUDGING
9623         g_nudge=0
9624         call ReachLS_write_io(nudge,g_nudge)
9625 #endif
9626         call ReachLS_write_io(order, g_order)
9627         call ReachLS_write_io(linkid, g_linkid)
9628         call ReachLS_write_io(chlon, g_chlon)
9629         call ReachLS_write_io(chlat, g_chlat)
9630         call ReachLS_write_io(zelev, g_zelev)
9631
9632         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9633            nlst(did)%output_channelBucket_influx .eq. 2      ) then
9634            call ReachLS_write_io(qSfcLatRunoff, g_qSfcLatRunoff)
9635            call ReachLS_write_io(qBucket,       g_qBucket)
9636         end if
9637
9638         if(nlst(did)%output_channelBucket_influx .eq. 2) &
9639              call ReachLS_write_io(qBtmVertRunoff, g_qBtmVertRunoff)
9640
9641         if(nlst(did)%output_channelBucket_influx .eq. 3) then
9642            call ReachLS_write_io(accSfcLatRunoff, g_accSfcLatRunoff)
9643            call ReachLS_write_io(accBucket,       g_accBucket)
9644         end if
9645
9646         call ReachLS_write_io(QLateral, g_QLateral)
9647         call ReachLS_write_io(velocity, g_velocity)
9648        !yw call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
9649        call  ReachLS_write_io(hlink,g_hlink)
9650
9651      else
9652
9653         call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
9654         call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
9655         call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order)
9656         call write_chanel_int8(linkid,map_l2g,gnlinks,nlinks,g_linkid)
9657         call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon)
9658         call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat)
9659         call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev)
9660         call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
9661      endif
9662
9663
9664      if(my_id .eq. IO_id) then
9665        call output_chrt2(igrid, split_output_count, GNLINKS, g_ORDER,                &
9666           startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K,     &
9667           gNLINKSL,channel_option, g_linkid  &
9668 #ifdef WRF_HYDRO_NUDGING
9669           , g_nudge                                     &
9670 #endif
9671           ,        g_QLateral,     io_config_outputs,      g_velocity  &
9672           , g_accSfcLatRunoff, g_accBucket                   &
9673           ,   g_qSfcLatRunoff,   g_qBucket, g_qBtmVertRunoff &
9674           ,          UDMP_OPT                                &
9675           )
9676      end if
9677
9678      call mpp_land_sync()
9679     if(allocated(g_order)) deallocate(g_order)
9680     if(allocated(g_chlon)) deallocate(g_chlon)
9681     if(allocated(g_chlat)) deallocate(g_chlat)
9682     if(allocated(g_hlink)) deallocate(g_hlink)
9683     if(allocated(g_zelev)) deallocate(g_zelev)
9684     if(allocated(g_qlink)) deallocate(g_qlink)
9685     if(allocated(g_linkid)) deallocate(g_linkid)
9686
9687 #ifdef WRF_HYDRO_NUDGING
9688     if(allocated(g_nudge)) deallocate(g_nudge)
9689 #endif
9690
9691     if(allocated(g_QLateral)) deallocate(g_QLateral)
9692     if(allocated(g_velocity)) deallocate(g_velocity)
9693
9694     if(allocated(g_qSfcLatRunoff)) deallocate(g_qSfcLatRunoff)
9695     if(allocated(g_qBucket)) deallocate(g_qBucket)
9696     if(allocated(g_qBtmVertRunoff)) deallocate(g_qBtmVertRunoff)
9697     if(allocated(g_accSfcLatRunoff)) deallocate(g_accSfcLatRunoff)
9698     if(allocated(g_accBucket)) deallocate(g_accBucket)
9699
9700 end subroutine mpp_output_chrt2
9701
9702 #endif
9703
9704
9705 !subroutine output_chrt2
9706 !For realtime output only when CHRTOUT_GRID = 2.
9707 !   subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER,             &
9708 !        startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
9709 !        STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, &
9710 !        lsmDt                                                                   &
9711 !        )
9712    subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER,             &
9713         startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
9714         NLINKSL, channel_option ,linkid &
9715 #ifdef WRF_HYDRO_NUDGING
9716         , nudge                                     &
9717 #endif
9718         ,        QLateral,   io_config_outputs,       velocity &
9719         , accSfcLatRunoff, accBucket                 &
9720         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff &
9721         ,        UDMP_OPT                            &
9722         )
9723
9724      implicit none
9725 !!output the routing variables over just channel
9726      integer,                                  intent(in) :: igrid,K,channel_option
9727      integer,                                  intent(in) :: split_output_count
9728      integer,                                  intent(in) :: NLINKS, NLINKSL
9729      real, dimension(:),                  intent(in) :: chlon,chlat
9730      real, dimension(:),                  intent(in) :: hlink,zelev
9731      integer, dimension(:),               intent(in) :: ORDER
9732
9733      real,                                     intent(in) :: dtrt_ch
9734      real, dimension(:,:),                intent(in) :: qlink
9735 #ifdef WRF_HYDRO_NUDGING
9736      real, dimension(:),                  intent(in) :: nudge
9737 #endif
9738      real, dimension(:), intent(in) :: QLateral, velocity
9739      integer, intent(in) :: io_config_outputs
9740      real*8, dimension(nlinks), intent(in) :: accSfcLatRunoff, accBucket
9741      real  , dimension(nlinks), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
9742      integer  :: UDMP_OPT
9743
9744      character(len=*),                         intent(in) :: startdate
9745      character(len=*),                         intent(in) :: date
9746
9747
9748
9749      integer(kind=int64), allocatable, dimension(:) :: linkid
9750
9751      integer, allocatable, DIMENSION(:)         :: rec_num_of_station
9752      integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
9753
9754      integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
9755
9756      integer, save  :: output_count
9757      integer, save  :: ncid
9758
9759      integer :: stationdim, dimdata, varid, charid, n
9760      integer :: timedim
9761
9762      integer :: iret,i !-- order_to_write is the lowest stream order to output
9763      integer :: start_posO, prev_posO, nlk
9764
9765      integer :: previous_pos  !-- used for the station model
9766      character(len=256) :: output_flnm
9767      character(len=34)  :: sec_since_date
9768      integer :: seconds_since,nstations,cnt,ObsStation
9769      character(len=32)  :: convention
9770      character(len=11),allocatable, DIMENSION(:)  :: stname
9771
9772      character(len=34) :: sec_valid_date
9773
9774     !--- all this for writing the station id string
9775      INTEGER   TDIMS, TXLEN
9776      PARAMETER (TDIMS=2)    ! number of TX dimensions
9777      PARAMETER (TXLEN = 11) ! length of example string
9778      INTEGER  TIMEID        ! record dimension id
9779      INTEGER  TXID          ! variable ID
9780      INTEGER  TXDIMS(TDIMS) ! variable shape
9781      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
9782
9783      !--  observation point  ids
9784      INTEGER   OTDIMS, OTXLEN
9785      PARAMETER (OTDIMS=2)    ! number of TX dimensions
9786      PARAMETER (OTXLEN = 15) ! length of example string
9787      INTEGER  OTIMEID        ! record dimension id
9788      INTEGER  OTXID          ! variable ID
9789      INTEGER  OTXDIMS(OTDIMS) ! variable shape
9790      INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
9791      character(len=19)  :: date19, date19start
9792
9793
9794      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
9795
9796
9797      if(channel_option .ne. 3) then
9798         nstations = NLINKSL
9799      else
9800         nstations = NLINKS
9801      endif
9802
9803        if(split_output_count .ne. 1 ) then
9804             write(6,*) "WARNING: split_output_count need to be 1 for this output option."
9805        endif
9806 !-- have moved sec_since_date from above here..
9807         sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
9808                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
9809
9810         date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
9811                   //startdate(12:13)//':'//startdate(15:16)//':00'
9812
9813         seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
9814         sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
9815                       //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
9816
9817         write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
9818
9819 #ifdef HYDRO_D
9820         print*, 'output_flnm = "'//trim(output_flnm)//'"'
9821 #endif
9822
9823        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
9824        if (iret /= 0) then
9825            print*,  "Problem nf90_create points"
9826            call hydro_stop("In output_chrt2() - Problem nf90_create points.")
9827        endif
9828
9829        iret = nf90_def_dim(ncid, "station", nstations, stationdim)
9830        iret = nf90_def_dim(ncid, "time", 1, timedim)
9831
9832 if (io_config_outputs .le. 0) then
9833       !- station location definition all,  lat
9834         iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
9835         iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude')
9836         iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
9837
9838       !- station location definition,  long
9839         iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
9840         iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude')
9841         iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
9842
9843 !     !-- elevation is ZELEV
9844         iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
9845         iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude')
9846         iret = nf90_put_att(ncid, varid, 'units', 'meters')
9847
9848 !-- parent index
9849 !        iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/stationdim/), varid)
9850 !        iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record')
9851
9852
9853      !-- prevChild
9854 !        iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/stationdim/), varid)
9855 !        iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station')
9856 !        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
9857
9858      !-- lastChild
9859 !        iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
9860 !        iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station')
9861 !        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
9862 endif
9863
9864         iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
9865         iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
9866         iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
9867
9868         !- flow definition, var
9869         iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/stationdim/), varid)
9870         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
9871         iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow')
9872
9873 #ifdef WRF_HYDRO_NUDGING
9874         !- nudge definition
9875         iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/stationdim/), varid)
9876         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
9877         iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration')
9878 #endif
9879
9880
9881 !     !- head definition, var
9882       if(channel_option .eq. 3) then
9883         iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/stationdim/), varid)
9884         iret = nf90_put_att(ncid, varid, 'units', 'meter')
9885         iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
9886       endif
9887 !#ifdef HYDRO_REALTIME
9888 !      if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
9889 !       iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/stationdim/), varid)
9890 !        iret = nf90_put_att(ncid, varid, 'units', 'meter')
9891 !        iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
9892 !      endif
9893 !#endif
9894
9895
9896         !-- NEW lateral inflow definition, var
9897         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
9898                 iret = nf90_def_var(ncid, "q_lateral", NF90_FLOAT, (/stationdim/), varid)
9899                 iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
9900                 iret = nf90_put_att(ncid, varid, 'long_name', 'Runoff into channel reach')
9901         endif
9902
9903         !-- NEW velocity definition, var
9904         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then
9905                 iret = nf90_def_var(ncid, "velocity", NF90_FLOAT, (/stationdim/), varid)
9906                 iret = nf90_put_att(ncid, varid, 'units', 'meter/sec')
9907                 iret = nf90_put_att(ncid, varid, 'long_name', 'River Velocity')
9908         endif
9909
9910 if (io_config_outputs .le. 0) then
9911 !     !- order definition, var
9912         iret = nf90_def_var(ncid, "order", NF90_INT, (/stationdim/), varid)
9913         iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order')
9914         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
9915 endif
9916
9917      !-- station  id
9918      ! define character-position dimension for strings of max length 11
9919         iret = nf90_def_var(ncid, "station_id", NF90_INT, (/stationdim/), varid)
9920         iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
9921
9922        !! JLM: Write/define a global attribute of the file as the LSM timestep. Enforce
9923        !! JLM: force_type=9 only reads these discharges to the channel if the LSM timesteps match.
9924
9925         if(UDMP_OPT .eq. 1 .and. nlst(did)%output_channelBucket_influx .ne. 0) then
9926            !! channel & channelBucketOnly global atts
9927            iret = nf90_put_att(ncid, NF90_GLOBAL, 'OVRTSWCRT', nlst(1)%OVRTSWCRT )
9928            iret = nf90_put_att(ncid, NF90_GLOBAL, 'NOAH_TIMESTEP', int(nlst(1)%dt) )
9929            iret = nf90_put_att(ncid, NF90_GLOBAL, "channel_only", nlst(did)%channel_only )
9930            iret = nf90_put_att(ncid, NF90_GLOBAL, "channelBucket_only", nlst(did)%channelBucket_only )
9931
9932            !! FLUXES to channel
9933            if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9934               nlst(did)%output_channelBucket_influx .eq. 2      ) then
9935               iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/stationdim/), varid)
9936               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
9937               if(nlst(did)%OVRTSWCRT .eq. 1) then              !123456789112345678921234567
9938                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing')
9939               else
9940                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff')
9941               end if
9942               iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/stationdim/), varid)
9943               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
9944               !                                                 1234567891234567892
9945               iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket')
9946            end if
9947
9948            !! Bucket influx
9949            !! In channel_only mode, there are not valie qBtmVertRunoff values
9950            if(nlst(did)%output_channelBucket_influx .eq. 2 .and. &
9951               nlst(did)%channel_only                .eq. 0         ) then
9952               iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/stationdim/), varid)
9953               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
9954               iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket')
9955            endif
9956
9957            !! ACCUMULATIONS
9958            if(nlst(did)%output_channelBucket_influx .eq. 3) then
9959               iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/stationdim/), varid)
9960               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
9961               if(nlst(did)%OVRTSWCRT .eq. 1) then
9962                  iret = nf90_put_att(ncid,varid,'long_name',&
9963                                         'ACCUMULATED runoff from terrain routing')
9964               else
9965                  iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land')
9966               end if
9967
9968               iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/stationdim/), varid)
9969               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
9970               iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED flux from gw bucket')
9971            endif
9972         endif
9973
9974          convention(1:32) = "Unidata Observation Dataset v1.0"
9975          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
9976          iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
9977
9978 if (io_config_outputs .le. 0) then
9979          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
9980          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
9981          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
9982          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
9983 endif
9984          iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
9985          iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
9986          iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
9987          iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", 1)
9988
9989         !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9990         !! END DEF
9991          iret = nf90_enddef(ncid)
9992
9993          iret = nf90_inq_varid(ncid,"time", varid)
9994          iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
9995
9996 if (io_config_outputs .le. 0) then
9997         !-- write latitudes
9998          iret = nf90_inq_varid(ncid,"latitude", varid)
9999          iret = nf90_put_var(ncid, varid, chlat, (/1/), (/nstations/))
10000
10001         !-- write longitudes
10002          iret = nf90_inq_varid(ncid,"longitude", varid)
10003          iret = nf90_put_var(ncid, varid, chlon, (/1/), (/nstations/))
10004
10005         !-- write elevations
10006          iret = nf90_inq_varid(ncid,"altitude", varid)
10007          iret = nf90_put_var(ncid, varid, zelev, (/1/), (/nstations/))
10008
10009         !-- write order
10010          iret = nf90_inq_varid(ncid,"order", varid)
10011          iret = nf90_put_var(ncid, varid, ORDER, (/1/), (/nstations/))
10012 endif
10013
10014         !-- write stream flow
10015          iret = nf90_inq_varid(ncid,"streamflow", varid)
10016          iret = nf90_put_var(ncid, varid, qlink(:,1), (/1/), (/nstations/))
10017
10018 #ifdef WRF_HYDRO_NUDGING
10019         !-- write nudge
10020          iret = nf90_inq_varid(ncid,"nudge", varid)
10021          iret = nf90_put_var(ncid, varid, nudge, (/1/), (/nstations/))
10022 #endif
10023
10024         !-- write head
10025         if(channel_option .eq. 3) then
10026            iret = nf90_inq_varid(ncid,"head", varid)
10027            iret = nf90_put_var(ncid, varid, hlink, (/1/), (/nstations/))
10028         endif
10029 !#ifdef HYDRO_REALTIME
10030 !       if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
10031 !             ! dummy value for now
10032 !              iret = nf90_inq_varid(ncid,"head", varid)
10033 !              iret = nf90_put_vara_real(ncid, varid, (/1/), (/nstations/), chlon*0.-9999.)
10034 !        endif
10035 !#endif
10036
10037         !-- write lateral inflow
10038         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
10039                 iret = nf90_inq_varid(ncid,"q_lateral", varid)
10040                 iret = nf90_put_var(ncid, varid, QLateral, (/1/), (/nstations/))
10041         endif
10042
10043         !-- writelvelocity (dummy value for now)
10044         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then
10045                 iret = nf90_inq_varid(ncid,"velocity", varid)
10046                 iret = nf90_put_var(ncid, varid, velocity, (/1/), (/nstations/))
10047         endif
10048
10049        !! JLM: Write/define a global attribute of the file as the LSM timestep. Enforce
10050        !! JLM:   force_type=9 only reads these discharges to the channel if the LSM timesteps match.
10051        if(UDMP_OPT .eq. 1 .and. nlst(did)%output_channelBucket_influx .ne. 0) then
10052              !! FLUXES
10053              if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
10054                 nlst(did)%output_channelBucket_influx .eq. 2      ) then
10055                 iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid)
10056                 iret = nf90_put_var(ncid, varid, qSfcLatRunoff, (/1/), (/nstations/))
10057
10058                 iret = nf90_inq_varid(ncid,"qBucket", varid)
10059                 iret = nf90_put_var(ncid, varid, qBucket, (/1/), (/nstations/))
10060              end if
10061
10062              !! Bucket model influxes
10063              if(nlst(did)%output_channelBucket_influx .eq. 2 .and. &
10064                 nlst(did)%channel_only                .eq. 0         ) then
10065                 iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid)
10066                 iret = nf90_put_var(ncid, varid, qBtmVertRunoff, (/1/), (/nstations/))
10067              endif
10068
10069             !! ACCUMULATIONS
10070             if(nlst(did)%output_channelBucket_influx .eq. 3) then
10071                iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid)
10072                iret = nf90_put_var(ncid, varid, accSfcLatRunoff, (/1/), (/nstations/))
10073
10074                iret = nf90_inq_varid(ncid,"accBucket", varid)
10075                iret = nf90_put_var(ncid, varid, accBucket, (/1/), (/nstations/))
10076             end if
10077          endif
10078
10079         !-- write id
10080         iret = nf90_inq_varid(ncid,"station_id", varid)
10081         iret = nf90_put_var(ncid, varid, linkid, (/1/), (/nstations/))
10082
10083
10084       iret = nf90_redef(ncid)
10085       date19(1:19) = "0000-00-00_00:00:00"
10086       date19(1:len_trim(date)) = date
10087       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
10088       iret = nf90_enddef(ncid)
10089
10090       iret = nf90_sync(ncid)
10091       iret = nf90_close(ncid)
10092
10093 #ifdef HYDRO_D
10094      print *, "Exited Subroutine output_chrt"
10095 #endif
10096
10097
10098 end subroutine output_chrt2
10099
10100
10101    subroutine output_GW_Diag(did)
10102        implicit none
10103        integer :: i , did, gnbasns
10104
10105 #ifdef MPP_LAND
10106        real, allocatable, dimension(:) :: g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas
10107        integer(kind=int64), allocatable, dimension(:) :: g_basnsInd
10108        if(my_id .eq. io_id) then
10109           if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then
10110                allocate(g_qin_gwsubbas(rt_domain(did)%gnumbasns))
10111                allocate(g_qout_gwsubbas(rt_domain(did)%gnumbasns))
10112                allocate(g_z_gwsubbas(rt_domain(did)%gnumbasns))
10113                allocate(g_basnsInd(rt_domain(did)%gnumbasns))
10114                gnbasns = rt_domain(did)%gnumbasns
10115           else
10116                allocate(g_qin_gwsubbas(rt_domain(did)%gnlinksl))
10117                allocate(g_qout_gwsubbas(rt_domain(did)%gnlinksl))
10118                allocate(g_z_gwsubbas(rt_domain(did)%gnlinksl))
10119                allocate(g_basnsInd(rt_domain(did)%gnlinksl))
10120                gnbasns = rt_domain(did)%gnlinksl
10121           endif
10122        endif
10123
10124        if(nlst(did)%channel_option .ne. 3) then
10125           call ReachLS_write_io(rt_domain(did)%qin_gwsubbas,g_qin_gwsubbas)
10126           call ReachLS_write_io(rt_domain(did)%qout_gwsubbas,g_qout_gwsubbas)
10127           call ReachLS_write_io(rt_domain(did)%z_gwsubbas,g_z_gwsubbas)
10128           call ReachLS_write_io(rt_domain(did)%linkid,g_basnsInd)
10129        else
10130           call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,  &
10131                  rt_domain(did)%basnsInd,g_qin_gwsubbas)
10132           call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,  &
10133                  rt_domain(did)%basnsInd,g_qout_gwsubbas)
10134           call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,  &
10135                  rt_domain(did)%basnsInd,g_z_gwsubbas)
10136           call gw_write_io_int(rt_domain(did)%numbasns,rt_domain(did)%basnsInd,  &
10137                  rt_domain(did)%basnsInd,g_basnsInd)
10138        endif
10139        if(my_id .eq. io_id) then
10140 !          open (unit=51,file='GW_inflow.txt',form='formatted',&
10141 !                status='unknown',position='append')
10142 !          open (unit=52,file='GW_outflow.txt',form='formatted',&
10143 !                status='unknown',position='append')
10144 !          open (unit=53,file='GW_zlev.txt',form='formatted',&
10145 !                status='unknown',position='append')
10146 !          do i=1,RT_DOMAIN(did)%gnumbasns
10147 !             write (51,951) i,nlst_rt(did)%olddate,g_qin_gwsubbas(i)
10148 951        FORMAT(I3,1X,A19,1X,F11.3)
10149 !            write (52,951) i,nlst_rt(did)%olddate,g_qout_gwsubbas(i)
10150 !            write (53,951) i,nlst_rt(did)%olddate,g_z_gwsubbas(i)
10151 !         end do
10152 !         close(51)
10153 !         close(52)
10154 !         close(53)
10155
10156           call   output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, gnbasns, &
10157                   trim(nlst(did)%sincedate), trim(nlst(did)%olddate), &
10158                   g_basnsInd,g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas )
10159           deallocate(g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas, g_basnsInd)
10160
10161        endif
10162           if(allocated(g_qin_gwsubbas))  deallocate(g_qin_gwsubbas)
10163           if(allocated(g_qout_gwsubbas))  deallocate(g_qout_gwsubbas)
10164           if(allocated(g_z_gwsubbas))  deallocate(g_z_gwsubbas)
10165
10166 # else
10167 !       open (unit=51,file='GW_inflow.txt',form='formatted',&
10168 !             status='unknown',position='append')
10169 !       open (unit=52,file='GW_outflow.txt',form='formatted',&
10170 !             status='unknown',position='append')
10171 !       open (unit=53,file='GW_zlev.txt',form='formatted',&
10172 !             status='unknown',position='append')
10173 !       do i=1,RT_DOMAIN(did)%numbasns
10174 !          write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i)
10175 951        FORMAT(I3,1X,A19,1X,F11.3)
10176 !          write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i)
10177 !          write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i)
10178 !       end do
10179 !       close(51)
10180 !       close(52)
10181 !       close(53)
10182         if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then
10183           call   output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, RT_DOMAIN(did)%numbasns, &
10184                   trim(nlst(did)%sincedate), trim(nlst(did)%olddate), &
10185                   rt_domain(did)%basnsInd,rt_domain(did)%qin_gwsubbas, &
10186                   rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas  )
10187         else
10188           call   output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, RT_DOMAIN(did)%nlinksl, &
10189                   trim(nlst(did)%sincedate), trim(nlst(did)%olddate), &
10190                   rt_domain(did)%linkid,rt_domain(did)%qin_gwsubbas, &
10191                   rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas  )
10192         endif
10193 #endif
10194     end subroutine output_GW_Diag
10195
10196
10197 !----------------------------------- gw netcdf output
10198
10199    subroutine output_gw_netcdf(igrid, split_output_count, nbasns, &
10200         startdate, date, &
10201         gw_id_var, gw_in_var, gw_out_var, gw_z_var)
10202
10203      integer,                                  intent(in) :: igrid
10204      integer,                                  intent(in) :: split_output_count
10205      integer,                                  intent(in) :: nbasns
10206      real, dimension(:),                  intent(in) :: gw_in_var, gw_out_var, gw_z_var
10207      integer(kind=int64), dimension(:),               intent(in) :: gw_id_var
10208
10209      character(len=*),                         intent(in) :: startdate
10210      character(len=*),                         intent(in) :: date
10211
10212
10213      integer, save  :: output_count
10214      integer, save :: ncid
10215
10216      integer :: basindim, varid,  n, nstations
10217      integer :: iret,i    !--
10218      character(len=256) :: output_flnm
10219      character(len=19)  :: date19, date19start
10220      character(len=32)  :: convention
10221      integer :: timedim
10222      integer :: seconds_since
10223      character(len=34)  :: sec_since_date
10224      character(len=34)  :: sec_valid_date
10225
10226      if(split_output_count .ne. 1 ) then
10227             write(6,*) "WARNING: split_output_count need to be 1 for this output option."
10228      endif
10229
10230      sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
10231                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
10232
10233      date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
10234                   //startdate(12:13)//':'//startdate(15:16)//':00'
10235
10236      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
10237
10238      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
10239                       //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
10240
10241      write(output_flnm, '(A12,".GWOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
10242
10243 #ifdef HYDRO_D
10244       print*, 'output_flnm = "'//trim(output_flnm)//'"'
10245 #endif
10246
10247       iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
10248
10249       if (iret /= 0) then
10250           print*, "Problem nf90_create"
10251           call hydro_stop("output_gw_netcdf")
10252       endif
10253
10254 !!! Define dimensions
10255
10256         nstations =nbasns
10257
10258       iret = nf90_def_dim(ncid, "basin", nstations, basindim)
10259
10260       iret = nf90_def_dim(ncid, "time", 1, timedim)
10261
10262 !!! Define variables
10263
10264
10265       !- gw basin ID
10266       iret = nf90_def_var(ncid, "gwbas_id", NF90_INT, (/basindim/), varid)
10267       iret = nf90_put_att(ncid, varid, 'long_name', 'GW basin ID')
10268
10269       !- gw inflow
10270       iret = nf90_def_var(ncid, "gw_inflow", NF90_FLOAT, (/basindim/), varid)
10271       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
10272
10273       !- gw outflow
10274       iret = nf90_def_var(ncid, "gw_outflow", NF90_FLOAT, (/basindim/), varid)
10275       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
10276
10277       !- depth in gw bucket
10278       iret = nf90_def_var(ncid, "gw_zlev", NF90_FLOAT, (/basindim/), varid)
10279       iret = nf90_put_att(ncid, varid, 'units', 'mm')
10280
10281       ! Time variable
10282       iret = nf90_def_var(ncid, "time", NF90_INT, (/timeDim/), varid)
10283       iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
10284       iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
10285
10286       date19(1:19) = "0000-00-00_00:00:00"
10287       date19(1:len_trim(startdate)) = startdate
10288
10289       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
10290       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
10291       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
10292
10293       iret = nf90_enddef(ncid)
10294
10295 !!! Input variables
10296
10297         !-- write lake id
10298         iret = nf90_inq_varid(ncid,"gwbas_id", varid)
10299         iret = nf90_put_var(ncid, varid, gw_id_var, (/1/), (/nstations/))
10300
10301         !-- write gw inflow
10302         iret = nf90_inq_varid(ncid,"gw_inflow", varid)
10303         iret = nf90_put_var(ncid, varid, gw_in_var, (/1/), (/nstations/))
10304
10305         !-- write elevation  of inflow
10306         iret = nf90_inq_varid(ncid,"gw_outflow", varid)
10307         iret = nf90_put_var(ncid, varid, gw_out_var, (/1/), (/nstations/))
10308
10309         !-- write elevation  of inflow
10310         iret = nf90_inq_varid(ncid,"gw_zlev", varid)
10311         iret = nf90_put_var(ncid, varid, gw_z_var, (/1/), (/nstations/))
10312
10313         !-- write time variable
10314         iret = nf90_inq_varid(ncid,"time", varid)
10315         iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
10316
10317         iret = nf90_close(ncid)
10318
10319     end subroutine output_gw_netcdf
10320
10321 !------------------------------- end gw netcdf output
10322
10323     subroutine read_NSIMLAKES(NLAKES,route_lake_f)
10324         integer                     :: NLAKES
10325         CHARACTER(len=*  )          :: route_lake_f
10326
10327         character(len=256)          :: route_lake_f_r
10328         integer                     :: lenRouteLakeFR, iRet, ncid, dimId
10329         logical                     :: routeLakeNetcdf
10330
10331       !! is RouteLake file netcdf (*.nc) or  from the LAKEPARM.TBL ascii
10332 #ifdef MPP_LAND
10333     if(my_id .eq. io_id) then
10334 #endif
10335       route_lake_f_r = adjustr(route_lake_f)
10336       lenRouteLakeFR = len(route_Lake_f_r)
10337       routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc'
10338
10339
10340       write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f)
10341       write(6,*) "routeLakeNetcdf TF Name Len",routeLakeNetcdf, route_lake_f,lenRouteLakeFR
10342       call flush(6)
10343
10344        if(routeLakeNetcdf) then
10345           write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f)
10346           NLAKES = -99
10347           NLAKES = get_netcdf_dim(trim(route_lake_f), 'feature_id',  &
10348                                    'read_NSIMLAKES', fatalErr=.false.)
10349           if (NLAKES .eq. -99) then
10350                  ! We were unsucessful in getting feature_id, try linkDim
10351                  NLAKES = get_netcdf_dim(trim(route_lake_f), 'nlakes',  &
10352                                    'read_NSIMLAKES', fatalErr=.false.)
10353           endif
10354           if (NLAKES .eq. -99) then
10355                  ! Neither the feature_id nor nlakes dimensions were found in
10356                  ! the LAKEPARM file. Throw an error...
10357                  call hydro_stop("Could not find either feature_id or nlakes in LAKEPARM netcdf file.")
10358           endif
10359        else
10360 !yw for IOC reach based routing, if netcdf lake file is not set from the hydro.namelist,
10361 !    we will assume that no lake will be assimulated.
10362           write(6,*) "No lake nectdf file defined. NLAKES is set to be zero."
10363           NLAKES = 0
10364       endif
10365 #ifdef MPP_LAND
10366     endif ! end if block of my_id .eq. io_id
10367          call mpp_land_bcast_int1(NLAKES)
10368 #endif
10369
10370     end subroutine read_NSIMLAKES
10371
10372 ! sequential code: not used.!!!!!!
10373     subroutine nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, gTO_NODE,LINKID, LAKEIDM, LAKEIDA)
10374         !--- get the lake configuration here.
10375         implicit none
10376         integer, dimension(:),         intent(inout) :: TYPEL, LAKEIDX
10377         integer(kind=int64), dimension(:), intent(inout) :: LINKID, LAKEIDA, LAKELINKID, LAKEIDM, gTO_NODE
10378         integer, intent(in) :: NLAKES, NLINKSL
10379         integer, dimension(NLINKSL) :: OUTLAKEID
10380         integer :: i,j,k, kk
10381
10382         TYPEL = -999
10383
10384 !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach
10385 #ifdef MPP_LAND
10386      call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, gTO_NODE,LINKID, LAKEIDM, LAKEIDA,NLINKSL)
10387 #endif
10388
10389         OUTLAKEID = gTO_NODE
10390         DO i = 1, NLAKES
10391           DO j = 1, NLINKSL
10392             DO k = 1, NLINKSL
10393
10394               if( (gTO_NODE(j) .eq. LINKID(k) ) .and. &
10395                   (LAKEIDA(k) .lt. 0 .and. LAKEIDA(j) .eq. LAKEIDM(i))) then
10396                   TYPEL(j) = 1  !this is the link flowing out of the lake
10397                   OUTLAKEID(j) = LAKEIDA(j) ! LINKID(j)
10398                   LAKELINKID(i) = j
10399 !                    write(61,*) gTO_NODE(j),LAKEIDA(j),LAKEIDA(k),LAKELINKID(i) , j
10400 !                    call flush(61)
10401               elseif( (gTO_NODE(j) .eq. LINKID(k)) .and. &
10402                   (LAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. &
10403                   (LAKEIDA(k) .eq. LAKEIDM(i)) ) then
10404                   TYPEL(j) = 3 !type_3 inflow link to lake
10405                   OUTLAKEID(j) = LAKEIDM(i)
10406               elseif (LAKEIDA(j) .eq. LAKEIDM(i) .and. .not. TYPEL(j) .eq. 1) then
10407                   TYPEL(j) = 2 ! internal lake linkd
10408               endif
10409             END DO
10410           END DO
10411        END DO
10412
10413        DO i = 1, NLAKES
10414             if(LAKELINKID(i) .gt. 0) then
10415                 LAKEIDX(LAKELINKID(i)) = i
10416             endif
10417        ENDDO
10418
10419  ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
10420        DO i = 1, NLINKSL
10421         DO j = 1, NLINKSL
10422             if(TYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. OUTLAKEID(i))) then
10423               gTO_NODE(i) = LINKID(j)  !   OUTLAKEID(i)
10424             endif
10425         ENDDO
10426        ENDDO
10427
10428 !     do k = 1, NLINKSL
10429 !         write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k)
10430 !         call flush(60+my_id)
10431 !     end do
10432
10433 !     DO i = 1, NLINKSL
10434 !        write(61,*) i,LAKEIDX(i), TYPEL(i)
10435 !     end do
10436 !     DO i = 1, NLAKES
10437 !        write(62,*) i,LAKELINKID(i)
10438 !        write(63,*) i,LAKEIDM(i)
10439 !     end do
10440 !     close(61)
10441 !     close(62)
10442 !     close(63)
10443 !     call hydro_finish()
10444
10445 !   write(60,*) TYPEL
10446 !   write(63,*) LAKELINKID, LAKEIDX
10447 !   write(64,*) gTO_NODE
10448 !   write(61,*) LINKID
10449 !   write(62,*) LAKEIDM, LAKEIDA
10450 !   close(60)
10451 !   close(61)
10452 !   close(62)
10453 !   close(63)
10454 !   close(64)
10455 !   call hydro_finish()
10456
10457
10458     end subroutine nhdLakeMap
10459
10460 #ifdef MPP_LAND
10461     subroutine nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
10462         !--- get the lake configuration here.
10463         implicit none
10464         integer, dimension(:),           intent(out)   :: TYPEL
10465         integer, dimension(:),   intent(out)   :: LAKEIDX
10466         integer(kind=int64), dimension(:),   intent(inout) :: TO_NODE
10467         integer(kind=int64), dimension(:),   intent(out)   :: LAKELINKID
10468         integer(kind=int64), dimension(:),   intent(in)    :: LINKID, LAKEIDA
10469         integer(kind=int64), dimension(:),   intent(inout) :: LAKEIDM
10470         integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL
10471 !yw        integer, dimension(NLINKSL) :: OUTLAKEID
10472         integer(kind=int64), allocatable, dimension(:) :: OUTLAKEID
10473         integer :: i,size2 ,j,k, kk, num, maxNum, m, mm, tmpSize
10474         integer, allocatable, dimension(:) :: tmpTYPEL, ind, gLAKEIDX
10475         integer(kind=int64), allocatable, dimension(:) :: gLINKID, tmpLINKID, tmplakeida, tmpoutlakeid, gLAKEIDA
10476         integer(kind=int64), allocatable, dimension(:,:) :: gtonodeout
10477
10478         integer, allocatable, dimension(:) ::  gTYPEL
10479         integer(kind=int64), allocatable, dimension(:) ::  tmpLAKELINKID, gOUTLAKEID, tmpTO_NODE, gto
10480
10481       integer(kind=int64) tmpBuf(GNLINKSL)
10482
10483       tmpSize = size(TO_NODE,1)
10484       allocate(OUTLAKEID(tmpSize))
10485
10486       allocate (gto(GNLINKSL))
10487
10488       if(my_id .eq. io_id) then
10489          allocate (tmpLAKELINKID(nlakes) )
10490       else
10491          allocate (tmpLAKELINKID(1))
10492       endif
10493
10494
10495 !     prescan the data and remove the LAKEIDM which point to two links.
10496 #ifdef MPP_LAND
10497      call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
10498 #endif
10499
10500       call gBcastValue(TO_NODE,gto)
10501
10502       maxNum = 0
10503       kk = 0
10504
10505             ! The following loops are replaced by a hashtable-based algorithm
10506       ! do m = 1, NLINKSL
10507       !       num = 0
10508       !       do k = 1, gnlinksl
10509       !          if(gto(k) .eq. LINKID(m) ) then
10510       !              kk = kk +1
10511       !              num = num + 1
10512       !          endif
10513       !       end do
10514       !       if(num .gt. maxNum) maxNum = num
10515       ! end do
10516
10517
10518
10519       block
10520         type(hash_t) :: hash_table
10521         integer(kind=int64) :: val,it
10522         integer(kind=int64), allocatable :: num_a(:)
10523         logical :: found
10524
10525         allocate(num_a(NLINKSL))
10526         num_a = 0
10527         kk = 0
10528
10529         call hash_table%set_all_idx(linkid, NLINKSL)
10530         do it=1, gnlinksl
10531            call hash_table%get(gto(it), val, found)
10532            if(found .eqv. .true.) then
10533               kk = kk + 1
10534               num_a(val) = num_a(val) + 1
10535            end if
10536         end do
10537         maxNum = maxval(num_a)
10538         num_a = 1
10539
10540         allocate(ind(kk))
10541         allocate(gToNodeOut(NLINKSL,maxNum+1))
10542         gToNodeOut = -99
10543         allocate(tmpTYPEL(kk))
10544         allocate(tmpLINKID(kk))
10545         allocate(tmpLAKEIDA(kk))
10546         allocate(tmpOUTLAKEID(kk))
10547         allocate(tmpTO_NODE(kk))
10548
10549         if(kk .gt. 0) then
10550            tmpOUTLAKEID = -999
10551            tmpTYPEL = -999
10552            tmpTO_NODE = -999
10553         endif
10554         if(NLINKSL .gt. 0) then
10555            OUTLAKEID = -999
10556            TYPEL = -999
10557         endif
10558
10559         kk = 0
10560
10561         ! The following loops are replaced by a hashtable-based algorithm
10562         ! do m = 1, NLINKSL
10563         !          num = 1
10564         !          do k = 1, gnlinksl
10565         !              if(gto(k) .eq. LINKID(m) ) then
10566         !                  kk = kk +1
10567         !                  ind(kk) = k
10568         !                  tmpTO_NODE(kk) = gto(k)
10569         !                  gToNodeOut(m,num+1) = kk
10570         !                  gToNodeOut(m,1) = num
10571         !                  num = num + 1
10572         !              endif
10573         !           end do
10574         ! enddo
10575
10576         do it=1, gnlinksl
10577            call hash_table%get(gto(it), val, found)
10578            if(found .eqv. .true.) then
10579               kk = kk + 1
10580               ind(kk) = it
10581               tmpTO_NODE(kk) = gto(it)
10582               gToNodeOut(val,num_a(val)+1) = kk
10583               gToNodeOut(val,1) = num_a(val)
10584               num_a(val) = num_a(val) + 1
10585            end if
10586         end do
10587
10588         deallocate(num_a)
10589         call hash_table%clear()
10590
10591       end block
10592
10593       size2 = kk
10594       deallocate (gto)
10595
10596       allocate(gLINKID(gnlinksl))
10597       call gBcastValue(LINKID,gLINKID)
10598       do i = 1, size2
10599             k = ind(i)
10600             tmpLINKID(i) = gLINKID(k)
10601       enddo
10602
10603       allocate(gLAKEIDA(gnlinksl))
10604       call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) )
10605       do i = 1, size2
10606             k = ind(i)
10607             tmpLAKEIDA(i) = gLAKEIDA(k)
10608       enddo
10609       if(allocated(gLAKEIDA)) deallocate(gLAKEIDA)
10610
10611 !yw LAKELINKID = 0
10612       tmpLAKELINKID = LAKELINKID
10613       tmpOUTLAKEID  = tmpTO_NODE
10614       OUTLAKEID(1:NLINKSL)  = TO_NODE(1:NLINKSL)
10615
10616  !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach
10617         DO i = 1, NLAKES
10618           DO k = 1, NLINKSL
10619              do m = 1, gToNodeOut(k,1)
10620                  j = gToNodeOut(k,m+1)
10621                  if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. &
10622                      (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then
10623                      tmpTYPEL(j) = 1  !this is the link flowing out of the lake
10624                      tmpOUTLAKEID(j) = tmpLAKEIDA(j) !tmpLINKID(j) ! Wei Check
10625                      LAKELINKID(i) = ind(j)
10626 !                    write(61,*) tmpTO_NODE(j),tmpLAKEIDA(j),LAKEIDA(k),LAKELINKID(i)
10627 !                    call flush(61)
10628                  elseif( (tmpTO_NODE(j) .eq. LINKID(k)) .and. &
10629                      (tmpLAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. &
10630                      (LAKEIDA(k) .eq. LAKEIDM(i)) ) then
10631                      tmpTYPEL(j) = 3 !type_3 inflow link to lake
10632                      tmpOUTLAKEID(j) = LAKEIDM(i) !Wei Check
10633 !                    write(62,*) tmpTO_NODE(j),tmpOUTLAKEID(j),LAKEIDM(i)
10634 !                    call flush(62)
10635                  elseif (tmpLAKEIDA(j) .eq. LAKEIDM(i) .and. tmpTYPEL(j) .ne. 1) then
10636                      tmpTYPEL(j) = 2 ! internal lake linkd
10637                      !! print the following to get the list of links which are ignored bc they are internal to lakes.
10638                      !print*,'Ndg: tmpLAKEIDA(j):', tmpLAKEIDA(j)
10639                  endif
10640             END DO
10641           END DO
10642        END DO
10643
10644 !yw       call sum_int1d(LAKELINKID, NLAKES)
10645        call updateLake_seqInt8(LAKELINKID,nlakes,tmpLAKELINKID)
10646
10647        if(allocated(tmplakelinkid))  deallocate(tmpLAKELINKID)
10648
10649        if(gNLINKSL .gt. 0) then
10650           if(my_id .eq. 0) then
10651               allocate(gLAKEIDX(gNLINKSL))
10652               gLAKEIDX = -999
10653               DO i = 1, NLAKES
10654                    if(LAKELINKID(i) .gt. 0) then
10655                       gLAKEIDX(LAKELINKID(i)) = i
10656                    endif
10657               ENDDO
10658           else
10659               allocate(gLAKEIDX(1))
10660           endif
10661           call ReachLS_decomp(gLAKEIDX, LAKEIDX)
10662           if(allocated(gLAKEIDX)) deallocate(gLAKEIDX)
10663        endif
10664
10665 !     do k = 1, size
10666 !         write(70+my_id,*) "k, ind(k), typel, lakeidx", k, ind(k),tmpTYPEL(k), lakeidx(ind(k))
10667 !         call flush(70+my_id)
10668 !     end do
10669
10670        call TONODE2RSL(ind,tmpTYPEL,size2,gNLINKSL,NLINKSL,TYPEL(1:NLINKSL), -999 )
10671        call TONODE2RSL8(ind,tmpOUTLAKEID,size2,gNLINKSL,NLINKSL,OUTLAKEID(1:NLINKSL), -999 )
10672
10673
10674  ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
10675 !yw       DO i = 1, NLINKSL
10676 !yw 105
10677 !     DO k = 1, NLINKSL
10678 !       do m = 1, gToNodeOut(k,1)
10679 !                i = gToNodeOut(k,m+1)
10680 !          DO j = 1, NLINKSL
10681 !             if (tmpTYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. tmpOUTLAKEID(i)) &
10682 !                  .and. tmpOUTLAKEID(i) .ne. -999) then
10683 !                    !yw tmpTO_NODE(i) = tmpOUTLAKEID(i)  !Wei Check
10684 !                    tmpTO_NODE(i) = LINKID(j)  !Wei Check
10685 !             endif
10686 !          END DO
10687 !        END DO
10688 !     END DO
10689 !     call TONODE2RSL(ind,tmpTO_NODE,size,gNLINKSL,NLINKSL,TO_NODE(1:NLINKSL), -999 )
10690
10691  ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
10692       allocate(gTYPEL(gNLINKSL))
10693       allocate(gOUTLAKEID(gNLINKSL))
10694       call gBcastValue(TYPEL,gTYPEL)
10695       call gBcastValue(OUTLAKEID,gOUTLAKEID)
10696        DO i = 1, NLINKSL
10697         DO j = 1, gNLINKSL
10698             if(TYPEL(i) .eq. 3 .and. gTYPEL(j) .eq. 1 .and. (gOUTLAKEID(j) .eq. OUTLAKEID(i))) then
10699               TO_NODE(i) = gLINKID(j)  !   OUTLAKEID(i)
10700             endif
10701         ENDDO
10702        ENDDO
10703       deallocate(gLINKID)
10704       deallocate(gTYPEL)
10705       deallocate(gOUTLAKEID)
10706
10707       deallocate(tmpTYPEL,tmpLINKID, tmpTO_NODE, tmpLAKEIDA, tmpOUTLAKEID,OUTLAKEID)
10708
10709
10710 !     do k = 1, NLINKSL
10711 !         write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k)
10712 !         call flush(60+my_id)
10713 !     end do
10714
10715
10716 !     call ReachLS_write_io(TO_NODE(1:NLINKSL), tmpBuf(1:gNLINKSL) )
10717 !     if(my_id .eq. io_id ) then
10718 !       write(70,*) tmpBuf(1:gNLINKSL)
10719 !       call flush(70)
10720 !     endif
10721 !     call ReachLS_write_io(TYPEL(1:NLINKSL), tmpBuf(1:gNLINKSL) )
10722 !     if(my_id .eq. io_id ) then
10723 !       write(71,*) tmpBuf
10724 !       call flush(71)
10725 !     endif
10726 !     call ReachLS_write_io(LAKEIDX(1:NLINKSL), tmpBuf(1:gNLINKSL))
10727 !     if(my_id .eq. io_id ) then
10728 !       write(72,*) tmpBuf
10729 !       call flush(72)
10730 !       close(72)
10731 !     endif
10732 !     call ReachLS_write_io(OUTLAKEID(1:NLINKSL), tmpBuf(1:gNLINKSL))
10733 !     if(my_id .eq. io_id ) then
10734 !       write(73,*) tmpBuf
10735 !       call flush(73)
10736 !     endif
10737 !     call hydro_finish()
10738
10739 !     DO i = 1, NLINKSL
10740 !        write(61,*) i,LAKEIDX(i), TYPEL(i)
10741 !     end do
10742 !     DO i = 1, NLAKES
10743 !        write(63,*) i,LAKEIDM(i)
10744 !        write(62,*) i,LAKELINKID(i)
10745 !     end do
10746 !     close(61)
10747 !     close(62)
10748 !     close(63)
10749
10750 !   write(60,*) TYPEL
10751 !   write(63,*) LAKELINKID, LAKEIDX
10752 !   write(64,*) TO_NODE
10753 !   write(61,*) LINKID
10754 !   write(62,*) LAKEIDM, LAKEIDA
10755 !   close(60)
10756 !   close(61)
10757 !   close(62)
10758 !   close(63)
10759 !   close(64)
10760 !   call hydro_finish()
10761
10762     end subroutine nhdLakeMap_mpp
10763
10764     subroutine nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
10765         !--- get the lake configuration here.
10766         implicit none
10767         integer(kind=int64), dimension(:), intent(in) :: TO_NODE
10768         integer(kind=int64), dimension(NLAKES) :: LAKELINKID
10769         integer(kind=int64), dimension(:),   intent(in) :: LINKID, LAKEIDA
10770         integer(kind=int64), dimension(:),   intent(inout) :: LAKEIDM
10771         integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL
10772         integer :: i,size ,j,k, kk, num, maxNum, m, mm
10773         integer(kind=int64), allocatable, dimension(:) :: tmplakeida, tmpoutlakeid, gLAKEIDA, tmpTO_NODE, gto
10774         integer(kind=int64), allocatable, dimension(:) :: ind
10775         integer(kind=int64), allocatable, dimension(:,:) :: gtonodeout
10776         integer(kind=int64), allocatable, dimension(:) ::  tmpLAKELINKID, gtoLakeId_g, gtoLakeId
10777
10778 !       integer tmpBuf(GNLINKSL)
10779         integer, dimension(nlakes) :: lakemask
10780         integer ii
10781
10782       allocate (gto(GNLINKSL))
10783       allocate (gtoLakeId_g(GNLINKSL))
10784       allocate (gtoLakeId(NLINKSL))
10785       if(my_id .eq. io_id) then
10786          allocate(tmpLAKELINKID(nlakes))
10787       else
10788          allocate(tmpLAKELINKID(1))
10789       endif
10790
10791       gtoLakeId_g=-999
10792
10793       call gBcastValue(TO_NODE,gto)
10794
10795       maxNum = 0
10796       kk = 0
10797
10798       ! The following loops are replaced by a hashtable-based algorithm
10799       ! do m = 1, NLINKSL
10800       !    num = 0
10801       !    do k = 1, gnlinksl
10802       !       if(gto(k) .eq. LINKID(m) ) then
10803       !          gtoLakeId_g(k) = lakeida(m)
10804       !          kk = kk +1
10805       !          num = num + 1
10806       !       endif
10807       !    end do
10808       !    if(num .gt. maxNum) maxNum = num
10809       ! end do
10810
10811       block
10812         type(hash_t) :: hash_table
10813         integer(kind=int64) :: val,it
10814         integer(kind=int64), allocatable :: num_a(:)
10815         logical :: found
10816
10817         allocate(num_a(NLINKSL))
10818         num_a = 0
10819         kk = 0
10820
10821         call hash_table%set_all_idx(linkid, NLINKSL)
10822         do it=1, gnlinksl
10823            call hash_table%get(gto(it), val, found)
10824            if(found .eqv. .true.) then
10825               gtoLakeId_g(it) = lakeida(val)
10826               kk = kk + 1
10827               num_a(val) = num_a(val) + 1
10828            end if
10829         end do
10830         maxNum = maxval(num_a)
10831         num_a = 1
10832
10833         allocate(ind(kk))
10834         allocate(gToNodeOut(NLINKSL,maxNum+1))
10835         gToNodeOut = -99
10836         allocate(tmpLAKEIDA(kk))
10837         allocate(tmpTO_NODE(kk))
10838
10839         kk = 0
10840
10841         ! The following loops are replaced by a hashtable-based algorithm
10842         ! do m = 1, NLINKSL
10843         !    num = 1
10844         !    do k = 1, gnlinksl
10845         !       if(gto(k) .eq. LINKID(m) ) then
10846         !          kk = kk +1
10847         !          ind(kk) = k
10848         !          tmpTO_NODE(kk) = gto(k)
10849         !          gToNodeOut(m,num+1) = kk
10850         !          gToNodeOut(m,1) = num
10851         !          num = num + 1
10852         !       endif
10853         !    end do
10854         ! end do
10855
10856         do it=1, gnlinksl
10857            call hash_table%get(gto(it), val, found)
10858            if(found .eqv. .true.) then
10859               kk = kk + 1
10860               ind(kk) = it
10861               tmpTO_NODE(kk) = gto(it)
10862               gToNodeOut(val,num_a(val)+1) = kk
10863               gToNodeOut(val,1) = num_a(val)
10864               num_a(val) = num_a(val) + 1
10865            end if
10866         end do
10867
10868         deallocate(num_a)
10869         call hash_table%clear()
10870
10871       end block
10872
10873       size = kk
10874       if(allocated(gto)) deallocate (gto)
10875
10876
10877       allocate(gLAKEIDA(gnlinksl))
10878       call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) )
10879       do i = 1, size
10880             k = ind(i)
10881             tmpLAKEIDA(i) = gLAKEIDA(k)
10882       enddo
10883       if(allocated(gLAKEIDA)) deallocate(gLAKEIDA)
10884
10885         tmpLAKELINKID = LAKELINKID
10886 !       LAKELINKID = 0
10887         DO i = 1, NLAKES
10888           DO k = 1, NLINKSL
10889              do m = 1, gToNodeOut(k,1)
10890                  j = gToNodeOut(k,m+1)
10891                  if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. &
10892                      (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then
10893                      if(LAKELINKID(i) .gt. 0) then
10894                          LAKELINKID(i) = -999
10895 #ifdef HYDRO_D
10896                          write(6,*) "remove the lake  LAKEIDM(i) ", i, LAKEIDM(i)
10897                          call flush(6)
10898 #endif
10899                      endif
10900                      if(LAKELINKID(i) .eq. 0) LAKELINKID(i) = ind(j)
10901                  endif
10902             END DO
10903           END DO
10904        END DO
10905 !yw        call match1dLake(LAKELINKID, NLAKES, -999)
10906
10907 !yw double check
10908       call combine_int8_1d(gtoLakeId_g,gnlinksl, -999)
10909       call ReachLS_decomp(gtoLakeId_g,gtoLakeId)
10910
10911        lakemask = 0
10912        DO k = 1, NLINKSL
10913           if(LAKEIDA(k) .gt. 0) then
10914              DO i = 1, NLAKES
10915                 if(gtoLakeId(k) .eq. LAKEIDM(i) )  then
10916                     goto 992
10917                 endif
10918              enddo
10919              DO i = 1, NLAKES
10920                 if(LAKEIDA(k) .eq. LAKEIDM(i) )  then
10921                      lakemask(i) = lakemask(i) + 1
10922                       goto 992
10923                 endif
10924              enddo
10925 992          continue
10926           endif
10927        enddo
10928
10929        if(allocated(gtoLakeId_g)) deallocate(gtoLakeId_g)
10930        if(allocated(gtoLakeId)) deallocate(gtoLakeId)
10931        call sum_int1d(lakemask, NLAKES)
10932
10933        do i = 1, nlakes
10934            if(lakemask(i) .ne. 1) then
10935                LAKELINKID(i) = -999
10936 #ifdef HYDRO_D
10937                if(my_id .eq. IO_id) then
10938                   write(6,*) "double check remove the lake : ",LAKEIDM(i)
10939                   call flush(6)
10940                endif
10941 #endif
10942            endif
10943        enddo
10944
10945
10946 !end double check
10947
10948
10949        call updateLake_seqInt8(LAKELINKID,nlakes,tmpLAKELINKID)
10950
10951 !      if(my_id .eq. 0) then
10952 !          write(65,*) "check LAKEIDM   *****,"
10953 !          write(65,*) LAKEIDM
10954 !          call flush(6)
10955 !      endif
10956
10957        do k = 1, NLAKES
10958            if(LAKELINKID(k) .eq. -999) LAKEIDM(k) = -999
10959        end do
10960
10961 !      if(my_id .eq. 0) then
10962 !          write(65,*) "check LAKEIDM   *****,"
10963 !          write(65,*) LAKEIDM
10964 !          call flush(6)
10965 !      endif
10966
10967        close(65)
10968       if(allocated(tmpTO_NODE)) deallocate(tmpTO_NODE)
10969       if(allocated(tmpLAKEIDA)) deallocate(tmpLAKEIDA)
10970       if(allocated(tmplakelinkid)) deallocate(tmplakelinkid)
10971
10972     end subroutine nhdLakeMap_scan
10973 #endif
10974
10975 !ADCHANGE: New output lake types routine
10976     subroutine output_lake_types( inNLINKS, inLINKID, inTYPEL )
10977
10978 #ifdef MPP_LAND
10979     use module_mpp_land
10980 #endif
10981
10982     implicit none
10983
10984     integer, dimension(:),  intent(in) :: inTYPEL
10985     integer(kind=int64), dimension(:), intent(in) :: inLINKID
10986     integer, intent(in) :: inNLINKS
10987
10988     integer            :: iret
10989     integer            :: ncid, varid
10990     integer            :: linkdim
10991     character(len=256), parameter :: output_flnm = "LAKE_TYPES.nc"
10992
10993     integer, allocatable, dimension(:) :: typeL
10994     integer(kind=int64), allocatable, dimension(:) :: linkId
10995
10996 #ifdef MPP_LAND
10997
10998     if(my_id .eq. io_id) then
10999        allocate( linkId(inNLINKS)  )
11000        allocate( typeL(inNLINKS)   )
11001     else
11002        allocate(linkId(1), typeL(1))
11003     end if
11004
11005     call mpp_land_sync()
11006     call ReachLS_write_io(inLINKID, linkId)
11007     call ReachLS_write_io(inTYPEL, typeL)
11008
11009 #else
11010
11011     allocate( linkId(inNLINKS) )
11012     allocate( typeL(inNLINKS)  )
11013
11014     linkId    = inLINKID
11015     typeL     = inTYPEL
11016
11017 #endif
11018
11019 #ifdef MPP_LAND
11020     if(my_id .eq. io_id) then
11021 #endif
11022
11023        ! Create the channel connectivity file
11024 #ifdef HYDRO_D
11025        print*,'Lakes: output_flnm = "'//trim(output_flnm)//'"'
11026        flush(6)
11027 #endif
11028
11029        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
11030
11031        if (iret /= 0) then
11032           print*,"Lakes: Problem nf90_create"
11033           call hydro_stop("output_lake_types")
11034        endif
11035
11036        iret = nf90_def_dim(ncid, "link", inNLINKS, linkdim)
11037
11038        !-- link  id
11039        iret = nf90_def_var(ncid, "LINKID", NF90_INT64, (/linkdim/), varid)
11040        iret = nf90_put_att(ncid, varid, 'long_name', 'Link ID')
11041
11042        !- lake reach type, var
11043        iret = nf90_def_var(ncid, "TYPEL", NF90_INT, (/linkdim/), varid)
11044        iret = nf90_put_att(ncid, varid, 'long_name', 'Lake reach type')
11045
11046        iret = nf90_enddef(ncid)
11047
11048        !-- write id
11049        iret = nf90_inq_varid(ncid,"LINKID", varid)
11050        iret = nf90_put_var(ncid, varid, linkId, (/1/), (/inNLINKS/))
11051
11052        !-- write type
11053        iret = nf90_inq_varid(ncid,"TYPEL", varid)
11054        iret = nf90_put_var(ncid, varid, typeL, (/1/), (/inNLINKS/))
11055
11056        iret = nf90_close(ncid)
11057
11058 #ifdef MPP_LAND
11059     endif
11060 #endif
11061     if(allocated(linkId)) deallocate(linkId)
11062     if(allocated(typeL)) deallocate(typeL)
11063
11064 #ifdef MPP_LAND
11065     if(my_id .eq. io_id) then
11066 #endif
11067 #ifdef HYDRO_D
11068     write(6,*) "end of output_lake_types"
11069     flush(6)
11070 #endif
11071 #ifdef MPP_LAND
11072     endif
11073 #endif
11074
11075 end subroutine output_lake_types
11076
11077 subroutine hdtbl_out_nc(did,ncid,count,count_flag,varName,varIn,descrip,ixd,jxd)
11078    implicit none
11079    integer :: did, iret, ncid, ixd,jxd, ix,jx, err_flag,count_flag, count,varid
11080    real, allocatable, dimension(:,:) :: xdump
11081    real, dimension(:,:) :: varIn
11082    character(len=*) :: descrip
11083    character(len=*) ::varName
11084
11085 #ifdef MPP_LAND
11086    ix=global_nx
11087    jx=global_ny
11088 #else
11089    ix=RT_DOMAIN(did)%ix
11090    jx=RT_DOMAIN(did)%jx
11091 #endif
11092    if( count == 0 .and. count_flag == 0) then
11093       count_flag = 1
11094 #ifdef MPP_LAND
11095      if(my_id .eq. IO_id) then
11096 #endif
11097      iret = nf90_create(trim(nlst(did)%hydrotbl_f), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
11098 #ifdef MPP_LAND
11099      endif
11100      call mpp_land_bcast_int1(iret)
11101 #endif
11102        if (iret /= 0) then
11103           call hydro_stop("FATAL ERROR:   - Problem nf90_create  in nc of hydrotab_f file")
11104        endif
11105
11106 #ifdef MPP_LAND
11107      if(my_id .eq. IO_id) then
11108 #endif
11109        iret = nf90_def_dim(ncid, "west_east", ix, ixd)  !-- make a decimated grid
11110        iret = nf90_def_dim(ncid, "south_north", jx, jxd)
11111 #ifdef MPP_LAND
11112      endif
11113 #endif
11114    endif ! count == 0
11115
11116
11117    if( count == 1 ) then  ! define variables
11118 #ifdef MPP_LAND
11119      if(my_id .eq. io_id) then
11120 #endif
11121        iret = nf90_def_var(ncid, trim(varName), NF90_FLOAT, (/ixd,jxd/), varid)
11122        ! iret = nf90_put_att(ncid, varid, 'description', trim(descrip))
11123        iret = nf90_put_att(ncid, varid, 'description', "test")
11124 #ifdef MPP_LAND
11125      endif
11126 #endif
11127    endif  !!! end of count == 1
11128
11129    if (count == 2) then ! write out the variables
11130        if(count_flag == 2) iret = nf90_enddef(ncid)
11131        count_flag = 3
11132 #ifdef MPP_LAND
11133      if(my_id .eq. io_id) then
11134 #endif
11135        allocate (xdump(ix, jx))
11136 #ifdef MPP_LAND
11137      else
11138        allocate (xdump(1, 1))
11139      endif
11140 #endif
11141
11142 #ifdef MPP_LAND
11143      call write_io_real(varIn,xdump)
11144      if(my_id .eq. io_id) iret = nf90_inq_varid(ncid,trim(varName), varid)
11145      if(my_id .eq. io_id)  iret = nf90_put_var(ncid, varid, xdump, (/1,1/), (/ix,jx/))
11146 #else
11147      iret = nf90_inq_varid(ncid,trim(varName), varid)
11148      iret = nf90_put_var(ncid, varid, varIn, (/1,1/), (/ix,jx/))
11149 #endif
11150
11151       deallocate(xdump)
11152     endif !! end of count == 2
11153     if(count == 3 .and. count_flag == 3) then
11154        count_flag = 4
11155 #ifdef MPP_LAND
11156        if(my_id .eq. io_id ) &
11157 #endif
11158        iret = nf90_close(ncid)
11159     endif !! end of count == 3
11160
11161
11162 end subroutine hdtbl_out_nc
11163 subroutine hdtbl_out(did)
11164    implicit none
11165    integer :: did, ncid, count,count_flag, i, ixd,jxd
11166    do i = 0,3
11167       count = i
11168       count_flag = i
11169       call hdtbl_out_nc(did,ncid, count,count_flag,"SMCMAX1",rt_domain(did)%SMCMAX1,"",ixd,jxd)
11170       call hdtbl_out_nc(did,ncid, count,count_flag,"SMCREF1",rt_domain(did)%SMCREF1,"",ixd,jxd)
11171       call hdtbl_out_nc(did,ncid, count,count_flag,"SMCWLT1",rt_domain(did)%SMCWLT1,"",ixd,jxd)
11172       call hdtbl_out_nc(did,ncid, count,count_flag,"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D,"",ixd,jxd)
11173       call hdtbl_out_nc(did,ncid, count,count_flag,"LKSAT",rt_domain(did)%LKSAT,"",ixd,jxd)
11174       call hdtbl_out_nc(did,ncid, count,count_flag,"NEXP",rt_domain(did)%NEXP,"",ixd,jxd)
11175    end do
11176 end subroutine hdtbl_out
11177
11178 subroutine hdtbl_in_nc(did)
11179    implicit none
11180    integer :: did
11181    integer :: ierr
11182    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCMAX1",rt_domain(did)%SMCMAX1,ierr)
11183    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCREF1",rt_domain(did)%SMCREF1,ierr)
11184    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCWLT1",rt_domain(did)%SMCWLT1,ierr)
11185    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%overland%properties%roughness,ierr, rt=.true.)
11186    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"LKSAT",rt_domain(did)%LKSAT,ierr)
11187    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"NEXP",rt_domain(did)%NEXP,ierr)
11188    ! Letting this variable be optional and setting to global default value if not found
11189    if (ierr /= 0) then
11190      write(6,*)  "WARNING (hydtbl_in_nc): NEXP not found so setting to global 1.0"
11191      rt_domain(did)%NEXP = 1.0
11192    endif
11193 end subroutine hdtbl_in_nc
11194
11195 subroutine read2dlsm(did,file,varName,varOut,ierr,rt)
11196 use module_mpp_land,only: mpp_land_bcast_int1
11197   implicit none
11198   integer :: did, ncid , iret
11199   character(len=*) :: file,varName
11200   real,dimension(:,:) :: varOut
11201   character(len=256) :: units
11202   integer, intent(out) :: ierr
11203   logical, optional, intent(in) :: rt
11204   logical :: regrid
11205
11206   real,allocatable,dimension(:,:) :: tmpArr
11207
11208 #ifdef MPP_LAND
11209   if(my_id .eq. io_id) then
11210 #endif
11211      allocate(tmpArr(global_nx,global_ny))
11212      iret = nf90_open(trim(file), NF90_NOWRITE, ncid)
11213      call get_2d_netcdf(trim(varName), ncid, tmpArr, units, global_nx, global_ny, &
11214           .false., ierr)
11215      iret = nf90_close(ncid)
11216 #ifdef MPP_LAND
11217   else
11218      allocate(tmpArr(1,1))
11219   endif
11220 #endif
11221
11222   if (present(rt)) then
11223     regrid = rt
11224   else
11225     regrid = .false.
11226   endif
11227
11228   if (regrid) then
11229     call regrid_lowres_to_highres(did, tmpArr, varOut, rt_domain(did)%ixrt, rt_domain(did)%jxrt)
11230   else
11231     call decompose_data_real (tmpArr,varOut)
11232   endif
11233
11234 #ifdef MPP_LAND
11235   call mpp_land_bcast_int1(ierr)
11236 #endif
11237
11238   deallocate(tmpArr)
11239 end subroutine read2dlsm
11240
11241 subroutine regrid_lowres_to_highres(did, lowres_grid, highres_grid, ixrt, jxrt)
11242
11243   implicit none
11244   integer :: did
11245   integer :: ixrt, jxrt
11246   real, dimension(global_nx, global_ny) :: lowres_grid
11247   real, dimension(ixrt,jxrt) :: highres_grid
11248   ! Local variables
11249   integer :: i, j, irt, jrt, aggfacxrt, aggfacyrt
11250
11251 #ifdef MPP_LAND
11252   real,allocatable,dimension(:,:) :: tmpArr
11253   if(my_id .eq. io_id) then
11254      allocate(tmpArr(global_rt_nx, global_rt_ny))
11255 #endif
11256
11257       do j = 1,global_ny ! Start coarse grid j loop
11258          do i = 1,global_nx ! Start coarse grid i loop
11259
11260             do aggfacyrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid j loop
11261             do aggfacxrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid i loop
11262
11263                irt = i * nlst(did)%AGGFACTRT - aggfacxrt ! Define fine grid i
11264                jrt = j * nlst(did)%AGGFACTRT - aggfacyrt ! Define fine grid j
11265 #ifdef MPP_LAND
11266                ! if(left_id.ge.0) irt = irt + 1
11267                ! if(down_id.ge.0) jrt = jrt + 1
11268                tmpArr(irt,jrt) = lowres_grid(i,j)
11269 #else
11270                highres_grid(irt,jrt) = lowres_grid(i,j)
11271 #endif
11272
11273             end do
11274             end do
11275
11276          end do
11277       end do
11278
11279 #ifdef MPP_LAND
11280   else
11281      allocate(tmpArr(1,1))
11282   endif
11283   call decompose_RT_real(tmpArr, highres_grid, global_rt_nx, global_rt_ny, ixrt, jxrt)
11284   deallocate(tmpArr)
11285 #endif
11286
11287 end subroutine regrid_lowres_to_highres
11288
11289 subroutine read_channel_only (olddateIn, hgrid, indir, dtbl)
11290 !use module_HYDRO_io, only: read_rst_crt_reach_nc
11291 use module_RT_data, only: rt_domain
11292 use module_mpp_land,only: mpp_land_bcast_int1, my_id, io_id
11293 use Module_Date_utilities_rt, only: geth_newdate
11294 use config_base, only: nlst
11295 implicit none
11296 integer :: iret, did, len, ncid
11297 integer :: dtbl
11298 character :: hgrid
11299 character(len=*):: olddateIn,indir
11300 character(len=19) :: olddate
11301 character(len=256):: fileName
11302 real*8, allocatable, dimension(:):: accBucket_in, accSfcLatRunoff_in
11303 real  , allocatable, dimension(:)::   qBucket_in,   qSfcLatRunoff_in
11304 integer, parameter :: r8 = selected_real_kind(8)
11305 real*8,  parameter :: zeroDbl=0.0000000000000000000_r8
11306 integer :: ovrtswcrt_in, noah_timestep_in, channel_only_in, channelBucket_only_in
11307 character(len=86) :: attNotInFileMsg
11308
11309 did = 1
11310 len = size(rt_domain(did)%QLATERAL,1)
11311 !! if len is .le. 0, this whole thing is pointless. huh?
11312
11313 if(my_id .eq. io_id) then
11314    call geth_newdate(olddate,olddateIn,dtbl)
11315    fileName = trim(indir)//"/"//&
11316         olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
11317         olddate(15:16)//".CHRTOUT_DOMAIN"//hgrid
11318 #ifdef HYDRO_D
11319    print*, " Channel only input forcing file: ",trim(fileName)
11320 #endif /* HYDRO_D */
11321    iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid)
11322 endif
11323
11324 call mpp_land_bcast_int1(iret)
11325 if (iret .ne. 0) then
11326    call hydro_stop( "FATAL ERROR: read forcing data for CHANNEL_ONLY failed. ")
11327 endif
11328
11329 !! ---------------------------------------------------------------------------
11330 !! Consistency checks - global att checking.
11331 if(my_id .eq. io_id) then
11332
11333    attNotInFileMsg=&  !! lenght fixed above
11334         'Fatal error for channel only: the following global attribute not in the forcing file: '
11335
11336    !! 1) overland routing v squeegee??
11337    !!if(nlst_rt(did)%OVRTSWCRT .eq. 1) then
11338    iret = nf90_get_att(ncid, NF90_GLOBAL, 'OVRTSWCRT', ovrtswcrt_in)
11339    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_OVRTSWCRT', ovrtswcrt_in)
11340    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'OVRTSWCRT & dev_OVRTSWCRT not in ' // trim(fileName) )
11341    if(nlst(1)%ovrtswcrt .ne. ovrtswcrt_in) &
11342         call hydro_stop('Channel only: OVRTSWCRT or dev_OVRSWCRT in forcing file does not match run config.')
11343
11344    !! 2) NOAH_TIMESTEP same?
11345    iret = nf90_get_att(ncid, NF90_GLOBAL, 'NOAH_TIMESTEP', noah_timestep_in)
11346    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_NOAH_TIMESTEP', noah_timestep_in)
11347    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'NOAH_TIMESTEP & dev_NOAH_TIMESTEP not in ' // trim(fileName) )
11348    if(nlst(1)%dt .ne. noah_timestep_in) &
11349         call hydro_stop('Channel only: NOAH_TIMESTEP or dev_NOAH_TIMESTEP in forcing file does not match run config.')
11350
11351    !! 3) channel_only or channelBucket_only?
11352    iret = nf90_get_att(ncid, NF90_GLOBAL, "channel_only",       channel_only_in)
11353    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, "dev_channel_only",       channel_only_in)
11354    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'channel_only not in ' // trim(fileName) )
11355
11356    iret = nf90_get_att(ncid, NF90_GLOBAL, "channelBucket_only", channelBucket_only_in)
11357    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, "dev_channelBucket_only", channel_only_in)
11358    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'channelBucket_only not in ' // trim(fileName) )
11359    !! See table of fatal combinations on wiki: https://wiki.ucar.edu/display/wrfhydro/Channel+Only
11360    !! First row: Can it even get to this combination? NO.
11361    !if( (nlst_rt(did)%channel_only .eq. 0 .and. nlst_rt(did)%channelBucket_only .eq. 0) .and. &
11362    !    (channel_only_in .eq. 1 .or.  channelBucket_only_in .eq. 1)        ) &
11363    !    call hydro_stop('Channel Only: Forcing files in consistent with forcing type.')
11364    !! Second row:
11365    if(nlst(did)%channel_only .eq. 1 .and. channelBucket_only_in .eq. 1) &
11366         write(6,*) "Warning: channelBucket_only output forcing channel_only run"
11367
11368 end if
11369
11370    !! ---------------------------------------------------------------------------
11371    !! FLUXES or accumulations? NOT SUPPORTING accumulations to be read in.
11372 !! FLUXES
11373 if(nlst(did)%channel_only       .eq. 1 .or. &
11374    nlst(did)%channelBucket_only .eq. 1      ) then
11375
11376    allocate(qBucket_in(len))
11377    allocate(qSfcLatRunoff_in(len))
11378    qBucket_in   = 0.0
11379    qSfcLatRunoff_in = 0.0
11380
11381    !! Surface Lateral Fluxes (currenly include exfiltration from subsurface)
11382    call read_rst_crt_reach_nc(ncid, qSfcLatRunoff_in, "qSfcLatRunoff", &
11383                               rt_domain(did)%GNLINKSL, fatalErr=.true. )
11384
11385    !! Fluxes from (channel only) or to (channelBucket only) bucket?
11386    !! Fluxes from bucket.
11387    if(nlst(did)%channel_only .eq. 1) then
11388       call read_rst_crt_reach_nc(ncid, qBucket_in, "qBucket",            &
11389                                  rt_domain(did)%GNLINKSL, fatalErr=.true.)
11390       rt_domain(did)%qout_gwsubbas = qBucket_in
11391       rt_domain(did)%QLateral      = qBucket_in + qSfcLatRunoff_in
11392    endif
11393
11394    !! Fluxes to bucket
11395    if(nlst(did)%channelBucket_only .eq. 1) then
11396       call read_rst_crt_reach_nc(ncid, qBucket_in, "qBtmVertRunoff",     &
11397                                  rt_domain(did)%GNLINKSL, fatalErr=.true.)
11398       rt_domain(did)%qin_gwsubbas = qBucket_in
11399       rt_domain(did)%QLateral     = qSfcLatRunoff_in
11400    end if
11401
11402    deallocate(qBucket_in, qSfcLatRunoff_in)
11403 end if
11404
11405 !! Accumulations - NOT SUPPORTED, MAY NEVER BE.
11406 !! How to figure out if fluxes or accums force??
11407 if(.FALSE.) then
11408    allocate(accBucket_in(len))
11409    allocate(accSfcLatRunoff_in(len))
11410    accBucket_in   = zeroDbl
11411    accSfcLatRunoff_in = zeroDbl
11412
11413    call read_rst_crt_reach_nc(ncid, accSfcLatRunoff_in, "accSfcLatRunoff", &
11414         rt_domain(did)%GNLINKSL, fatalErr=.true.)
11415    !! Could worry about bucket being off or not output...
11416    call read_rst_crt_reach_nc(ncid, accBucket_in,         "accBucket",       &
11417         rt_domain(did)%GNLINKSL, fatalErr=.true.)
11418
11419    !! Calculate the current
11420    if(len .gt. 0) then  !! would the length be zero on some images?
11421       rt_domain(did)%qout_gwsubbas = &
11422            real( (accBucket_in - rt_domain(did)%accBucket)/nlst(did)%DT )
11423       rt_domain(did)%QLateral      = &
11424            real( rt_domain(did)%qout_gwsubbas +     &
11425                  (accSfcLatRunoff_in - rt_domain(did)%accSfcLatRunoff)/nlst(did)%DT )
11426
11427       !! Negative accumulations imply accumulations were zeroed, e.g. the code was restarted
11428       if(any(rt_domain(did)%QLateral .lt. 0)) &
11429            rt_domain(did)%QLateral      = real( (accSfcLatRunoff_in)/nlst(did)%DT )
11430       if(any(rt_domain(did)%qout_gwsubbas .lt. 0)) &
11431            rt_domain(did)%qout_gwsubbas = real( (accBucket_in)/nlst(did)%DT )
11432
11433       !! /\ ORDER MATTERS \/ because the pre-input accumulations are needed above.
11434       !! else below would be zero.
11435       rt_domain(did)%accBucket     = accBucket_in
11436       rt_domain(did)%accSfcLatRunoff = accSfcLatRunoff_in
11437
11438    end if
11439
11440    deallocate(accBucket_in, accSfcLatRunoff_in)
11441 end if
11442
11443 if(my_id .eq. io_id) then
11444    iret = nf90_close(ncid)
11445 #ifdef HYDRO_D
11446    print*, "finish read channel only forcing "
11447 #endif /* HYDRO_D */
11448 endif
11449 call flush(6)
11450
11451 end subroutine read_channel_only
11452
11453
11454 !---------------------------------------------------------------------------
11455 end module module_HYDRO_io