hydro/Routing/module_HYDRO_io.F

   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
  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, gw_buck_loss
1522    real,    intent(out), dimension(numbasns) :: z_max, z_gwsubbas, basns_area
1523    integer, intent(out), dimension(numbasns) :: bas_id
1524    real, dimension(gnumbasns) :: tmp_buck_coeff, tmp_buck_exp, tmp_buck_loss
1525    real, dimension(gnumbasns) :: tmp_z_max, tmp_z_gwsubbas,  tmp_basns_area
1526    integer, dimension(gnumbasns) :: tmp_bas_id
1527    CHARACTER(len=100)                     :: header
1528    CHARACTER(len=1)                       :: jnk
1529    character(len=*) :: inFile
1530    integer :: bas,k
1531    integer :: iret, ncid
1532    logical :: fexist
1533
1534 #ifdef MPP_LAND
1535    if(my_id .eq. IO_id) then
1536 #endif
1537      inquire (file=trim(inFile), exist=fexist)
1538      if(.not. fexist) then
1539         call hydro_stop("Cound not find file : "//trim(inFile))
1540      endif
1541      iret = nf90_open(trim(inFile), NF90_NOWRITE, ncid)
1542      if(iret .eq. 0 ) then
1543         print*, "read GWBUCKPARM file as nc format: " , trim(inFile)
1544         call get_1d_netcdf_int(ncid, "Basin", tmp_bas_id, "read GWBUCKPARM", .true.)
1545         call get_1d_netcdf_real(ncid, "Coeff",tmp_buck_coeff , "read GWBUCKPARM", .true.)
1546         call get_1d_netcdf_real(ncid, "Expon",tmp_buck_exp   , "read GWBUCKPARM", .true.)
1547         if(nlst(did)%bucket_loss .eq. 1) then
1548            call get_1d_netcdf_real(ncid, "Loss",tmp_buck_loss, "read GWBUCKPARM", .true.)
1549         endif
1550         call get_1d_netcdf_real(ncid, "Zmax" ,tmp_z_max      , "read GWBUCKPARM", .true.)
1551         call get_1d_netcdf_real(ncid, "Zinit",tmp_z_gwsubbas , "read GWBUCKPARM", .true.)
1552         call get_1d_netcdf_real(ncid, "Area_sqkm",tmp_basns_area , "read GWBUCKPARM", .true.)
1553         iret = nf90_close(ncid)
1554      else
1555         !iret = nf90_close(ncid)
1556         print*, "read GWBUCKPARM file as TBL format : "
1557 #ifndef NCEP_WCOSS
1558 !yw        OPEN(81, FILE='GWBUCKPARM.TBL',FORM='FORMATTED',STATUS='OLD')
1559         OPEN(81, FILE=trim(inFile),FORM='FORMATTED',STATUS='OLD')
1560         read(81,811) header
1561 #else
1562         OPEN(24, FORM='FORMATTED',STATUS='OLD')
1563         read(24,811) header
1564 #endif
1565 811      FORMAT(A19)
1566
1567
1568 #ifndef NCEP_WCOSS
1569         do bas = 1,gnumbasns
1570            read(81,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , &
1571                  jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas)
1572
1573         end do
1574 812       FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4)
1575         close(81)
1576 #else
1577         do bas = 1,gnumbasns
1578             read(24,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , &
1579                 jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas)
1580         end do
1581 812      FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4)
1582         close(24)
1583 #endif
1584      endif
1585 #ifdef MPP_LAND
1586    endif
1587
1588    if(gnumbasns .gt. 0 ) then
1589       call mpp_land_bcast_real(gnumbasns,tmp_buck_coeff)
1590       call mpp_land_bcast_real(gnumbasns,tmp_buck_exp  )
1591       if(nlst(did)%bucket_loss .eq. 1) then
1592          call mpp_land_bcast_real(gnumbasns,tmp_buck_loss   )
1593       endif
1594       call mpp_land_bcast_real(gnumbasns,tmp_z_max   )
1595       call mpp_land_bcast_real(gnumbasns,tmp_z_gwsubbas   )
1596       call mpp_land_bcast_real(gnumbasns,tmp_basns_area   )
1597       call mpp_land_bcast_int(gnumbasns,tmp_bas_id)
1598    endif
1599 #endif
1600
1601     do k = 1, numbasns
1602        bas = basnsInd(k)
1603        gw_buck_coeff(k) = tmp_buck_coeff(bas)
1604        gw_buck_exp(k) = tmp_buck_exp(bas)
1605        if(nlst(did)%bucket_loss .eq. 1) then
1606           gw_buck_loss(k) = tmp_buck_loss(bas)
1607        endif
1608        z_max(k) = tmp_z_max(bas)
1609        z_gwsubbas(k) = tmp_z_gwsubbas(bas)
1610        basns_area(k) = tmp_basns_area(bas)
1611        bas_id(k) = tmp_bas_id(bas)
1612     end do
1613   end subroutine read_GWBUCKPARM
1614
1615
1616
1617   ! BF read the static input fields needed for the 2D GW scheme
1618   subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype, ihShift)
1619   implicit none
1620   integer, intent(in) :: ix, jx
1621   real, intent(in) :: ihShift
1622   integer, dimension(ix,jx), intent(inout)::   ltype
1623   real, dimension(ix,jx), intent(inout)   ::   hc, ihead, botelv, por
1624
1625 #ifdef MPP_LAND
1626   integer, dimension(:,:), allocatable ::  gLtype
1627   real, dimension(:,:), allocatable    ::  gHC, gIHEAD, gBOTELV, gPOR
1628 #endif
1629   integer :: i
1630
1631
1632 #ifdef MPP_LAND
1633   if(my_id .eq. IO_id) then
1634       allocate(gHC(global_rt_nx, global_rt_ny))
1635       allocate(gIHEAD(global_rt_nx, global_rt_ny))
1636       allocate(gBOTELV(global_rt_nx, global_rt_ny))
1637       allocate(gPOR(global_rt_nx, global_rt_ny))
1638       allocate(gLtype(global_rt_nx, global_rt_ny))
1639   else
1640       allocate(gHC(1, 1))
1641       allocate(gIHEAD(1, 1))
1642       allocate(gBOTELV(1, 1))
1643       allocate(gPOR(1, 1))
1644       allocate(gLtype(1, 1))
1645   endif
1646
1647 #ifndef PARALLELIO
1648   if(my_id .eq. IO_id) then
1649 #endif
1650 #ifdef HYDRO_D
1651   print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..."
1652 #endif
1653 #endif
1654
1655
1656         ! hydraulic conductivity
1657         i = get2d_real("HC", &
1658 #ifdef MPP_LAND
1659 #ifndef PARALLELIO
1660                        gHC, global_nx, global_ny,  &
1661 #else
1662                        hc, ix, jx,  &
1663 #endif
1664 #else
1665                        hc, ix, jx,  &
1666 #endif
1667                        trim("./gwhires.nc"))
1668
1669         ! initial head
1670         i = get2d_real("IHEAD", &
1671 #ifdef MPP_LAND
1672                        gIHEAD, global_nx, global_ny, &
1673 #else
1674                        ihead,  ix, jx, &
1675 #endif
1676                        trim("./gwhires.nc"))
1677
1678         ! aquifer bottom elevation
1679         i = get2d_real("BOTELV", &
1680 #ifdef MPP_LAND
1681 #ifndef PARALLELIO
1682                        gBOTELV, global_nx, global_ny, &
1683 #else
1684                        botelv, ix, jx,  &
1685 #endif
1686 #else
1687                        botelv, ix, jx,  &
1688 #endif
1689                        trim("./gwhires.nc"))
1690
1691         ! aquifer porosity
1692         i = get2d_real("POR", &
1693 #ifdef MPP_LAND
1694 #ifndef PARALLELIO
1695                        gPOR, global_nx, global_ny, &
1696 #else
1697                        por, ix, jx,  &
1698 #endif
1699 #else
1700                        por, ix, jx,  &
1701 #endif
1702                        trim("./gwhires.nc"))
1703
1704
1705         ! groundwater model mask (0 no aquifer, aquifer > 0
1706         call get2d_int("LTYPE", &
1707 #ifdef MPP_LAND
1708 #ifndef PARALLELIO
1709                        gLtype, global_nx, global_ny, &
1710 #else
1711                        ltype, ix, jx, &
1712 #endif
1713 #else
1714                        ltype, ix, jx,  &
1715 #endif
1716                        trim("./gwhires.nc"))
1717
1718
1719 #ifdef MPP_LAND
1720 #ifndef PARALLELIO
1721        gLtype(1,:) = 2
1722        gLtype(:,1) = 2
1723        gLtype(global_rt_nx,:) = 2
1724        gLtype(:,global_rt_ny) = 2
1725 #else
1726 ! BF TODO parallel io for gw ltype
1727 #endif
1728 #else
1729        ltype(1,:) = 2
1730        ltype(:,1) = 2
1731        ltype(ix,:)= 2
1732        ltype(:,jx)= 2
1733 #endif
1734
1735 #ifdef MPP_LAND
1736 #ifndef PARALLELIO
1737   endif
1738      call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx)
1739      call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx)
1740      call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx)
1741      call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx)
1742      call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx)
1743      if(allocated(gLtype)) deallocate(gLtype)
1744      if(allocated(gHC)) deallocate(gHC)
1745      if(allocated(gIHEAD)) deallocate(gIHEAD)
1746      if(allocated(gBOTELV)) deallocate(gBOTELV)
1747      if(allocated(gPOR)) deallocate(gPOR)
1748 #endif
1749 #endif
1750
1751
1752   ihead = ihead + ihShift
1753
1754   where(ltype .eq. 0)
1755    hc = 0.
1756 !yw   por = 10**21
1757    por = 10E21
1758   end where
1759
1760
1761   !bftodo: make filename accessible in namelist
1762   return
1763   end subroutine readGW2d
1764   !BF
1765
1766   subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, &
1767        startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID,       &
1768        q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, &
1769        geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,CHRTOUT_GRID,  &
1770        QBDRYRT,  &
1771        io_config_outputs &
1772        )
1773
1774 !output the routing variables over routing grid.
1775     implicit none
1776
1777     integer,                                  intent(in) :: igrid
1778
1779     integer,                                  intent(in) :: io_config_outputs
1780     integer,                                  intent(in) :: split_output_count
1781     integer,                                  intent(in) :: ixrt,jxrt
1782     real,                                     intent(in) :: dt
1783     real,                                     intent(in) :: dist(ixrt,jxrt,9)
1784     integer,                                  intent(in) :: nsoil
1785     integer,                                  intent(in) :: CHRTOUT_GRID
1786     character(len=*),                         intent(in) :: startdate
1787     character(len=*),                         intent(in) :: date
1788     character(len=*),          intent(in)                :: geo_finegrid_flnm
1789     real,             dimension(nsoil),       intent(in) :: sldpth
1790     real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
1791     real*8, allocatable, DIMENSION(:)                   :: xcoord_d
1792     real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
1793
1794     integer, save :: ncid,ncstatic
1795     integer, save :: output_count
1796     real,    dimension(nsoil) :: asldpth
1797
1798     integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
1799     integer :: iret, dimid_soil, i,j,ii,jj
1800     character(len=256) :: output_flnm
1801     character(len=19)  :: date19
1802     character(len=32)  :: convention
1803     character(len=34)  :: sec_since_date
1804     character(len=34)  :: sec_valid_date
1805
1806     character(len=30)  :: soilm
1807
1808     real                                :: long_cm,lat_po,fe,fn, chan_in
1809     real, dimension(2)                  :: sp
1810
1811     real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID
1812     real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y
1813     real, dimension(ixrt,jxrt) :: QSTRMVOLRT
1814     real, dimension(ixrt,jxrt) :: SFCHEADSUBRT
1815     real, dimension(ixrt,jxrt) :: soxrt,soyrt
1816     real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT
1817     real, dimension(ixrt,jxrt,nsoil) :: SMCRT
1818
1819     character(len=2) :: strTmp
1820
1821     integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
1822     sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
1823     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
1824     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
1825                   //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
1826
1827     decimation = 1 !-- decimation factor
1828 #ifdef MPP_LAND
1829     ixrtd = int(global_rt_nx/decimation)
1830     jxrtd = int(global_rt_ny/decimation)
1831 #else
1832     ixrtd = int(ixrt/decimation)
1833     jxrtd = int(jxrt/decimation)
1834 #endif
1835
1836 #ifdef MPP_LAND
1837     if(my_id .eq. io_id) then
1838 #endif
1839        allocate(xdumd(ixrtd,jxrtd))
1840        allocate(xcoord_d(ixrtd))
1841        allocate(ycoord_d(jxrtd))
1842        allocate(ycoord(jxrtd))
1843
1844        xdumd = -999
1845        xcoord_d = -999
1846        ycoord_d = -999
1847        ycoord = -999
1848 #ifdef MPP_LAND
1849     else
1850        allocate(xdumd(1,1))
1851        allocate(xcoord_d(1))
1852        allocate(ycoord_d(1))
1853        allocate(ycoord(1))
1854     endif
1855 #endif
1856     ii = 0
1857
1858 !DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09)
1859     chan_in = 0.0
1860     do j=1,jxrt
1861       do i=1,ixrt
1862         chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9))  !(units m^3)
1863       enddo
1864     enddo
1865 #ifdef MPP_LAND
1866       call sum_real1(chan_in)
1867 #endif
1868 #ifdef MPP_LAND
1869     if(my_id .eq. io_id) then
1870 #endif
1871 #ifdef NCEP_WCOSS
1872        open (unit=54, form='formatted', status='unknown', position='append')
1873         write (54,713) chan_in
1874        close (54)
1875 #else
1876        if (io_config_outputs .le. 0) then
1877          open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',&
1878              status='unknown',position='append')
1879          write (46,713) chan_in
1880          close (46)
1881        endif
1882 #endif
1883 #ifdef MPP_LAND
1884     endif
1885 #endif
1886 713 FORMAT (F20.7)
1887 !    return
1888 !DJG end dump of channel inflow for calibration....
1889
1890     if (CHRTOUT_GRID.eq.0) return  ! return if hires flag eq 1, if =2 output full grid
1891
1892     if (output_count == 0) then
1893
1894    !-- Open the  finemesh static files to obtain projection information
1895 #ifdef HYDRO_D
1896       write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
1897 #endif
1898
1899 #ifdef MPP_LAND
1900    if(my_id .eq. io_id) then
1901 #endif
1902       iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic)
1903 #ifdef MPP_LAND
1904    endif
1905    call mpp_land_bcast_int1(iret)
1906 #endif
1907
1908       if (iret /= 0) then
1909          write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
1910          trim(geo_finegrid_flnm)
1911          write(*,*) "HIRES_OUTPUT will not be georeferenced..."
1912         hires_flag = 0
1913       else
1914         hires_flag = 1
1915       endif
1916
1917 #ifdef MPP_LAND
1918    if(my_id .eq. io_id) then
1919 #endif
1920
1921      if(hires_flag.eq.1) then !if/then hires_georef
1922       ! Get Latitude (X)
1923       iret = NF90_INQ_VARID(ncstatic,'x',varid)
1924       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord_d)
1925       ! Get Longitude (Y)
1926       iret = NF90_INQ_VARID(ncstatic,'y',varid)
1927       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord)
1928      else
1929       ycoord_d = 0.
1930       xcoord_d = 0.
1931      end if  !endif hires_georef
1932
1933      jj = 0
1934 #ifdef MPP_LAND
1935      do j=global_rt_ny,1,-1*decimation
1936 #else
1937      do j=jxrt,1,-1*decimation
1938 #endif
1939         jj = jj+1
1940         if (jj<= jxrtd) then
1941          ycoord_d(jj) = ycoord(j)
1942         endif
1943      enddo
1944
1945    if (io_config_outputs .le. 0) then
1946      if(hires_flag.eq.1) then !if/then hires_georef
1947       ! Get projection information from finegrid netcdf file
1948       iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
1949       if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
1950       iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
1951       iret = nf90_get_att(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
1952       iret = nf90_get_att(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
1953       iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
1954      end if  !endif hires_georef
1955       iret = nf90_close(ncstatic)
1956    endif
1957
1958 !-- create the fine grid routing file
1959        write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
1960 #ifdef HYDRO_D
1961        print*, 'output_flnm = "'//trim(output_flnm)//'"'
1962 #endif
1963        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
1964        if (iret /= 0) then
1965          call hydro_stop("In output_rt() - Problem nf90_create")
1966        endif
1967
1968        iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times)
1969        iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
1970        iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx)
1971      if (io_config_outputs .le. 0) then
1972        iret = nf90_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
1973      endif
1974
1975 !--- define variables
1976 !     !- time definition, timeObs
1977          iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid)
1978          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
1979          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
1980
1981 if (io_config_outputs .le. 0) then
1982        !- x-coordinate in cartesian system
1983         iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid)
1984         iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
1985         iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
1986         iret = nf90_put_att(ncid, varid, 'units', 'Meter')
1987
1988        !- y-coordinate in cartesian ssystem
1989           iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid)
1990           iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
1991           iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
1992           iret = nf90_put_att(ncid, varid, 'units', 'Meter')
1993
1994        !- LATITUDE
1995         iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
1996         iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE')
1997         iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE')
1998         iret = nf90_put_att(ncid, varid, 'units', 'deg North')
1999
2000        !- LONGITUDE
2001           iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2002           iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE')
2003           iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE')
2004           iret = nf90_put_att(ncid, varid, 'units', 'deg east')
2005
2006        !-- z-level is soil
2007         iret = nf90_def_var(ncid, "depth", NF90_FLOAT, (/dimid_soil/), varid)
2008         iret = nf90_put_att(ncid, varid, 'units', 'cm')
2009         iret = nf90_put_att(ncid, varid, 'long_name', 'depth of soil layer')
2010
2011          do n = 1, NSOIL
2012              write(strTmp,'(I2)') n
2013              iret = nf90_def_var(ncid, "SOIL_M"//trim(strTmp), NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2014          end do
2015             iret = nf90_put_att(ncid, varid, 'units', 'm^3/m^3')
2016             iret = nf90_put_att(ncid, varid, 'description', 'moisture content')
2017             iret = nf90_put_att(ncid, varid, 'long_name', soilm)
2018 !           iret = nf90_put_att(ncid, varid, 'coordinates', 'x y z')
2019             iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2020             iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2021
2022 !      iret = nf90_def_var(ncid, "ESNOW2D", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2023
2024 !       iret = nf90_def_var(ncid, "QSUBRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2025 !       iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2026 !       iret = nf90_put_att(ncid, varid, 'long_name', 'subsurface flow')
2027 !       iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2028 !       iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2029 !       iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2030 endif
2031
2032 ! All but long range
2033 if ( io_config_outputs .ne. 4 ) then
2034
2035    iret = nf90_def_var(ncid, "zwattablrt", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2036    iret = nf90_put_att(ncid, varid, 'units', 'm')
2037    iret = nf90_put_att(ncid, varid, 'long_name', 'water table depth')
2038    iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2039    iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2040    iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2041
2042    !iret = nf90_def_var(ncid, "Q_SFCFLX_X", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2043    !iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2044    !iret = nf90_put_att(ncid, varid, 'long_name', 'surface flux x')
2045    !iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2046    !iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2047    !iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2048
2049    !iret = nf90_def_var(ncid, "Q_SFCFLX_Y", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2050    !iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2051    !iret = nf90_put_att(ncid, varid, 'long_name', 'surface flux y')
2052    !iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2053    !iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2054    !iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2055
2056    iret = nf90_def_var(ncid, "sfcheadsubrt", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2057    iret = nf90_put_att(ncid, varid, 'units', 'mm')
2058    iret = nf90_put_att(ncid, varid, 'long_name', 'surface head')
2059    iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2060    iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2061    iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2062
2063 endif
2064
2065 if (io_config_outputs .le. 0) then
2066        iret = nf90_def_var(ncid, "QSTRMVOLRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2067        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2068        iret = nf90_put_att(ncid, varid, 'long_name', 'accum channel inflow')
2069        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2070        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2071        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2072
2073 !      iret = nf90_def_var(ncid, "SOXRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2074 !      iret = nf90_put_att(ncid, varid, 'units', '1')
2075 !      iret = nf90_put_att(ncid, varid, 'long_name', 'slope x')
2076 !      iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2077 !      iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2078 !      iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2079
2080 !      iret = nf90_def_var(ncid, "SOYRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2081 !      iret = nf90_put_att(ncid, varid, 'units', '1')
2082 !      iret = nf90_put_att(ncid, varid, 'long_name', 'slope 7')
2083 !      iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2084 !      iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2085 !      iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2086
2087 !       iret = nf90_def_var(ncid, "SUB_RESID", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2088
2089        iret = nf90_def_var(ncid, "QBDRYRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2090        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2091        iret = nf90_put_att(ncid,varid,'long_name',&
2092           'accumulated value of the boundary flux, + into domain, - out of domain')
2093        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2094        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2095        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2096
2097 !-- place projection information
2098      if(hires_flag.eq.1) then !if/then hires_georef
2099       iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid)
2100       iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic')
2101       iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm)
2102       iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po)
2103       iret = nf90_put_att(ncid, varid, 'false_easting', fe)
2104       iret = nf90_put_att(ncid, varid, 'false_northing', fn)
2105       iret = nf90_put_att(ncid, varid, 'standard_parallel', sp)
2106      end if   !endif hires_georef
2107 endif
2108
2109 !      iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid)
2110
2111       date19(1:19) = "0000-00-00_00:00:00"
2112       date19(1:len_trim(startdate)) = startdate
2113       convention(1:32) = "CF-1.0"
2114       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
2115       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
2116       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
2117       iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation)
2118
2119        ! iret = nf90_redef(ncid)
2120        iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
2121        ! iret = nf90_enddef(ncid)
2122
2123       iret = nf90_enddef(ncid)
2124
2125 if (io_config_outputs .le. 0) then
2126 !!-- write latitude and longitude locations
2127          iret = nf90_inq_varid(ncid,"x", varid)
2128          iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array
2129
2130          iret = nf90_inq_varid(ncid,"y", varid)
2131          iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array
2132 endif
2133
2134 #ifdef MPP_LAND
2135     endif
2136 #endif
2137
2138 iret = nf90_inq_varid(ncid,"time", varid)
2139 iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
2140
2141 if (io_config_outputs .le. 0) then
2142 #ifdef MPP_LAND
2143         call write_IO_rt_real(LATVAL,xdumd)
2144     if( my_id .eq. io_id) then
2145 #else
2146         xdumd = LATVAL
2147 #endif
2148         iret = nf90_inq_varid(ncid,"LATITUDE", varid)
2149         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2150
2151
2152 #ifdef MPP_LAND
2153     endif   !!! end if block of my_id .eq. io_id
2154
2155         call write_IO_rt_real(LONVAL,xdumd)
2156
2157     if( my_id .eq. io_id) then
2158 #else
2159         xdumd = LONVAL
2160 #endif
2161         iret = nf90_inq_varid(ncid,"LONGITUDE", varid)
2162         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2163
2164 #ifdef MPP_LAND
2165     endif
2166
2167     if( my_id .eq. io_id) then
2168 #endif
2169
2170        do n = 1,nsoil
2171         if(n == 1) then
2172          asldpth(n) = -sldpth(n)
2173         else
2174          asldpth(n) = asldpth(n-1) - sldpth(n)
2175         endif
2176        enddo
2177
2178        iret = nf90_inq_varid(ncid,"depth", varid)
2179        iret = nf90_put_var(ncid, varid, asldpth, (/1/), (/nsoil/))
2180 !yw       iret = nf90_close(ncstatic)
2181 #ifdef MPP_LAND
2182     endif  ! end of my_id .eq. io_id
2183 #endif
2184 endif
2185
2186    endif !!! end of if block output_count == 0
2187     output_count = output_count + 1
2188
2189 if (io_config_outputs .le. 0) then
2190 !-- 3-d soils
2191      do n = 1, nsoil
2192 #ifdef MPP_LAND
2193           call write_IO_rt_real(smcrt(:,:,n),xdumd)
2194 #else
2195           xdumd(:,:) = smcrt(:,:,n)
2196 #endif
2197 #ifdef MPP_LAND
2198     if(my_id .eq. io_id) then
2199 #endif
2200           write(strTmp,'(I2)') n
2201           iret = nf90_inq_varid(ncid,  "SOIL_M"//trim(strTmp), varid)
2202           iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2203 #ifdef MPP_LAND
2204     endif
2205 #endif
2206     enddo !-n soils
2207 endif
2208
2209 ! All but long range
2210 if ( (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then
2211 #ifdef MPP_LAND
2212    call write_IO_rt_real(ZWATTABLRT,xdumd)
2213 #else
2214    xdumd(:,:) = ZWATTABLRT(:,:)
2215 #endif
2216 #ifdef MPP_LAND
2217    if (my_id .eq. io_id) then
2218 #endif
2219       iret = nf90_inq_varid(ncid,  "zwattablrt", varid)
2220       iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2221 #ifdef MPP_LAND
2222    endif
2223 #endif
2224 endif
2225
2226 if (io_config_outputs .le. 0) then
2227 #ifdef MPP_LAND
2228           call write_IO_rt_real(QBDRYRT,xdumd)
2229 #else
2230           xdumd(:,:) = QBDRYRT(:,:)
2231 #endif
2232 #ifdef MPP_LAND
2233     if(my_id .eq. io_id) then
2234 #endif
2235      iret = nf90_inq_varid(ncid,  "QBDRYRT", varid)
2236      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2237 #ifdef MPP_LAND
2238      endif
2239 #endif
2240
2241 #ifdef MPP_LAND
2242           call write_IO_rt_real(QSTRMVOLRT,xdumd)
2243 #else
2244           xdumd(:,:) = QSTRMVOLRT(:,:)
2245 #endif
2246 #ifdef MPP_LAND
2247     if(my_id .eq. io_id) then
2248 #endif
2249      iret = nf90_inq_varid(ncid,  "QSTRMVOLRT", varid)
2250      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2251 #ifdef MPP_LAND
2252      endif
2253 #endif
2254 endif
2255
2256 ! All but long range
2257 if ( io_config_outputs .ne. 4 ) then
2258 #ifdef MPP_LAND
2259    call write_IO_rt_real(SFCHEADSUBRT,xdumd)
2260 #else
2261    xdumd(:,:) = SFCHEADSUBRT(:,:)
2262 #endif
2263 #ifdef MPP_LAND
2264    if (my_id .eq. io_id) then
2265 #endif
2266       iret = nf90_inq_varid(ncid,  "sfcheadsubrt", varid)
2267       iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2268 #ifdef MPP_LAND
2269    endif
2270 #endif
2271 endif
2272
2273 #ifdef MPP_LAND
2274     if(my_id .eq. io_id) then
2275 #endif
2276
2277
2278 !yw      iret = nf90_sync(ncid)
2279       if (output_count == split_output_count) then
2280         output_count = 0
2281         iret = nf90_close(ncid)
2282       endif
2283 #ifdef MPP_LAND
2284      endif
2285      call mpp_land_bcast_int1(output_count)
2286 #endif
2287
2288      if(allocated(xdumd))  deallocate(xdumd)
2289      if(allocated(xcoord_d))  deallocate(xcoord_d)
2290      if(allocated(ycoord_d)) deallocate(ycoord_d)
2291      if(allocated(ycoord))  deallocate(ycoord)
2292
2293 #ifdef HYDRO_D
2294      write(6,*) "end of output_rt"
2295 #endif
2296
2297   end subroutine output_rt
2298
2299
2300 !BF output section for gw2d model
2301 !bftodo: clean up an customize for GW usage
2302
2303   subroutine output_gw_spinup(igrid, split_output_count, ixrt, jxrt, &
2304        startdate, date, HEAD, convgw, excess, &
2305        geo_finegrid_flnm,dt,LATVAL,LONVAL,dist,output_gw)
2306
2307 #ifdef MPP_LAND
2308        USE module_mpp_land
2309 #endif
2310 !output the routing variables over routing grid.
2311     implicit none
2312
2313     integer,                                  intent(in) :: igrid
2314     integer,                                  intent(in) :: split_output_count
2315     integer,                                  intent(in) :: ixrt,jxrt
2316     real,                                     intent(in) :: dt
2317     real,                                     intent(in) :: dist(ixrt,jxrt,9)
2318     integer,                                  intent(in) ::  output_gw
2319     character(len=*),                         intent(in) :: startdate
2320     character(len=*),                         intent(in) :: date
2321     character(len=*),          intent(in)                :: geo_finegrid_flnm
2322     real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
2323     real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
2324     real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
2325
2326     integer, save :: ncid,ncstatic
2327     integer, save :: output_count
2328
2329     integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
2330     integer :: iret, dimid_soil, i,j,ii,jj
2331     character(len=256) :: output_flnm
2332     character(len=19)  :: date19
2333     character(len=32)  :: convention
2334     character(len=34)  :: sec_since_date
2335     character(len=34)  :: sec_valid_date
2336
2337     character(len=30)  :: soilm
2338
2339     real                                :: long_cm,lat_po,fe,fn, chan_in
2340     real, dimension(2)                  :: sp
2341
2342     real, dimension(ixrt,jxrt) :: head, convgw, excess, &
2343                                   latval, lonval
2344
2345     integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
2346
2347 #ifdef MPP_LAND
2348     real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gExcess
2349     real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval
2350 #endif
2351
2352 #ifdef MPP_LAND
2353     call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99)
2354     call write_IO_rt_real(latval,gLatval)
2355     call write_IO_rt_real(lonval,gLonval)
2356     call write_IO_rt_real(head,gHead)
2357     call write_IO_rt_real(convgw,gConvgw)
2358     call write_IO_rt_real(excess,gExcess)
2359
2360
2361    if(my_id.eq.IO_id) then
2362
2363
2364 #endif
2365     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
2366     sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
2367     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
2368                   //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
2369
2370     decimation = 1 !-- decimation factor
2371 #ifdef MPP_LAND
2372     ixrtd = int(global_rt_nx/decimation)
2373     jxrtd = int(global_rt_ny/decimation)
2374 #else
2375     ixrtd = int(ixrt/decimation)
2376     jxrtd = int(jxrt/decimation)
2377 #endif
2378     allocate(xdumd(ixrtd,jxrtd))
2379     allocate(xcoord_d(ixrtd))
2380     allocate(ycoord_d(jxrtd))
2381     allocate(xcoord(ixrtd))
2382     allocate(ycoord(jxrtd))
2383     ii = 0
2384     jj = 0
2385
2386     if (output_gw.eq.0) return  ! return if hires flag eq 0, if =1 output full grid
2387
2388     if (output_count == 0) then
2389
2390    !-- Open the  finemesh static files to obtain projection information
2391 #ifdef HYDRO_D
2392       write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
2393
2394 #endif
2395       iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic)
2396
2397       if (iret /= 0) then
2398 #ifdef HYDRO_D
2399          write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
2400          trim(geo_finegrid_flnm)
2401          write(*,*) "HIRES_OUTPUT will not be georeferenced..."
2402 #endif
2403         hires_flag = 0
2404       else
2405         hires_flag = 1
2406       endif
2407
2408      if(hires_flag.eq.1) then !if/then hires_georef
2409       ! Get Latitude (X)
2410       iret = NF90_INQ_VARID(ncstatic,'x',varid)
2411       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord)
2412       ! Get Longitude (Y)
2413       iret = NF90_INQ_VARID(ncstatic,'y',varid)
2414       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord)
2415      else
2416       xcoord_d = 0.
2417       ycoord_d = 0.
2418      end if  !endif hires_georef
2419
2420      do j=jxrtd,1,-1*decimation
2421         jj = jj+1
2422         if (jj<= jxrtd) then
2423          ycoord_d(jj) = ycoord(j)
2424         endif
2425      enddo
2426
2427 !yw     do i = 1,ixrt,decimation
2428 !yw        ii = ii + 1
2429 !yw        if (ii <= ixrtd) then
2430 !yw         xcoord_d(ii) = xcoord(i)
2431          xcoord_d = xcoord
2432 !yw        endif
2433 !yw     enddo
2434
2435
2436      if(hires_flag.eq.1) then !if/then hires_georef
2437       ! Get projection information from finegrid netcdf file
2438       iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
2439       if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
2440       iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
2441       iret = nf90_get_att(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
2442       iret = nf90_get_att(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
2443       iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
2444      end if  !endif hires_georef
2445       iret = nf90_close(ncstatic)
2446
2447 !-- create the fine grid routing file
2448        write(output_flnm, '(A12,".GW_SPINUP",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
2449 #ifdef HYDRO_D
2450        print*, 'output_flnm = "'//trim(output_flnm)//'"'
2451 #endif
2452
2453
2454        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
2455        if (iret /= 0) then
2456          call hydro_stop("In output_gw_spinup() - Problem nf90_create")
2457        endif
2458
2459        iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times)
2460        iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
2461        iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx)
2462
2463 !--- define variables
2464        !- time definition, timeObs
2465        iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid)
2466        iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
2467
2468        !- x-coordinate in cartesian system
2469        iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid)
2470        iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
2471        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
2472        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2473
2474        !- y-coordinate in cartesian ssystem
2475        iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid)
2476        iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
2477        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
2478        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2479
2480        !- LATITUDE
2481        iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2482        iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE')
2483        iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE')
2484        iret = nf90_put_att(ncid, varid, 'units', 'deg North')
2485
2486        !- LONGITUDE
2487        iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2488        iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE')
2489        iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE')
2490        iret = nf90_put_att(ncid, varid, 'units', 'deg east')
2491
2492
2493        iret = nf90_def_var(ncid, "GwHead", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2494        iret = nf90_put_att(ncid, varid, 'units', 'm')
2495        iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater head')
2496        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2497        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2498        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2499
2500        iret = nf90_def_var(ncid, "GwConv", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2501        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2502        iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater convergence')
2503        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2504        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2505        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2506
2507        iret = nf90_def_var(ncid, "GwExcess", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2508        iret = nf90_put_att(ncid, varid, 'units', 'm')
2509        iret = nf90_put_att(ncid, varid, 'long_name', 'surface excess groundwater')
2510        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2511        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2512        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2513
2514 !-- place projection information
2515      if(hires_flag.eq.1) then !if/then hires_georef
2516       iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid)
2517       iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic')
2518       iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm)
2519       iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po)
2520       iret = nf90_put_att(ncid, varid, 'false_easting', fe)
2521       iret = nf90_put_att(ncid, varid, 'false_northing', fn)
2522       iret = nf90_put_att(ncid, varid, 'standard_parallel', sp)
2523      end if   !endif hires_georef
2524
2525 !      iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid)
2526
2527       date19(1:19) = "0000-00-00_00:00:00"
2528       date19(1:len_trim(startdate)) = startdate
2529       convention(1:32) = "CF-1.0"
2530       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
2531       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
2532       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
2533       iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation)
2534
2535       iret = nf90_enddef(ncid)
2536
2537 !!-- write latitude and longitude locations
2538 !       xdumd = LATVAL
2539         iret = nf90_inq_varid(ncid,"x", varid)
2540 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2541         iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array
2542
2543 !       xdumd = LONVAL
2544         iret = nf90_inq_varid(ncid,"y", varid)
2545 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2546         iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array
2547
2548 #ifdef MPP_LAND
2549         xdumd = gLATVAL
2550 #else
2551         xdumd = LATVAL
2552 #endif
2553         iret = nf90_inq_varid(ncid,"LATITUDE", varid)
2554         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2555
2556 #ifdef MPP_LAND
2557         xdumd = gLONVAL
2558 #else
2559         xdumd = LONVAL
2560 #endif
2561         iret = nf90_inq_varid(ncid,"LONGITUDE", varid)
2562         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2563
2564
2565     endif
2566
2567     output_count = output_count + 1
2568
2569 !!-- time
2570         iret = nf90_inq_varid(ncid,"time", varid)
2571         iret = nf90_put_var(ncid, varid, seconds_since, (/output_count/))
2572
2573
2574 #ifdef MPP_LAND
2575         xdumd = gHead
2576 #else
2577         xdumd = head
2578 #endif
2579
2580      iret = nf90_inq_varid(ncid,  "GwHead", varid)
2581      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2582
2583 #ifdef MPP_LAND
2584         xdumd = gConvgw
2585 #else
2586         xdumd = convgw
2587 #endif
2588      iret = nf90_inq_varid(ncid,  "GwConv", varid)
2589      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2590
2591
2592 #ifdef MPP_LAND
2593      xdumd = gExcess
2594 #else
2595      xdumd = excess
2596 #endif
2597      iret = nf90_inq_varid(ncid,  "GwExcess", varid)
2598      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2599
2600
2601 !!time in seconds since startdate
2602
2603      iret = nf90_redef(ncid)
2604      date19(1:len_trim(date)) = date
2605      iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
2606      iret = nf90_enddef(ncid)
2607      iret = nf90_sync(ncid)
2608      if (output_count == split_output_count) then
2609         output_count = 0
2610         iret = nf90_close(ncid)
2611      endif
2612
2613      if(allocated(xdumd))  deallocate(xdumd)
2614      if(allocated(xcoord_d)) deallocate(xcoord_d)
2615      if(allocated(xcoord)) deallocate(xcoord)
2616      if(allocated(ycoord_d)) deallocate(ycoord_d)
2617      if(allocated(ycoord)) deallocate(ycoord)
2618
2619 #ifdef MPP_LAND
2620     endif
2621 #endif
2622
2623   end subroutine output_gw_spinup
2624
2625
2626 subroutine sub_output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, &
2627        startdate, date, HEAD, SMCRT, convgw, excess, qsgwrt, qgw_chanrt, &
2628        geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,output_gw)
2629
2630 #ifdef MPP_LAND
2631        USE module_mpp_land
2632 #endif
2633 !output the routing variables over routing grid.
2634     implicit none
2635
2636     integer,                                  intent(in) :: igrid
2637     integer,                                  intent(in) :: split_output_count
2638     integer,                                  intent(in) :: ixrt,jxrt
2639     real,                                     intent(in) :: dt
2640     real,                                     intent(in) :: dist(ixrt,jxrt,9)
2641     integer,                                  intent(in) :: nsoil
2642     integer,                                  intent(in) ::  output_gw
2643     character(len=*),                         intent(in) :: startdate
2644     character(len=*),                         intent(in) :: date
2645     character(len=*),          intent(in)                :: geo_finegrid_flnm
2646     real,             dimension(nsoil),       intent(in) :: sldpth
2647     real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
2648     real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
2649     real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
2650
2651     integer, save :: ncid,ncstatic
2652     integer, save :: output_count
2653     real,    dimension(nsoil) :: asldpth
2654
2655     integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
2656     integer :: iret, dimid_soil, i,j,ii,jj
2657     character(len=256) :: output_flnm
2658     character(len=19)  :: date19
2659     character(len=32)  :: convention
2660     character(len=34)  :: sec_since_date
2661     character(len=34)  :: sec_valid_date
2662
2663     character(len=30)  :: soilm
2664
2665     real                                :: long_cm,lat_po,fe,fn, chan_in
2666     real, dimension(2)                  :: sp
2667
2668     real, dimension(ixrt,jxrt) :: head, convgw, excess, &
2669                                   qsgwrt, qgw_chanrt, &
2670                                   latval, lonval
2671     real, dimension(ixrt,jxrt,nsoil) :: SMCRT
2672
2673     integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
2674
2675 #ifdef MPP_LAND
2676     real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gqsgwrt, gExcess, &
2677                                                   gQgw_chanrt
2678     real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval
2679     real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT
2680 #endif
2681
2682 #ifdef MPP_LAND
2683     call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99)
2684     call MPP_LAND_COM_REAL(qsgwrt, ixrt, jxrt, 99)
2685     call MPP_LAND_COM_REAL(qgw_chanrt, ixrt, jxrt, 99)
2686     call write_IO_rt_real(latval,gLatval)
2687     call write_IO_rt_real(lonval,gLonval)
2688     call write_IO_rt_real(qsgwrt,gqsgwrt)
2689     call write_IO_rt_real(qgw_chanrt,gQgw_chanrt)
2690     call write_IO_rt_real(head,gHead)
2691     call write_IO_rt_real(convgw,gConvgw)
2692     call write_IO_rt_real(excess,gExcess)
2693
2694     do i = 1, NSOIL
2695      call MPP_LAND_COM_REAL(smcrt(:,:,i), ixrt, jxrt, 99)
2696      call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i))
2697     end do
2698
2699    if(my_id.eq.IO_id) then
2700
2701
2702 #endif
2703     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
2704     sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
2705     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
2706                   //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
2707
2708     decimation = 1 !-- decimation factor
2709 #ifdef MPP_LAND
2710     ixrtd = int(global_rt_nx/decimation)
2711     jxrtd = int(global_rt_ny/decimation)
2712 #else
2713     ixrtd = int(ixrt/decimation)
2714     jxrtd = int(jxrt/decimation)
2715 #endif
2716     allocate(xdumd(ixrtd,jxrtd))
2717     allocate(xcoord_d(ixrtd))
2718     allocate(ycoord_d(jxrtd))
2719     allocate(xcoord(ixrtd))
2720     allocate(ycoord(jxrtd))
2721     ii = 0
2722     jj = 0
2723
2724     if (output_gw.eq.0) return  ! return if hires flag eq 0, if =1 output full grid
2725
2726     if (output_count == 0) then
2727
2728    !-- Open the  finemesh static files to obtain projection information
2729 #ifdef HYDRO_D
2730       write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
2731
2732 #endif
2733       iret = nf90_open(trim(geo_finegrid_flnm), NF90_NOWRITE, ncstatic)
2734
2735       if (iret /= 0) then
2736 #ifdef HYDRO_D
2737          write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
2738          trim(geo_finegrid_flnm)
2739          write(*,*) "HIRES_OUTPUT will not be georeferenced..."
2740 #endif
2741         hires_flag = 0
2742       else
2743         hires_flag = 1
2744       endif
2745
2746      if(hires_flag.eq.1) then !if/then hires_georef
2747       ! Get Latitude (X)
2748       iret = NF90_INQ_VARID(ncstatic,'x',varid)
2749       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, xcoord)
2750       ! Get Longitude (Y)
2751       iret = NF90_INQ_VARID(ncstatic,'y',varid)
2752       if(iret .eq. 0) iret = nf90_get_var(ncstatic, varid, ycoord)
2753      else
2754       xcoord_d = 0.
2755       ycoord_d = 0.
2756      end if  !endif hires_georef
2757
2758      do j=jxrtd,1,-1*decimation
2759         jj = jj+1
2760         if (jj<= jxrtd) then
2761          ycoord_d(jj) = ycoord(j)
2762         endif
2763      enddo
2764
2765 !yw     do i = 1,ixrt,decimation
2766 !yw        ii = ii + 1
2767 !yw        if (ii <= ixrtd) then
2768 !yw         xcoord_d(ii) = xcoord(i)
2769          xcoord_d = xcoord
2770 !yw        endif
2771 !yw     enddo
2772
2773
2774      if(hires_flag.eq.1) then !if/then hires_georef
2775       ! Get projection information from finegrid netcdf file
2776       iret = NF90_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
2777       if(iret .eq. 0) iret = nf90_get_att(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
2778       iret = nf90_get_att(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
2779       iret = nf90_get_att(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
2780       iret = nf90_get_att(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
2781       iret = nf90_get_att(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
2782      end if  !endif hires_georef
2783       iret = nf90_close(ncstatic)
2784
2785 !-- create the fine grid routing file
2786        write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
2787 #ifdef HYDRO_D
2788        print*, 'output_flnm = "'//trim(output_flnm)//'"'
2789 #endif
2790
2791
2792        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
2793        if (iret /= 0) then
2794          call hydro_stop("In output_gw_spinup() - Problem nf90_create")
2795        endif
2796
2797        iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, dimid_times)
2798        iret = nf90_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
2799        iret = nf90_def_dim(ncid, "y", jxrtd, dimid_jx)
2800        iret = nf90_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
2801
2802 !--- define variables
2803        !- time definition, timeObs
2804        iret = nf90_def_var(ncid, "time", NF90_INT, (/dimid_times/), varid)
2805        iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
2806
2807        !- x-coordinate in cartesian system
2808        iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/dimid_ix/), varid)
2809        iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
2810        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
2811        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2812
2813        !- y-coordinate in cartesian ssystem
2814        iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/dimid_jx/), varid)
2815        iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
2816        iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
2817        iret = nf90_put_att(ncid, varid, 'units', 'Meter')
2818
2819        !- LATITUDE
2820        iret = nf90_def_var(ncid, "LATITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2821        iret = nf90_put_att(ncid, varid, 'long_name', 'LATITUDE')
2822        iret = nf90_put_att(ncid, varid, 'standard_name', 'LATITUDE')
2823        iret = nf90_put_att(ncid, varid, 'units', 'deg North')
2824
2825        !- LONGITUDE
2826        iret = nf90_def_var(ncid, "LONGITUDE", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
2827        iret = nf90_put_att(ncid, varid, 'long_name', 'LONGITUDE')
2828        iret = nf90_put_att(ncid, varid, 'standard_name', 'LONGITUDE')
2829        iret = nf90_put_att(ncid, varid, 'units', 'deg east')
2830
2831        !-- z-level is soil
2832        iret = nf90_def_var(ncid, "depth", NF90_FLOAT, (/dimid_soil/), varid)
2833        iret = nf90_put_att(ncid, varid, 'units', 'cm')
2834        iret = nf90_put_att(ncid, varid, 'long_name', 'depth of soil layer')
2835
2836        iret = nf90_def_var(ncid, "SOIL_M", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid)
2837        iret = nf90_put_att(ncid, varid, 'units', 'kg m-2')
2838        iret = nf90_put_att(ncid, varid, 'description', 'moisture content')
2839        iret = nf90_put_att(ncid, varid, 'long_name', soilm)
2840 !      iret = nf90_put_att(ncid, varid, 'coordinates', 'x y z')
2841        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2842        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2843
2844        iret = nf90_def_var(ncid, "HEAD", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2845        iret = nf90_put_att(ncid, varid, 'units', 'm')
2846        iret = nf90_put_att(ncid, varid, 'long_name', 'groundwater head')
2847        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2848        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2849        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2850
2851        iret = nf90_def_var(ncid, "CONVGW", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2852        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2853        iret = nf90_put_att(ncid, varid, 'long_name', 'channel flux')
2854        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2855        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2856        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2857
2858        iret = nf90_def_var(ncid, "GwExcess", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2859        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2860        iret = nf90_put_att(ncid, varid, 'long_name', 'surface excess groundwater')
2861        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2862        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2863        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2864
2865        iret = nf90_def_var(ncid, "QSGWRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2866        iret = nf90_put_att(ncid, varid, 'units', 'mm')
2867        iret = nf90_put_att(ncid, varid, 'long_name', 'surface head')
2868        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2869        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2870        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2871
2872        iret = nf90_def_var(ncid, "QGW_CHANRT", NF90_FLOAT, (/dimid_ix,dimid_jx,dimid_times/), varid)
2873        iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
2874        iret = nf90_put_att(ncid, varid, 'long_name', 'surface head')
2875        iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
2876        iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
2877        iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
2878 !-- place projection information
2879      if(hires_flag.eq.1) then !if/then hires_georef
2880       iret = nf90_def_var(ncid, "lambert_conformal_conic", NF90_INT, 0, varid)
2881       iret = nf90_put_att(ncid, varid, 'grid_mapping_name', 'lambert_conformal_conic')
2882       iret = nf90_put_att(ncid, varid, 'longitude_of_central_meridian', long_cm)
2883       iret = nf90_put_att(ncid, varid, 'latitude_of_projection_origin', lat_po)
2884       iret = nf90_put_att(ncid, varid, 'false_easting', fe)
2885       iret = nf90_put_att(ncid, varid, 'false_northing', fn)
2886       iret = nf90_put_att(ncid, varid, 'standard_parallel', sp)
2887      end if   !endif hires_georef
2888
2889 !      iret = nf90_def_var(ncid, "Date", NF90_CHAR, (/dimid_datelen,dimid_times/), varid)
2890
2891       date19(1:19) = "0000-00-00_00:00:00"
2892       date19(1:len_trim(startdate)) = startdate
2893       convention(1:32) = "CF-1.0"
2894       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
2895       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
2896       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
2897       iret = nf90_put_att(ncid, NF90_GLOBAL, "output_decimation_factor", decimation)
2898
2899       iret = nf90_enddef(ncid)
2900
2901 !!-- write latitude and longitude locations
2902 !       xdumd = LATVAL
2903         iret = nf90_inq_varid(ncid,"x", varid)
2904 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2905         iret = nf90_put_var(ncid, varid, xcoord_d, (/1/), (/ixrtd/)) !-- 1-d array
2906
2907 !       xdumd = LONVAL
2908         iret = nf90_inq_varid(ncid,"y", varid)
2909 !       iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2910         iret = nf90_put_var(ncid, varid, ycoord_d, (/1/), (/jxrtd/)) !-- 1-d array
2911
2912 #ifdef MPP_LAND
2913         xdumd = gLATVAL
2914 #else
2915         xdumd = LATVAL
2916 #endif
2917         iret = nf90_inq_varid(ncid,"LATITUDE", varid)
2918         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2919
2920 #ifdef MPP_LAND
2921         xdumd = gLONVAL
2922 #else
2923         xdumd = LONVAL
2924 #endif
2925         iret = nf90_inq_varid(ncid,"LONGITUDE", varid)
2926         iret = nf90_put_var(ncid, varid, xdumd, (/1,1/), (/ixrtd,jxrtd/))
2927
2928        do n = 1,nsoil
2929         if(n == 1) then
2930          asldpth(n) = -sldpth(n)
2931         else
2932          asldpth(n) = asldpth(n-1) - sldpth(n)
2933         endif
2934        enddo
2935
2936        iret = nf90_inq_varid(ncid,"depth", varid)
2937        iret = nf90_put_var(ncid, varid, asldpth, (/1/), (/nsoil/))
2938 !yw       iret = nf90_close(ncstatic)
2939
2940     endif
2941
2942     output_count = output_count + 1
2943
2944 !!-- time
2945         iret = nf90_inq_varid(ncid,"time", varid)
2946         iret = nf90_put_var(ncid, varid, seconds_since, (/output_count/))
2947
2948 !-- 3-d soils
2949      do n = 1, nsoil
2950 #ifdef MPP_LAND
2951         xdumd = gSMCRT(:,:,n)
2952 #else
2953         xdumd = SMCRT(:,:,n)
2954 #endif
2955 ! !DJG inv      jj = int(jxrt/decimation)
2956 !       jj = 1
2957 !       ii = 0
2958 ! !DJG inv      do j = jxrt,1,-decimation
2959 !        do j = 1,jxrt,decimation
2960 !        do i = 1,ixrt,decimation
2961 !         ii = ii + 1
2962 !         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
2963 !          xdumd(ii,jj) = smcrt(i,j,n)
2964 !         endif
2965 !       enddo
2966 !        ii = 0
2967 ! !DJG inv       jj = jj -1
2968 !        jj = jj + 1
2969 !      enddo
2970 !       where (vegtyp(:,:) == 16) xdum = -1.E33
2971           iret = nf90_inq_varid(ncid,  "SOIL_M", varid)
2972           iret = nf90_put_var(ncid, varid, xdumd, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/))
2973     enddo !-n soils
2974
2975 #ifdef MPP_LAND
2976         xdumd = gHead
2977 #else
2978         xdumd = head
2979 #endif
2980
2981      iret = nf90_inq_varid(ncid,  "HEAD", varid)
2982      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2983
2984 #ifdef MPP_LAND
2985         xdumd = gConvgw
2986 #else
2987         xdumd = convgw
2988 #endif
2989      iret = nf90_inq_varid(ncid,  "CONVGW", varid)
2990      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
2991
2992
2993 #ifdef MPP_LAND
2994         xdumd = gExcess
2995 #else
2996         xdumd = excess
2997 #endif
2998      iret = nf90_inq_varid(ncid,  "GwExcess", varid)
2999      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
3000
3001
3002 #ifdef MPP_LAND
3003         xdumd = gqsgwrt
3004 #else
3005         xdumd = qsgwrt
3006 #endif
3007
3008      iret = nf90_inq_varid(ncid,  "QSGWRT", varid)
3009      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
3010
3011 #ifdef MPP_LAND
3012         xdumd = gQgw_chanrt
3013 #else
3014         xdumd = qgw_chanrt
3015 #endif
3016
3017      iret = nf90_inq_varid(ncid,  "QGW_CHANRT", varid)
3018      iret = nf90_put_var(ncid, varid, xdumd, (/1,1,output_count/), (/ixrtd,jxrtd,1/))
3019
3020
3021 !!time in seconds since startdate
3022
3023      iret = nf90_redef(ncid)
3024      date19(1:len_trim(date)) = date
3025      iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
3026      iret = nf90_enddef(ncid)
3027      iret = nf90_sync(ncid)
3028      if (output_count == split_output_count) then
3029         output_count = 0
3030         iret = nf90_close(ncid)
3031      endif
3032
3033      if(allocated(xdumd)) deallocate(xdumd)
3034      if(allocated(xcoord_d)) deallocate(xcoord_d)
3035      if(allocated(xcoord)) deallocate(xcoord)
3036      if(allocated(ycoord_d)) deallocate(ycoord_d)
3037      if(allocated(ycoord)) deallocate(ycoord)
3038
3039 #ifdef HYDRO_D
3040      write(6,*) "end of output_ge"
3041 #endif
3042 #ifdef MPP_LAND
3043     endif
3044 #endif
3045
3046   end subroutine sub_output_gw
3047
3048 !NOte: output_chrt is the old version comparing to "output_chrt_bak".
3049
3050    subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER,             &
3051         startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
3052         STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, &
3053         lsmDt                                       &
3054 #ifdef WRF_HYDRO_NUDGING
3055         , nudge                                     &
3056 #endif
3057         , accSfcLatRunoff, accBucket                      &
3058         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff      &
3059         ,        UDMP_OPT                                 &
3060         )
3061
3062      implicit none
3063 !!output the routing variables over just channel
3064      integer,                                  intent(in) :: igrid,K,channel_option
3065      integer,                                  intent(in) :: split_output_count
3066      integer,                                  intent(in) :: NLINKS, NLINKSL
3067      real, dimension(:),                  intent(in) :: chlon,chlat
3068      real, dimension(:),                  intent(in) :: hlink,zelev
3069      integer, dimension(:),               intent(in) :: ORDER
3070      integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
3071      character(len=15), dimension(:),     intent(inout) :: gages
3072      character(len=15),                        intent(in) :: gageMiss
3073      real,                                     intent(in) :: lsmDt
3074
3075      real,                                     intent(in) :: dtrt_ch
3076      real, dimension(:,:),                intent(in) :: qlink
3077 #ifdef WRF_HYDRO_NUDGING
3078      real, dimension(:),                  intent(in) :: nudge
3079 #endif
3080
3081      integer, intent(in)  :: UDMP_OPT
3082
3083      character(len=*),                         intent(in) :: startdate
3084      character(len=*),                         intent(in) :: date
3085
3086      real, allocatable, DIMENSION(:)            :: chanlat,chanlon
3087      real, allocatable, DIMENSION(:)            :: chanlatO,chanlonO
3088
3089      real, allocatable, DIMENSION(:)            :: elevation
3090      real, allocatable, DIMENSION(:)            :: elevationO
3091
3092      integer, allocatable, DIMENSION(:)         :: station_id
3093      integer, allocatable, DIMENSION(:)         :: station_idO
3094
3095      integer, allocatable, DIMENSION(:)         :: rec_num_of_station
3096      integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
3097
3098      integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
3099      integer, allocatable, DIMENSION(:)         :: lOrderO !- local stream order
3100
3101      integer, save  :: output_count
3102      integer, save  :: ncid,ncid2
3103
3104      integer :: stationdim, dimdata, varid, charid, n
3105      integer :: obsdim, dimdataO, charidO
3106      integer :: timedim, timedim2
3107      character(len=34) :: sec_valid_date
3108
3109      integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output
3110      integer :: start_posO, prev_posO, nlk
3111
3112      integer :: previous_pos  !-- used for the station model
3113      character(len=256) :: output_flnm,output_flnm2
3114      character(len=19)  :: date19,date19start, hydroTime
3115      character(len=34)  :: sec_since_date
3116      integer :: seconds_since,nstations,cnt,ObsStation,nobs
3117      character(len=32)  :: convention
3118      character(len=11),allocatable, DIMENSION(:)  :: stname
3119      character(len=15),allocatable, DIMENSION(:)  :: stnameO
3120
3121     !--- all this for writing the station id string
3122      INTEGER   TDIMS, TXLEN
3123      PARAMETER (TDIMS=2)    ! number of TX dimensions
3124      PARAMETER (TXLEN = 11) ! length of example string
3125      INTEGER  TIMEID        ! record dimension id
3126      INTEGER  TXID          ! variable ID
3127      INTEGER  TXDIMS(TDIMS) ! variable shape
3128      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
3129
3130      !--  observation point  ids
3131      INTEGER   OTDIMS, OTXLEN
3132      PARAMETER (OTDIMS=2)    ! number of TX dimensions
3133      PARAMETER (OTXLEN = 15) ! length of example string
3134      INTEGER  OTIMEID        ! record dimension id
3135      INTEGER  OTXID          ! variable ID
3136      INTEGER  OTXDIMS(OTDIMS) ! variable shape
3137      INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
3138
3139      real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket
3140      real,   dimension(:), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
3141
3142      !! currently, this is the time of the hydro model, it's
3143      !! lsm time (olddate) plus one lsm timestep
3144      !call geth_newdate(hydroTime, date, nint(lsmDt))
3145      hydroTime=date
3146
3147      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
3148      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
3149                    //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
3150
3151 !    order_to_write = 2  !-- 1 all; 6 fewest
3152       nstations = 0  ! total number of channel points to display
3153       nobs      = 0  ! number of observation points
3154
3155      if(channel_option .ne. 3) then
3156         nlk = NLINKSL
3157      else
3158         nlk = NLINKS
3159      endif
3160
3161
3162 !-- output only the higher oder streamflows  and only observation points
3163      do i=1,nlk
3164         if(ORDER(i) .ge. order_to_write) nstations = nstations + 1
3165         if(channel_option .ne. 3) then
3166            if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1
3167         else
3168            if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1
3169         endif
3170      enddo
3171
3172      if (nobs .eq. 0) then ! let's at least make one obs point
3173         nobs = 1
3174         if(channel_option .ne. 3) then
3175            !           123456789012345
3176            gages(1) = '          dummy'
3177         else
3178            STRMFRXSTPTS(1) = 1
3179         endif
3180      endif
3181
3182        allocate(chanlat(nstations))
3183        allocate(chanlon(nstations))
3184        allocate(elevation(nstations))
3185        allocate(lOrder(nstations))
3186        allocate(stname(nstations))
3187        allocate(station_id(nstations))
3188        allocate(rec_num_of_station(nstations))
3189
3190        allocate(chanlatO(nobs))
3191        allocate(chanlonO(nobs))
3192        allocate(elevationO(nobs))
3193        allocate(lOrderO(nobs))
3194        allocate(stnameO(nobs))
3195        allocate(station_idO(nobs))
3196        allocate(rec_num_of_stationO(nobs))
3197
3198        if(output_count == 0) then
3199 !-- have moved sec_since_date from above here..
3200         sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
3201                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
3202
3203         date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
3204                   //startdate(12:13)//':'//startdate(15:16)//':00'
3205
3206         nstations = 0
3207         nobs = 0
3208
3209         write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3210         write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3211
3212 #ifdef HYDRO_D
3213         print*, 'output_flnm = "'//trim(output_flnm)//'"'
3214 #endif
3215
3216         iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
3217         if (iret /= 0) then
3218            call hydro_stop("In output_chrt() - Problem nf90_create points")
3219         endif
3220
3221         iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2)
3222         if (iret /= 0) then
3223            call hydro_stop("In output_chrt() - Problem nf90_create observation")
3224         endif
3225
3226        do i=1,nlk
3227         if(ORDER(i) .ge. order_to_write) then
3228          nstations = nstations + 1
3229          chanlat(nstations) = chlat(i)
3230          chanlon(nstations) = chlon(i)
3231          elevation(nstations) = zelev(i)
3232          lOrder(nstations) = ORDER(i)
3233          station_id(nstations) = i
3234          if(STRMFRXSTPTS(nstations) .eq. -9999) then
3235            ObsStation = 0
3236          else
3237            ObsStation = 1
3238          endif
3239          write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation
3240         endif
3241        enddo
3242
3243
3244        do i=1,nlk
3245           if(channel_option .ne. 3) then
3246              if(trim(gages(i)) .ne. trim(gageMiss)) then
3247                 nobs = nobs + 1
3248                 chanlatO(nobs) = chlat(i)
3249                 chanlonO(nobs) = chlon(i)
3250                 elevationO(nobs) = zelev(i)
3251                 lOrderO(nobs) = ORDER(i)
3252                 station_idO(nobs) = i
3253                 stnameO(nobs) = gages(i)
3254              endif
3255           else
3256              if(STRMFRXSTPTS(i) .ne. -9999) then
3257                 nobs = nobs + 1
3258                 chanlatO(nobs) = chlat(i)
3259                 chanlonO(nobs) = chlon(i)
3260                 elevationO(nobs) = zelev(i)
3261                 lOrderO(nobs) = ORDER(i)
3262                 station_idO(nobs) = i
3263                 write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs)
3264 #ifdef HYDRO_D
3265                 !        print *,"stationobservation name",  stnameO(nobs)
3266 #endif
3267              endif
3268           endif
3269        enddo
3270
3271        iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata)  !--for linked list approach
3272        iret = nf90_def_dim(ncid, "station", nstations, stationdim)
3273        iret = nf90_def_dim(ncid, "time", 1, timedim)
3274
3275
3276        iret = nf90_def_dim(ncid2, "recNum", NF90_UNLIMITED, dimdataO)  !--for linked list approach
3277        iret = nf90_def_dim(ncid2, "station", nobs, obsdim)
3278        iret = nf90_def_dim(ncid2, "time", 1, timedim2)
3279
3280       !- station location definition all,  lat
3281         iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
3282 #ifdef HYDRO_D
3283        write(6,*) "iret 2.1,  ", iret, stationdim
3284 #endif
3285         iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude')
3286 #ifdef HYDRO_D
3287        write(6,*) "iret 2.2", iret
3288 #endif
3289         iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
3290 #ifdef HYDRO_D
3291        write(6,*) "iret 2.3", iret
3292 #endif
3293
3294
3295       !- station location definition obs,  lat
3296         iret = nf90_def_var(ncid2, "latitude", NF90_FLOAT, (/obsdim/), varid)
3297         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation latitude')
3298         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_north')
3299
3300
3301       !- station location definition,  long
3302         iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
3303         iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude')
3304         iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
3305
3306
3307       !- station location definition, obs long
3308         iret = nf90_def_var(ncid2, "longitude", NF90_FLOAT, (/obsdim/), varid)
3309         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation longitude')
3310         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_east')
3311
3312
3313 !     !-- elevation is ZELEV
3314         iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
3315         iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude')
3316         iret = nf90_put_att(ncid, varid, 'units', 'meters')
3317
3318
3319 !     !-- elevation is obs ZELEV
3320         iret = nf90_def_var(ncid2, "altitude", NF90_FLOAT, (/obsdim/), varid)
3321         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation altitude')
3322         iret = nf90_put_att(ncid2, varid, 'units', 'meters')
3323
3324
3325 !     !--  gage observation
3326 !       iret = nf90_def_var(ncid, "gages", NF90_FLOAT, (/stationdim/), varid)
3327 !       iret = nf90_put_att(ncid, varid, 'long_name', 'Stream Gage Location')
3328 !       iret = nf90_put_att(ncid, varid, 'units', 'none')
3329
3330 !-- parent index
3331         iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid)
3332         iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record')
3333
3334         iret = nf90_def_var(ncid2, "parent_index", NF90_INT, (/dimdataO/), varid)
3335         iret = nf90_put_att(ncid2, varid, 'long_name', 'index of the station for this record')
3336
3337      !-- prevChild
3338         iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid)
3339         iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station')
3340 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3341         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3342
3343         iret = nf90_def_var(ncid2, "prevChild", NF90_INT, (/dimdataO/), varid)
3344         iret = nf90_put_att(ncid2, varid, 'long_name', 'record number of the previous record for the same station')
3345 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3346         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3347
3348      !-- lastChild
3349         iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
3350         iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station')
3351 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3352         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3353
3354         iret = nf90_def_var(ncid2, "lastChild", NF90_INT, (/obsdim/), varid)
3355         iret = nf90_put_att(ncid2, varid, 'long_name', 'latest report for this station')
3356 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3357         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
3358
3359 !     !- flow definition, var
3360
3361         if(UDMP_OPT .eq. 1) then
3362
3363            !! FLUXES to channel
3364            if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
3365               nlst(did)%output_channelBucket_influx .eq. 2      ) then
3366               iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/dimdata/), varid)
3367               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
3368               if(nlst(did)%OVRTSWCRT .eq. 1) then              !123456789112345678921234567
3369                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing')
3370               else
3371                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff')
3372               end if
3373               iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/dimdata/), varid)
3374               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
3375               iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket')
3376            end if
3377
3378            !! Bucket influx
3379            if(nlst(did)%output_channelBucket_influx .eq. 2) then
3380               iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/dimdata/), varid)
3381               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
3382               iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket')
3383            end if
3384
3385            !! ACCUMULATIONS
3386            if(nlst(did)%output_channelBucket_influx .eq. 3) then
3387                  iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimdata/), varid)
3388                  iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
3389                  if(nlst(did)%OVRTSWCRT .eq. 1) then
3390                     iret = nf90_put_att(ncid,varid,'long_name',&
3391                                            'ACCUMULATED runoff from terrain routing')
3392                  else
3393                     iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land')
3394                  end if
3395               iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimdata/), varid)
3396               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
3397               iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from gw bucket')
3398            endif
3399         endif
3400
3401         iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/dimdata/), varid)
3402         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
3403         iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow')
3404
3405         iret = nf90_def_var(ncid2, "streamflow", NF90_FLOAT, (/dimdataO/), varid)
3406         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
3407         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Flow')
3408
3409 #ifdef WRF_HYDRO_NUDGING
3410         iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/dimdata/), varid)
3411         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
3412         iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration')
3413
3414         iret = nf90_def_var(ncid2, "nudge", NF90_FLOAT, (/dimdataO/), varid)
3415         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
3416         iret = nf90_put_att(ncid2, varid, 'long_name', 'Amount of stream flow alteration')
3417 #endif
3418
3419 !     !- flow definition, var
3420 !       iret = nf90_def_var(ncid, "pos_streamflow", NF90_FLOAT, (/dimdata/), varid)
3421 !       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
3422 !       iret = nf90_put_att(ncid, varid, 'long_name', 'abs streamflow')
3423
3424 !     !- head definition, var
3425         iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/dimdata/), varid)
3426         iret = nf90_put_att(ncid, varid, 'units', 'meter')
3427         iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
3428
3429         iret = nf90_def_var(ncid2, "head", NF90_FLOAT, (/dimdataO/), varid)
3430         iret = nf90_put_att(ncid2, varid, 'units', 'meter')
3431         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Stage')
3432
3433 !     !- order definition, var
3434         iret = nf90_def_var(ncid, "order", NF90_INT, (/dimdata/), varid)
3435         iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order')
3436         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3437
3438         iret = nf90_def_var(ncid2, "order", NF90_INT, (/dimdataO/), varid)
3439         iret = nf90_put_att(ncid2, varid, 'long_name', 'Strahler Stream Order')
3440         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
3441
3442      !-- station  id
3443      ! define character-position dimension for strings of max length 11
3444          iret = NF90_DEF_DIM(ncid, "id_len", 11, charid)
3445          TXDIMS(1) = charid   ! define char-string variable and position dimension first
3446          TXDIMS(2) = stationdim
3447          iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid)
3448          iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
3449
3450
3451          iret = NF90_DEF_DIM(ncid2, "id_len", 15, charidO)
3452          OTXDIMS(1) = charidO   ! define char-string variable and position dimension first
3453          OTXDIMS(2) = obsdim
3454          iret = nf90_def_var(ncid2, "station_id", NF90_CHAR, OTXDIMS, varid)
3455          iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation id')
3456
3457
3458 !     !- time definition, timeObs
3459          iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
3460          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
3461          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
3462
3463          iret = nf90_def_var(ncid2, "time", NF90_INT, (/timedim2/), varid)
3464          iret = nf90_put_att(ncid2, varid, 'units', sec_valid_date)
3465          iret = nf90_put_att(ncid2, varid, 'long_name', 'valid output time')
3466
3467          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
3468          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
3469
3470          convention(1:32) = "Unidata Observation Dataset v1.0"
3471          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
3472          iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
3473
3474          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
3475          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
3476          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
3477          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
3478
3479          iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
3480          iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
3481          iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
3482          iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", order_to_write)
3483
3484          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
3485          iret = nf90_put_att(ncid2, NF90_GLOBAL, "cdm_datatype", "Station")
3486
3487          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_max", "90.0")
3488          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
3489          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_max", "180.0")
3490          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
3491
3492          iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
3493          iret = nf90_put_att(ncid2, NF90_GLOBAL, "station_dimension", "station")
3494          iret = nf90_put_att(ncid2, NF90_GLOBAL, "missing_value", -9E15)
3495          iret = nf90_put_att(ncid2, NF90_GLOBAL, "stream_order_output", order_to_write)
3496
3497          iret = nf90_enddef(ncid)
3498          iret = nf90_enddef(ncid2)
3499
3500         !-- write latitudes
3501          iret = nf90_inq_varid(ncid,"latitude", varid)
3502          iret = nf90_put_var(ncid, varid, chanlat, (/1/), (/nstations/))
3503
3504          iret = nf90_inq_varid(ncid2,"latitude", varid)
3505          iret = nf90_put_var(ncid2, varid, chanlatO, (/1/), (/nobs/))
3506
3507         !-- write longitudes
3508          iret = nf90_inq_varid(ncid,"longitude", varid)
3509          iret = nf90_put_var(ncid, varid, chanlon, (/1/), (/nstations/))
3510
3511          iret = nf90_inq_varid(ncid2,"longitude", varid)
3512          iret = nf90_put_var(ncid2, varid, chanlonO, (/1/), (/nobs/))
3513
3514         !-- write elevations
3515          iret = nf90_inq_varid(ncid,"altitude", varid)
3516          iret = nf90_put_var(ncid, varid, elevation, (/1/), (/nstations/))
3517
3518          iret = nf90_inq_varid(ncid2,"altitude", varid)
3519          iret = nf90_put_var(ncid2, varid, elevationO, (/1/), (/nobs/))
3520
3521       !-- write gage location
3522 !      iret = nf90_inq_varid(ncid,"gages", varid)
3523 !      iret = nf90_put_var(ncid, varid, STRMFRXSTPTS, (/1/), (/nstations/))
3524
3525         !-- write number_of_stations, OPTIONAL
3526       !!  iret = nf90_inq_varid(ncid,"number_stations", varid)
3527       !!  iret = nf90_put_var_int(ncid, varid, nstations)
3528
3529         !-- write station id's
3530          do i=1,nstations
3531           TSTART(1) = 1
3532           TSTART(2) = i
3533           TCOUNT(1) = TXLEN
3534           TCOUNT(2) = 1
3535           iret = nf90_inq_varid(ncid,"station_id", varid)
3536           iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT)
3537          enddo
3538
3539         !-- write observation id's
3540          do i=1, nobs
3541           OTSTART(1) = 1
3542           OTSTART(2) = i
3543           OTCOUNT(1) = OTXLEN
3544           OTCOUNT(2) = 1
3545           iret = nf90_inq_varid(ncid2,"station_id", varid)
3546           iret = nf90_put_var(ncid2, varid, stnameO(i), OTSTART, OTCOUNT)
3547          enddo
3548
3549      endif
3550
3551      output_count = output_count + 1
3552
3553      open (unit=55, &
3554 #ifndef NCEP_WCOSS
3555      file='frxst_pts_out.txt', &
3556 #endif
3557      status='unknown',position='append')
3558
3559      cnt=0
3560      do i=1,nlk
3561
3562        if(ORDER(i) .ge. order_to_write) then
3563          start_pos = (cnt+1)+(nstations*(output_count-1))
3564
3565          !!--time in seconds since startdate
3566           iret = nf90_inq_varid(ncid,"time", varid)
3567           iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
3568
3569          if(UDMP_OPT .eq. 1) then
3570             !! FLUXES to channel
3571              if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
3572                 nlst(did)%output_channelBucket_influx .eq. 2      ) then
3573                 iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid)
3574                 iret = nf90_put_var(ncid, varid, qSfcLatRunoff(i), (/start_pos/))
3575
3576                 iret = nf90_inq_varid(ncid,"qBucket", varid)
3577                 iret = nf90_put_var(ncid, varid, qBucket(i), (/start_pos/))
3578              end if
3579
3580              !! FLUXES to bucket
3581              if(nlst(did)%output_channelBucket_influx .eq. 2) then
3582                 iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid)
3583                 iret = nf90_put_var(ncid, varid, qBtmVertRunoff(i), (/start_pos/))
3584              end if
3585
3586             !! ACCUMULATIONS
3587              if(nlst(did)%output_channelBucket_influx .eq. 3) then
3588                 iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid)
3589                 iret = nf90_put_var(ncid, varid, accSfcLatRunoff(i), (/start_pos/))
3590
3591                 iret = nf90_inq_varid(ncid,"accBucket", varid)
3592                 iret = nf90_put_var(ncid, varid, accBucket(i), (/start_pos/))
3593              end if
3594           endif
3595
3596          iret = nf90_inq_varid(ncid,"streamflow", varid)
3597          iret = nf90_put_var(ncid, varid, qlink(i,1), (/start_pos/))
3598
3599 #ifdef WRF_HYDRO_NUDGING
3600          iret = nf90_inq_varid(ncid,"nudge", varid)
3601          iret = nf90_put_var(ncid, varid, nudge(i), (/start_pos/))
3602 #endif
3603
3604 !        iret = nf90_inq_varid(ncid,"pos_streamflow", varid)
3605 !        iret = nf90_put_var(ncid, varid, abs(qlink(i,1), (/start_pos/)))
3606
3607          iret = nf90_inq_varid(ncid,"head", varid)
3608          iret = nf90_put_var(ncid, varid, hlink(i), (/start_pos/))
3609
3610          iret = nf90_inq_varid(ncid,"order", varid)
3611          iret = nf90_put_var(ncid, varid, ORDER(i), (/start_pos/))
3612
3613          !-- station index.. will repeat for every timesstep
3614          iret = nf90_inq_varid(ncid,"parent_index", varid)
3615          iret = nf90_put_var(ncid, varid, cnt, (/start_pos/))
3616
3617           !--record number of previous record for same station
3618 !obsolete format         prev_pos = cnt+(nstations*(output_count-1))
3619          prev_pos = cnt+(nobs*(output_count-2))
3620          if(output_count.ne.1) then !-- only write next set of records
3621            iret = nf90_inq_varid(ncid,"prevChild", varid)
3622            iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/))
3623          endif
3624          cnt=cnt+1  !--indices are 0 based
3625          rec_num_of_station(cnt) = start_pos-1  !-- save position for last child, 0-based!!
3626
3627
3628        endif
3629     enddo
3630 !    close(999)
3631
3632     !-- output  only observation points
3633     cnt=0
3634     do i=1,nlk
3635        if(channel_option .ne. 3) then
3636           ! jlm this verry repetitiuos, oh well.
3637           if(trim(gages(i)) .ne. trim(gageMiss)) then
3638
3639              start_posO = (cnt+1)+(nobs * (output_count-1))
3640              !Write frxst_pts to text file...
3641              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
3642 118          FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
3643              !write(55,118) seconds_since, date(1:10), date(12:19), &
3644
3645              write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), &
3646                   gages(i), chlon(i), chlat(i),                               &
3647                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
3648
3649              !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
3650              !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)
3651
3652              !!--time in seconds since startdate
3653              iret = nf90_inq_varid(ncid2,"time", varid)
3654              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
3655
3656              iret = nf90_inq_varid(ncid2,"streamflow", varid)
3657              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
3658
3659 #ifdef WRF_HYDRO_NUDGING
3660              iret = nf90_inq_varid(ncid2,"nudge", varid)
3661              iret = nf90_put_var(ncid2, varid, nudge(i), (/start_posO/))
3662 #endif
3663
3664              iret = nf90_inq_varid(ncid2,"head", varid)
3665              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
3666
3667              iret = nf90_inq_varid(ncid,"order", varid)
3668              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
3669
3670              !-- station index.. will repeat for every timesstep
3671              iret = nf90_inq_varid(ncid2,"parent_index", varid)
3672              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
3673
3674              !--record number of previous record for same station
3675              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
3676              prev_posO = cnt+(nobs*(output_count-2))
3677              if(output_count.ne.1) then !-- only write next set of records
3678                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
3679                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3680
3681                 !IF block to add -1 to last element of prevChild array to designate end of list...
3682                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
3683                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
3684                 !           else
3685                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3686                 !           endif
3687
3688              endif
3689              cnt=cnt+1  !--indices are 0 based
3690              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
3691           endif
3692
3693
3694        else !! channel options 3 below
3695
3696           if(STRMFRXSTPTS(i) .ne. -9999) then
3697              start_posO = (cnt+1)+(nobs * (output_count-1))
3698              !Write frxst_pts to text file...
3699              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
3700 117          FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
3701              !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), &
3702              !     qlink(i,1), qlink(i,1)*35.315,hlink(i)
3703              ! JLM: makes more sense to output the value in frxstpts incase they have meaning,
3704              ! as below, but I'm not going to make this change until I'm working with gridded
3705              ! streamflow again.
3706              write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), &
3707                   strmfrxstpts(i), chlon(i), chlat(i),                        &
3708                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
3709
3710              !!--time in seconds since startdate
3711              iret = nf90_inq_varid(ncid2,"time", varid)
3712              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
3713
3714              iret = nf90_inq_varid(ncid2,"streamflow", varid)
3715              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
3716
3717              iret = nf90_inq_varid(ncid2,"head", varid)
3718              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
3719
3720              iret = nf90_inq_varid(ncid,"order", varid)
3721              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
3722
3723              !-- station index.. will repeat for every timesstep
3724              iret = nf90_inq_varid(ncid2,"parent_index", varid)
3725              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
3726
3727              !--record number of previous record for same station
3728              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
3729              prev_posO = cnt+(nobs*(output_count-2))
3730              if(output_count.ne.1) then !-- only write next set of records
3731                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
3732                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3733
3734                 !IF block to add -1 to last element of prevChild array to designate end of list...
3735                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
3736                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
3737                 !           else
3738                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
3739                 !           endif
3740
3741              endif
3742              cnt=cnt+1  !--indices are 0 based
3743              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
3744           endif
3745
3746        endif
3747
3748     enddo
3749     close(55)
3750
3751       !-- lastChild variable gives the record number of the most recent report for the station
3752       iret = nf90_inq_varid(ncid,"lastChild", varid)
3753       iret = nf90_put_var(ncid, varid, rec_num_of_station, (/1/), (/nstations/))
3754
3755       !-- lastChild variable gives the record number of the most recent report for the station
3756       iret = nf90_inq_varid(ncid2,"lastChild", varid)
3757       iret = nf90_put_var(ncid2, varid, rec_num_of_stationO, (/1/), (/nobs/))
3758
3759       iret = nf90_redef(ncid)
3760       date19(1:19) = "0000-00-00_00:00:00"
3761       date19(1:len_trim(date)) = date
3762       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
3763
3764       iret = nf90_redef(ncid2)
3765       iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
3766
3767       iret = nf90_enddef(ncid)
3768       iret = nf90_sync(ncid)
3769
3770       iret = nf90_enddef(ncid2)
3771       iret = nf90_sync(ncid2)
3772
3773       if (output_count == split_output_count) then
3774         output_count = 0
3775         iret = nf90_close(ncid)
3776         iret = nf90_close(ncid2)
3777      endif
3778
3779      deallocate(chanlat)
3780      deallocate(chanlon)
3781      deallocate(elevation)
3782      deallocate(station_id)
3783      deallocate(lOrder)
3784      deallocate(rec_num_of_station)
3785      deallocate(stname)
3786
3787      deallocate(chanlatO)
3788      deallocate(chanlonO)
3789      deallocate(elevationO)
3790      deallocate(station_idO)
3791      deallocate(lOrderO)
3792      deallocate(rec_num_of_stationO)
3793      deallocate(stnameO)
3794 #ifdef HYDRO_D
3795      print *, "Exited Subroutine output_chrt"
3796 #endif
3797      close(16)
3798
3799 20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3)
3800
3801 end subroutine output_chrt
3802 !-- output the channel route in an IDV 'station' compatible format
3803 !Note: This version has pool output performance need to be
3804 !solved. We renamed it from output_chrt to be output_chrt_bak.
3805    subroutine output_chrt_bak(igrid, split_output_count, NLINKS, ORDER,             &
3806         startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
3807         STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, &
3808         lsmDt                                       &
3809 #ifdef WRF_HYDRO_NUDGING
3810         , nudge                                     &
3811 #endif
3812         , accSfcLatRunoff, accBucket                      &
3813         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff      &
3814         ,        UDMP_OPT                                 &
3815         )
3816
3817      implicit none
3818 !!output the routing variables over just channel
3819      integer,                                  intent(in) :: igrid,K,channel_option
3820      integer,                                  intent(in) :: split_output_count
3821      integer,                                  intent(in) :: NLINKS, NLINKSL
3822      real, dimension(:),                  intent(in) :: chlon,chlat
3823      real, dimension(:),                  intent(in) :: hlink,zelev
3824      integer, dimension(:),               intent(in) :: ORDER
3825      integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
3826      character(len=15), dimension(:),     intent(inout) :: gages
3827      character(len=15),                        intent(in) :: gageMiss
3828      real,                                     intent(in) :: lsmDt
3829
3830      real,                                     intent(in) :: dtrt_ch
3831      real, dimension(:,:),                intent(in) :: qlink
3832 #ifdef WRF_HYDRO_NUDGING
3833      real, dimension(:),                  intent(in) :: nudge
3834 #endif
3835
3836      integer, intent(in)  :: UDMP_OPT
3837
3838      character(len=*),                         intent(in) :: startdate
3839      character(len=*),                         intent(in) :: date
3840
3841      real, allocatable, DIMENSION(:)            :: chanlat,chanlon
3842      real, allocatable, DIMENSION(:)            :: chanlatO,chanlonO
3843
3844      real, allocatable, DIMENSION(:)            :: elevation
3845      real, allocatable, DIMENSION(:)            :: elevationO
3846
3847      integer, allocatable, DIMENSION(:)         :: station_id
3848      integer, allocatable, DIMENSION(:)         :: station_idO
3849
3850      integer, allocatable, DIMENSION(:)         :: rec_num_of_station
3851      integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
3852
3853      integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
3854      integer, allocatable, DIMENSION(:)         :: lOrderO !- local stream order
3855
3856      integer, save  :: output_count
3857      integer, save  :: ncid,ncid2
3858
3859      integer :: stationdim, dimdata, varid, charid, n
3860      integer :: obsdim, dimdataO, charidO
3861      integer :: timedim, timedim2
3862      character(len=34) :: sec_valid_date
3863
3864      integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output
3865      integer :: start_posO, prev_posO, nlk
3866
3867      integer :: previous_pos  !-- used for the station model
3868      character(len=256) :: output_flnm,output_flnm2
3869      character(len=19)  :: date19,date19start, hydroTime
3870      character(len=34)  :: sec_since_date
3871      integer :: seconds_since,nstations,cnt,ObsStation,nobs
3872      character(len=32)  :: convention
3873      character(len=11),allocatable, DIMENSION(:)  :: stname
3874      character(len=15),allocatable, DIMENSION(:)  :: stnameO
3875
3876     !--- all this for writing the station id string
3877      INTEGER   TDIMS, TXLEN
3878      PARAMETER (TDIMS=2)    ! number of TX dimensions
3879      PARAMETER (TXLEN = 11) ! length of example string
3880      INTEGER  TIMEID        ! record dimension id
3881      INTEGER  TXID          ! variable ID
3882      INTEGER  TXDIMS(TDIMS) ! variable shape
3883      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
3884
3885      !--  observation point  ids
3886      INTEGER   OTDIMS, OTXLEN
3887      PARAMETER (OTDIMS=2)    ! number of TX dimensions
3888      PARAMETER (OTXLEN = 15) ! length of example string
3889      INTEGER  OTIMEID        ! record dimension id
3890      INTEGER  OTXID          ! variable ID
3891      INTEGER  OTXDIMS(OTDIMS) ! variable shape
3892      INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
3893
3894      real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket
3895      real,   dimension(:), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
3896
3897      !! currently, this is the time of the hydro model, it's
3898      !! lsm time (olddate) plus one lsm timestep
3899      !call geth_newdate(hydroTime, date, nint(lsmDt))
3900      hydroTime=date
3901
3902      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
3903      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
3904                    //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
3905
3906 !    order_to_write = 2  !-- 1 all; 6 fewest
3907       nstations = 0  ! total number of channel points to display
3908       nobs      = 0  ! number of observation points
3909
3910      if(channel_option .ne. 3) then
3911         nlk = NLINKSL
3912      else
3913         nlk = NLINKS
3914      endif
3915
3916
3917 !-- output only the higher oder streamflows  and only observation points
3918      do i=1,nlk
3919         if(ORDER(i) .ge. order_to_write) nstations = nstations + 1
3920         if(channel_option .ne. 3) then
3921            if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1
3922         else
3923            if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1
3924         endif
3925      enddo
3926
3927      if (nobs .eq. 0) then ! let's at least make one obs point
3928         nobs = 1
3929         if(channel_option .ne. 3) then
3930            !           123456789012345
3931            gages(1) = '          dummy'
3932         else
3933            STRMFRXSTPTS(1) = 1
3934         endif
3935      endif
3936
3937        allocate(chanlat(nstations))
3938        allocate(chanlon(nstations))
3939        allocate(elevation(nstations))
3940        allocate(lOrder(nstations))
3941        allocate(stname(nstations))
3942        allocate(station_id(nstations))
3943        allocate(rec_num_of_station(nstations))
3944
3945        allocate(chanlatO(nobs))
3946        allocate(chanlonO(nobs))
3947        allocate(elevationO(nobs))
3948        allocate(lOrderO(nobs))
3949        allocate(stnameO(nobs))
3950        allocate(station_idO(nobs))
3951        allocate(rec_num_of_stationO(nobs))
3952
3953        if(output_count == 0) then
3954 !-- have moved sec_since_date from above here..
3955         sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
3956                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
3957
3958         date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
3959                   //startdate(12:13)//':'//startdate(15:16)//':00'
3960
3961         nstations = 0
3962         nobs = 0
3963
3964         write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3965         write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
3966
3967 #ifdef HYDRO_D
3968         print*, 'output_flnm = "'//trim(output_flnm)//'"'
3969 #endif
3970
3971        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
3972        if (iret /= 0) then
3973            call hydro_stop("In output_chrt() - Problem nf90_create points")
3974        endif
3975
3976        iret = nf90_create(trim(output_flnm2), OR(NF90_CLOBBER, NF90_NETCDF4), ncid2)
3977        if (iret /= 0) then
3978            call hydro_stop("In output_chrt() - Problem nf90_create observation")
3979        endif
3980
3981        do i=1,nlk
3982         if(ORDER(i) .ge. order_to_write) then
3983          nstations = nstations + 1
3984          chanlat(nstations) = chlat(i)
3985          chanlon(nstations) = chlon(i)
3986          elevation(nstations) = zelev(i)
3987          lOrder(nstations) = ORDER(i)
3988          station_id(nstations) = i
3989          if(STRMFRXSTPTS(nstations) .eq. -9999) then
3990            ObsStation = 0
3991          else
3992            ObsStation = 1
3993          endif
3994          write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation
3995         endif
3996        enddo
3997
3998
3999        do i=1,nlk
4000           if(channel_option .ne. 3) then
4001              if(trim(gages(i)) .ne. trim(gageMiss)) then
4002                 nobs = nobs + 1
4003                 chanlatO(nobs) = chlat(i)
4004                 chanlonO(nobs) = chlon(i)
4005                 elevationO(nobs) = zelev(i)
4006                 lOrderO(nobs) = ORDER(i)
4007                 station_idO(nobs) = i
4008                 stnameO(nobs) = gages(i)
4009              endif
4010           else
4011              if(STRMFRXSTPTS(i) .ne. -9999) then
4012                 nobs = nobs + 1
4013                 chanlatO(nobs) = chlat(i)
4014                 chanlonO(nobs) = chlon(i)
4015                 elevationO(nobs) = zelev(i)
4016                 lOrderO(nobs) = ORDER(i)
4017                 station_idO(nobs) = i
4018                 write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs)
4019 #ifdef HYDRO_D
4020                 !        print *,"stationobservation name",  stnameO(nobs)
4021 #endif
4022              endif
4023           endif
4024        enddo
4025
4026        iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata)  !--for linked list approach
4027        iret = nf90_def_dim(ncid, "station", nstations, stationdim)
4028        iret = nf90_def_dim(ncid, "time", 1, timedim)
4029
4030
4031        iret = nf90_def_dim(ncid2, "recNum", NF90_UNLIMITED, dimdataO)  !--for linked list approach
4032        iret = nf90_def_dim(ncid2, "station", nobs, obsdim)
4033        iret = nf90_def_dim(ncid2, "time", 1, timedim2)
4034
4035       !- station location definition all,  lat
4036         iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
4037         iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude')
4038         iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
4039
4040       !- station location definition obs,  lat
4041         iret = nf90_def_var(ncid2, "latitude", NF90_FLOAT, (/obsdim/), varid)
4042         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation latitude')
4043         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_north')
4044
4045
4046       !- station location definition,  long
4047         iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
4048         iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude')
4049         iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
4050
4051
4052       !- station location definition, obs long
4053         iret = nf90_def_var(ncid2, "longitude", NF90_FLOAT, (/obsdim/), varid)
4054         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation longitude')
4055         iret = nf90_put_att(ncid2, varid, 'units', 'degrees_east')
4056
4057
4058 !     !-- elevation is ZELEV
4059         iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
4060         iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude')
4061         iret = nf90_put_att(ncid, varid, 'units', 'meters')
4062
4063
4064 !     !-- elevation is obs ZELEV
4065         iret = nf90_def_var(ncid2, "altitude", NF90_FLOAT, (/obsdim/), varid)
4066         iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation altitude')
4067         iret = nf90_put_att(ncid2, varid, 'units', 'meters')
4068
4069
4070 !     !--  gage observation
4071 !       iret = nf90_def_var(ncid, "gages", NF90_FLOAT, (/stationdim/), varid)
4072 !       iret = nf90_put_att(ncid, varid, 'long_name', 'Stream Gage Location')
4073 !       iret = nf90_put_att(ncid, varid, 'units', 'none')
4074
4075 !-- parent index
4076         iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid)
4077         iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record')
4078
4079         iret = nf90_def_var(ncid2, "parent_index", NF90_INT, (/dimdataO/), varid)
4080         iret = nf90_put_att(ncid2, varid, 'long_name', 'index of the station for this record')
4081
4082      !-- prevChild
4083         iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid)
4084         iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station')
4085 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4086         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4087
4088         iret = nf90_def_var(ncid2, "prevChild", NF90_INT, (/dimdataO/), varid)
4089         iret = nf90_put_att(ncid2, varid, 'long_name', 'record number of the previous record for the same station')
4090 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4091         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4092
4093      !-- lastChild
4094         iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
4095         iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station')
4096 !ywtmp        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4097         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4098
4099         iret = nf90_def_var(ncid2, "lastChild", NF90_INT, (/obsdim/), varid)
4100         iret = nf90_put_att(ncid2, varid, 'long_name', 'latest report for this station')
4101 !ywtmp        iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4102         iret = nf90_put_att(ncid2, varid, '_FillValue', -1)
4103
4104 !     !- flow definition, var
4105
4106         if(UDMP_OPT .eq. 1) then
4107
4108            !! FLUXES to channel
4109            if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4110               nlst(did)%output_channelBucket_influx .eq. 2      ) then
4111               iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/dimdata/), varid)
4112               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
4113               if(nlst(did)%OVRTSWCRT .eq. 1) then              !123456789112345678921234567
4114                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing')
4115               else
4116                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff')
4117               end if
4118               iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/dimdata/), varid)
4119               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
4120               iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket')
4121            end if
4122
4123            !! Bucket influx
4124            if(nlst(did)%output_channelBucket_influx .eq. 2) then
4125               iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/dimdata/), varid)
4126               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
4127               iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket')
4128            end if
4129
4130            !! ACCUMULATIONS
4131            if(nlst(did)%output_channelBucket_influx .eq. 3) then
4132                  iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimdata/), varid)
4133                  iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
4134                  if(nlst(did)%OVRTSWCRT .eq. 1) then
4135                     iret = nf90_put_att(ncid,varid,'long_name', &
4136                                            'ACCUMULATED runoff from terrain routing')
4137                  else
4138                     iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land')
4139                  end if
4140               iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimdata/), varid)
4141               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
4142               iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from gw bucket')
4143            endif
4144         endif
4145
4146         iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/dimdata/), varid)
4147         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4148         iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow')
4149
4150         iret = nf90_def_var(ncid2, "streamflow", NF90_FLOAT, (/dimdataO/), varid)
4151         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
4152         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Flow')
4153
4154 #ifdef WRF_HYDRO_NUDGING
4155         iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/dimdata/), varid)
4156         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4157         iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration')
4158
4159         iret = nf90_def_var(ncid2, "nudge", NF90_FLOAT, (/dimdataO/), varid)
4160         iret = nf90_put_att(ncid2, varid, 'units', 'meter^3 / sec')
4161         iret = nf90_put_att(ncid2, varid, 'long_name', 'Amount of stream flow alteration')
4162 #endif
4163
4164 !     !- flow definition, var
4165 !       iret = nf90_def_var(ncid, "pos_streamflow", NF90_FLOAT, (/dimdata/), varid)
4166 !       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4167 !       iret = nf90_put_att(ncid, varid, 'long_name', 'abs streamflow')
4168
4169 !     !- head definition, var
4170         iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/dimdata/), varid)
4171         iret = nf90_put_att(ncid, varid, 'units', 'meter')
4172         iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
4173
4174         iret = nf90_def_var(ncid2, "head", NF90_FLOAT, (/dimdataO/), varid)
4175         iret = nf90_put_att(ncid2, varid, 'units', 'meter')
4176         iret = nf90_put_att(ncid2, varid, 'long_name', 'River Stage')
4177
4178 !     !- order definition, var
4179         iret = nf90_def_var(ncid, "order", NF90_INT, (/dimdata/), varid)
4180         iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order')
4181         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4182
4183         iret = nf90_def_var(ncid2, "order", NF90_INT, (/dimdataO/), varid)
4184         iret = nf90_put_att(ncid2, varid, 'long_name', 'Strahler Stream Order')
4185         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4186
4187      !-- station  id
4188      ! define character-position dimension for strings of max length 11
4189          iret = NF90_DEF_DIM(ncid, "id_len", 11, charid)
4190          TXDIMS(1) = charid   ! define char-string variable and position dimension first
4191          TXDIMS(2) = stationdim
4192          iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid)
4193          iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
4194
4195
4196          iret = NF90_DEF_DIM(ncid2, "id_len", 15, charidO)
4197          OTXDIMS(1) = charidO   ! define char-string variable and position dimension first
4198          OTXDIMS(2) = obsdim
4199          iret = nf90_def_var(ncid2, "station_id", NF90_CHAR, OTXDIMS, varid)
4200          iret = nf90_put_att(ncid2, varid, 'long_name', 'Observation id')
4201
4202
4203 !     !- time definition, timeObs
4204          iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
4205          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
4206          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
4207
4208          iret = nf90_def_var(ncid2, "time", NF90_INT, (/timedim2/), varid)
4209          iret = nf90_put_att(ncid2, varid, 'units', sec_valid_date)
4210          iret = nf90_put_att(ncid2, varid, 'long_name', 'valid output time')
4211
4212          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4213          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
4214
4215          convention(1:32) = "Unidata Observation Dataset v1.0"
4216          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4217          iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
4218
4219          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
4220          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
4221          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
4222          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
4223          iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
4224          iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
4225          iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
4226          iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", order_to_write)
4227
4228          iret = nf90_put_att(ncid2, NF90_GLOBAL, "Conventions", convention)
4229          iret = nf90_put_att(ncid2, NF90_GLOBAL, "cdm_datatype", "Station")
4230
4231          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_max", "90.0")
4232          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
4233          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_max", "180.0")
4234          iret = nf90_put_att(ncid2, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
4235
4236          iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
4237          iret = nf90_put_att(ncid2, NF90_GLOBAL, "station_dimension", "station")
4238          iret = nf90_put_att(ncid2, NF90_GLOBAL, "missing_value", -9E15)
4239          iret = nf90_put_att(ncid2, NF90_GLOBAL, "stream_order_output", order_to_write)
4240
4241          iret = nf90_enddef(ncid)
4242          iret = nf90_enddef(ncid2)
4243
4244         !-- write latitudes
4245          iret = nf90_inq_varid(ncid,"latitude", varid)
4246          iret = nf90_put_var(ncid, varid, chanlat, (/1/), (/nstations/))
4247
4248          iret = nf90_inq_varid(ncid2,"latitude", varid)
4249          iret = nf90_put_var(ncid2, varid, chanlatO, (/1/), (/nobs/))
4250
4251         !-- write longitudes
4252          iret = nf90_inq_varid(ncid,"longitude", varid)
4253          iret = nf90_put_var(ncid, varid, chanlon, (/1/), (/nstations/))
4254
4255          iret = nf90_inq_varid(ncid2,"longitude", varid)
4256          iret = nf90_put_var(ncid2, varid, chanlonO, (/1/), (/nobs/))
4257
4258         !-- write elevations
4259          iret = nf90_inq_varid(ncid,"altitude", varid)
4260          iret = nf90_put_var(ncid, varid, elevation, (/1/), (/nstations/))
4261
4262          iret = nf90_inq_varid(ncid2,"altitude", varid)
4263          iret = nf90_put_var(ncid2, varid, elevationO, (/1/), (/nobs/))
4264
4265       !-- write gage location
4266 !      iret = nf90_inq_varid(ncid,"gages", varid)
4267 !      iret = nf90_put_var(ncid, varid, STRMFRXSTPTS, (/1/), (/nstations/))
4268
4269         !-- write number_of_stations, OPTIONAL
4270       !!  iret = nf90_inq_varid(ncid,"number_stations", varid)
4271       !!  iret = nf90_put_var_int(ncid, varid, nstations)
4272
4273         !-- write station id's
4274          do i=1,nstations
4275           TSTART(1) = 1
4276           TSTART(2) = i
4277           TCOUNT(1) = TXLEN
4278           TCOUNT(2) = 1
4279           iret = nf90_inq_varid(ncid,"station_id", varid)
4280           iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT)
4281          enddo
4282
4283         !-- write observation id's
4284          do i=1, nobs
4285           OTSTART(1) = 1
4286           OTSTART(2) = i
4287           OTCOUNT(1) = OTXLEN
4288           OTCOUNT(2) = 1
4289           iret = nf90_inq_varid(ncid2,"station_id", varid)
4290           iret = nf90_put_var(ncid2, varid, stnameO(i), OTSTART, OTCOUNT)
4291          enddo
4292
4293      endif
4294
4295      output_count = output_count + 1
4296
4297      open (unit=55, &
4298 #ifndef NCEP_WCOSS
4299      file='frxst_pts_out.txt', &
4300 #endif
4301      status='unknown',position='append')
4302
4303      cnt=0
4304      do i=1,nlk
4305
4306        if(ORDER(i) .ge. order_to_write) then
4307          start_pos = (cnt+1)+(nstations*(output_count-1))
4308
4309          !!--time in seconds since startdate
4310           iret = nf90_inq_varid(ncid,"time", varid)
4311           iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
4312
4313          if(UDMP_OPT .eq. 1) then
4314             !! FLUXES to channel
4315              if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4316                 nlst(did)%output_channelBucket_influx .eq. 2      ) then
4317                 iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid)
4318                 iret = nf90_put_var(ncid, varid, qSfcLatRunoff(i), (/start_pos/))
4319
4320                 iret = nf90_inq_varid(ncid,"qBucket", varid)
4321                 iret = nf90_put_var(ncid, varid, qBucket(i), (/start_pos/))
4322              end if
4323
4324              !! FLUXES to bucket
4325              if(nlst(did)%output_channelBucket_influx .eq. 2) then
4326                 iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid)
4327                 iret = nf90_put_var(ncid, varid, qBtmVertRunoff(i), (/start_pos/))
4328              end if
4329
4330             !! ACCUMULATIONS
4331              if(nlst(did)%output_channelBucket_influx .eq. 3) then
4332                 iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid)
4333                 iret = nf90_put_var(ncid, varid, accSfcLatRunoff(i), (/start_pos/))
4334
4335                 iret = nf90_inq_varid(ncid,"accBucket", varid)
4336                 iret = nf90_put_var(ncid, varid, accBucket(i), (/start_pos/))
4337              end if
4338           endif
4339
4340          iret = nf90_inq_varid(ncid,"streamflow", varid)
4341          iret = nf90_put_var(ncid, varid, qlink(i,1), (/start_pos/))
4342
4343 #ifdef WRF_HYDRO_NUDGING
4344          iret = nf90_inq_varid(ncid,"nudge", varid)
4345          iret = nf90_put_var(ncid, varid, nudge(i), (/start_pos/))
4346 #endif
4347
4348 !        iret = nf90_inq_varid(ncid,"pos_streamflow", varid)
4349 !        iret = nf90_put_var(ncid, varid, abs(qlink(i,1), (/start_pos/)))
4350
4351          iret = nf90_inq_varid(ncid,"head", varid)
4352          iret = nf90_put_var(ncid, varid, hlink(i), (/start_pos/))
4353
4354          iret = nf90_inq_varid(ncid,"order", varid)
4355          iret = nf90_put_var(ncid, varid, ORDER(i), (/start_pos/))
4356
4357          !-- station index.. will repeat for every timesstep
4358          iret = nf90_inq_varid(ncid,"parent_index", varid)
4359          iret = nf90_put_var(ncid, varid, cnt, (/start_pos/))
4360
4361           !--record number of previous record for same station
4362 !obsolete format         prev_pos = cnt+(nstations*(output_count-1))
4363          prev_pos = cnt+(nobs*(output_count-2))
4364          if(output_count.ne.1) then !-- only write next set of records
4365            iret = nf90_inq_varid(ncid,"prevChild", varid)
4366            iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/))
4367          endif
4368          cnt=cnt+1  !--indices are 0 based
4369          rec_num_of_station(cnt) = start_pos-1  !-- save position for last child, 0-based!!
4370
4371
4372        endif
4373     enddo
4374 !    close(999)
4375
4376     !-- output  only observation points
4377     cnt=0
4378     do i=1,nlk
4379        if(channel_option .ne. 3) then
4380           ! jlm this verry repetitiuos, oh well.
4381           if(trim(gages(i)) .ne. trim(gageMiss)) then
4382
4383              start_posO = (cnt+1)+(nobs * (output_count-1))
4384              !Write frxst_pts to text file...
4385              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
4386 118          FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
4387              !write(55,118) seconds_since, date(1:10), date(12:19), &
4388
4389              write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), &
4390                   gages(i), chlon(i), chlat(i),                               &
4391                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
4392
4393              !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
4394              !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)
4395
4396              !!--time in seconds since startdate
4397              iret = nf90_inq_varid(ncid2,"time", varid)
4398              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
4399
4400              iret = nf90_inq_varid(ncid2,"streamflow", varid)
4401              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
4402
4403 #ifdef WRF_HYDRO_NUDGING
4404              iret = nf90_inq_varid(ncid2,"nudge", varid)
4405              iret = nf90_put_var(ncid2, varid, nudge(i), (/start_posO/))
4406 #endif
4407
4408              iret = nf90_inq_varid(ncid2,"head", varid)
4409              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
4410
4411              iret = nf90_inq_varid(ncid,"order", varid)
4412              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
4413
4414              !-- station index.. will repeat for every timesstep
4415              iret = nf90_inq_varid(ncid2,"parent_index", varid)
4416              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
4417
4418              !--record number of previous record for same station
4419              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
4420              prev_posO = cnt+(nobs*(output_count-2))
4421              if(output_count.ne.1) then !-- only write next set of records
4422                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
4423                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4424
4425                 !IF block to add -1 to last element of prevChild array to designate end of list...
4426                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
4427                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
4428                 !           else
4429                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4430                 !           endif
4431
4432              endif
4433              cnt=cnt+1  !--indices are 0 based
4434              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
4435           endif
4436
4437
4438        else !! channel options 3 below
4439
4440           if(STRMFRXSTPTS(i) .ne. -9999) then
4441              start_posO = (cnt+1)+(nobs * (output_count-1))
4442              !Write frxst_pts to text file...
4443              !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
4444 117          FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
4445              !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), &
4446              !     qlink(i,1), qlink(i,1)*35.315,hlink(i)
4447              ! JLM: makes more sense to output the value in frxstpts incase they have meaning,
4448              ! as below, but I'm not going to make this change until I'm working with gridded
4449              ! streamflow again.
4450              write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), &
4451                   strmfrxstpts(i), chlon(i), chlat(i),                        &
4452                   qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
4453
4454              !!--time in seconds since startdate
4455              iret = nf90_inq_varid(ncid2,"time", varid)
4456              iret = nf90_put_var(ncid2, varid, seconds_since, (/1/))
4457
4458              iret = nf90_inq_varid(ncid2,"streamflow", varid)
4459              iret = nf90_put_var(ncid2, varid, qlink(i,1), (/start_posO/))
4460
4461              iret = nf90_inq_varid(ncid2,"head", varid)
4462              iret = nf90_put_var(ncid2, varid, hlink(i), (/start_posO/))
4463
4464              iret = nf90_inq_varid(ncid,"order", varid)
4465              iret = nf90_put_var(ncid2, varid, ORDER(i), (/start_posO/))
4466
4467              !-- station index.. will repeat for every timesstep
4468              iret = nf90_inq_varid(ncid2,"parent_index", varid)
4469              iret = nf90_put_var(ncid2, varid, cnt, (/start_posO/))
4470
4471              !--record number of previous record for same station
4472              !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
4473              prev_posO = cnt+(nobs*(output_count-2))
4474              if(output_count.ne.1) then !-- only write next set of records
4475                 iret = nf90_inq_varid(ncid2,"prevChild", varid)
4476                 iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4477
4478                 !IF block to add -1 to last element of prevChild array to designate end of list...
4479                 !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
4480                 !             iret = nf90_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
4481                 !           else
4482                 !             iret = nf90_put_var(ncid2, varid, prev_posO, (/start_posO/))
4483                 !           endif
4484
4485              endif
4486              cnt=cnt+1  !--indices are 0 based
4487              rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
4488           endif
4489
4490        endif
4491
4492     enddo
4493     close(55)
4494
4495       !-- lastChild variable gives the record number of the most recent report for the station
4496       iret = nf90_inq_varid(ncid,"lastChild", varid)
4497       iret = nf90_put_var(ncid, varid, rec_num_of_station, (/1/), (/nstations/))
4498
4499       !-- lastChild variable gives the record number of the most recent report for the station
4500       iret = nf90_inq_varid(ncid2,"lastChild", varid)
4501       iret = nf90_put_var(ncid2, varid, rec_num_of_stationO, (/1/), (/nobs/))
4502
4503       iret = nf90_redef(ncid)
4504       date19(1:19) = "0000-00-00_00:00:00"
4505       date19(1:len_trim(date)) = date
4506       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
4507
4508       iret = nf90_redef(ncid2)
4509       iret = nf90_put_att(ncid2, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
4510
4511       iret = nf90_enddef(ncid)
4512       iret = nf90_sync(ncid)
4513
4514       iret = nf90_enddef(ncid2)
4515       iret = nf90_sync(ncid2)
4516
4517       if (output_count == split_output_count) then
4518         output_count = 0
4519         iret = nf90_close(ncid)
4520         iret = nf90_close(ncid2)
4521      endif
4522
4523      if(allocated(chanlat))  deallocate(chanlat)
4524      if(allocated(chanlon))  deallocate(chanlon)
4525      if(allocated(elevation))  deallocate(elevation)
4526      if(allocated(station_id))  deallocate(station_id)
4527      if(allocated(lOrder))  deallocate(lOrder)
4528      if(allocated(rec_num_of_station))  deallocate(rec_num_of_station)
4529      if(allocated(stname))  deallocate(stname)
4530
4531      if(allocated(chanlatO))  deallocate(chanlatO)
4532      if(allocated(chanlonO))  deallocate(chanlonO)
4533      if(allocated(elevationO))  deallocate(elevationO)
4534      if(allocated(station_idO))  deallocate(station_idO)
4535      if(allocated(lOrderO))  deallocate(lOrderO)
4536      if(allocated(rec_num_of_stationO))  deallocate(rec_num_of_stationO)
4537      if(allocated(stnameO))  deallocate(stnameO)
4538 #ifdef HYDRO_D
4539      print *, "Exited Subroutine output_chrt"
4540 #endif
4541      close(16)
4542
4543 20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3)
4544
4545 end subroutine output_chrt_bak
4546
4547 #ifdef MPP_LAND
4548 !-- output the channel route in an IDV 'station' compatible format
4549    subroutine mpp_output_chrt(gnlinks,gnlinksl,map_l2g,igrid,                  &
4550         split_output_count, NLINKS, ORDER,                                     &
4551         startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch,              &
4552         K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, &
4553         lsmDt                                       &
4554 #ifdef WRF_HYDRO_NUDGING
4555         , nudge                                     &
4556 #endif
4557         , accSfcLatRunoff, accBucket                 &
4558         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff &
4559         ,        UDMP_OPT                            &
4560         )
4561
4562        USE module_mpp_land
4563
4564        implicit none
4565
4566 !!output the routing variables over just channel
4567      integer,                                  intent(in) :: igrid,K,channel_option,NLINKSL
4568      integer,                                  intent(in) :: split_output_count
4569      integer,                                  intent(in) :: NLINKS
4570      real, dimension(:),               intent(in) :: chlon,chlat
4571      real, dimension(:),                  intent(in) :: hlink,zelev
4572
4573      integer, dimension(:),               intent(in) :: ORDER
4574      integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
4575      character(len=15), dimension(:),     intent(inout) :: gages
4576      character(len=15),                   intent(in) :: gageMiss
4577      real,                                intent(in) :: lsmDt
4578
4579      real,                                     intent(in) :: dtrt_ch
4580      real, dimension(:,:),                intent(in) :: qlink
4581 #ifdef WRF_HYDRO_NUDGING
4582      real, dimension(:),                  intent(in) :: nudge
4583 #endif
4584
4585      integer, intent(in) :: UDMP_OPT
4586
4587      character(len=*),                         intent(in) :: startdate
4588      character(len=*),                         intent(in) :: date
4589
4590       integer  :: gnlinks, map_l2g(nlinks), order_to_write, gnlinksl
4591       real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev
4592 #ifdef WRF_HYDRO_NUDGING
4593       real, allocatable,dimension(:) :: g_nudge
4594 #endif
4595       integer, allocatable,dimension(:) :: g_order,g_STRMFRXSTPTS
4596       real,allocatable,dimension(:,:) :: g_qlink
4597       integer  :: gsize
4598       character(len=15),allocatable,dimension(:) :: g_gages
4599       real*8, dimension(:), intent(in) ::   accSfcLatRunoff,   accBucket
4600       real  , dimension(:), intent(in) ::     qSfcLatRunoff,     qBucket, qBtmVertRunoff
4601       real*8,allocatable,dimension(:)  :: g_accSfcLatRunoff, g_accBucket
4602       real  ,allocatable,dimension(:)  ::   g_qSfcLatRunoff,   g_qBucket, g_qBtmVertRunoff
4603
4604         gsize = gNLINKS
4605         if(gnlinksl .gt. gsize) gsize = gnlinksl
4606      if(my_id .eq. io_id ) then
4607         allocate(g_chlon(gsize  ))
4608         allocate(g_chlat(gsize  ))
4609         allocate(g_hlink(gsize  ))
4610         allocate(g_zelev(gsize  ))
4611         allocate(g_qlink(gsize  ,2))
4612 #ifdef WRF_HYDRO_NUDGING
4613         allocate(g_nudge(gsize))
4614 #endif
4615         allocate(g_order(gsize  ))
4616         allocate(g_STRMFRXSTPTS(gsize  ))
4617         allocate(g_gages(gsize))
4618
4619         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4620            nlst(did)%output_channelBucket_influx .eq. 2      ) then
4621            allocate(g_qSfcLatRunoff(  gsize ))
4622            allocate(g_qBucket(        gsize ))
4623         endif
4624
4625         if(nlst(did)%output_channelBucket_influx .eq. 2) &
4626              allocate(g_qBtmVertRunoff(  gsize ))
4627
4628         if(nlst(did)%output_channelBucket_influx .eq. 3) then
4629            allocate(g_accSfcLatRunoff(gsize ))
4630            allocate(g_accBucket(      gsize ))
4631         endif
4632
4633      else
4634
4635         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4636            nlst(did)%output_channelBucket_influx .eq. 2      ) then
4637            allocate(g_qSfcLatRunoff(  1))
4638            allocate(g_qBucket(        1))
4639         end if
4640
4641         if(nlst(did)%output_channelBucket_influx .eq. 2) &
4642              allocate(g_qBtmVertRunoff(  1))
4643
4644         if(nlst(did)%output_channelBucket_influx .eq. 3) then
4645            allocate(g_accSfcLatRunoff(1))
4646            allocate(g_accBucket(      1))
4647         end if
4648
4649         allocate(g_chlon(1))
4650         allocate(g_chlat(1))
4651         allocate(g_hlink(1))
4652         allocate(g_zelev(1))
4653         allocate(g_qlink(1,2))
4654 #ifdef WRF_HYDRO_NUDGING
4655         allocate(g_nudge(1))
4656 #endif
4657         allocate(g_order(1))
4658         allocate(g_STRMFRXSTPTS(1))
4659         allocate(g_gages(1))
4660      endif
4661
4662      call mpp_land_sync()
4663
4664      if(channel_option .eq. 1 .or. channel_option .eq. 2) then
4665         g_qlink = 0
4666         g_gages = gageMiss
4667         call ReachLS_write_io(qlink(:,1), g_qlink(:,1))
4668         call ReachLS_write_io(qlink(:,2), g_qlink(:,2))
4669 #ifdef WRF_HYDRO_NUDGING
4670         g_nudge=0
4671         call ReachLS_write_io(nudge,g_nudge)
4672 #endif
4673         call ReachLS_write_io(order, g_order)
4674         call ReachLS_write_io(chlon, g_chlon)
4675         call ReachLS_write_io(chlat, g_chlat)
4676         call ReachLS_write_io(zelev, g_zelev)
4677
4678         call ReachLS_write_io(gages, g_gages)
4679         call ReachLS_write_io(STRMFRXSTPTS, g_STRMFRXSTPTS)
4680         call ReachLS_write_io(hlink, g_hlink)
4681
4682         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
4683            nlst(did)%output_channelBucket_influx .eq. 2      ) then
4684            call ReachLS_write_io(qSfcLatRunoff, g_qSfcLatRunoff)
4685            call ReachLS_write_io(qBucket, g_qBucket)
4686         end if
4687
4688         if(nlst(did)%output_channelBucket_influx .eq. 2) &
4689              call ReachLS_write_io(qBtmVertRunoff, g_qBtmVertRunoff)
4690
4691         if(nlst(did)%output_channelBucket_influx .eq. 3) then
4692            call ReachLS_write_io(accSfcLatRunoff, g_accSfcLatRunoff)
4693            call ReachLS_write_io(accBucket, g_accBucket)
4694         end if
4695
4696      else
4697         call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
4698         call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
4699         call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order)
4700         call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon)
4701         call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat)
4702         call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev)
4703         call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS)
4704         call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
4705      endif
4706
4707
4708      if(my_id .eq. IO_id) then
4709        call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER,                &
4710           startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K,     &
4711           g_STRMFRXSTPTS,order_to_write,gNLINKSL,channel_option, g_gages, gageMiss, &
4712           lsmDt                                                                     &
4713 #ifdef WRF_HYDRO_NUDGING
4714           , g_nudge                                     &
4715 #endif
4716           , g_accSfcLatRunoff, g_accBucket                   &
4717           , g_qSfcLatRunoff,   g_qBucket,   g_qBtmVertRunoff &
4718           , UDMP_OPT                                         &
4719           )
4720
4721     end if
4722      call mpp_land_sync()
4723     if(allocated(g_order)) deallocate(g_order)
4724     if(allocated(g_STRMFRXSTPTS)) deallocate(g_STRMFRXSTPTS)
4725     if(allocated(g_chlon)) deallocate(g_chlon)
4726     if(allocated(g_chlat)) deallocate(g_chlat)
4727     if(allocated(g_hlink)) deallocate(g_hlink)
4728     if(allocated(g_zelev)) deallocate(g_zelev)
4729     if(allocated(g_qlink)) deallocate(g_qlink)
4730     if(allocated(g_gages)) deallocate(g_gages)
4731 #ifdef WRF_HYDRO_NUDGING
4732     if(allocated(g_nudge)) deallocate(g_nudge)
4733 #endif
4734     if(allocated(g_qSfcLatRunoff))   deallocate(g_qSfcLatRunoff)
4735     if(allocated(g_qBucket))         deallocate(g_qBucket)
4736     if(allocated(g_qBtmVertRunoff))  deallocate(g_qBtmVertRunoff)
4737     if(allocated(g_accSfcLatRunoff)) deallocate(g_accSfcLatRunoff)
4738     if(allocated(g_accBucket))       deallocate(g_accBucket)
4739
4740 end subroutine mpp_output_chrt
4741
4742 !---------  lake netcdf output -----------------------------------------
4743 !-- output the ilake info an IDV 'station' compatible format -----------
4744    subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, &
4745         startdate, date, latlake, lonlake, elevlake, &
4746         qlakei,qlakeo, resht,dtrt_ch,K)
4747
4748    USE module_mpp_land
4749
4750 !!output the routing variables over just channel
4751      integer,                                  intent(in) :: igrid, K
4752      integer,                                  intent(in) :: split_output_count
4753      integer,                                  intent(in) :: NLAKES
4754      real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
4755      real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
4756      real,                                     intent(in) :: dtrt_ch
4757
4758      character(len=*),                         intent(in) :: startdate
4759      character(len=*),                         intent(in) :: date
4760      integer lake_index(nlakes)
4761
4762
4763      call write_lake_real(latlake,lake_index,nlakes)
4764      call write_lake_real(lonlake,lake_index,nlakes)
4765      call write_lake_real(elevlake,lake_index,nlakes)
4766      call write_lake_real(resht,lake_index,nlakes)
4767      call write_lake_real(qlakei,lake_index,nlakes)
4768      call write_lake_real(qlakeo,lake_index,nlakes)
4769      if(my_id.eq. IO_id) then
4770         call output_lakes(igrid, split_output_count, NLAKES, &
4771            startdate, date, latlake, lonlake, elevlake, &
4772            qlakei,qlakeo, resht,dtrt_ch,K)
4773      end if
4774      call mpp_land_sync()
4775      return
4776      end subroutine mpp_output_lakes
4777
4778    subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, &
4779         startdate, date, latlake, lonlake, elevlake, &
4780         qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM)
4781
4782    USE module_mpp_land
4783
4784 !!output the routing variables over just channel
4785      integer,                                  intent(in) :: igrid, K
4786      integer,                                  intent(in) :: split_output_count
4787      integer,                                  intent(in) :: NLAKES
4788      real, dimension(NLAKES),                  intent(inout) :: latlake,lonlake,elevlake,resht
4789      real, dimension(NLAKES),                  intent(inout) :: qlakei,qlakeo  !-- inflow and outflow of lake
4790      real,                                     intent(in) :: dtrt_ch
4791      integer(kind=int64), dimension(NLAKES),   intent(in) :: LAKEIDM     ! lake id
4792
4793      character(len=*),                         intent(in) :: startdate
4794      character(len=*),                         intent(in) :: date
4795      integer lake_index(nlakes)
4796
4797      call write_lake_real(latlake,lake_index,nlakes)
4798      call write_lake_real(lonlake,lake_index,nlakes)
4799      call write_lake_real(elevlake,lake_index,nlakes)
4800      call write_lake_real(resht,lake_index,nlakes)
4801      call write_lake_real(qlakei,lake_index,nlakes)
4802      call write_lake_real(qlakeo,lake_index,nlakes)
4803
4804      if(my_id.eq. IO_id) then
4805         call output_lakes2(igrid, split_output_count, NLAKES, &
4806            startdate, date, latlake, lonlake, elevlake, &
4807            qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM)
4808      end if
4809      call mpp_land_sync()
4810      return
4811      end subroutine mpp_output_lakes2
4812 #endif
4813
4814 !----------------------------------- lake netcdf output
4815 !-- output the ilake info an IDV 'station' compatible format
4816    subroutine output_lakes(igrid, split_output_count, NLAKES, &
4817         startdate, date, latlake, lonlake, elevlake, &
4818         qlakei,qlakeo, resht,dtrt_ch,K)
4819
4820 !!output the routing variables over just channel
4821      integer,                                  intent(in) :: igrid, K
4822      integer,                                  intent(in) :: split_output_count
4823      integer,                                  intent(in) :: NLAKES
4824      real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
4825      real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
4826      real,                                     intent(in) :: dtrt_ch
4827
4828      character(len=*),                         intent(in) :: startdate
4829      character(len=*),                         intent(in) :: date
4830
4831      integer, allocatable, DIMENSION(:)                   :: station_id
4832      integer, allocatable, DIMENSION(:)                   :: rec_num_of_lake
4833
4834      integer, save  :: output_count
4835      integer, save :: ncid
4836
4837      integer :: stationdim, dimdata, varid, charid, n
4838      integer :: iret,i, start_pos, prev_pos  !--
4839      integer :: previous_pos        !-- used for the station model
4840      character(len=256) :: output_flnm
4841      character(len=19)  :: date19, date19start
4842      character(len=34)  :: sec_since_date
4843      integer :: seconds_since,cnt
4844      character(len=32)  :: convention
4845      character(len=6),allocatable, DIMENSION(:)  :: stname
4846      integer :: timedim
4847      character(len=34) :: sec_valid_date
4848
4849     !--- all this for writing the station id string
4850      INTEGER   TDIMS, TXLEN
4851      PARAMETER (TDIMS=2)    ! number of TX dimensions
4852      PARAMETER (TXLEN = 6) ! length of example string
4853      INTEGER  TIMEID        ! record dimension id
4854      INTEGER  TXID          ! variable ID
4855      INTEGER  TXDIMS(TDIMS) ! variable shape
4856      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
4857
4858 !    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
4859 !    seconds_since = int(dtrt_ch)*output_count
4860      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
4861      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
4862                      //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
4863
4864
4865      allocate(station_id(NLAKES))
4866      allocate(rec_num_of_lake(NLAKES))
4867      allocate(stname(NLAKES))
4868
4869      if (output_count == 0) then
4870
4871 !-- have moved sec_since_date from above here..
4872       sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
4873                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
4874
4875       date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
4876                   //startdate(12:13)//':'//startdate(15:16)//':00'
4877
4878       write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
4879 #ifdef HYDRO_D
4880       print*, 'output_flnm = "'//trim(output_flnm)//'"'
4881 #endif
4882
4883       iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
4884       if (iret /= 0) then
4885          call hydro_stop("In output_lakes() - Problem nf90_create")
4886       endif
4887
4888       do i=1,NLAKES
4889          station_id(i) = i
4890          write(stname(i),'(I6)') i
4891       enddo
4892
4893       iret = nf90_def_dim(ncid, "recNum", NF90_UNLIMITED, dimdata)  !--for linked list approach
4894       iret = nf90_def_dim(ncid, "station", nlakes, stationdim)
4895       iret = nf90_def_dim(ncid, "time", 1, timedim)
4896
4897 !#ifndef HYDRO_REALTIME
4898       !- station location definition,  lat
4899       iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
4900       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake latitude')
4901       iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
4902
4903       !- station location definition,  long
4904       iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
4905       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake longitude')
4906       iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
4907
4908 !     !-- lake's phyical elevation
4909 !     iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
4910 !     iret = nf90_put_att(ncid, varid, 'long_name', 'Lake altitude')
4911 !     iret = nf90_put_att(ncid, varid, 'units', 'meters')
4912 !#endif
4913
4914      !-- parent index
4915 !     iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/dimdata/), varid)
4916 !     iret = nf90_put_att(ncid, varid, 'long_name', 'index of the lake for this record')
4917
4918      !-- prevChild
4919 !     iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/dimdata/), varid)
4920 !     iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same lake')
4921 !ywtmp      iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4922 !     iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4923
4924      !-- lastChild
4925 !     iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
4926 !     iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this lake')
4927 !ywtmp      iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4928 !     iret = nf90_put_att(ncid, varid, '_FillValue', -1)
4929
4930 !     !- water surface elevation
4931       iret = nf90_def_var(ncid, "wse", NF90_FLOAT, (/dimdata/), varid)
4932       iret = nf90_put_att(ncid, varid, 'units', 'meters')
4933       iret = nf90_put_att(ncid, varid, 'long_name', 'Water Surface Elevation')
4934
4935 !     !- inflow to lake
4936       iret = nf90_def_var(ncid, "inflow", NF90_FLOAT, (/dimdata/), varid)
4937       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4938
4939 !     !- outflow to lake
4940       iret = nf90_def_var(ncid, "outflow", NF90_FLOAT, (/dimdata/), varid)
4941       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
4942
4943      !-- station  id
4944      ! define character-position dimension for strings of max length 6
4945          iret = NF90_DEF_DIM(ncid, "id_len", 6, charid)
4946          TXDIMS(1) = charid   ! define char-string variable and position dimension first
4947          TXDIMS(2) = stationdim
4948          iret = nf90_def_var(ncid, "station_id", NF90_CHAR, TXDIMS, varid)
4949          iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
4950
4951 !     !- time definition, timeObs
4952          iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
4953          iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
4954          iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
4955
4956 !       date19(1:19) = "0000-00-00_00:00:00"
4957 !       date19(1:len_trim(startdate)) = startdate
4958 !       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4959 !
4960         date19(1:19) = "0000-00-00_00:00:00"
4961         date19(1:len_trim(startdate)) = startdate
4962         convention(1:32) = "Unidata Observation Dataset v1.0"
4963         iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
4964         iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
4965 !#ifndef HYDRO_REALTIME
4966         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
4967         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
4968         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
4969         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
4970 !#endif
4971         iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
4972         iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
4973 !!       iret = nf90_put_att(ncid, NF90_GLOBAL, "observation_dimension", "recNum")
4974 !!        iret = nf90_put_att(ncid, NF90_GLOBAL, "time_coordinate", "time_observation")
4975         iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
4976         iret = nf90_enddef(ncid)
4977
4978 !#ifndef HYDRO_REALTIME
4979         !-- write latitudes
4980         iret = nf90_inq_varid(ncid,"latitude", varid)
4981         iret = nf90_put_var(ncid, varid, LATLAKE, (/1/), (/NLAKES/))
4982
4983         !-- write longitudes
4984         iret = nf90_inq_varid(ncid,"longitude", varid)
4985         iret = nf90_put_var(ncid, varid, LONLAKE, (/1/), (/NLAKES/))
4986
4987         !-- write physical height of lake
4988 !       iret = nf90_inq_varid(ncid,"altitude", varid)
4989 !       iret = nf90_put_var(ncid, varid, elevlake, (/1/), (/NLAKES/))
4990 !#endif
4991
4992         !-- write station id's
4993          do i=1,nlakes
4994           TSTART(1) = 1
4995           TSTART(2) = i
4996           TCOUNT(1) = TXLEN
4997           TCOUNT(2) = 1
4998           iret = nf90_inq_varid(ncid,"station_id", varid)
4999           iret = nf90_put_var(ncid, varid, stname(i), TSTART, TCOUNT)
5000          enddo
5001
5002      endif
5003
5004      iret = nf90_inq_varid(ncid,"time", varid)
5005      iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
5006
5007      output_count = output_count + 1
5008
5009      cnt=0
5010      do i=1,NLAKES
5011
5012          start_pos = (cnt+1)+(nlakes*(output_count-1))
5013
5014          !!--time in seconds since startdate
5015          iret = nf90_inq_varid(ncid,"time_observation", varid)
5016          iret = nf90_put_var(ncid, varid, seconds_since, (/start_pos/))
5017
5018          iret = nf90_inq_varid(ncid,"wse", varid)
5019          iret = nf90_put_var(ncid, varid, resht(i), (/start_pos/))
5020
5021          iret = nf90_inq_varid(ncid,"inflow", varid)
5022          iret = nf90_put_var(ncid, varid, qlakei(i), (/start_pos/))
5023
5024          iret = nf90_inq_varid(ncid,"outflow", varid)
5025          iret = nf90_put_var(ncid, varid, qlakeo(i), (/start_pos/))
5026
5027          !-- station index.. will repeat for every timesstep
5028 !        iret = nf90_inq_varid(ncid,"parent_index", varid)
5029 !        iret = nf90_put_var(ncid, varid, cnt, (/start_pos/))
5030
5031           !--record number of previous record for same station
5032 !        prev_pos = cnt+(nlakes*(output_count-1))
5033 !        if(output_count.ne.1) then !-- only write next set of records
5034 !          iret = nf90_inq_varid(ncid,"prevChild", varid)
5035 !          iret = nf90_put_var(ncid, varid, prev_pos, (/start_pos/))
5036 !        endif
5037
5038          cnt=cnt+1  !--indices are 0 based
5039          rec_num_of_lake(cnt) = start_pos-1  !-- save position for last child, 0-based!!
5040
5041     enddo
5042
5043       !-- lastChild variable gives the record number of the most recent report for the station
5044       iret = nf90_inq_varid(ncid,"lastChild", varid)
5045       iret = nf90_put_var(ncid, varid, rec_num_of_lake, (/1/), (/nlakes/))
5046
5047      !-- number of children reported for this station, OPTIONAL
5048      !--  iret = nf90_inq_varid(ncid,"numChildren", varid)
5049      !--  iret = nf90_put_var(ncid, varid, rec_num_of_lake, (/1/), (/nlakes/))
5050
5051     iret = nf90_redef(ncid)
5052     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
5053     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5054     iret = nf90_enddef(ncid)
5055
5056     iret = nf90_sync(ncid)
5057      if (output_count == split_output_count) then
5058         output_count = 0
5059         iret = nf90_close(ncid)
5060      endif
5061
5062      if(allocated(station_id)) deallocate(station_id)
5063      if(allocated(rec_num_of_lake)) deallocate(rec_num_of_lake)
5064      if(allocated(stname)) deallocate(stname)
5065 #ifdef HYDRO_D
5066      print *, "Exited Subroutine output_lakes"
5067 #endif
5068      close(16)
5069
5070  end subroutine output_lakes
5071
5072 !----------------------------------- lake netcdf output
5073 !-- output the lake as regular netcdf file format for better performance than point netcdf file.
5074    subroutine output_lakes2(igrid, split_output_count, NLAKES, &
5075         startdate, date, latlake, lonlake, elevlake, &
5076         qlakei,qlakeo, resht,dtrt_ch,K,LAKEIDM)
5077
5078 !!output the routing variables over just channel
5079      integer,                                  intent(in) :: igrid, K
5080      integer,                                  intent(in) :: split_output_count
5081      integer,                                  intent(in) :: NLAKES
5082      real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
5083      real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
5084      integer(kind=int64), dimension(NLAKES),       intent(in) :: LAKEIDM        !-- LAKE ID
5085      real,                                     intent(in) :: dtrt_ch
5086
5087      character(len=*),                         intent(in) :: startdate
5088      character(len=*),                         intent(in) :: date
5089
5090
5091      integer, save  :: output_count
5092      integer, save :: ncid
5093
5094      integer :: stationdim, varid,  n
5095      integer :: iret,i    !--
5096      character(len=256) :: output_flnm
5097      character(len=19)  :: date19, date19start
5098      character(len=32)  :: convention
5099      integer :: timedim
5100      integer :: seconds_since
5101      character(len=34) :: sec_valid_date
5102      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
5103                          //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
5104
5105      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
5106
5107      if (output_count == 0) then
5108
5109       date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
5110                   //startdate(12:13)//':'//startdate(15:16)//':00'
5111
5112       write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
5113 #ifdef HYDRO_D
5114       print*, 'output_flnm = "'//trim(output_flnm)//'"'
5115 #endif
5116
5117       iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5118       if (iret /= 0) then
5119          call hydro_stop("In output_lakes() - Problem nf90_create")
5120       endif
5121
5122       iret = nf90_def_dim(ncid, "station", nlakes, stationdim)
5123
5124       iret = nf90_def_dim(ncid, "time", 1, timedim)
5125
5126 !#ifndef HYDRO_REALTIME
5127       !- station location definition,  lat
5128       iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
5129       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake latitude')
5130       iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
5131 !#endif
5132
5133       !- station location definition,  LAKEIDM
5134       iret = nf90_def_var(ncid, "lake_id", NF90_INT, (/stationdim/), varid)
5135       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake COMMON ID')
5136
5137 !#ifndef HYDRO_REALTIME
5138       !- station location definition,  long
5139       iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
5140       iret = nf90_put_att(ncid, varid, 'long_name', 'Lake longitude')
5141       iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
5142
5143 !     !-- lake's phyical elevation
5144 !     iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
5145 !     iret = nf90_put_att(ncid, varid, 'long_name', 'Lake altitude')
5146 !     iret = nf90_put_att(ncid, varid, 'units', 'meters')
5147 !#endif
5148
5149 !     !- water surface elevation
5150       iret = nf90_def_var(ncid, "wse", NF90_FLOAT, (/stationdim/), varid)
5151       iret = nf90_put_att(ncid, varid, 'units', 'meters')
5152       iret = nf90_put_att(ncid, varid, 'long_name', 'Water Surface Elevation')
5153
5154 !     !- inflow to lake
5155       iret = nf90_def_var(ncid, "inflow", NF90_FLOAT, (/stationdim/), varid)
5156       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
5157
5158 !     !- outflow to lake
5159       iret = nf90_def_var(ncid, "outflow", NF90_FLOAT, (/stationdim/), varid)
5160       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
5161
5162       ! Time variable
5163       iret = nf90_def_var(ncid, "time", NF90_INT, (/timeDim/), varid)
5164       iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
5165       iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
5166
5167         date19(1:19) = "0000-00-00_00:00:00"
5168         date19(1:len_trim(startdate)) = startdate
5169 !#ifndef HYDRO_REALTIME
5170         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
5171         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
5172         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
5173         iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
5174 !#endif
5175         iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5176         iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
5177         iret = nf90_enddef(ncid)
5178
5179         iret = nf90_inq_varid(ncid,"time", varid)
5180         iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
5181
5182 !#ifndef HYDRO_REALTIME
5183         !-- write latitudes
5184         iret = nf90_inq_varid(ncid,"latitude", varid)
5185         iret = nf90_put_var(ncid, varid, LATLAKE, (/1/), (/NLAKES/))
5186
5187         !-- write longitudes
5188         iret = nf90_inq_varid(ncid,"longitude", varid)
5189         iret = nf90_put_var(ncid, varid, LONLAKE, (/1/), (/NLAKES/))
5190
5191         !-- write physical height of lake
5192 !       iret = nf90_inq_varid(ncid,"altitude", varid)
5193 !       iret = nf90_put_var(ncid, varid, elevlake, (/1/), (/NLAKES/))
5194 !#endif
5195
5196         !-- write elevation  of lake
5197         iret = nf90_inq_varid(ncid,"wse", varid)
5198         iret = nf90_put_var(ncid, varid, resht, (/1/), (/NLAKES/))
5199
5200         !-- write elevation  of inflow
5201         iret = nf90_inq_varid(ncid,"inflow", varid)
5202         iret = nf90_put_var(ncid, varid, qlakei, (/1/), (/NLAKES/))
5203
5204         !-- write elevation  of inflow
5205         iret = nf90_inq_varid(ncid,"outflow", varid)
5206         iret = nf90_put_var(ncid, varid, qlakeo, (/1/), (/NLAKES/))
5207
5208         !-- write lake id
5209         iret = nf90_inq_varid(ncid,"lake_id", varid)
5210         iret = nf90_put_var(ncid, varid, LAKEIDM, (/1/), (/NLAKES/))
5211
5212      endif
5213
5214      output_count = output_count + 1
5215
5216     iret = nf90_redef(ncid)
5217     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5218     iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
5219     iret = nf90_enddef(ncid)
5220
5221     iret = nf90_sync(ncid)
5222      if (output_count == split_output_count) then
5223         output_count = 0
5224         iret = nf90_close(ncid)
5225      endif
5226
5227  end subroutine output_lakes2
5228 !----------------------------------- lake netcdf output
5229
5230 #ifdef MPP_LAND
5231
5232 !-- output the channel route in an IDV 'grid' compatible format
5233    subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
5234         NLINKS,CH_NETLNK_in, startdate, date, &
5235         qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt )
5236
5237    USE module_mpp_land
5238
5239      implicit none
5240      integer g_ixrt,g_jxrt
5241      integer,                                  intent(in) :: igrid
5242      integer,                                  intent(in) :: split_output_count
5243      integer,                                  intent(in) :: NLINKS,ixrt,jxrt
5244      real,                                     intent(in) :: dt
5245      real, dimension(:,:),                intent(in) :: qlink
5246      integer(kind=int64), dimension(IXRT,JXRT),            intent(in) :: CH_NETLNK_in
5247      character(len=*),          intent(in)     :: geo_finegrid_flnm
5248      character(len=*),                         intent(in) :: startdate
5249      character(len=*),                         intent(in) :: date
5250
5251      integer::  gnlinks , map_l2g(nlinks)
5252
5253      integer(kind=int64), allocatable,dimension(:,:)         :: CH_NETLNK
5254      real, allocatable,dimension(:,:)                :: g_qlink
5255
5256      if(my_id .eq. io_id) then
5257         allocate(CH_NETLNK(g_IXRT,g_JXRT))
5258         allocate(g_qlink(gNLINKS,2) )
5259      else
5260         allocate(CH_NETLNK(1,1))
5261         allocate(g_qlink(1,2) )
5262      endif
5263
5264      call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
5265      call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
5266
5267      call write_IO_rt_int8(CH_NETLNK_in, CH_NETLNK)
5268
5269     if(my_id.eq.IO_id) then
5270         call  output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, &
5271            GNLINKS, CH_NETLNK, startdate, date, &
5272            g_qlink, dt, geo_finegrid_flnm)
5273     endif
5274
5275      if(allocated(g_qlink)) deallocate(g_qlink)
5276      if(allocated(CH_NETLNK)) deallocate(CH_NETLNK)
5277      return
5278      end subroutine mpp_output_chrtgrd
5279 #endif
5280
5281 !-- output the channel route in an IDV 'grid' compatible format
5282    subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
5283         NLINKS, CH_NETLNK, startdate, date, &
5284         qlink, dt, geo_finegrid_flnm)
5285
5286      integer,                                  intent(in) :: igrid
5287      integer,                                  intent(in) :: split_output_count
5288      integer,                                  intent(in) :: NLINKS,ixrt,jxrt
5289      real,                                     intent(in) :: dt
5290      real, dimension(:,:),                intent(in) :: qlink
5291      integer(kind=int64), dimension(IXRT,JXRT), intent(in) :: CH_NETLNK
5292      character(len=*),          intent(in)     :: geo_finegrid_flnm
5293      character(len=*),                         intent(in) :: startdate
5294      character(len=*),                         intent(in) :: date
5295      character(len=32)  :: convention
5296      integer,save  :: output_count
5297      integer, save :: ncid,ncstatic
5298      real, dimension(IXRT,JXRT)          :: tmpflow
5299      real, dimension(IXRT)            :: xcoord
5300      real, dimension(JXRT)            :: ycoord
5301      real                                :: long_cm,lat_po,fe,fn
5302      real, dimension(2)                  :: sp
5303
5304     integer :: varid, n
5305     integer :: jxlatdim,ixlondim,timedim !-- dimension ids
5306     integer :: timedim2
5307     character(len=34) :: sec_valid_date
5308
5309     integer :: iret,i,j
5310     character(len=256) :: output_flnm
5311     character(len=19)  :: date19
5312     character(len=34)  :: sec_since_date
5313
5314
5315     integer :: seconds_since
5316
5317     seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
5318     sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
5319                  //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
5320
5321
5322       tmpflow = -9E15
5323
5324
5325         write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
5326 #ifdef HYDRO_D
5327         print*, 'output_flnm = "'//trim(output_flnm)//'"'
5328 #endif
5329
5330
5331 !--- define dimension
5332         iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5333         if (iret /= 0) then
5334            call hydro_stop("In output_chrtgrd() - Problem nf90_create")
5335         endif
5336
5337         iret = nf90_def_dim(ncid, "time", NF90_UNLIMITED, timedim)
5338         iret = nf90_def_dim(ncid, "x", ixrt, ixlondim)
5339         iret = nf90_def_dim(ncid, "y", jxrt, jxlatdim)
5340
5341 !--- define variables
5342 !     !- time definition, timeObs
5343
5344        !- x-coordinate in cartesian system
5345 !yw         iret = nf90_def_var(ncid, "x", NF90_DOUBLE, (/ixlondim/), varid)
5346 !yw         iret = nf90_put_att(ncid, varid, 'long_name', 'x coordinate of projection')
5347 !yw         iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_x_coordinate')
5348 !yw         iret = nf90_put_att(ncid, varid, 'units', 'Meter')
5349
5350        !- y-coordinate in cartesian ssystem
5351 !yw         iret = nf90_def_var(ncid, "y", NF90_DOUBLE, (/jxlatdim/), varid)
5352 !yw         iret = nf90_put_att(ncid, varid, 'long_name', 'y coordinate of projection')
5353 !yw         iret = nf90_put_att(ncid, varid, 'standard_name', 'projection_y_coordinate')
5354 !yw         iret = nf90_put_att(ncid, varid, 'units', 'Meter')
5355
5356 !     !- flow definition, var
5357         iret = nf90_def_var(ncid, "streamflow", NF90_REAL, (/ixlondim,jxlatdim,timedim/), varid)
5358         iret = nf90_put_att(ncid, varid, 'units', 'm3 s-1')
5359         iret = nf90_put_att(ncid, varid, 'long_name', 'water flow rate')
5360         iret = nf90_put_att(ncid, varid, 'coordinates', 'x y')
5361         iret = nf90_put_att(ncid, varid, 'grid_mapping', 'lambert_conformal_conic')
5362         iret = nf90_put_att(ncid, varid, 'missing_value', -9E15)
5363         iret = nf90_def_var(ncid, "index", NF90_INT, (/ixlondim,jxlatdim/), varid)
5364         iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
5365         iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
5366         iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
5367
5368
5369 !-- place prjection information
5370
5371
5372       date19(1:19) = "0000-00-00_00:00:00"
5373       date19(1:len_trim(startdate)) = startdate
5374       convention(1:32) = "CF-1.0"
5375       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
5376       iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
5377       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
5378       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
5379       iret = nf90_enddef(ncid)
5380
5381       iret = nf90_inq_varid(ncid,"time", varid)
5382       iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
5383
5384 !!-- write latitude and longitude locations
5385
5386 !DJG inv    do j=jxrt,1,-1
5387     do j=1,jxrt
5388      do i=1,ixrt
5389        if(CH_NETLNK(i,j).GE.0) then
5390          tmpflow(i,j) = qlink(CH_NETLNK(i,j),1)
5391        else
5392          tmpflow(i,j) = -9E15
5393        endif
5394      enddo
5395     enddo
5396
5397 !!time in seconds since startdate
5398     iret = nf90_inq_varid(ncid,"index", varid)
5399     iret = nf90_put_var(ncid, varid, CH_NETLNK, (/1,1/), (/ixrt,jxrt/))
5400
5401     iret = nf90_inq_varid(ncid,"streamflow", varid)
5402     iret = nf90_put_var(ncid, varid, tmpflow, (/1,1,1/), (/ixrt,jxrt,1/))
5403
5404     iret = nf90_close(ncid)
5405
5406
5407
5408  end subroutine output_chrtgrd
5409
5410
5411  subroutine read_chan_forcing( &
5412        indir,olddate,startdate,hgrid,&
5413        ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT)
5414 ! This subrouting is going to read channel forcing for
5415 !  the old, channel-only simulations (ie when CHANRTSWCRT = 2)
5416 !  forced by RTOUT_DOMAIN files.
5417
5418    implicit none
5419    ! in variable
5420    character(len=*) :: olddate,hgrid,indir,startdate
5421    character(len=256) :: filename
5422    integer :: ixrt,jxrt
5423    real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT
5424    ! tmp variable
5425    character(len=256) :: inflnm, product
5426    integer  :: i,j,mmflag
5427    character(len=256) :: units
5428    integer :: ierr
5429    integer :: ncid
5430
5431
5432 !DJG Create filename...
5433         inflnm = trim(indir)//"/"//&
5434              olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
5435              olddate(15:16)//".RTOUT_DOMAIN"//hgrid
5436 #ifdef HYDRO_D
5437         print *, "Channel forcing file...",inflnm
5438 #endif
5439
5440
5441 !DJG Open NetCDF file...
5442     ierr = nf90_open(inflnm, NF90_NOWRITE, ncid)
5443     if (ierr /= 0) then
5444        write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm)
5445        call hydro_stop("In read_chan_forcing() - Problem opening netcdf file")
5446     endif
5447
5448 !DJG read data...
5449     call get_2d_netcdf("QSTRMVOLRT",  ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr)
5450 !DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
5451 !DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
5452
5453     ierr = nf90_close(ncid)
5454
5455  end subroutine read_chan_forcing
5456
5457
5458
5459  subroutine get2d_int(var_name,out_buff,ix,jx,fileName, fatalErr)
5460     implicit none
5461     integer :: iret,varid,ncid,ix,jx
5462     integer out_buff(ix,jx)
5463     character(len=*), intent(in) :: var_name
5464     character(len=*), intent(in) :: fileName
5465     logical, optional, intent(in) :: fatalErr
5466     logical :: fatalErr_local
5467     character(len=256) :: errMsg
5468
5469     fatalErr_local = .false.
5470     if(present(fatalErr)) fatalErr_local=fatalErr
5471
5472     iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid)
5473     if (iret .ne. 0) then
5474        errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName)
5475        print*, trim(errMsg)
5476        if(fatalErr_local) call hydro_stop(trim(errMsg))
5477     endif
5478
5479     iret = nf90_inq_varid(ncid,trim(var_name),  varid)
5480     if(iret .ne. 0) then
5481        errMsg = "get2d_int: failed to find the variable: " // &
5482                  trim(var_name) // ' in ' // trim(fileName)
5483        print*, trim(errMsg)
5484        if(fatalErr_local) call hydro_stop(errMsg)
5485     endif
5486
5487     iret = nf90_get_var(ncid, varid, out_buff)
5488     if(iret .ne. 0) then
5489        errMsg = "get2d_int: failed to read the variable: " // &
5490                 trim(var_name) // " in " //trim(fileName)
5491        print*,trim(errMsg)
5492        if(fatalErr_local) call hydro_stop(trim(errMsg))
5493     endif
5494
5495     iret = nf90_close(ncid)
5496     if(iret .ne. 0) then
5497        errMsg = "get2d_int: failed to close the file: " // &
5498                 trim(fileName)
5499        print*,trim(errMsg)
5500        if(fatalErr_local) call hydro_stop(trim(errMsg))
5501     endif
5502
5503     return
5504   end subroutine get2d_int
5505
5506     subroutine get2d_int8(var_name,out_buff,ix,jx,fileName, fatalErr)
5507         implicit none
5508         integer :: iret,varid,ncid,ix,jx
5509         integer(kind=int64) out_buff(ix,jx)
5510         character(len=*), intent(in) :: var_name
5511         character(len=*), intent(in) :: fileName
5512         logical, optional, intent(in) :: fatalErr
5513         logical :: fatalErr_local
5514         character(len=256) :: errMsg
5515
5516         fatalErr_local = .false.
5517         if(present(fatalErr)) fatalErr_local=fatalErr
5518
5519         iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid)
5520         if (iret .ne. 0) then
5521             errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName)
5522             print*, trim(errMsg)
5523             if(fatalErr_local) call hydro_stop(trim(errMsg))
5524         endif
5525
5526         iret = nf90_inq_varid(ncid,trim(var_name),  varid)
5527         if(iret .ne. 0) then
5528             errMsg = "get2d_int: failed to find the variable: " // &
5529                     trim(var_name) // ' in ' // trim(fileName)
5530             print*, trim(errMsg)
5531             if(fatalErr_local) call hydro_stop(errMsg)
5532         endif
5533
5534         iret = nf90_get_var(ncid, varid, out_buff)
5535         if(iret .ne. 0) then
5536             errMsg = "get2d_int: failed to read the variable: " // &
5537                     trim(var_name) // " in " //trim(fileName)
5538             print*,trim(errMsg)
5539             if(fatalErr_local) call hydro_stop(trim(errMsg))
5540         endif
5541
5542         iret = nf90_close(ncid)
5543         if(iret .ne. 0) then
5544             errMsg = "get2d_int: failed to close the file: " // &
5545                     trim(fileName)
5546             print*,trim(errMsg)
5547             if(fatalErr_local) call hydro_stop(trim(errMsg))
5548         endif
5549
5550         return
5551     end subroutine get2d_int8
5552
5553 #ifdef MPP_LAND
5554       SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, &
5555             route_chan_f,route_link_f, &
5556             route_direction_f, NLINKS, &
5557             CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT,NLAKES)
5558
5559          USE module_mpp_land
5560
5561          implicit none
5562         INTEGER                                      :: channel_option, did
5563         INTEGER                                      :: g_IXRT,g_JXRT
5564         INTEGER, INTENT(INOUT)                       :: NLINKS, GNLINKS,NLINKSL
5565         INTEGER, INTENT(IN)                          :: IXRT,JXRT
5566         INTEGER                                      :: CHNID,cnt
5567         INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT   !- binary channel mask
5568         INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK  !- each node gets unique id
5569         INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK  !- each node gets unique id based on global domain
5570         ! INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK  ! temp array
5571         INTEGER, allocatable,DIMENSION(:,:) :: g_CH_NETLNK  ! temp array
5572         INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION  !- flow direction
5573         INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT
5574         REAL, DIMENSION(IXRT,JXRT)                   :: LAT, LON
5575         INTEGER, INTENT(IN)                          :: UDMP_OPT
5576         integer:: i,j, NLAKES
5577
5578         CHARACTER(len=*)       :: route_chan_f, route_link_f,route_direction_f
5579         CHARACTER(len=*)       :: geo_finegrid_flnm
5580 !       CHARACTER(len=*)       :: geo_finegrid_flnm
5581
5582 !       integer, allocatable, dimension(:) :: tmp_int
5583         integer :: ywcount
5584
5585
5586
5587         if(my_id .eq. IO_id) then
5588            allocate(g_CH_NETLNK(g_IXRT,g_JXRT))
5589            g_CH_NETLNK = -9999
5590            CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, &
5591               route_direction_f, GNLINKS, &
5592               g_CH_NETLNK, channel_option,geo_finegrid_flnm,NLINKSL, UDMP_OPT,nlakes)
5593            call get_NLINKSL(NLINKSL, channel_option, route_link_f)
5594         else
5595            allocate(g_CH_NETLNK(1,1))
5596         endif
5597
5598         call mpp_land_bcast_int1(GNLINKS)
5599         call mpp_land_bcast_int1(NLINKSL)
5600         call mpp_land_bcast_int1(NLAKES)
5601
5602
5603         call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt)
5604         if(allocated(g_CH_NETLNK)) deallocate(g_CH_NETLNK)
5605         ywcount = 0
5606         CH_NETLNK = -9999
5607         do j = 1, jxrt
5608            do i = 1, ixrt
5609                   if(GCH_NETLNK(i,j) .gt. 0) then
5610                        ywcount = ywcount + 1
5611                        CH_NETLNK(i,j) = ywcount
5612                   endif
5613            end do
5614         end do
5615         NLINKS = ywcount
5616
5617
5618 !ywcheck
5619 !        CH_NETLNK = GCH_NETLNK
5620
5621
5622         allocate(rt_domain(did)%map_l2g(NLINKS))
5623
5624         rt_domain(did)%map_l2g = -1
5625         do j = 1, jxrt
5626            do i = 1, ixrt
5627               if(CH_NETLNK(i,j) .gt. 0) then
5628                   rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j)
5629               endif
5630            end do
5631         end do
5632
5633         call mpp_chrt_nlinks_collect(NLINKS)
5634         return
5635
5636       end SUBROUTINE MPP_READ_ROUTEDIM
5637
5638
5639
5640
5641 #endif
5642
5643       SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo_f,    &
5644             route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC,IMPERVFRAC, &
5645             channel_option, UDMP_OPT, imperv_adj)
5646
5647
5648         INTEGER, INTENT(IN) :: IXRT,JXRT
5649         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC
5650         INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT
5651         INTEGER(kind=int64), INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_LNKRT
5652 !Dummy inverted grids
5653         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC
5654         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC
5655         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: IMPERVFRAC
5656
5657         integer         :: I,J, iret, jj, channel_option, UDMP_OPT, imperv_adj
5658         CHARACTER(len=256)        :: var_name
5659         CHARACTER(len=*  )       :: route_topo_f
5660         CHARACTER(len=*  )       :: route_chan_f
5661         CHARACTER(len=*  )       :: geo_finegrid_flnm
5662
5663         var_name = "TOPOGRAPHY"
5664
5665         call nreadRT2d_real(var_name,ELRT,ixrt,jxrt,&
5666                      trim(geo_finegrid_flnm))
5667
5668      IF(channel_option .ne. 3 .and. UDMP_OPT .ne. 1) then  !get maxnodes and links from grid
5669         var_name = "LINKID"
5670         call nreadRT2d_int8(var_name,CH_LNKRT,ixrt,jxrt,&
5671                trim(geo_finegrid_flnm), fatalErr=.true.)
5672      endif
5673
5674
5675
5676 #ifdef HYDRO_D
5677         write(6,*) "read linkid grid CH_LNKRT ",var_name
5678 #endif
5679
5680 !!!DY to be fixed ... 6/27/08
5681 !        var_name = "BED_ELEVATION"
5682 !        iret = get2d_real(var_name,ELRT,ixrt,jxrt,&
5683 !                     trim(geo_finegrid_flnm))
5684
5685         var_name = "CHANNELGRID"
5686         call nreadRT2d_int(var_name,CH_NETRT,ixrt,jxrt,&
5687                trim(geo_finegrid_flnm))
5688
5689 #ifdef HYDRO_D
5690         write(6,*) "read ",var_name
5691 #endif
5692
5693         var_name = "LKSATFAC"
5694         LKSATFAC = -9999.9
5695         call nreadRT2d_real(var_name,LKSATFAC,ixrt,jxrt,&
5696                trim(geo_finegrid_flnm))
5697
5698 #ifdef HYDRO_D
5699         write(6,*) "read ",var_name
5700 #endif
5701
5702            where (LKSATFAC == -9999.9) LKSATFAC = 1000.0  !specify LKSAFAC if no term avail...
5703
5704
5705 !1.12.2012...Read in routing calibration factors...
5706         var_name = "RETDEPRTFAC"
5707         call nreadRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,&
5708                      trim(geo_finegrid_flnm))
5709         where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0  ! reset grid to = 1.0 if non-valid value exists
5710
5711         var_name = "OVROUGHRTFAC"
5712         call nreadRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,&
5713                      trim(geo_finegrid_flnm))
5714         where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists
5715
5716 !Read in new optional impervious layer
5717         var_name = "IMPERVFRAC"
5718         IMPERVFRAC = -9999.9
5719         if (imperv_adj > 0) then
5720           call nreadRT2d_real(var_name,IMPERVFRAC,ixrt,jxrt,&
5721                      trim(geo_finegrid_flnm), fatalErr=.true.)
5722           where (IMPERVFRAC < 0.) IMPERVFRAC = 0.0  ! reset grid to = 0.0 if non-valid value exists
5723         else
5724           IMPERVFRAC = 0.0
5725         endif
5726
5727 #ifdef HYDRO_D
5728         write(6,*) "finish READ_ROUTING_seq"
5729 #endif
5730
5731         return
5732
5733 !DJG -----------------------------------------------------
5734    END SUBROUTINE READ_ROUTING_seq
5735
5736 !DJG _____________________________
5737    subroutine output_lsm(outFile,did)
5738
5739
5740    implicit none
5741
5742    integer did
5743
5744    character(len=*) outFile
5745
5746     integer :: ncid,irt, dimid_ix, dimid_jx,  &
5747              dimid_ixrt, dimid_jxrt, varid, &
5748              dimid_links, dimid_basns, dimid_soil
5749     integer :: iret, n
5750     character(len=2) tmpStr
5751
5752
5753
5754 #ifdef MPP_LAND
5755      if(IO_id.eq.my_id) &
5756 #endif
5757
5758        iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5759
5760 #ifdef MPP_LAND
5761        call mpp_land_bcast_int1(iret)
5762 #endif
5763
5764        if (iret /= 0) then
5765           call hydro_stop("In output_lsm() - Problem nf90_create")
5766        endif
5767
5768
5769 #ifdef MPP_LAND
5770      if(IO_id.eq.my_id) then
5771 #endif
5772 #ifdef HYDRO_D
5773          write(6,*) "output file ", outFile
5774 #endif
5775 ! define dimension for variables
5776           iret = nf90_def_dim(ncid, "depth", nlst(did)%nsoil, dimid_soil)  !-- 3-d soils
5777 #ifdef MPP_LAND
5778           iret = nf90_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
5779           iret = nf90_def_dim(ncid, "iy", global_ny, dimid_jx)
5780 #else
5781           iret = nf90_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
5782           iret = nf90_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
5783 #endif
5784
5785 !define variables
5786           do n = 1, nlst(did)%nsoil
5787              if( n .lt. 10) then
5788                 write(tmpStr, '(i1)') n
5789              else
5790                 write(tmpStr, '(i2)') n
5791              endif
5792              iret = nf90_def_var(ncid, "stc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5793              iret = nf90_def_var(ncid, "smc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5794              iret = nf90_def_var(ncid, "sh2ox"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5795           end do
5796
5797           !iret = nf90_def_var(ncid, "smcmax1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5798           !iret = nf90_def_var(ncid, "smcref1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5799           !iret = nf90_def_var(ncid, "smcwlt1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5800           iret = nf90_def_var(ncid, "infxsrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5801           iret = nf90_def_var(ncid, "sfcheadrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5802
5803           iret = nf90_enddef(ncid)
5804
5805 #ifdef MPP_LAND
5806     endif
5807 #endif
5808         call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc")
5809         call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc")
5810         call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
5811         !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
5812         !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
5813         !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  )
5814         call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  )
5815         call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt" )
5816
5817
5818 #ifdef MPP_LAND
5819      if(IO_id.eq.my_id) then
5820 #endif
5821
5822         iret = nf90_close(ncid)
5823 #ifdef HYDRO_D
5824         write(6,*) "finish writing outFile : ", outFile
5825 #endif
5826
5827 #ifdef MPP_LAND
5828     endif
5829 #endif
5830
5831         return
5832         end subroutine output_lsm
5833
5834
5835    subroutine RESTART_OUT_nc(outFile,did)
5836
5837
5838    implicit none
5839
5840    integer did
5841    integer :: n
5842    character(len=2) :: tmpStr
5843    character(len=*) outFile
5844
5845     integer :: ncid,irt, dimid_ix, dimid_jx,  &
5846              dimid_ixrt, dimid_jxrt, varid, &
5847              dimid_links, dimid_basns, dimid_soil, dimid_lakes
5848     integer :: iret
5849
5850
5851 #ifdef MPP_LAND
5852      if(IO_id.eq.my_id) &
5853 #endif
5854
5855        iret = nf90_create(trim(outFile), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
5856
5857 #ifdef MPP_LAND
5858        call mpp_land_bcast_int1(iret)
5859 #endif
5860
5861        if (iret /= 0) then
5862           call hydro_stop("In RESTART_OUT_nc() - Problem nf90_create")
5863        endif
5864
5865 #ifdef MPP_LAND
5866      if(IO_id.eq.my_id) then
5867 #endif
5868
5869    if( nlst(did)%channel_only       .eq. 0 .and. &
5870        nlst(did)%channelBucket_only .eq. 0         ) then
5871
5872 ! define dimension for variables
5873           iret = nf90_def_dim(ncid, "depth", nlst(did)%nsoil, dimid_soil)  !-- 3-d soils
5874 #ifdef MPP_LAND
5875           iret = nf90_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
5876           iret = nf90_def_dim(ncid, "iy", global_ny, dimid_jx)
5877           iret = nf90_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt)  !-- make a decimated grid
5878           iret = nf90_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt)
5879 #else
5880           iret = nf90_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
5881           iret = nf90_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
5882           iret = nf90_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt)  !-- make a decimated grid
5883           iret = nf90_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt)
5884 #endif
5885
5886        endif ! neither channel_only nor channelBucket_only
5887
5888        if(nlst(did)%channel_option .eq. 3) then
5889           iret = nf90_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links)
5890        else
5891           iret = nf90_def_dim(ncid, "links", rt_domain(did)%gnlinksl, dimid_links)
5892        endif
5893        iret = nf90_def_dim(ncid, "basns", rt_domain(did)%gnumbasns, dimid_basns)
5894        if(rt_domain(did)%nlakes .gt. 0) then
5895           iret = nf90_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes)
5896        endif
5897
5898        !define variables
5899        if( nlst(did)%channel_only       .eq. 0 .and. &
5900             nlst(did)%channelBucket_only .eq. 0         ) then
5901
5902           do n = 1, nlst(did)%nsoil
5903              if( n .lt. 10) then
5904                 write(tmpStr, '(i1)') n
5905              else
5906                 write(tmpStr, '(i2)') n
5907              endif
5908              iret = nf90_def_var(ncid, "stc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5909              iret = nf90_def_var(ncid, "smc"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5910              iret = nf90_def_var(ncid, "sh2ox"//trim(tmpStr), NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5911           end do
5912
5913           !iret = nf90_def_var(ncid, "smcmax1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5914           !iret = nf90_def_var(ncid, "smcref1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5915           !iret = nf90_def_var(ncid, "smcwlt1", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5916           iret = nf90_def_var(ncid, "infxsrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5917           iret = nf90_def_var(ncid, "soldrain", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5918           iret = nf90_def_var(ncid, "sfcheadrt", NF90_FLOAT, (/dimid_ix,dimid_jx/), varid)
5919
5920        end if  ! neither channel_only nor channelBucket_only
5921
5922    if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
5923       nlst(did)%OVRTSWCRT   .eq. 1 .or. &
5924       nlst(did)%GWBASESWCRT .ne. 0       ) then
5925
5926       if( nlst(did)%channel_only       .eq. 0 .and. &
5927            nlst(did)%channelBucket_only .eq. 0         ) then
5928
5929             iret = nf90_def_var(ncid, "QBDRYRT", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5930             iret = nf90_def_var(ncid, "infxswgt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5931             iret = nf90_def_var(ncid, "sfcheadsubrt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5932           do n = 1, nlst(did)%nsoil
5933              if( n .lt. 10) then
5934                 write(tmpStr, '(i1)') n
5935              else
5936                 write(tmpStr, '(i2)') n
5937              endif
5938              iret = nf90_def_var(ncid, "sh2owgt"//trim(tmpStr), NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5939           end do
5940             iret = nf90_def_var(ncid, "qstrmvolrt", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5941             !AD_CHANGE: Not needed in RESTART
5942             !iret = nf90_def_var(ncid, "RETDEPRT", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5943
5944       end if  ! neither channel_only nor channelBucket_only
5945
5946       if(nlst(did)%CHANRTSWCRT.eq.1) then
5947
5948 !yw based on Laura request, hlink will do the restart for reach method.
5949 !         if(nlst(did)%channel_option .eq. 3) &
5950          iret = nf90_def_var(ncid, "hlink", NF90_FLOAT, (/dimid_links/), varid)
5951          iret = nf90_def_var(ncid, "qlink1", NF90_FLOAT, (/dimid_links/), varid)
5952          iret = nf90_def_var(ncid, "qlink2", NF90_FLOAT, (/dimid_links/), varid)
5953          if(nlst(did)%channel_option .eq. 3) &
5954               iret = nf90_def_var(ncid, "cvol", NF90_FLOAT, (/dimid_links/), varid)
5955          if(rt_domain(did)%nlakes .gt. 0) then
5956             iret = nf90_def_var(ncid, "resht", NF90_FLOAT, (/dimid_lakes/), varid)
5957             iret = nf90_def_var(ncid, "qlakeo", NF90_FLOAT, (/dimid_lakes/), varid)
5958             iret = nf90_def_var(ncid, "qlakei", NF90_FLOAT, (/dimid_lakes/), varid)
5959          endif
5960
5961          if( nlst(did)%channel_only       .eq. 0 .and. &
5962              nlst(did)%channelBucket_only .eq. 0         ) &
5963              iret = nf90_def_var(ncid, "lake_inflort", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5964
5965          !! JLM: who wants these? They can be put back if someone cares.
5966          !! But just calculate accQLateral locally so the redundant variable isnt held in
5967          !! memory with all the other variables
5968          !if(nlst_rt(did)%UDMP_OPT .eq. 1) then
5969          !       iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/dimid_links/), varid)
5970          !       iret = nf90_def_var(ncid, "accQLateral", NF90_DOUBLE, (/dimid_links/), varid)
5971          !       iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_DOUBLE, (/dimid_links/), varid)
5972          !       iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/dimid_links/), varid)
5973          !endif
5974
5975       end if ! CHANRTSWCRT .eq. 1
5976
5977       if(nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.ge.4) then
5978
5979          if( nlst(did)%channel_only .eq. 0) then
5980
5981             if(nlst(did)%UDMP_OPT .eq. 1) then
5982                iret = nf90_def_var(ncid, "z_gwsubbas", NF90_FLOAT, (/dimid_links/), varid)
5983             else
5984                iret = nf90_def_var(ncid, "z_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid)
5985             endif
5986
5987          end if ! not channel_only : dont use buckets in channel only runs
5988
5989 !yw test bucket model
5990 !             iret = nf90_def_var(ncid, "gwbas_pix_ct", NF90_FLOAT, (/dimid_basns/), varid)
5991 !             iret = nf90_def_var(ncid, "gw_buck_exp", NF90_FLOAT, (/dimid_basns/), varid)
5992 !             iret = nf90_def_var(ncid, "z_max", NF90_FLOAT, (/dimid_basns/), varid)
5993 !             iret = nf90_def_var(ncid, "gw_buck_coeff", NF90_FLOAT, (/dimid_basns/), varid)
5994 !             iret = nf90_def_var(ncid, "qin_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid)
5995 !             iret = nf90_def_var(ncid, "qinflowbase", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
5996 !             iret = nf90_def_var(ncid, "qout_gwsubbas", NF90_FLOAT, (/dimid_basns/), varid)
5997       end if ! GWBASESWCRT .eq.1 .or. GWBASESWCRT .ge. 4
5998
5999       !! What is this option??
6000       if(nlst(did)%gwBaseSwCRT .eq. 3)then
6001          iret = nf90_def_var(ncid, "HEAD", NF90_FLOAT, (/dimid_ixrt,dimid_jxrt/), varid)
6002       end if
6003
6004    end if  !  end if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
6005 !                    nlst(did)%OVRTSWCRT   .eq. 1 .or. &
6006 !                    nlst(did)%GWBASESWCRT .ne. 0       )
6007
6008    !         put global attribute
6009    iret = nf90_put_att(ncid, NF90_GLOBAL, "his_out_counts", rt_domain(did)%his_out_counts)
6010    iret = nf90_put_att(ncid, NF90_GLOBAL, "Restart_Time", nlst(did)%olddate(1:19))
6011    iret = nf90_put_att(ncid, NF90_GLOBAL, "Since_Date", nlst(did)%sincedate(1:19))
6012    iret = nf90_put_att(ncid, NF90_GLOBAL, "DTCT", nlst(did)%DTCT)
6013    iret = nf90_put_att(ncid, NF90_GLOBAL, "channel_only", nlst(did)%channel_only)
6014    iret = nf90_put_att(ncid, NF90_GLOBAL, "channelBucket_only", nlst(did)%channelBucket_only)
6015
6016    !! end definition
6017    iret = nf90_enddef(ncid)
6018
6019
6020 #ifdef MPP_LAND
6021 endif  ! my_id .eq. io_id
6022 #endif
6023
6024 if( nlst(did)%channel_only       .eq. 0 .and. &
6025      nlst(did)%channelBucket_only .eq. 0         ) then
6026
6027    call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc")
6028    call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc")
6029    call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
6030
6031    !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
6032    !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
6033    !call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  )
6034    call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  )
6035    call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain"  )
6036    call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt"  )
6037
6038 end if ! neither channel_only nor channelBucket_only
6039
6040 if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
6041    nlst(did)%OVRTSWCRT   .eq. 1 .or. &
6042    nlst(did)%GWBASESWCRT .ne. 0       ) then
6043
6044    if( nlst(did)%channel_only       .eq. 0 .and. &
6045        nlst(did)%channelBucket_only .eq. 0         ) then
6046       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%boundary_flux, "QBDRYRT" )
6047       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" )
6048       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%surface_water_head_routing, "sfcheadsubrt" )
6049       call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" )
6050       call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT_ACC, "qstrmvolrt" )
6051       !AD_CHANGE: Not needed in RESTART
6052       !call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%properties%retention_depth, "RETDEPRT" )
6053    end if ! neither channel_only nor channelBucket_only
6054
6055    if(nlst(did)%CHANRTSWCRT.eq.1) then
6056
6057
6058       if(nlst(did)%channel_option .eq. 3) then
6059          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" &
6060 #ifdef MPP_LAND
6061               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6062 #endif
6063               )
6064       else
6065          call w_rst_crt_reach(ncid,rt_domain(did)%HLINK, "hlink"  &
6066 #ifdef MPP_LAND
6067               ,rt_domain(did)%gnlinksl&
6068 #endif
6069               )
6070         !call checkReach(99,rt_domain(did)%HLINK)
6071       endif
6072
6073       if(nlst(did)%channel_option .eq. 3) then
6074          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" &
6075 #ifdef MPP_LAND
6076               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6077 #endif
6078               )
6079       else
6080          call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,1), "qlink1"  &
6081 #ifdef MPP_LAND
6082               ,rt_domain(did)%gnlinksl &
6083 #endif
6084               )
6085       endif
6086
6087       if(nlst(did)%channel_option .eq. 3) then
6088          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" &
6089 #ifdef MPP_LAND
6090               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6091 #endif
6092               )
6093       else
6094          call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,2), "qlink2"  &
6095 #ifdef MPP_LAND
6096               ,rt_domain(did)%gnlinksl &
6097 #endif
6098               )
6099
6100 !! JLM If someone really wants the accumulated fluxes in the restart file, you can add them back.
6101 !! But Calculate accQLateral locally
6102 !                    if(nlst_rt(did)%UDMP_OPT .eq. 1) then
6103 !                        call w_rst_crt_reach(ncid,rt_domain(did)%accSfcLatRunoff, "accSfcLatRunoff"  &
6104 !#ifdef MPP_LAND
6105 !                                ,rt_domain(did)%gnlinksl &
6106 !#endif
6107 !                              )
6108 !                        call w_rst_crt_reach(ncid,rt_domain(did)%accQLateral, "accQLateral"  &
6109 !#ifdef MPP_LAND
6110 !                                ,rt_domain(did)%gnlinksl &
6111 !#endif
6112 !                              )
6113 !                        call w_rst_crt_reach(ncid,rt_domain(did)%qSfcLatRunoff, "qSfcLatRunoff"  &
6114 !#ifdef MPP_LAND
6115 !                                ,rt_domain(did)%gnlinksl &
6116 !#endif
6117 !                              )
6118 !                        call w_rst_crt_reach(ncid,rt_domain(did)%accBucket, "accBucket"  &
6119 !#ifdef MPP_LAND
6120 !                                ,rt_domain(did)%gnlinksl &
6121 !#endif
6122 !                              )
6123 !                    endif   ! end if of UDMP_OPT .eq. 1
6124       endif  ! channel_option .eq. 3
6125
6126
6127       !! Cvol is not prognostic for Musk-cunge.
6128       if(nlst(did)%channel_option .eq. 3) then
6129          call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" &
6130 #ifdef MPP_LAND
6131               ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6132 #endif
6133               )
6134 !      else
6135 !         call w_rst_crt_reach(ncid,rt_domain(did)%cvol, "cvol"  &
6136 !#ifdef MPP_LAND
6137 !              ,rt_domain(did)%gnlinksl &
6138 !#endif
6139 !              )
6140       endif
6141
6142
6143 !              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" &
6144 !#ifdef MPP_LAND
6145 !                 ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
6146 !#endif
6147 !                  )
6148
6149
6150       call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" &
6151 #ifdef MPP_LAND
6152            ,rt_domain(did)%lake_index  &
6153 #endif
6154            )
6155
6156       call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" &
6157 #ifdef MPP_LAND
6158            ,rt_domain(did)%lake_index  &
6159 #endif
6160            )
6161
6162       call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakei,"qlakei" &
6163 #ifdef MPP_LAND
6164            ,rt_domain(did)%lake_index  &
6165 #endif
6166            )
6167
6168       if( nlst(did)%channel_only       .eq. 0 .and. &
6169           nlst(did)%channelBucket_only .eq. 0         ) &
6170
6171           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")
6172
6173    end if  !    if(nlst_rt(did)%CHANRTSWCRT.eq.1)
6174
6175    if(nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.ge.4) then
6176
6177       !call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" )
6178       if( nlst(did)%channel_only .eq. 0) then
6179
6180          if(nlst(did)%UDMP_OPT .eq. 1) then
6181
6182             call w_rst_crt_reach(ncid,rt_domain(did)%z_gwsubbas, "z_gwsubbas"  &
6183 #ifdef MPP_LAND
6184                  ,rt_domain(did)%gnlinksl  &
6185 #endif
6186                  )
6187          else
6188             call w_rst_gwbucket_real(ncid,rt_domain(did)%numbasns,rt_domain(did)%gnumbasns, &
6189                  rt_domain(did)%basnsInd, rt_domain(did)%z_gwsubbas,"z_gwsubbas" )
6190          endif
6191
6192       end if ! not channel_only : dont use buckets in channel only runs
6193
6194 !yw test bucket model
6195 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" )
6196 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" )
6197 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" )
6198 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" )
6199 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" )
6200 !             call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase")
6201 !             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" )
6202    end if ! GWBASESWCRT .eq. 1 .or. GWBASESWCRT .ge. 4
6203
6204    if(nlst(did)%GWBASESWCRT.eq.3) then
6205       if( nlst(did)%channel_only       .eq. 0 .and. &
6206           nlst(did)%channelBucket_only .eq. 0         ) &
6207           call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho, "HEAD" )
6208    end if
6209
6210 end if  ! end if(nlst_rt(did)%SUBRTSWCRT  .eq. 1 .or. &
6211 !                nlst_rt(did)%OVRTSWCRT   .eq. 1 .or. &
6212 !                nlst_rt(did)%GWBASESWCRT .ne. 0       )
6213
6214
6215 #ifdef MPP_LAND
6216         if(IO_id.eq.my_id) &
6217 #endif
6218         iret = nf90_close(ncid)
6219
6220         return
6221         end subroutine RESTART_OUT_nc
6222
6223 #ifdef MPP_LAND
6224
6225    subroutine RESTART_OUT_bi(outFile,did)
6226
6227
6228    implicit none
6229
6230    integer did
6231
6232    character(len=*) outFile
6233
6234     integer :: iunit
6235     integer  :: i0,ie, i, istep, mkdirStatus
6236
6237
6238     call mpp_land_sync()
6239
6240     iunit = 81
6241  istep = 64
6242  i0 = 0
6243  ie = istep
6244  do i = 0, numprocs,istep
6245    if(my_id .ge. i0 .and. my_id .lt. ie) then
6246      open(iunit, file = "restart/"//trim(outFile), form="unformatted",ERR=101, access="sequential")
6247           write(iunit,ERR=101) rt_domain(did)%his_out_counts
6248 !         write(iunit,ERR=101) nlst(did)%olddate(1:19)
6249           write(iunit,ERR=101) nlst(did)%sincedate(1:19)
6250 !         write(iunit,ERR=101) nlst_rt(did)%DTCT
6251           write(iunit,ERR=101) rt_domain(did)%stc
6252           write(iunit,ERR=101) rt_domain(did)%smc
6253           write(iunit,ERR=101) rt_domain(did)%sh2ox
6254           write(iunit,ERR=101) rt_domain(did)%SMCMAX1
6255           write(iunit,ERR=101) rt_domain(did)%SMCREF1
6256           write(iunit,ERR=101) rt_domain(did)%SMCWLT1
6257           write(iunit,ERR=101) rt_domain(did)%INFXSRT
6258           write(iunit,ERR=101) rt_domain(did)%soldrain
6259           write(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_lsm
6260
6261           if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1 .or. nlst(did)%GWBASESWCRT .ne. 0) then
6262                 if(nlst(did)%CHANRTSWCRT.EQ.1) then
6263                    write(iunit,ERR=101) rt_domain(did)%HLINK
6264                    write(iunit,ERR=101) rt_domain(did)%QLINK(:,1)
6265                    write(iunit,ERR=101) rt_domain(did)%QLINK(:,2)
6266                    write(iunit,ERR=101) rt_domain(did)%cvol
6267                    write(iunit,ERR=101) rt_domain(did)%resht
6268                    write(iunit,ERR=101) rt_domain(did)%qlakeo
6269                    write(iunit,ERR=101) rt_domain(did)%qlakei
6270                    write(iunit,ERR=101) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake
6271                 end if
6272
6273                 if(nlst(did)%GWBASESWCRT.EQ.1.OR.nlst(did)%GWBASESWCRT.GE.4) then
6274                      write(iunit,ERR=101) rt_domain(did)%z_gwsubbas
6275                 end if
6276                 if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1) then
6277                     write(iunit,ERR=101) rt_domain(did)%overland%control%boundary_flux
6278                     write(iunit,ERR=101) rt_domain(did)%INFXSWGT
6279                     write(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_routing
6280                     write(iunit,ERR=101) rt_domain(did)%SH2OWGT
6281                     write(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT_ACC
6282                     !AD_CHANGE: Not needed in RESTART
6283                     !write(iunit,ERR=101) rt_domain(did)%RETDEPRT
6284                 endif
6285           end if
6286
6287         close(iunit)
6288     endif
6289     call mpp_land_sync()
6290     i0 = i0 + istep
6291     ie = ie + istep
6292   end do ! end do of i loop
6293
6294         return
6295 101     continue
6296         call hydro_stop("FATAL ERROR: failed to output the hydro restart file.")
6297         end subroutine RESTART_OUT_bi
6298
6299    subroutine RESTART_in_bi(inFileTmp,did)
6300
6301
6302    implicit none
6303
6304    integer did
6305
6306    character(len=*) inFileTmp
6307    character(len=256) inFile
6308    character(len=19) str_tmp
6309
6310     integer :: iunit
6311     logical :: fexist
6312     integer  :: i0,ie, i, istep
6313
6314     iunit = 81
6315
6316              if(my_id .lt. 10) then
6317                 write(str_tmp,'(I1)') my_id
6318              else if(my_id .lt. 100) then
6319                 write(str_tmp,'(I2)') my_id
6320              else if(my_id .lt. 1000) then
6321                 write(str_tmp,'(I3)') my_id
6322              else if(my_id .lt. 10000) then
6323                 write(str_tmp,'(I4)') my_id
6324              else if(my_id .lt. 100000) then
6325                 write(str_tmp,'(I5)') my_id
6326              endif
6327
6328     inFile = trim(inFileTmp)//"."//str_tmp
6329
6330     inquire (file=trim(inFile), exist=fexist)
6331     if(.not. fexist) then
6332         call hydro_stop("In RESTART_in_bi()- Could not find restart file "//trim(inFile))
6333     endif
6334
6335  istep = 64
6336  i0 = 0
6337  ie = istep
6338  do i = 0, numprocs,istep
6339    if(my_id .ge. i0 .and. my_id .lt. ie) then
6340     open(iunit, file = inFile, form="unformatted",ERR=101,access="sequential")
6341           read(iunit,ERR=101) rt_domain(did)%his_out_counts
6342 !         read(iunit,ERR=101) nlst_rt(did)%olddate(1:19)
6343           read(iunit,ERR=101) nlst(did)%sincedate(1:19)
6344 !         read(iunit,ERR=101) nlst_rt(did)%DTCT
6345           read(iunit,ERR=101) rt_domain(did)%stc
6346           read(iunit,ERR=101) rt_domain(did)%smc
6347           read(iunit,ERR=101) rt_domain(did)%sh2ox
6348           read(iunit,ERR=101) rt_domain(did)%SMCMAX1
6349           read(iunit,ERR=101) rt_domain(did)%SMCREF1
6350           read(iunit,ERR=101) rt_domain(did)%SMCWLT1
6351           read(iunit,ERR=101) rt_domain(did)%INFXSRT
6352           read(iunit,ERR=101) rt_domain(did)%soldrain
6353           read(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_lsm
6354           if(nlst(did)%SUBRTSWCRT.EQ.0.and.nlst(did)%OVRTSWCRT.EQ.0) rt_domain(did)%overland%control%surface_water_head_lsm = 0
6355
6356           if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1 .or. nlst(did)%GWBASESWCRT .ne. 0) then
6357                 if(nlst(did)%CHANRTSWCRT.EQ.1) then
6358                    read(iunit,ERR=101) rt_domain(did)%HLINK
6359                    read(iunit,ERR=101) rt_domain(did)%QLINK(:,1)
6360                    read(iunit,ERR=101) rt_domain(did)%QLINK(:,2)
6361                    read(iunit,ERR=101) rt_domain(did)%cvol
6362                    read(iunit,ERR=101) rt_domain(did)%resht
6363                    read(iunit,ERR=101) rt_domain(did)%qlakeo
6364                    read(iunit,ERR=101) rt_domain(did)%qlakei
6365                    read(iunit,ERR=101) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake
6366                 end if
6367
6368                 if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then
6369                      read(iunit,ERR=101) rt_domain(did)%z_gwsubbas
6370                 end if
6371                 if(nlst(did)%SUBRTSWCRT.EQ.1.OR.nlst(did)%OVRTSWCRT.EQ.1) then
6372                    read(iunit,ERR=101) rt_domain(did)%overland%control%boundary_flux
6373                    read(iunit,ERR=101) rt_domain(did)%INFXSWGT
6374                    read(iunit,ERR=101) rt_domain(did)%overland%control%surface_water_head_routing
6375                    read(iunit,ERR=101) rt_domain(did)%SH2OWGT
6376                    read(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT_ACC
6377                    !AD_CHANGE: This is overwriting the RETDEPRTFAC version, so causes issues when changing that factor.
6378                    !No need to have in restart since live calculated.
6379                    !read(iunit,ERR=101) rt_domain(did)%RETDEPRT
6380                 endif
6381           end if
6382
6383         close(iunit)
6384     endif
6385     call mpp_land_sync()
6386     i0 = i0 + istep
6387     ie = ie + istep
6388   end do ! end do of i loop
6389
6390         return
6391 101     continue
6392         call hydro_stop("In RESTART_in_bi() - failed to read the hydro restart file "//trim(inFile))
6393         end subroutine RESTART_in_bi
6394 #endif
6395
6396         subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName)
6397            implicit none
6398            integer:: ncid,ix,jx,varid , iret
6399            character(len=*) varName
6400            real, dimension(ix,jx):: inVar
6401 #ifdef MPP_LAND
6402            real, allocatable, dimension(:,:) :: varTmp
6403            if(my_id .eq. io_id ) then
6404                allocate(varTmp(global_rt_nx, global_rt_ny))
6405            else
6406                allocate(varTmp(1,1))
6407            endif
6408            call write_IO_rt_real(inVar,varTmp)
6409            if(my_id .eq. IO_id) then
6410               iret = nf90_inq_varid(ncid,varName, varid)
6411               if(iret .eq. 0) then
6412                  iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_rt_nx,global_rt_ny/))
6413               else
6414                  write(6,*) "Error: variable not defined in rst file before write: ", varName
6415               endif
6416            endif
6417            if(allocated(varTmp))  deallocate(varTmp)
6418 #else
6419            iret = nf90_inq_varid(ncid,varName, varid)
6420            if(iret .eq. 0) then
6421               iret = nf90_put_var(ncid, varid, inVar, (/1,1/), (/ix,jx/))
6422            else
6423               write(6,*) "Error : variable not defined in rst file before write: ", varName
6424            endif
6425 #endif
6426
6427            return
6428         end subroutine w_rst_rt_nc2
6429
6430         subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName)
6431            implicit none
6432            integer:: ncid,ix,jx,varid , iret, nsoil
6433            character(len=*) varName
6434            real,dimension(ix,jx,nsoil):: inVar
6435            character(len=2) tmpStr
6436            integer k
6437 #ifdef MPP_LAND
6438            real varTmp(global_rt_nx,global_rt_ny)
6439            do k = 1, nsoil
6440               call write_IO_rt_real(inVar(:,:,k),varTmp(:,:))
6441               if(my_id .eq. IO_id) then
6442                  if( k .lt. 10) then
6443                     write(tmpStr, '(i1)') k
6444                  else
6445                     write(tmpStr, '(i2)') k
6446                  endif
6447                  iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6448                  iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_rt_nx,global_rt_ny/))
6449               endif
6450            end do
6451 #else
6452            do k = 1, nsoil
6453                  if( k .lt. 10) then
6454                     write(tmpStr, '(i1)') k
6455                  else
6456                     write(tmpStr, '(i2)') k
6457                  endif
6458               iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6459               iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/))
6460            end do
6461 #endif
6462            return
6463         end subroutine w_rst_rt_nc3
6464
6465         subroutine w_rst_nc2(ncid,ix,jx,inVar,varName)
6466            implicit none
6467            integer:: ncid,ix,jx,varid , iret
6468            character(len=*) varName
6469            real inVar(ix,jx)
6470
6471 #ifdef MPP_LAND
6472            real varTmp(global_nx,global_ny)
6473            call write_IO_real(inVar,varTmp)
6474            if(my_id .eq. IO_id) then
6475               iret = nf90_inq_varid(ncid,varName, varid)
6476               iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_nx,global_ny/))
6477            endif
6478 #else
6479            iret = nf90_inq_varid(ncid,varName, varid)
6480            iret = nf90_put_var(ncid, varid, invar, (/1,1/), (/ix,jx/))
6481 #endif
6482
6483            return
6484         end subroutine w_rst_nc2
6485
6486         subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName)
6487            implicit none
6488            integer:: ncid,ix,jx,varid , iret, nsoil
6489            character(len=*) varName
6490            real inVar(ix,jx,nsoil)
6491            integer k
6492            character(len=2) tmpStr
6493
6494 #ifdef MPP_LAND
6495            real varTmp(global_nx,global_ny)
6496            do k = 1, nsoil
6497               call write_IO_real(inVar(:,:,k),varTmp(:,:))
6498               if(my_id .eq. IO_id) then
6499                  if( k .lt. 10) then
6500                     write(tmpStr, '(i1)') k
6501                  else
6502                     write(tmpStr, '(i2)') k
6503                  endif
6504                 iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6505                 iret = nf90_put_var(ncid, varid, varTmp, (/1,1/), (/global_nx,global_ny/))
6506               endif
6507            end do
6508 #else
6509            do k = 1, nsoil
6510                  if( k .lt. 10) then
6511                     write(tmpStr, '(i1)') k
6512                  else
6513                     write(tmpStr, '(i2)') k
6514                  endif
6515              iret = nf90_inq_varid(ncid,varName//trim(tmpStr), varid)
6516              iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/))
6517            end do
6518 #endif
6519            return
6520         end subroutine w_rst_nc3
6521
6522         subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName &
6523 #ifdef MPP_LAND
6524                  ,nodelist     &
6525 #endif
6526                   )
6527            implicit none
6528            integer:: ncid,n,varid , iret
6529            character(len=*) varName
6530            real inVar(n)
6531 #ifdef MPP_LAND
6532            integer:: nodelist(n)
6533            if(n .eq. 0) return
6534
6535            call write_lake_real(inVar,nodelist,n)
6536            if(my_id .eq. IO_id) then
6537 #endif
6538               iret = nf90_inq_varid(ncid,varName, varid)
6539               iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6540 #ifdef MPP_LAND
6541            endif
6542 #endif
6543            return
6544         end subroutine w_rst_crt_nc1_lake
6545
6546         subroutine w_rst_crt_reach_real(ncid,inVar,varName &
6547 #ifdef MPP_LAND
6548                  , gnlinksl&
6549 #endif
6550                   )
6551            implicit none
6552            integer:: ncid,varid , iret, n
6553            character(len=*) varName
6554            real, dimension(:) :: inVar
6555
6556 #ifdef MPP_LAND
6557            integer:: gnlinksl
6558            real,allocatable,dimension(:) :: g_var
6559            if(my_id .eq. io_id) then
6560                 allocate(g_var(gnlinksl))
6561                 g_var  = 0
6562            else
6563                 allocate(g_var(1) )
6564            endif
6565
6566            call ReachLS_write_io(inVar, g_var)
6567            if(my_id .eq. IO_id) then
6568               iret = nf90_inq_varid(ncid,varName, varid)
6569               iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinksl/))
6570            endif
6571            if(allocated(g_var)) deallocate(g_var)
6572 #else
6573            n = size(inVar,1)
6574            iret = nf90_inq_varid(ncid,varName, varid)
6575            iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6576 #endif
6577            return
6578         end subroutine w_rst_crt_reach_real
6579
6580
6581         subroutine w_rst_crt_reach_real8(ncid,inVar,varName &
6582 #ifdef MPP_LAND
6583                  , gnlinksl&
6584 #endif
6585                   )
6586            implicit none
6587            integer:: ncid,varid , iret, n
6588            character(len=*) varName
6589            real*8, dimension(:) :: inVar
6590
6591 #ifdef MPP_LAND
6592            integer:: gnlinksl
6593            real*8,allocatable,dimension(:) :: g_var
6594            if(my_id .eq. io_id) then
6595                 allocate(g_var(gnlinksl))
6596                 g_var  = 0
6597            else
6598                 allocate(g_var(1) )
6599            endif
6600
6601            call ReachLS_write_io(inVar, g_var)
6602            if(my_id .eq. IO_id) then
6603               iret = nf90_inq_varid(ncid,varName, varid)
6604               iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinksl/))
6605            endif
6606            if(allocated(g_var)) deallocate(g_var)
6607 #else
6608            n = size(inVar,1)
6609            iret = nf90_inq_varid(ncid,varName, varid)
6610            iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6611 #endif
6612            return
6613         end subroutine w_rst_crt_reach_real8
6614
6615
6616
6617         subroutine w_rst_crt_nc1(ncid,n,inVar,varName &
6618 #ifdef MPP_LAND
6619                  ,map_l2g, gnlinks&
6620 #endif
6621                   )
6622            implicit none
6623            integer:: ncid,n,varid , iret
6624            character(len=*) varName
6625            real inVar(n)
6626 #ifdef MPP_LAND
6627            integer:: gnlinks, map_l2g(n)
6628            real g_var(gnlinks)
6629            call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var)
6630            if(my_id .eq. IO_id) then
6631               iret = nf90_inq_varid(ncid,varName, varid)
6632               iret = nf90_put_var(ncid, varid, g_var, (/1/), (/gnlinks/))
6633 #else
6634               iret = nf90_inq_varid(ncid,varName, varid)
6635               iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6636 #endif
6637 #ifdef MPP_LAND
6638            endif
6639 #endif
6640            return
6641         end subroutine w_rst_crt_nc1
6642
6643         subroutine w_rst_crt_nc1g(ncid,n,inVar,varName)
6644            implicit none
6645            integer:: ncid,n,varid , iret
6646            character(len=*) varName
6647            real,dimension(:) ::  inVar
6648 #ifdef MPP_LAND
6649            if(my_id .eq. IO_id) then
6650 #endif
6651               iret = nf90_inq_varid(ncid,varName, varid)
6652               iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/))
6653 #ifdef MPP_LAND
6654            endif
6655 #endif
6656            return
6657         end subroutine w_rst_crt_nc1g
6658
6659    subroutine w_rst_gwbucket_real(ncid,numbasns,gnumbasns, &
6660                        basnsInd, inV,vName )
6661       implicit none
6662       integer :: ncid,numbasns,gnumbasns
6663       integer(kind=int64), dimension(:) :: basnsInd
6664       real, dimension(:) :: inV
6665       character(len=*) :: vName
6666       integer i, j, k
6667       real, allocatable,dimension(:) :: buf
6668 #ifdef MPP_LAND
6669       if (my_id .eq. IO_id) then
6670         allocate(buf(gnumbasns))
6671       else
6672         allocate(buf(1))
6673       endif
6674       call gw_write_io_real(numbasns,inV,basnsInd,buf)
6675 #else
6676       allocate(buf(gnumbasns))
6677       do k = 1, numbasns
6678         buf(basnsInd(k)) = inV(k)
6679       end do
6680 #endif
6681       call w_rst_crt_nc1g(ncid,gnumbasns,buf,vName)
6682       if(allocated(buf)) deallocate(buf)
6683    end subroutine w_rst_gwbucket_real
6684
6685    subroutine read_rst_gwbucket_real(ncid,outV,numbasns,&
6686                        gnumbasns,basnsInd, vName)
6687       implicit none
6688       integer :: ncid,numbasns,gnumbasns
6689       integer(kind=int64), dimension(:) :: basnsInd
6690       real, dimension(:) :: outV
6691       character(len=*) :: vName
6692       integer i, j,k
6693       real, dimension(gnumbasns) :: buf
6694       call read_rst_crt_nc(ncid,buf,gnumbasns,vName)
6695       do k = 1, numbasns
6696          outV(k) = buf(basnsInd(k))
6697       end do
6698    end subroutine read_rst_gwbucket_real
6699
6700
6701 subroutine RESTART_IN_NC(inFile,did)
6702
6703 implicit none
6704 character(len=*) inFile
6705 integer :: ierr, iret,ncid, did
6706 integer :: channel_only_in, channelBucket_only_in
6707 integer :: i, j
6708
6709
6710 #ifdef MPP_LAND
6711 if(IO_id .eq. my_id) then
6712 #endif
6713 !open a netcdf file
6714    iret = nf90_open(trim(inFile), NF90_NOWRITE, ncid)
6715 #ifdef MPP_LAND
6716 endif
6717 call mpp_land_bcast_int1(iret)
6718 #endif
6719 if (iret /= 0) then
6720    write(*,'("Problem opening file: ''", A, "''")') &
6721         trim(inFile)
6722    call hydro_stop("In RESTART_IN_NC() - Problem opening file")
6723 endif
6724
6725 #ifdef MPP_LAND
6726 if(IO_id .eq. my_id) then
6727 #endif
6728
6729    !! Dont use a restart from a channel_only run if you're not running channel_only
6730    iret = nf90_get_att(ncid, NF90_GLOBAL, "channel_only", channel_only_in)
6731    if(iret .eq. 0) then !! If channel_only attribute prsent, then proceed with this logic
6732
6733       iret = nf90_get_att(ncid, NF90_GLOBAL, "channelBucket_only", channelBucket_only_in)
6734
6735       iret=0 ! borrow the variable for our own error flagging
6736       !! Hierarchy of model restarting ability.
6737       !! 1) Full model restarts: all model runs (full, channel_only and channelBucket_only)
6738       !! No test needed here.
6739
6740       !! 2) channelBucket_only restarts: channelBucket_only and channel_only runs
6741       if(channelBucket_only_in .eq. 1) then
6742          if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) iret=1
6743       end if
6744
6745       !! 3) channel_only restarts: only channel_only runs
6746       if(channel_only_in .eq. 1) then
6747          if(nlst(did)%channel_only .eq. 0) iret=1
6748       end if
6749
6750       if(iret .eq. 1) then
6751
6752          !! JLM Why dont we adopt this strategy elsewhere, e.g. define logUnit as a module variable.
6753          !! JLM Would massively cut down on #ifdefs and repetitive code in certain parts of the code.
6754 #ifdef NCEP_WCOSS
6755          logUnit=78
6756 #else
6757          logUnit=6
6758 #endif
6759
6760          write(logUnit,*) 'Restart is not respecting the hierarchy of model restarting ability:'
6761          write(logUnit,*) '1) Full model restarts: all model runs (full, channel_only and channelBucket_only),'
6762          write(logUnit,*) '2) channelBucket_only restarts: channelBucket_only and channel_only runs,'
6763          write(logUnit,*) '3) channel_only restarts: only channel_only runs.'
6764          write(logUnit,*) 'Diagnostics:'
6765          write(logUnit,*) 'channel_only restart present:', channel_only_in
6766          write(logUnit,*) 'channel_only run:', nlst(did)%channel_only
6767          write(logUnit,*) 'channelBucket_only restart present:', channelBucket_only_in
6768          write(logUnit,*) 'channelBucket_only run:', nlst(did)%channelBucket_only
6769          call flush(logUnit)
6770          call hydro_stop('Channel Only: Restart file in consistent with forcing type.')
6771       end if
6772    end if
6773
6774    iret = nf90_get_att(ncid, NF90_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts)
6775    iret = nf90_get_att(ncid, NF90_GLOBAL, 'DTCT', nlst(did)%DTCT)
6776    iret = nf90_get_att(ncid,NF90_GLOBAL,"Since_Date",nlst(did)%sincedate(1:19))
6777 !   if( nlst(did)%channel_only       .eq. 1 .or. &
6778 !       nlst(did)%channelBucket_only .eq. 1         ) &
6779 !       iret = nf90_get_att(ncid,NF90_GLOBAL,"Restart_Time",nlst(did)%olddate(1:19))
6780    if(iret /= 0) nlst(did)%sincedate = nlst(did)%startdate
6781    if(nlst(did)%DTCT .gt. 0) then
6782       nlst(did)%DTCT = min(nlst(did)%DTCT, nlst(did)%DTRT_CH)
6783    else
6784       nlst(did)%DTCT = nlst(did)%DTRT_CH
6785    endif
6786
6787 #ifdef MPP_LAND
6788 endif
6789
6790 !yw call mpp_land_bcast_int1(rt_domain(did)%out_counts)
6791 ! Not sure what caused the problem. added out_counts = 1 as a temporary fix for the hydro output.
6792 rt_domain(did)%out_counts = 1
6793
6794 call mpp_land_bcast_real1(nlst(did)%DTCT)
6795 !if( nlst_rt(did)%channel_only       .eq. 1 .or. &
6796 !    nlst_rt(did)%channelBucket_only .eq. 1         ) &
6797 !    call mpp_land_bcast_char(19, nlst_rt(did)%olddate)
6798 !! call mpp_land_bcast_char(19, nlst_rt(did)%sincedate) ! why not? we read it in.
6799 #endif
6800
6801 #ifdef HYDRO_D
6802 write(6,*) "nlst(did)%nsoil=",nlst(did)%nsoil
6803 #endif
6804
6805 if( nlst(did)%channel_only       .eq. 0 .and. &
6806     nlst(did)%channelBucket_only .eq. 0         ) then
6807
6808    if(nlst(did)%rst_typ .eq. 1 ) then
6809       call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%stc,"stc")
6810       call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%smc,"smc")
6811       call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
6812       call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt")
6813       call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%overland%control%surface_water_head_lsm,"sfcheadrt")
6814       call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain")
6815
6816    end if ! rst_typ .eq. 1
6817    !yw check
6818
6819    !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
6820    !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1")
6821    !call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1")
6822
6823 endif ! neither channel_only nor channelBucket_only
6824
6825 if(nlst(did)%SUBRTSWCRT  .eq. 1 .or. &
6826    nlst(did)%OVRTSWCRT   .eq. 1 .or. &
6827    nlst(did)%GWBASESWCRT .ne. 0       ) then
6828    !! JLM ?? restarting channel depends on these options?
6829
6830    if( nlst(did)%channel_only       .eq. 0 .and. &
6831        nlst(did)%channelBucket_only .eq. 0         ) then
6832
6833       if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then
6834
6835          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt")
6836          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%surface_water_head_routing,"sfcheadsubrt")
6837          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%control%boundary_flux,"QBDRYRT")
6838          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT_ACC,"qstrmvolrt")
6839          !AD_CHANGE: This is overwriting the RETDEPRTFAC version, so causes issues when changing that factor.
6840          !No need to have in restart since live calculated.
6841          !call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%overland%properties%retention_depth,"RETDEPRT")
6842          call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt")
6843       endif
6844
6845    end if ! neither channel_only nor channelBucket_only
6846
6847    if(nlst(did)%CHANRTSWCRT.eq.1) then
6848       if(nlst(did)%channel_option .eq. 3) then
6849          !! Have not setup channel_only for gridded routing YET
6850          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)
6851          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)
6852          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)
6853          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)
6854       else
6855          call read_rst_crt_reach_nc(ncid,rt_domain(did)%HLINK,"hlink",rt_domain(did)%GNLINKSL,fatalErr=.FALSE.)
6856          call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,1),"qlink1",rt_domain(did)%GNLINKSL)
6857          call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,2),"qlink2",rt_domain(did)%GNLINKSL)
6858          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%CVOL,"cvol",rt_domain(did)%GNLINKSL)
6859          !if(nlst_rt(did)%UDMP_OPT .eq. 1) then
6860          ! read in the statistic value
6861          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accSfcLatRunoff,"accSfcLatRunoff",rt_domain(did)%GNLINKSL)
6862          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accQLateral,"accQLateral",rt_domain(did)%GNLINKSL)
6863          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%qSfcLatRunoff,"qSfcLatRunoff",rt_domain(did)%GNLINKSL)
6864          !call read_rst_crt_reach_nc(ncid,rt_domain(did)%accBucket,"accBucket",rt_domain(did)%GNLINKS)
6865          !endif
6866       endif
6867
6868       if(rt_domain(did)%NLAKES .gt. 0) then
6869          call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht")
6870          call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo")
6871          call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEI,rt_domain(did)%NLAKES,"qlakei")
6872       endif
6873
6874       if( nlst(did)%channel_only       .eq. 0 .and. &
6875            nlst(did)%channelBucket_only .eq. 0         ) then
6876
6877          if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then
6878             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")
6879          endif
6880       end if
6881
6882    end if  !  end if(nlst_rt(did)%CHANRTSWCRT.eq.1)
6883
6884    if((nlst(did)%GWBASESWCRT .eq. 1 .or.  &
6885       nlst(did)%GWBASESWCRT .ge. 4) .and. &
6886       nlst(did)%GW_RESTART  .ne. 0 .and.  &
6887       rt_domain(did)%gnumbasns .gt. 0) then
6888
6889       if(nlst(did)%channel_only .eq. 0) then
6890          if(nlst(did)%UDMP_OPT .eq. 1) then
6891             call read_rst_crt_reach_nc(ncid,rt_domain(did)%z_gwsubbas,"z_gwsubbas",rt_domain(did)%GNLINKSL)
6892          else
6893             call read_rst_gwbucket_real(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,&
6894                  rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd, "z_gwsubbas")
6895          endif
6896
6897       end if !       if( nlst_rt(did)%channel_only .eq. 0 ) then
6898
6899    end if  ! end    if((nlst_rt(did)%GWBASESWCRT .eq. 1 .or. nlst_rt(did)%GWBASESWCRT .ge. 4) .and. &
6900 !                      nlst_rt(did)%GW_RESTART  .ne. 0 .and. &
6901 !                      rt_domain(did)%gnumbasns .gt. 0        )
6902
6903    !! JLM: WHat is this option??
6904    if(nlst(did)%GWBASESWCRT.eq.3) then
6905       if(nlst(did)%SUBRTSWCRT.eq.1.or.nlst(did)%OVRTSWCRT.eq.1) then
6906          call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho,"HEAD")
6907       endif
6908    end if
6909
6910 end if  !  end if(nlst_rt(did)%SUBRTSWCRT  .eq. 1 .or. &
6911 !                 nlst_rt(did)%OVRTSWCRT   .eq. 1 .or. &
6912 !                 nlst_rt(did)%GWBASESWCRT .ne. 0       )
6913
6914 !! Resetting these after writing the t=0 output file instead so that no information is
6915 !! lost.
6916 !if(nlst_rt(did)%rstrt_swc.eq.1) then  !Switch for rest of restart accum vars...
6917 !#ifdef HYDRO_D
6918 !            print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc
6919 !#endif
6920 !! JLM:
6921 !! Reset of accumulation variables move to end of subroutine
6922 !!   Routing/module_HYDRO_drv.F: HYDRO_ini
6923 !! See comments there.
6924 !! Conensed, commented code:
6925 !! rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake=0.!rt_domain(did)%surface_water_to_channel=0.
6926 !end if
6927
6928 #ifdef MPP_LAND
6929 if(my_id .eq. IO_id) &
6930 #endif
6931      iret =  nf90_close(ncid)
6932 #ifdef HYDRO_D
6933 write(6,*) "end of RESTART_IN"
6934 call flush(6)
6935 #endif
6936
6937 return
6938 end subroutine RESTART_IN_nc
6939
6940
6941       subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr)
6942          implicit none
6943          integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
6944          real,dimension(ix,jx,nsoil) ::  var
6945          character(len=*) :: varStr
6946          character(len=2) :: tmpStr
6947          integer :: n
6948          integer i
6949 #ifdef MPP_LAND
6950          real,dimension(global_nx,global_ny) :: xtmp
6951 #endif
6952
6953          do i = 1, nsoil
6954 #ifdef MPP_LAND
6955          if(my_id .eq. IO_id) then
6956 #endif
6957                  if( i .lt. 10) then
6958                     write(tmpStr, '(i1)') i
6959                  else
6960                     write(tmpStr, '(i2)') i
6961                  endif
6962            iret = nf90_inq_varid(ncid,  trim(varStr)//trim(tmpStr),  varid)
6963 #ifdef MPP_LAND
6964          endif
6965          call mpp_land_bcast_int1(iret)
6966 #endif
6967
6968          if (iret /= 0) then
6969 #ifdef HYDRO_D
6970             print*, 'variable not found: name = "', trim(varStr)//'"'
6971 #endif
6972             return
6973          endif
6974 #ifdef HYDRO_D
6975          print*, "read restart variable ", varStr//trim(tmpStr)
6976 #endif
6977 #ifdef MPP_LAND
6978          if(my_id .eq. IO_id) &
6979             iret = nf90_get_var(ncid, varid, xtmp)
6980
6981             call decompose_data_real(xtmp(:,:), var(:,:,i))
6982 #else
6983             iret = nf90_get_var(ncid, varid, var(:,:,i))
6984 #endif
6985          end do
6986
6987          return
6988       end subroutine read_rst_nc3
6989
6990       subroutine read_rst_nc2(ncid,ix,jx,var,varStr)
6991          implicit none
6992          integer ::  ix,jx,ireg, ncid, varid, iret
6993          real,dimension(ix,jx) ::  var
6994          character(len=*) :: varStr
6995 #ifdef MPP_LAND
6996          real,dimension(global_nx,global_ny) :: xtmp
6997          if(my_id .eq. IO_id) &
6998 #endif
6999            iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7000
7001 #ifdef MPP_LAND
7002          call mpp_land_bcast_int1(iret)
7003 #endif
7004
7005          if (iret /= 0) then
7006 #ifdef HYDRO_D
7007             print*, 'variable not found: name = "', trim(varStr)//'"'
7008 #endif
7009             return
7010          endif
7011 #ifdef HYDRO_D
7012          print*, "read restart variable ", varStr
7013 #endif
7014 #ifdef MPP_LAND
7015          if(my_id .eq. IO_id) &
7016             iret = nf90_get_var(ncid, varid, xtmp)
7017
7018          call decompose_data_real(xtmp, var)
7019 #else
7020             var = 0.0
7021             iret = nf90_get_var(ncid, varid, var)
7022 #endif
7023          return
7024       end subroutine read_rst_nc2
7025
7026       subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr)
7027          implicit none
7028          integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
7029          real,dimension(ix,jx,nsoil) ::  var
7030          character(len=*) :: varStr
7031          character(len=2) :: tmpStr
7032          integer i
7033 #ifdef MPP_LAND
7034          real,dimension(global_rt_nx,global_rt_ny) :: xtmp
7035 #endif
7036          do i = 1, nsoil
7037                  if( i .lt. 10) then
7038                     write(tmpStr, '(i1)') i
7039                  else
7040                     write(tmpStr, '(i2)') i
7041                  endif
7042 #ifdef MPP_LAND
7043          if(my_id .eq. IO_id) &
7044 #endif
7045             iret = nf90_inq_varid(ncid,  trim(varStr)//trim(tmpStr),  varid)
7046 #ifdef MPP_LAND
7047          call mpp_land_bcast_int1(iret)
7048 #endif
7049          if (iret /= 0) then
7050 #ifdef HYDRO_D
7051             print*, 'variable not found: name = "', trim(varStr)//'"'
7052 #endif
7053             return
7054          endif
7055 #ifdef HYDRO_D
7056          print*, "read restart variable ", varStr//trim(tmpStr)
7057 #endif
7058 #ifdef MPP_LAND
7059          iret = nf90_get_var(ncid, varid, xtmp)
7060             call decompose_RT_real(xtmp(:,:),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx)
7061 #else
7062          iret = nf90_get_var(ncid, varid, var(:,:,i))
7063 #endif
7064          end do
7065          return
7066       end subroutine read_rst_rt_nc3
7067
7068       subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr)
7069          implicit none
7070          integer ::  ix,jx,ireg, ncid, varid, iret
7071          real,dimension(ix,jx) ::  var
7072          character(len=*) :: varStr
7073 #ifdef MPP_LAND
7074          real,dimension(global_rt_nx,global_rt_ny) :: xtmp
7075 #endif
7076          iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7077 #ifdef MPP_LAND
7078          call mpp_land_bcast_int1(iret)
7079 #endif
7080          if (iret /= 0) then
7081 #ifdef HYDRO_D
7082             print*, 'variable not found: name = "', trim(varStr)//'"'
7083 #endif
7084             return
7085          endif
7086 #ifdef HYDRO_D
7087          print*, "read restart variable ", varStr
7088 #endif
7089 #ifdef MPP_LAND
7090          if(my_id .eq. IO_id) &
7091              iret = nf90_get_var(ncid, varid, xtmp)
7092          call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
7093 #else
7094             iret = nf90_get_var(ncid, varid, var)
7095 #endif
7096          return
7097       end subroutine read_rst_rt_nc2
7098
7099       subroutine read_rt_nc2(ncid,ix,jx,var,varStr)
7100          implicit none
7101          integer ::  ix,jx, ncid, varid, iret
7102          real,dimension(ix,jx) ::  var
7103          character(len=*) :: varStr
7104
7105 #ifdef MPP_LAND
7106          real,allocatable, dimension(:,:) :: xtmp
7107 !yw         real,dimension(global_rt_nx,global_rt_ny) :: xtmp
7108          if(my_id .eq. io_id ) then
7109              allocate(xtmp(global_rt_nx,global_rt_ny))
7110          else
7111              allocate(xtmp(1,1))
7112          endif
7113          xtmp = 0.0
7114 #endif
7115             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7116 #ifdef MPP_LAND
7117          call mpp_land_bcast_int1(iret)
7118 #endif
7119             if (iret /= 0) then
7120 #ifdef HYDRO_D
7121                print*, 'variable not found: name = "', trim(varStr)//'"'
7122 #endif
7123                return
7124             endif
7125 #ifdef HYDRO_D
7126          print*, "read restart variable ", varStr
7127 #endif
7128 #ifdef MPP_LAND
7129          if(my_id .eq. IO_id) then
7130             iret = nf90_get_var(ncid, varid, xtmp)
7131          endif
7132          call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
7133
7134          if(allocated(xtmp)) deallocate(xtmp)
7135
7136 #else
7137             iret = nf90_get_var(ncid, varid, var)
7138 #endif
7139          return
7140       end subroutine read_rt_nc2
7141
7142       subroutine read_rst_crt_nc(ncid,var,n,varStr)
7143          implicit none
7144          integer ::  ireg, ncid, varid, n, iret
7145          real,dimension(n) ::  var
7146          character(len=*) :: varStr
7147
7148          if( n .le. 0)  return
7149 #ifdef MPP_LAND
7150          if(my_id .eq. IO_id) &
7151 #endif
7152             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7153 #ifdef MPP_LAND
7154          call mpp_land_bcast_int1(iret)
7155 #endif
7156             if (iret /= 0) then
7157 #ifdef HYDRO_D
7158                print*, 'variable not found: name = "', trim(varStr)//'"'
7159 #endif
7160                return
7161             endif
7162 #ifdef HYDRO_D
7163          print*, "read restart variable ", varStr
7164 #endif
7165 #ifdef MPP_LAND
7166          if(my_id .eq. IO_id) then
7167 #endif
7168             iret = nf90_get_var(ncid, varid, var)
7169 #ifdef MPP_LAND
7170          endif
7171          if(n .gt. 0) then
7172              call mpp_land_bcast_real(n,var)
7173          endif
7174 #endif
7175          return
7176       end subroutine read_rst_crt_nc
7177
7178       subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g)
7179          implicit none
7180          integer ::  ncid, varid, n, iret, gnlinks
7181          integer, intent(in), dimension(:) :: map_l2g
7182          character(len=*) :: varStr
7183          integer :: l, g
7184          real,intent(out) , dimension(:) ::  var_out
7185 #ifdef MPP_LAND
7186          real,dimension(gnlinks) ::  var
7187 #else
7188          real,dimension(n) ::  var
7189 #endif
7190
7191
7192 #ifdef MPP_LAND
7193          if(my_id .eq. IO_id) &
7194 #endif
7195             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7196 #ifdef MPP_LAND
7197          call mpp_land_bcast_int1(iret)
7198 #endif
7199             if (iret /= 0) then
7200 #ifdef HYDRO_D
7201                print*, 'variable not found: name = "', trim(varStr)//'"'
7202 #endif
7203                return
7204             endif
7205 #ifdef HYDRO_D
7206          print*, "read restart variable ", varStr
7207 #endif
7208 #ifdef MPP_LAND
7209          if(my_id .eq. IO_id) then
7210 #endif
7211             var = 0.0
7212             iret = nf90_get_var(ncid, varid, var)
7213 #ifdef MPP_LAND
7214          endif
7215          if(gnlinks .gt. 0) then
7216             call mpp_land_bcast_real(gnlinks,var)
7217          endif
7218
7219          if(n .le. 0) return
7220          var_out = 0
7221
7222          do l = 1, n
7223             g = map_l2g(l)
7224             var_out(l) = var(g)
7225          end do
7226 #else
7227          var_out = var
7228 #endif
7229          return
7230       end subroutine read_rst_crt_stream_nc
7231
7232       subroutine read_rst_crt_reach_nc_real(ncid,var_out,varStr,gnlinksl, fatalErr)
7233          implicit none
7234          integer ::  ncid, varid, n, iret, gnlinksl
7235          character(len=*) :: varStr
7236          integer :: l, g
7237          real, dimension(:) ::  var_out
7238          logical, optional, intent(in) :: fatalErr
7239          logical :: fatalErr_local
7240          real :: scale_factor, add_offset
7241          integer :: ovrtswcrt_in, ss
7242          real,allocatable,dimension(:) ::  var, varTmp
7243
7244          fatalErr_local = .false.
7245          if(present(fatalErr)) fatalErr_local=fatalErr
7246
7247          n = size(var_out,1)
7248
7249 #ifdef MPP_LAND
7250          if(my_id .eq. IO_id) then
7251               allocate(var(gnlinksl))
7252          else
7253               allocate(var(1))
7254          endif
7255 #else
7256               allocate(var(n))
7257 #endif
7258
7259
7260 #ifdef MPP_LAND
7261          if(my_id .eq. IO_id) then
7262             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7263          endif
7264          call mpp_land_bcast_int1(iret)
7265          if (iret /= 0) then
7266 #ifdef HYDRO_D
7267             print*, 'read_rst_crt_reach_nc: variable not found: name = "', trim(varStr)//'"'
7268 #endif
7269
7270             if(allocated(var))  deallocate(var)
7271
7272             !! JLM: is this desirable?
7273             !! JLM I think so, maybe an option to this routine specifying if errors are fatal?
7274             if (fatalErr_local) &
7275                  call hydro_stop("read_rst_crt_reach_nc: variable not found: "//trim(varStr))
7276
7277             return
7278          endif
7279
7280          if(my_id .eq. IO_id) then
7281 #ifdef HYDRO_D
7282             print*, "read restart variable ", varStr
7283             call flush(6)
7284 #endif
7285
7286             var = 0.0
7287             iret = nf90_get_var(ncid, varid, var)
7288             !! JLM: need a check here.
7289
7290             iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor)
7291             if(iret .eq. 0) var = var * scale_factor
7292             iret = nf90_get_att(ncid, varid, 'add_offset', add_offset)
7293             if(iret .eq. 0) var = var + add_offset
7294
7295             !! NWM channel-only forcings have to be "decoded"/unshuffled.
7296             !! As of NWM1.2 the following global attribute is different/identifiable
7297             !! for files created when io_form_outputs=1,2 (not 0).
7298             iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_OVRTSWCRT', ovrtswcrt_in)
7299             if((nlst(did)%channel_only .eq. 1 .or. nlst(did)%channelBucket_only .eq. 1) .and. &
7300                iret .eq. 0) then
7301                allocate(varTmp(gnlinksl))
7302                do ss=1,gnlinksl
7303                   varTmp(rt_domain(did)%ascendIndex(ss)+1)=var(ss)
7304                end do
7305                var=varTmp
7306                deallocate(varTmp)
7307             end if
7308          endif
7309
7310          call ReachLS_decomp(var,   var_out)
7311          if(allocated(var)) deallocate(var)
7312 #else
7313             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7314            if (iret /= 0) then
7315 #ifdef HYDRO_D
7316                print*, 'variable not found: name = "', trim(varStr)//'"'
7317 #endif
7318                if(allocated(var)) deallocate(var)
7319                return
7320             endif
7321 #ifdef HYDRO_D
7322          print*, "read restart variable ", varStr
7323 #endif
7324          iret = nf90_get_var(ncid, varid, var_out)
7325          if(allocated(var)) deallocate(var)
7326 #endif
7327
7328          return
7329          end subroutine read_rst_crt_reach_nc_real
7330
7331
7332       subroutine read_rst_crt_reach_nc_real8(ncid, var_out, varStr, gnlinksl, fatalErr)
7333          implicit none
7334          integer, intent(in)          ::  ncid, gnlinksl
7335          real*8, dimension(:), intent(inout) ::  var_out
7336          character(len=*), intent(in) :: varStr
7337          logical, optional, intent(in)       ::  fatalErr
7338
7339          integer :: varid, n, iret, l, g
7340          logical :: fatalErr_local
7341          real*8,allocatable,dimension(:) ::  var
7342          real :: scale_factor, add_offset
7343
7344          fatalErr_local = .false.
7345          if(present(fatalErr)) fatalErr_local=fatalErr
7346
7347          n = size(var_out,1)
7348
7349 #ifdef MPP_LAND
7350          if(my_id .eq. IO_id) then
7351               allocate(var(gnlinksl))
7352          else
7353               allocate(var(1))
7354          endif
7355 #else
7356               allocate(var(n))
7357 #endif
7358 #ifdef MPP_LAND
7359          if(my_id .eq. IO_id) then
7360             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7361          endif
7362          call mpp_land_bcast_int1(iret)
7363          if (iret /= 0) then
7364 #ifdef HYDRO_D
7365             print*, 'read_rst_crt_reach_nc: variable not found: name = "', trim(varStr)//'"'
7366 #endif
7367
7368             if(allocated(var))  deallocate(var)
7369
7370             !! JLM: is this desirable?
7371             !! JLM I think so, maybe an option to this routine specifying if errors are fatal?
7372             if (fatalErr_local) &
7373                  call hydro_stop("read_rst_crt_reach_nc: variable not found: "//trim(varStr))
7374
7375             return
7376          endif
7377 #ifdef HYDRO_D
7378          print*, "read restart variable ", varStr
7379          call flush(6)
7380 #endif
7381          if(my_id .eq. IO_id) then
7382             var = 0.0
7383             iret = nf90_get_var(ncid, varid, var)
7384             !! JLM need a check here...
7385
7386             iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor)
7387             if(iret .eq. 0) var = var * scale_factor
7388             iret = nf90_get_att(ncid, varid, 'add_offset', add_offset)
7389             if(iret .eq. 0) var = var + add_offset
7390
7391          endif
7392          call ReachLS_decomp(var,   var_out)
7393          if(allocated(var)) deallocate(var)
7394 #else
7395             iret = nf90_inq_varid(ncid,  trim(varStr),  varid)
7396            if (iret /= 0) then
7397 #ifdef HYDRO_D
7398                print*, 'variable not found: name = "', trim(varStr)//'"'
7399 #endif
7400                if(allocated(var)) deallocate(var)
7401                return
7402             endif
7403 #ifdef HYDRO_D
7404          print*, "read restart variable ", varStr
7405 #endif
7406          iret = nf90_get_var(ncid, varid, var_out)
7407          if(allocated(var)) deallocate(var)
7408 #endif
7409          return
7410          end subroutine read_rst_crt_reach_nc_real8
7411
7412
7413       subroutine hrldas_out()
7414       end subroutine hrldas_out
7415
7416
7417 subroutine READ_CHROUTING1( &
7418      IXRT,         JXRT,              fgDEM,        CH_NETRT, &
7419      CH_LNKRT,     LAKE_MSKRT,        FROM_NODE,    TO_NODE,  &
7420      TYPEL,        ORDER,             MAXORDER,     NLINKS,   &
7421      NLAKES,       CHANLEN,           MannN,        So,       &
7422      ChSSlp,       Bw,                Tw,                     &
7423      Tw_CC,        n_CC,              ChannK,       HRZAREA,      LAKEMAXH, &
7424      WEIRH,        WEIRC,             WEIRL,        DAML,     &
7425      ORIFICEC,     ORIFICEA,          ORIFICEE,               &
7426      reservoir_type_specified,        reservoir_type,         &
7427      reservoir_parameter_file,        LATLAKE,      LONLAKE,  &
7428      ELEVLAKE,     dist,              ZELEV,        LAKENODE, &
7429      CH_NETLNK,    CHANXI,            CHANYJ,       CHLAT,    &
7430      CHLON,        channel_option,    LATVAL,       LONVAL,   &
7431      STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f, LAKEIDM,  &
7432      UDMP_OPT                                                 & !! no comma at end
7433 #ifdef MPP_LAND
7434     ,Link_Location                                         &
7435 #endif
7436     )
7437
7438 #ifdef MPP_LAND
7439 use module_mpp_land, only:  my_id, io_id
7440 #endif
7441 integer, intent(IN)                          :: IXRT,JXRT, UDMP_OPT
7442 integer                                      :: CHANRTSWCRT, NLINKS, NLAKES
7443 real, intent(IN), dimension(IXRT,JXRT)       :: fgDEM
7444 integer, dimension(IXRT,JXRT)                :: DIRECTION
7445 integer, dimension(IXRT,JXRT)                :: GSTRMFRXSTPTS
7446 integer, intent(IN), dimension(IXRT,JXRT)    :: CH_NETRT
7447 integer(kind=int64), intent(IN), dimension(IXRT,JXRT)    :: CH_LNKRT
7448 integer, intent(INOUT), dimension(IXRT,JXRT) :: LAKE_MSKRT
7449 integer,                dimension(IXRT,JXRT) :: GORDER  !-- gridded stream orderk
7450 #ifdef MPP_LAND
7451 integer(kind=int64),    dimension(IXRT,JXRT) :: Link_Location !-- gridded stream orderk
7452 integer :: LNLINKSL
7453 #endif
7454 integer                                      :: I,J,K,channel_option
7455 real, intent(OUT), dimension(IXRT,JXRT)      :: LATVAL, LONVAL
7456 character(len=28)                            :: dir
7457 !Dummy inverted grids from arc
7458
7459 !----DJG,DNY New variables for channel and lake routing
7460 character(len=155)       :: header
7461 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: FROM_NODE
7462 real, intent(INOUT),  dimension(NLINKS)      :: ZELEV
7463 real, intent(INOUT),  dimension(NLINKS)      :: CHLAT,CHLON
7464
7465 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: TO_NODE
7466 integer, intent(INOUT),  dimension(NLINKS)   :: TYPEL
7467 integer, intent(INOUT),  dimension(NLINKS)   :: ORDER
7468 integer, intent(INOUT),  dimension(NLINKS)   :: STRMFRXSTPTS
7469
7470 integer, intent(INOUT)                       :: MAXORDER
7471 real, intent(INOUT),  dimension(NLINKS)      :: CHANLEN   !channel length
7472 real, intent(INOUT),  dimension(NLINKS)      :: MannN, So !mannings N
7473 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: LAKENODE !,LINKID   ! identifies which nodes pour into which lakes
7474 real, intent(IN)                             :: dist(ixrt,jxrt,9)
7475
7476 integer(kind=int64), intent(IN), dimension(IXRT,JXRT)    :: CH_NETLNK
7477 real,  dimension(IXRT,JXRT)                  :: ChSSlpG,BwG,TwG,MannNG  !channel properties
7478 real,  dimension(IXRT,JXRT)                  :: Tw_CCG,n_CCG            !channel properties of compound
7479 real,  dimension(IXRT,JXRT)                  :: ChannKG                 !Channel Infiltration
7480 real,  dimension(IXRT,JXRT)                  :: chanDepth, elrt
7481
7482
7483 !-- store the location x,y location of the channel element
7484 integer, intent(INOUT), dimension(NLINKS)   :: CHANXI, CHANYJ
7485 integer(kind=int64), dimension(:) ::  LAKEIDM
7486
7487 !--reservoir/lake attributes
7488 logical, intent(IN)                                 :: reservoir_type_specified
7489 real, intent(INOUT),  dimension(:)      :: HRZAREA
7490
7491 real, intent(INOUT),  dimension(:)      :: LAKEMAXH, WEIRH
7492 real, intent(INOUT),  dimension(:)      :: WEIRC
7493 real, intent(INOUT),  dimension(:)      :: WEIRL
7494 real, intent(INOUT),  dimension(:)      :: DAML
7495 real, intent(INOUT),  dimension(:)      :: ORIFICEC
7496 real, intent(INOUT),  dimension(:)      :: ORIFICEA
7497 real, intent(INOUT),  dimension(:)      :: ORIFICEE
7498 integer, intent(INOUT), dimension(:)    :: reservoir_type
7499 character(len=*), intent(in)            :: reservoir_parameter_file
7500 real, intent(INOUT),  dimension(:)      :: LATLAKE,LONLAKE,ELEVLAKE
7501 real, intent(INOUT),  dimension(:)      :: ChSSlp, Bw, Tw
7502 real, intent(INOUT),  dimension(:)      :: Tw_CC, n_CC, ChannK ! channel properties of compund
7503
7504
7505 character(len=*  )                           :: geo_finegrid_flnm, route_lake_f
7506 character(len=256)                           :: var_name
7507
7508 integer                                      :: tmp, cnt, ncid, iret, jj,ct
7509 integer                                      :: IOstatus
7510 integer(kind=int64)              :: OUTLAKEID
7511
7512 real                                         :: gc,n
7513 integer :: did
7514 logical :: fexist
7515
7516 did = 1
7517
7518 !---------------------------------------------------------
7519 ! End Declarations
7520 !---------------------------------------------------------
7521
7522
7523 !LAKEIDX  = -999
7524 !LAKELINKID = 0
7525 MAXORDER = -9999
7526 !initialize GSTRM
7527 GSTRMFRXSTPTS = -9999
7528
7529 !yw initialize the array.
7530 to_node =   MAXORDER
7531 from_node = MAXORDER
7532 #ifdef MPP_LAND
7533 Link_location = MAXORDER
7534 #endif
7535
7536 var_name = "LATITUDE"
7537 call nreadRT2d_real  (   &
7538      var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm))
7539
7540 var_name = "LONGITUDE"
7541 call nreadRT2d_real(   &
7542      var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm))
7543
7544 var_name = "LAKEGRID"
7545 call nreadRT2d_int(&
7546      var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm))
7547
7548 var_name = "FLOWDIRECTION"
7549 call nreadRT2d_int(&
7550      var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm))
7551
7552 var_name = "STREAMORDER"
7553 call nreadRT2d_int(&
7554      var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm))
7555
7556
7557 var_name = "frxst_pts"
7558 call nreadRT2d_int(&
7559      var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm))
7560
7561 !!!Flip y-dimension of highres grids from exported Arc files...
7562
7563 var_name = "CHAN_DEPTH"
7564 call nreadRT2d_real(   &
7565      var_name,chanDepth,ixrt,jxrt,trim(geo_finegrid_flnm))
7566
7567 if(nlst(did)%GWBASESWCRT .eq. 3) then
7568    elrt = fgDEM - chanDepth
7569 else
7570    elrt = fgDEM     !ywtmp
7571 endif
7572
7573 ct = 0
7574
7575 ! temp fix for buggy Arc export...
7576 do j=1,jxrt
7577    do i=1,ixrt
7578       if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128
7579    end do
7580 end do
7581
7582 cnt    = 0
7583 BwG    = 0.0
7584 TwG    = 0.0
7585 Tw_CCG = 0.0
7586 n_CCG  = 0.0
7587
7588
7589 ChSSlpG = 0.0
7590 MannNG  = 0.0
7591 TYPEL   = 0
7592 MannN   = 0.0
7593 Bw      = 0.0
7594 Tw      = 0.0
7595 Tw_CC   = 0.0
7596 n_CC    = 0.0
7597 ChSSlp  = 0.0
7598 ChannK  = 0.0
7599 ChannKG = 0.0
7600
7601
7602 if (channel_option .eq. 3) then
7603
7604 #ifdef MPP_LAND
7605   if(my_id .eq. IO_id) then
7606 #endif
7607
7608     if (NLAKES .gt. 0) then
7609       inquire (file=trim(route_lake_f), exist=fexist)
7610       if(fexist) then
7611         ! use netcdf lake file of LAKEPARM.nc
7612         iret = nf90_open(trim(route_lake_f), NF90_NOWRITE, ncid)
7613         if( iret .eq. 0 ) then
7614           iret = nf90_close(ncid)
7615           write(6,*) "Before read LAKEPARM from NetCDF ", trim(route_lake_f)
7616           write(6,*) "NLAKES = ", NLAKES
7617           call flush(6)
7618           call read_route_lake_netcdf(trim(route_lake_f),HRZAREA, &
7619                 LAKEMAXH, WEIRH, WEIRC,WEIRL, DAML, ORIFICEC,       &
7620                 ORIFICEA,  ORIFICEE, reservoir_type_specified, reservoir_type, &
7621                 reservoir_parameter_file, LAKEIDM, latlake, lonlake, ELEVLAKE, NLAKES)
7622         else
7623           open(unit=79,file=trim(route_lake_f), form='formatted',status='old')
7624           write(6,*) "Before read LAKEPARM from text ", trim(route_lake_f)
7625           write(6,*) "NLAKES = ", NLAKES
7626           call flush(6)
7627           read(79,*)  header  !-- read the lake file
7628           do i=1, NLAKES
7629             read (79,*,err=5101) tmp, HRZAREA(i),LAKEMAXH(i), &
7630             WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),&
7631             LATLAKE(i), LONLAKE(i),ELEVLAKE(i), WEIRH(i), reservoir_type(i)
7632           enddo
7633 5101      continue
7634           close(79)
7635         endif !endif for iret
7636       else ! lake parm files does not exist
7637         call hydro_stop("Fatal error: route_lake_f must be specified in the hydro.namelist")
7638         !write(6,*) "ERROR: route_lake_f required for lakes"
7639         !write(6,*) "NLAKES = ", NLAKES
7640         !call flush(6)
7641       endif !endif for fexist
7642     endif ! endif for nlakes
7643
7644 #ifdef MPP_LAND
7645    endif
7646
7647    if (NLAKES > 0) then
7648       call mpp_land_bcast_real(NLAKES,HRZAREA)
7649       call mpp_land_bcast_real(NLAKES,LAKEMAXH)
7650       call mpp_land_bcast_real(NLAKES,WEIRH  )
7651       call mpp_land_bcast_real(NLAKES,WEIRC  )
7652       call mpp_land_bcast_real(NLAKES,WEIRL  )
7653       call mpp_land_bcast_real(NLAKES,DAML)
7654       call mpp_land_bcast_real(NLAKES,ORIFICEC)
7655       call mpp_land_bcast_real(NLAKES,ORIFICEA)
7656       call mpp_land_bcast_real(NLAKES,ORIFICEE)
7657       call mpp_land_bcast_real(NLAKES,LATLAKE )
7658       call mpp_land_bcast_real(NLAKES,LONLAKE )
7659       call mpp_land_bcast_real(NLAKES,ELEVLAKE)
7660       call mpp_land_bcast_int(NLAKES, reservoir_type)
7661    endif
7662 #endif
7663 end if  !! channel_option .eq. 3
7664
7665 if (UDMP_OPT .eq. 1) return
7666
7667 !DJG inv       DO j = JXRT,1,-1  !rows
7668 do j = 1,JXRT  !rows
7669    do i = 1 ,IXRT   !colsumns
7670
7671       if (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order
7672
7673          if ((DIRECTION(i, j) .eq. 64) .and. (j + 1 .le. JXRT) ) then !North
7674             if(CH_NETRT(i,j+1).ge.0) then
7675 #ifdef MPP_LAND
7676                cnt = CH_NETLNK(i,j)
7677 #else
7678                cnt = cnt + 1
7679 #endif
7680                ORDER(cnt) = GORDER(i,j)
7681                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7682                ZELEV(cnt) = ELRT(i,j)
7683                MannN(cnt) = MannNG(i,j)
7684                ChSSlp(cnt) = ChSSlpG(i,j)
7685                Bw(cnt) = BwG(i,j)
7686                ChannK(cnt) = ChannKG(i,j)
7687                Tw(cnt) = TwG(i,j)
7688                Tw_CC(cnt) = Tw_CCG(i,j)
7689                n_CC(cnt) = n_CCG(i,j)
7690                CHLAT(cnt) = LATVAL(i,j)
7691                CHLON(cnt) = LONVAL(i,j)
7692                FROM_NODE(cnt) = CH_NETLNK(i, j)
7693                TO_NODE(cnt) = CH_NETLNK(i, j + 1)
7694                CHANLEN(cnt) = dist(i,j,1)
7695                CHANXI(cnt) = i
7696                CHANYJ(cnt) = j
7697 #ifdef MPP_LAND
7698                Link_Location(i,j) = cnt
7699 #endif
7700             endif
7701
7702          else if ((DIRECTION(i, j) .eq. 128) .and. (i + 1 .le. IXRT) &
7703               .and. (j + 1 .le. JXRT)  ) then !North East
7704
7705             if(CH_NETRT(i+1,j+1).ge.0) then
7706 #ifdef MPP_LAND
7707                cnt = CH_NETLNK(i,j)
7708 #else
7709                cnt = cnt + 1
7710 #endif
7711                ORDER(cnt) = GORDER(i,j)
7712                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7713                ZELEV(cnt) = ELRT(i,j)
7714                MannN(cnt) = MannNG(i,j)
7715                ChSSlp(cnt) = ChSSlpG(i,j)
7716                Bw(cnt) = BwG(i,j)
7717                ChannK(cnt) = ChannKG(i,j)
7718                Tw(cnt) = TwG(i,j)
7719                Tw_CC(cnt) = Tw_CCG(i,j)
7720                n_CC(cnt) = n_CCG(i,j)
7721                CHLAT(cnt) = LATVAL(i,j)
7722                CHLON(cnt) = LONVAL(i,j)
7723                FROM_NODE(cnt) = CH_NETLNK(i, j)
7724                TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1)
7725                CHANLEN(cnt) = dist(i,j,2)
7726                CHANXI(cnt) = i
7727                CHANYJ(cnt) = j
7728 #ifdef MPP_LAND
7729                Link_Location(i,j) = cnt
7730 #endif
7731             endif
7732
7733          else if ((DIRECTION(i, j) .eq. 1) .and. (i + 1 .le. IXRT) ) then !East
7734
7735             if(CH_NETRT(i+1,j).ge.0) then
7736 #ifdef MPP_LAND
7737                cnt = CH_NETLNK(i,j)
7738 #else
7739                cnt = cnt + 1
7740 #endif
7741                ORDER(cnt) = GORDER(i,j)
7742                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7743                ZELEV(cnt) = ELRT(i,j)
7744                MannN(cnt) = MannNG(i,j)
7745                ChSSlp(cnt) = ChSSlpG(i,j)
7746                Bw(cnt) = BwG(i,j)
7747                ChannK(cnt) = ChannKG(i,j)
7748                Tw(cnt) = TwG(i,j)
7749                Tw_CC(cnt) = Tw_CCG(i,j)
7750                n_CC(cnt) = n_CCG(i,j)
7751                CHLAT(cnt) = LATVAL(i,j)
7752                CHLON(cnt) = LONVAL(i,j)
7753                FROM_NODE(cnt) = CH_NETLNK(i, j)
7754                TO_NODE(cnt) = CH_NETLNK(i + 1, j)
7755                CHANLEN(cnt) = dist(i,j,3)
7756                CHANXI(cnt) = i
7757                CHANYJ(cnt) = j
7758 #ifdef MPP_LAND
7759                Link_Location(i,j) = cnt
7760 #endif
7761             endif
7762
7763          else if ((DIRECTION(i, j) .eq. 2) .and. (i + 1 .le. IXRT) &
7764               .and. (j - 1 .ne. 0)  ) then !south east
7765
7766             if(CH_NETRT(i+1,j-1).ge.0) then
7767 #ifdef MPP_LAND
7768                cnt = CH_NETLNK(i,j)
7769 #else
7770                cnt = cnt + 1
7771 #endif
7772                ORDER(cnt) = GORDER(i,j)
7773                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7774                ZELEV(cnt) = ELRT(i,j)
7775                MannN(cnt) = MannNG(i,j)
7776                ChSSlp(cnt) = ChSSlpG(i,j)
7777                Bw(cnt) = BwG(i,j)
7778                ChannK(cnt) = ChannKG(i,j)
7779                Tw(cnt) = TwG(i,j)
7780                Tw_CC(cnt) = Tw_CCG(i,j)
7781                n_CC(cnt) = n_CCG(i,j)
7782                CHLAT(cnt) = LATVAL(i,j)
7783                CHLON(cnt) = LONVAL(i,j)
7784                FROM_NODE(cnt) = CH_NETLNK(i, j)
7785                TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1)
7786                CHANLEN(cnt) = dist(i,j,4)
7787                CHANXI(cnt) = i
7788                CHANYJ(cnt) = j
7789 #ifdef MPP_LAND
7790                Link_Location(i,j) = cnt
7791 #endif
7792             endif
7793
7794          else if ((DIRECTION(i, j) .eq. 4) .and. (j - 1 .ne. 0) ) then !due south
7795
7796             if(CH_NETRT(i,j-1).ge.0) then
7797 #ifdef MPP_LAND
7798                cnt = CH_NETLNK(i,j)
7799 #else
7800                cnt = cnt + 1
7801 #endif
7802                ORDER(cnt) = GORDER(i,j)
7803                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7804                ZELEV(cnt) = ELRT(i,j)
7805                MannN(cnt) = MannNG(i,j)
7806                ChSSlp(cnt) = ChSSlpG(i,j)
7807                Bw(cnt) = BwG(i,j)
7808                ChannK(cnt) = ChannKG(i,j)
7809                Tw(cnt) = TwG(i,j)
7810                Tw_CC(cnt) = Tw_CCG(i,j)
7811                n_CC(cnt) = n_CCG(i,j)
7812                CHLAT(cnt) = LATVAL(i,j)
7813                CHLON(cnt) = LONVAL(i,j)
7814                FROM_NODE(cnt) = CH_NETLNK(i, j)
7815                TO_NODE(cnt) = CH_NETLNK(i, j - 1)
7816                CHANLEN(cnt) = dist(i,j,5)
7817                CHANXI(cnt) = i
7818                CHANYJ(cnt) = j
7819 #ifdef MPP_LAND
7820                Link_Location(i,j) = cnt
7821 #endif
7822             endif
7823
7824          else if ((DIRECTION(i, j) .eq. 8) .and. (i - 1 .gt. 0) &
7825               .and. (j - 1 .ne. 0) ) then !south west
7826
7827             if(CH_NETRT(i-1,j-1).ge.0) then
7828 #ifdef MPP_LAND
7829                cnt = CH_NETLNK(i,j)
7830 #else
7831                cnt = cnt + 1
7832 #endif
7833                ORDER(cnt) = GORDER(i,j)
7834                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7835                ZELEV(cnt) = ELRT(i,j)
7836                MannN(cnt) = MannNG(i,j)
7837                ChSSlp(cnt) = ChSSlpG(i,j)
7838                Bw(cnt) = BwG(i,j)
7839                ChannK(cnt) = ChannKG(i,j)
7840                Tw(cnt) = TwG(i,j)
7841                Tw_CC(cnt) = Tw_CCG(i,j)
7842                n_CC(cnt) = n_CCG(i,j)
7843                CHLAT(cnt) = LATVAL(i,j)
7844                CHLON(cnt) = LONVAL(i,j)
7845                FROM_NODE(cnt) = CH_NETLNK(i,j)
7846                TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1)
7847                CHANLEN(cnt) = dist(i,j,6)
7848                CHANXI(cnt) = i
7849                CHANYJ(cnt) = j
7850 #ifdef MPP_LAND
7851                Link_Location(i,j) = cnt
7852 #endif
7853             endif
7854
7855          else if ((DIRECTION(i, j) .eq. 16) .and. (i - 1 .gt. 0) ) then !West
7856
7857             if(CH_NETRT(i-1,j).ge.0) then
7858 #ifdef MPP_LAND
7859                cnt = CH_NETLNK(i,j)
7860 #else
7861                cnt = cnt + 1
7862 #endif
7863                FROM_NODE(cnt) = CH_NETLNK(i, j)
7864                ORDER(cnt) = GORDER(i,j)
7865                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7866                ZELEV(cnt) = ELRT(i,j)
7867                MannN(cnt) = MannNG(i,j)
7868                ChSSlp(cnt) = ChSSlpG(i,j)
7869                Bw(cnt) = BwG(i,j)
7870                ChannK(cnt) = ChannKG(i,j)
7871                Tw(cnt) = TwG(i,j)
7872                Tw_CC(cnt) = Tw_CCG(i,j)
7873                n_CC(cnt) = n_CCG(i,j)
7874                CHLAT(cnt) = LATVAL(i,j)
7875                CHLON(cnt) = LONVAL(i,j)
7876                TO_NODE(cnt) = CH_NETLNK(i - 1, j)
7877                CHANLEN(cnt) = dist(i,j,7)
7878                CHANXI(cnt) = i
7879                CHANYJ(cnt) = j
7880 #ifdef MPP_LAND
7881                Link_Location(i,j) = cnt
7882 #endif
7883             endif
7884
7885          else if ((DIRECTION(i, j) .eq. 32) .and. (i - 1 .gt. 0) &
7886               .and. (j + 1 .le. JXRT)  ) then !North West
7887
7888             if(CH_NETRT(i-1,j+1).ge.0) then
7889 #ifdef MPP_LAND
7890                cnt = CH_NETLNK(i,j)
7891 #else
7892                cnt = cnt + 1
7893 #endif
7894                ORDER(cnt) = GORDER(i,j)
7895                STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7896                ZELEV(cnt) = ELRT(i,j)
7897                MannN(cnt) = MannNG(i,j)
7898                ChSSlp(cnt) = ChSSlpG(i,j)
7899                Bw(cnt) = BwG(i,j)
7900                ChannK(cnt) = ChannKG(i,j)
7901                Tw(cnt) = TwG(i,j)
7902                Tw_CC(cnt) = Tw_CCG(i,j)
7903                n_CC(cnt) = n_CCG(i,j)
7904                CHLAT(cnt) = LATVAL(i,j)
7905                CHLON(cnt) = LONVAL(i,j)
7906                FROM_NODE(cnt) = CH_NETLNK(i, j)
7907                TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1)
7908                CHANLEN(cnt) = dist(i,j,8)
7909                CHANXI(cnt) = i
7910                CHANYJ(cnt) = j
7911 #ifdef MPP_LAND
7912                Link_Location(i,j) = cnt
7913 #endif
7914             endif
7915          else
7916 #ifdef HYDRO_D
7917             !print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east
7918 #endif
7919          end if
7920
7921       end if !CH_NETRT check for this node
7922
7923    end do
7924 end do
7925
7926 #ifdef HYDRO_D
7927 print *, "after exiting the channel, this many nodes", cnt
7928 write(*,*) " "
7929 #endif
7930
7931
7932 !Find out if the boundaries are on an edge
7933 !DJG inv       DO j = JXRT,1,-1
7934 do j = 1,JXRT
7935    do i = 1 ,IXRT
7936       if (CH_NETRT(i, j) .ge. 0) then !get its direction
7937
7938          if (DIRECTION(i, j).eq. 64) then
7939             if( j + 1 .gt. JXRT)  then         !-- 64's can only flow north
7940                goto 101
7941
7942             elseif ( CH_NETRT(i,j+1) .lt. 0) then !North
7943
7944                goto 101
7945             endif
7946             goto 102
7947 101         continue
7948 #ifdef MPP_LAND
7949             cnt = CH_NETLNK(i,j)
7950 #else
7951             cnt = cnt + 1
7952 #endif
7953             ORDER(cnt) = GORDER(i,j)
7954             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
7955             ZELEV(cnt) = ELRT(i,j)
7956             MannN(cnt) = MannNG(i,j)
7957             ChSSlp(cnt) = ChSSlpG(i,j)
7958             Bw(cnt) = BwG(i,j)
7959             ChannK(cnt) = ChannKG(i,j)
7960             Tw(cnt) = TwG(i,j)
7961             Tw_CC(cnt) = Tw_CCG(i,j)
7962             n_CC(cnt) = n_CCG(i,j)
7963             CHLAT(cnt) = LATVAL(i,j)
7964             CHLON(cnt) = LONVAL(i,j)
7965             if(j+1 .gt. JXRT) then !-- an edge
7966                TYPEL(cnt) = 1
7967             elseif(LAKE_MSKRT(i,j+1).gt.0) then
7968                TYPEL(cnt) = 2
7969                LAKENODE(cnt) = LAKE_MSKRT(i,j+1)
7970             else
7971                TYPEL(cnt) = 1
7972             endif
7973             FROM_NODE(cnt) = CH_NETLNK(i, j)
7974             CHANLEN(cnt) = dist(i,j,1)
7975             CHANXI(cnt) = i
7976             CHANYJ(cnt) = j
7977 #ifdef MPP_LAND
7978             Link_Location(i,j) = cnt
7979 #endif
7980 #ifdef HYDRO_D
7981             !                print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
7982 #endif
7983 102         continue
7984
7985          else if ( DIRECTION(i, j) .eq. 128) then
7986
7987             !-- 128's can flow out of the North or East edge
7988             if ((i + 1 .gt. IXRT)   .or.  (j + 1 .gt. JXRT))  then !   this is due north edge
7989                goto 201
7990             elseif (CH_NETRT(i + 1, j + 1).lt.0) then !North East
7991                goto 201
7992             endif
7993 !#endif
7994             goto 202
7995 201         continue
7996 #ifdef MPP_LAND
7997             cnt = CH_NETLNK(i,j)
7998 #else
7999             cnt = cnt + 1
8000 #endif
8001             ORDER(cnt) = GORDER(i,j)
8002             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8003             ZELEV(cnt) = ELRT(i,j)
8004             MannN(cnt) = MannNG(i,j)
8005             ChSSlp(cnt) = ChSSlpG(i,j)
8006             Bw(cnt) = BwG(i,j)
8007             ChannK(cnt) = ChannKG(i,j)
8008             Tw(cnt) = TwG(i,j)
8009             Tw_CC(cnt) = Tw_CCG(i,j)
8010             n_CC(cnt) = n_CCG(i,j)
8011             CHLAT(cnt) = LATVAL(i,j)
8012             CHLON(cnt) = LONVAL(i,j)
8013             if((i+1 .gt. IXRT) .or. (j+1 .gt. JXRT))  then ! an edge
8014                TYPEL(cnt) = 1
8015             elseif(LAKE_MSKRT(i+1,j+1).gt.0) then
8016                TYPEL(cnt) = 2
8017                LAKENODE(cnt) = LAKE_MSKRT(i+1,j+1)
8018             else
8019                TYPEL(cnt) = 1
8020             endif
8021             FROM_NODE(cnt) = CH_NETLNK(i, j)
8022             CHANLEN(cnt) = dist(i,j,2)
8023             CHANXI(cnt) = i
8024             CHANYJ(cnt) = j
8025 #ifdef MPP_LAND
8026             Link_Location(i,j) = cnt
8027 #endif
8028 #ifdef HYDRO_D
8029             !print *, "Pour Point NE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8030 #endif
8031 202         continue
8032
8033          else if (DIRECTION(i, j) .eq. 1) then
8034
8035             if(i + 1 .gt. IXRT) then     !-- 1's can only flow due east
8036                goto 301
8037             elseif(CH_NETRT(i + 1, j) .lt. 0) then !East
8038                goto 301
8039             endif
8040             goto 302
8041 301         continue
8042 #ifdef MPP_LAND
8043             cnt = CH_NETLNK(i,j)
8044 #else
8045             cnt = cnt + 1
8046 #endif
8047             ORDER(cnt) = GORDER(i,j)
8048             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8049             ZELEV(cnt) = ELRT(i,j)
8050             MannN(cnt) = MannNG(i,j)
8051             ChSSlp(cnt) = ChSSlpG(i,j)
8052             Bw(cnt) = BwG(i,j)
8053             ChannK(cnt) = ChannKG(i,j)
8054             Tw(cnt) = TwG(i,j)
8055             Tw_CC(cnt) = Tw_CCG(i,j)
8056             n_CC(cnt) = n_CCG(i,j)
8057             CHLAT(cnt) = LATVAL(i,j)
8058             CHLON(cnt) = LONVAL(i,j)
8059             if(i+1 .gt. IXRT) then  !an edge
8060                TYPEL(cnt) = 1
8061             elseif(LAKE_MSKRT(i+1,j).gt.0) then
8062                TYPEL(cnt) = 2
8063                LAKENODE(cnt) = LAKE_MSKRT(i+1,j)
8064             else
8065                TYPEL(cnt) = 1
8066             endif
8067             FROM_NODE(cnt) = CH_NETLNK(i, j)
8068             CHANLEN(cnt) = dist(i,j,3)
8069             CHANXI(cnt) = i
8070             CHANYJ(cnt) = j
8071 #ifdef MPP_LAND
8072             Link_Location(i,j) = cnt
8073 #endif
8074 #ifdef HYDRO_D
8075             !print *, "Pour Point E", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8076 #endif
8077 302         continue
8078
8079          else if (DIRECTION(i, j) .eq. 2) then
8080
8081             !-- 2's can flow out of east or south edge
8082             if((i + 1 .gt. IXRT) .or.  (j - 1 .eq. 0)) then     !-- this is the south edge
8083                goto 401
8084             elseif (CH_NETRT(i + 1, j - 1) .lt.0) then !south east
8085                goto 401
8086             endif
8087             goto 402
8088 401         continue
8089 #ifdef MPP_LAND
8090             cnt = CH_NETLNK(i,j)
8091 #else
8092             cnt = cnt + 1
8093 #endif
8094             ORDER(cnt) = GORDER(i,j)
8095             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8096             ZELEV(cnt) = ELRT(i,j)
8097             MannN(cnt) = MannNG(i,j)
8098             ChSSlp(cnt) = ChSSlpG(i,j)
8099             Bw(cnt) = BwG(i,j)
8100             ChannK(cnt) = ChannKG(i,j)
8101             Tw(cnt) = TwG(i,j)
8102             Tw_CC(cnt) = Tw_CCG(i,j)
8103             n_CC(cnt) = n_CCG(i,j)
8104             CHLAT(cnt) = LATVAL(i,j)
8105             CHLON(cnt) = LONVAL(i,j)
8106             if((i+1 .gt. IXRT) .or. (j-1 .eq. 0)) then !an edge
8107                TYPEL(cnt) = 1
8108             elseif(LAKE_MSKRT(i+1,j-1).gt.0) then
8109                TYPEL(cnt) = 2
8110                LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1)
8111             else
8112                TYPEL(cnt) = 1
8113             endif
8114             FROM_NODE(cnt) = CH_NETLNK(i, j)
8115             CHANLEN(cnt) = dist(i,j,4)
8116             CHANXI(cnt) = i
8117             CHANYJ(cnt) = j
8118 #ifdef MPP_LAND
8119             Link_Location(i,j) = cnt
8120 #endif
8121 #ifdef HYDRO_D
8122             !print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8123 #endif
8124 402         continue
8125
8126          else if (DIRECTION(i, j) .eq. 4)  then
8127
8128             if(j - 1 .eq. 0) then         !-- 4's can only flow due south
8129                goto 501
8130             elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south
8131                goto 501
8132             endif
8133             goto 502
8134 501         continue
8135 #ifdef MPP_LAND
8136             cnt = CH_NETLNK(i,j)
8137 #else
8138             cnt = cnt + 1
8139 #endif
8140             ORDER(cnt) = GORDER(i,j)
8141             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8142             ZELEV(cnt) = ELRT(i,j)
8143             MannN(cnt) = MannNG(i,j)
8144             ChSSlp(cnt) = ChSSlpG(i,j)
8145             Bw(cnt) = BwG(i,j)
8146             ChannK(cnt) = ChannKG(i,j)
8147             Tw(cnt) = TwG(i,j)
8148             Tw_CC(cnt) = Tw_CCG(i,j)
8149             n_CC(cnt) = n_CCG(i,j)
8150             CHLAT(cnt) = LATVAL(i,j)
8151             CHLON(cnt) = LONVAL(i,j)
8152             if(j-1 .eq. 0) then !- an edge
8153                TYPEL(cnt) =1
8154             elseif(LAKE_MSKRT(i,j-1).gt.0) then
8155                TYPEL(cnt) = 2
8156                LAKENODE(cnt) = LAKE_MSKRT(i,j-1)
8157             else
8158                TYPEL(cnt) = 1
8159             endif
8160             FROM_NODE(cnt) = CH_NETLNK(i, j)
8161             CHANLEN(cnt) = dist(i,j,5)
8162             CHANXI(cnt) = i
8163             CHANYJ(cnt) = j
8164 #ifdef MPP_LAND
8165             Link_Location(i,j) = cnt
8166 #endif
8167 #ifdef HYDRO_D
8168             !print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8169 #endif
8170 502         continue
8171
8172          else if ( DIRECTION(i, j) .eq. 8) then
8173
8174             !-- 8's can flow south or west
8175             if( (i - 1 .le. 0) .or.  (j - 1 .eq. 0)) then        !-- this is the south edge
8176                goto 601
8177             elseif (CH_NETRT(i - 1, j - 1).lt.0) then !south west
8178                goto 601
8179             endif
8180             goto 602
8181 601         continue
8182 #ifdef MPP_LAND
8183             cnt = CH_NETLNK(i,j)
8184 #else
8185             cnt = cnt + 1
8186 #endif
8187             ORDER(cnt) = GORDER(i,j)
8188             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8189             ZELEV(cnt) = ELRT(i,j)
8190             MannN(cnt) = MannNG(i,j)
8191             ChSSlp(cnt) = ChSSlpG(i,j)
8192             Bw(cnt) = BwG(i,j)
8193             ChannK(cnt) = ChannKG(i,j)
8194             Tw(cnt) = TwG(i,j)
8195             Tw_CC(cnt) = Tw_CCG(i,j)
8196             n_CC(cnt) = n_CCG(i,j)
8197             CHLAT(cnt) = LATVAL(i,j)
8198             CHLON(cnt) = LONVAL(i,j)
8199             if( (i-1 .eq. 0) .or. (j-1 .eq. 0) ) then !- an edge
8200                TYPEL(cnt) = 1
8201             elseif(LAKE_MSKRT(i-1,j-1).gt.0) then
8202                TYPEL(cnt) = 2
8203                LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1)
8204             else
8205                TYPEL(cnt) = 1
8206             endif
8207             FROM_NODE(cnt) = CH_NETLNK(i, j)
8208             CHANLEN(cnt) = dist(i,j,6)
8209             CHANXI(cnt) = i
8210             CHANYJ(cnt) = j
8211 #ifdef MPP_LAND
8212             Link_Location(i,j) = cnt
8213 #endif
8214 #ifdef HYDRO_D
8215             !print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8216 #endif
8217 602         continue
8218
8219          else if (DIRECTION(i, j) .eq. 16) then
8220
8221             if( i - 1 .le.0) then                 !16's can only flow due west
8222                goto 701
8223             elseif( CH_NETRT(i - 1, j).lt.0) then !West
8224                goto 701
8225             endif
8226             goto 702
8227 701         continue
8228 #ifdef MPP_LAND
8229             cnt = CH_NETLNK(i,j)
8230 #else
8231             cnt = cnt + 1
8232 #endif
8233             ORDER(cnt) = GORDER(i,j)
8234             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8235             ZELEV(cnt) = ELRT(i,j)
8236             MannN(cnt) = MannNG(i,j)
8237             ChSSlp(cnt) = ChSSlpG(i,j)
8238             Bw(cnt) = BwG(i,j)
8239             ChannK(cnt) = ChannKG(i,j)
8240             Tw(cnt) = TwG(i,j)
8241             Tw_CC(cnt) = Tw_CCG(i,j)
8242             n_CC(cnt) = n_CCG(i,j)
8243             CHLAT(cnt) = LATVAL(i,j)
8244             CHLON(cnt) = LONVAL(i,j)
8245             if(i-1 .eq. 0) then !-- an edge
8246                TYPEL(cnt) = 1
8247             elseif(LAKE_MSKRT(i-1,j).gt.0) then
8248                TYPEL(cnt) = 2
8249                LAKENODE(cnt) = LAKE_MSKRT(i-1,j)
8250             else
8251                TYPEL(cnt) = 1
8252             endif
8253             FROM_NODE(cnt) = CH_NETLNK(i, j)
8254             CHANLEN(cnt) = dist(i,j,7)
8255             CHANXI(cnt) = i
8256             CHANYJ(cnt) = j
8257 #ifdef MPP_LAND
8258             Link_Location(i,j) = cnt
8259 #endif
8260 #ifdef HYDRO_D
8261             !             print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8262 #endif
8263 702         continue
8264
8265          else if ( DIRECTION(i, j) .eq. 32) then
8266
8267             !-- 32's can flow either west or north
8268             if( (i - 1 .le. 0) .or.  (j + 1 .gt. JXRT)) then     !-- this is the north edge
8269                goto 801
8270             elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West
8271                goto 801
8272             endif
8273             goto 802
8274 801         continue
8275 #ifdef MPP_LAND
8276             cnt = CH_NETLNK(i,j)
8277 #else
8278             cnt = cnt + 1
8279 #endif
8280             ORDER(cnt) = GORDER(i,j)
8281             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
8282             ZELEV(cnt) = ELRT(i,j)
8283             MannN(cnt) = MannNG(i,j)
8284             ChSSlp(cnt) = ChSSlpG(i,j)
8285             Bw(cnt) = BwG(i,j)
8286             ChannK(cnt) = ChannKG(i,j)
8287             Tw(cnt) = TwG(i,j)
8288             Tw_CC(cnt) = Tw_CCG(i,j)
8289             n_CC(cnt) = n_CCG(i,j)
8290             CHLAT(cnt) = LATVAL(i,j)
8291             CHLON(cnt) = LONVAL(i,j)
8292             if( (i-1 .eq. 0) .or. (j+1 .gt. JXRT)) then !-- an edge
8293                TYPEL(cnt) = 1
8294             elseif(LAKE_MSKRT(i-1,j+1).gt.0) then
8295                TYPEL(cnt) = 2
8296                LAKENODE(cnt) = LAKE_MSKRT(i-1,j+1)
8297             else
8298                TYPEL(cnt) = 1
8299             endif
8300             FROM_NODE(cnt) = CH_NETLNK(i, j)
8301             CHANLEN(cnt) = dist(i,j,8)
8302             CHANXI(cnt) = i
8303             CHANYJ(cnt) = j
8304 #ifdef MPP_LAND
8305             Link_Location(i,j) = cnt
8306 #endif
8307 #ifdef HYDRO_D
8308             !print *, "Pour Point NW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
8309 #endif
8310 802         continue
8311
8312          endif
8313       endif !CH_NETRT check for this node
8314    end do
8315 end do
8316
8317 #ifdef MPP_LAND
8318 #ifdef HYDRO_D
8319 print*, "my_id=",my_id, "cnt = ", cnt
8320 #endif
8321 #endif
8322
8323 #ifdef MPP_LAND
8324 Link_location = CH_NETLNK
8325 call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,int(TYPEL, int64),NLINKS,99)
8326 call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,LAKENODE,NLINKS,99)
8327 #endif
8328
8329 end subroutine READ_CHROUTING1
8330
8331
8332 !! Author JLM.
8333 !! Separate the 2D channel routing memory from the vector/routelink channel routing memory.
8334 subroutine read_routelink(&
8335      TO_NODE,      TYPEL,        ORDER,    MAXORDER,   &
8336      NLAKES,       MUSK,         MUSX,                 &
8337      QLINK,        CHANLEN,      MannN,    So,         &
8338      ChSSlp,       Bw,           Tw,       Tw_CC,      &
8339      n_CC,         ChannK,       LAKEIDA,  HRZAREA,    &
8340      LAKEMAXH,     WEIRH,        WEIRC,   WEIRL, DAML, &
8341      ORIFICEC,     ORIFICEA,     ORIFICEE,             &
8342      reservoir_type_specified,   reservoir_type,       &
8343      reservoir_parameter_file,   LATLAKE,              &
8344      LONLAKE,      ELEVLAKE,     LAKEIDM,  LAKEIDX,    &
8345      route_link_f, route_lake_f, ZELEV,    CHLAT,      &
8346      CHLON,        NLINKSL,      LINKID,   GNLINKSL,   &
8347      NLINKS,       gages,        gageMiss               )
8348
8349 integer, intent(INOUT),  dimension(NLINKS) :: TYPEL, ORDER
8350 integer, intent(INOUT)                     :: MAXORDER
8351 integer                                    :: NLAKES
8352 real,    intent(INOUT),  dimension(NLINKS) :: MUSK, MUSX
8353 real,    intent(INOUT),  dimension(:,:)    :: QLINK  !channel flow
8354 real,    intent(INOUT),  dimension(NLINKS) :: CHANLEN, MannN, So
8355 real,    intent(INOUT),  dimension(:)      :: ChSSlp, Bw, Tw !added Top Width LKR/DY
8356 real,    intent(INOUT),  dimension(:)      :: Tw_CC, n_CC !compound chnannel params
8357 real,    intent(INOUT),  dimension(:)      :: ChannK !added ChanLoss
8358 real,    intent(INOUT),  dimension(:)      :: HRZAREA
8359 real,    intent(INOUT),  dimension(:)      :: LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML
8360 real,    intent(INOUT),  dimension(:)      :: ORIFICEC, ORIFICEA, ORIFICEE
8361 logical, intent(IN)                        :: reservoir_type_specified
8362 integer, intent(INOUT),  dimension(:)      :: reservoir_type
8363 character(len=*), intent(in)               :: reservoir_parameter_file
8364 real,    intent(INOUT),  dimension(:)      :: LATLAKE, LONLAKE, ELEVLAKE
8365 integer(kind=int64), intent(INOUT), dimension(:)  :: LAKEIDM !lake id in LAKEPARM table (.nc or .tbl)
8366 integer(kind=int64), intent(INOUT), dimension(:)  :: LAKEIDA !lake COMid 4all link on full nlinks database
8367 integer, intent(INOUT),  dimension(:)      :: LAKEIDX !seq index of lakes(1:Nlakes) mapped to COMID
8368 character(len=256)                         :: route_link_f, route_lake_f
8369 real,    intent(INOUT),  dimension(NLINKS) :: ZELEV, CHLAT, CHLON
8370 integer                                    :: NLINKS, NLINKSL
8371 integer(kind=int64), intent(INOUT),  dimension(NLINKS) :: TO_NODE, LINKID   !  which nodes pour into which lakes
8372 integer                                    :: GNLINKSL
8373 character(len=15), intent(inout), dimension(nlinks) :: gages  !! need to respect the default values
8374 character(len=15), intent(in)              :: gageMiss
8375 integer :: did
8376
8377 !! local variables
8378 integer(kind=int64), dimension(NLAKES)         :: LAKELINKID !temporarily store the outlet index for each modeled lake
8379
8380 did = 1
8381 LAKELINKID = 0
8382
8383 call readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f,maxorder, &
8384      LINKID, TO_NODE, TYPEL, ORDER , &
8385      QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, &
8386      MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, ChannK, LAKEIDA, HRZAREA,  &
8387      LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, ORIFICEC, &
8388      ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, &
8389      gages, gageMiss, LAKEIDM, NLAKES, latlake, lonlake,ELEVLAKE)
8390
8391 !--- get the lake configuration here.
8392 #ifdef MPP_LAND
8393 call nhdLakeMap_mpp(NLAKES,  NLINKSL, TYPEL,   LAKELINKID, LAKEIDX, &
8394                     TO_NODE, LINKID,  LAKEIDM, LAKEIDA,    GNLINKSL  )
8395 !call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA
8396 #else
8397 call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA)
8398 #endif
8399
8400 #ifdef MPP_LAND
8401 if (NLAKES > 0) then
8402    !         call mpp_land_bcast_int(NLINKSL,LAKEIDA)
8403    !         call mpp_land_bcast_int(NLINKSL,LAKEIDX)
8404    call mpp_land_bcast_real(NLAKES,HRZAREA)
8405    call mpp_land_bcast_int8(NLAKES,LAKEIDM)
8406    call mpp_land_bcast_real(NLAKES,LAKEMAXH)
8407    call mpp_land_bcast_real(NLAKES,WEIRH  )
8408    call mpp_land_bcast_real(NLAKES,WEIRC  )
8409    call mpp_land_bcast_real(NLAKES,WEIRL  )
8410    call mpp_land_bcast_real(NLAKES,DAML)
8411    call mpp_land_bcast_real(NLAKES,ORIFICEC)
8412    call mpp_land_bcast_real(NLAKES,ORIFICEA)
8413    call mpp_land_bcast_real(NLAKES,ORIFICEE)
8414    call mpp_land_bcast_real(NLAKES,LATLAKE )
8415    call mpp_land_bcast_real(NLAKES,LONLAKE )
8416    call mpp_land_bcast_real(NLAKES,ELEVLAKE)
8417    call mpp_land_bcast_int(NLAKES, reservoir_type)
8418 endif
8419 #endif
8420
8421 end subroutine read_routelink
8422
8423
8424
8425    subroutine readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f, maxorder, &
8426                    LINKID, TO_NODE, TYPEL, ORDER , &
8427                    QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, &
8428                    MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, ChannK, LAKEIDA, HRZAREA,  &
8429                    LAKEMAXH,WEIRH,  WEIRC, WEIRL, DAML, ORIFICEC, &
8430                    ORIFICEA, ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, &
8431                    gages, gageMiss, LAKEIDM,NLAKES, latlake, lonlake, ELEVLAKE)
8432
8433         implicit none
8434         character(len=*) :: route_link_f,route_lake_f
8435         integer  :: GNLINKSL, NLINKSL, tmp_from_node,NLAKES
8436
8437         INTEGER, INTENT(INOUT)                     :: MAXORDER
8438         integer(kind=int64), intent(out), dimension(:) :: LAKEIDA, LINKID, TO_NODE
8439         INTEGER, intent(out), dimension(:)         :: TYPEL, ORDER
8440
8441         real,dimension(:,:)  :: QLINK
8442         real, intent(out), dimension(:) ::  CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN
8443         real, intent(out), dimension(:) ::  MannN, So, ChSSlp, Bw, Tw, latlake, lonlake, Tw_CC, n_CC
8444         real, intent(out), dimension(:) ::  ChannK
8445
8446         character(len=15), dimension(:), intent(inout) :: gages
8447         character(len=15), intent(in) :: gageMiss
8448
8449 !NLAKES
8450         integer(kind=int64), intent(out), dimension(:)  ::  LAKEIDM
8451         integer, intent(out), dimension(:)  ::  reservoir_type
8452         logical, intent(in)                         ::  reservoir_type_specified
8453         character(len=*), intent(in)        ::  reservoir_parameter_file
8454         REAL, intent(out), dimension(:) :: HRZAREA,LAKEMAXH, WEIRC, WEIRL, DAML, ORIFICEC, WEIRH, &
8455                    ORIFICEA, ORIFICEE, ELEVLAKE
8456 !end NLAKES
8457
8458         INTEGER(kind=int64), dimension(GNLINKSL) ::  tmpLAKEIDA, tmpLINKID,  tmpTO_NODE
8459         INTEGER, dimension(GNLINKSL) ::  tmpTYPEL, tmpORDER
8460         character(len=15), dimension(gnlinksl) :: tmpGages
8461         CHARACTER(len=155)       :: header
8462         integer :: i
8463
8464         character(len=256) :: route_link_f_r,route_lake_f_r
8465         integer :: lenRouteLinkFR,lenRouteLakeFR ! so the preceeding chan be changed without changing code
8466         logical :: routeLinkNetcdf, routeLakeNetcdf
8467
8468 #ifdef MPP_LAND
8469         real :: tmpQLINK(GNLINKSL,2)
8470         real, allocatable, dimension(:) ::  tmpCHLON, tmpCHLAT, tmpZELEV, tmpMUSK, tmpMUSX, tmpCHANLEN
8471         real, allocatable, dimension(:) ::  tmpMannN, tmpSo, tmpChSSlp, tmpBw, tmpTw, tmpTw_CC, tmpn_CC
8472         real, allocatable, dimension(:) ::  tmpChannK
8473 #endif
8474
8475         !! is RouteLink file netcdf (*.nc) or csv (*.csv)
8476         route_link_f_r = adjustr(route_link_f)
8477         lenRouteLinkFR = len(route_link_f_r)
8478         routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq. '.nc'
8479
8480         !! is RouteLake file netcdf (*.nc) or .TBL
8481         route_lake_f_r = adjustr(route_lake_f)
8482         lenRouteLakeFR = len(route_lake_f_r)
8483         routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc'
8484
8485 #ifdef MPP_LAND
8486        tmpQLINK = 0
8487        tmpGages = gageMiss
8488
8489        if(my_id .eq. IO_id) then
8490
8491           allocate(tmpCHLON(GNLINKSL))
8492           allocate(tmpCHLAT(GNLINKSL))
8493           allocate(tmpZELEV(GNLINKSL))
8494           allocate(tmpMUSK(GNLINKSL))
8495           allocate(tmpMUSX(GNLINKSL))
8496           allocate(tmpCHANLEN(GNLINKSL))
8497           allocate(tmpMannN(GNLINKSL))
8498           allocate(tmpSo(GNLINKSL))
8499           allocate(tmpChSSlp(GNLINKSL))
8500           allocate(tmpBw(GNLINKSL))
8501           allocate(tmpTw(GNLINKSL))
8502           allocate(tmpTw_CC(GNLINKSL))
8503           allocate(tmpn_CC(GNLINKSL))
8504           allocate(tmpChannK(GNLINKSL))
8505
8506           if(routeLinkNetcdf) then
8507
8508              call read_route_link_netcdf(                                &
8509                   route_link_f,                                          &
8510                   tmpLINKID,     tmpTO_NODE,   tmpCHLON,                 &
8511                   tmpCHLAT,      tmpZELEV,     tmpTYPEL,    tmpORDER,    &
8512                   tmpQLINK(:,1), tmpMUSK,      tmpMUSX,     tmpCHANLEN,  &
8513                   tmpMannN,      tmpSo,        tmpChSSlp,   tmpBw,       &
8514                   tmpTw,         tmpTw_CC,     tmpn_CC,     tmpChannK,   &
8515                   tmpGages,      tmpLAKEIDA                         )
8516
8517           else
8518
8519              open(unit=17,file=trim(route_link_f),form='formatted',status='old')
8520              read(17,*)  header
8521 #ifdef HYDRO_D
8522              print *, "header ", header, "NLINKSL = ", NLINKSL, GNLINKSL
8523 #endif
8524              call flush(6)
8525              do i=1,GNLINKSL
8526                 read (17,*) tmpLINKID(i),   tmp_from_node,   tmpTO_NODE(i), tmpCHLON(i),    &
8527                             tmpCHLAT(i),    tmpZELEV(i),     tmpTYPEL(i),   tmpORDER(i),    &
8528                             tmpQLINK(i,1),  tmpMUSK(i),      tmpMUSX(i),    tmpCHANLEN(i),  &
8529                             tmpMannN(i),    tmpSo(i),        tmpChSSlp(i),  tmpBw(i),       &
8530                             tmpTw(i),       tmpTw_CC(i),     tmpn_CC(i),    tmpChannK(i)
8531
8532                 ! if (So(i).lt.0.005) So(i) = 0.005  !-- impose a minimum slope requireement
8533                 if (tmpORDER(i) .gt. MAXORDER) MAXORDER = tmpORDER(i)
8534              end do
8535              close(17)
8536
8537           end if  ! routeLinkNetcdf
8538
8539           if(routeLakeNetcdf) then
8540              call read_route_lake_netcdf(route_lake_f,HRZAREA, &
8541                 LAKEMAXH, WEIRH, WEIRC, WEIRL, DAML, ORIFICEC,       &
8542                 ORIFICEA,  ORIFICEE, reservoir_type_specified, reservoir_type, reservoir_parameter_file, &
8543                 LAKEIDM, latlake, lonlake, ELEVLAKE, NLAKES)
8544           endif
8545
8546 !!- initialize channel  if missing in input
8547            do i=1,GNLINKSL
8548               if(tmpQLINK(i,1) .le. 1e-3) then
8549                  tmpQLINK(i,1) = 20.0 * (1.0/(float(MAXORDER+1) - float(tmpORDER(i))))**3
8550                 tmpQLINK(i,2) = tmpQLINK(i,1) !## initialize the current flow at each link
8551               endif
8552            end do
8553
8554        endif ! my_id .eq. IO_id
8555
8556         call ReachLS_decomp(tmpLINKID,  LINKID )
8557         call ReachLS_decomp(tmpLAKEIDA, LAKEIDA )
8558
8559         call ReachLS_decomp(tmpTO_NODE, TO_NODE)
8560         call ReachLS_decomp(tmpCHLON,    CHLON  )
8561         call ReachLS_decomp(tmpCHLAT,    CHLAT  )
8562         call ReachLS_decomp(tmpZELEV,    ZELEV  )
8563         call ReachLS_decomp(tmpTYPEL,   TYPEL  )
8564         call ReachLS_decomp(tmpORDER,   ORDER  )
8565         call ReachLS_decomp(tmpQLINK(:,1), QLINK(:,1))
8566         call ReachLS_decomp(tmpQLINK(:,2), QLINK(:,2))
8567         call ReachLS_decomp(tmpMUSK,    MUSK   )
8568         call ReachLS_decomp(tmpMUSX,     MUSX   )
8569         call ReachLS_decomp(tmpCHANLEN,  CHANLEN)
8570         call ReachLS_decomp(tmpMannN,    MannN  )
8571         call ReachLS_decomp(tmpSo,       So     )
8572         call ReachLS_decomp(tmpChSSlp,   ChSSlp )
8573         call ReachLS_decomp(tmpBw,       Bw     )
8574         call ReachLS_decomp(tmpTw,       Tw     )
8575         call ReachLS_decomp(tmpTw_CC,    Tw_CC  )
8576         call ReachLS_decomp(tmpn_CC,     n_CC   )
8577         call ReachLS_decomp(tmpChannK,   ChannK )
8578
8579 !       call ReachLS_decomp(tmpHRZAREA,  HRZAREA)
8580 !       call ReachLS_decomp(tmpLAKEMAXH, LAKEMAXH)
8581 !       call ReachLS_decomp(tmpWEIRC,    WEIRC  )
8582 !       call ReachLS_decomp(tmpWEIRL,    WEIRL  )
8583 !       call ReachLS_decomp(tmpORIFICEC, ORIFICEC)
8584 !       call ReachLS_decomp(tmpORIFICEA, ORIFICEA)
8585 !       call ReachLS_decomp(tmpORIFICEE, ORIFICEE)
8586
8587         call ReachLS_decomp(tmpGages,    gages)
8588         call mpp_land_bcast_int1(MAXORDER)
8589
8590         if (NLAKES > 0) then
8591            call mpp_land_bcast_real(NLAKES, HRZAREA)
8592            call mpp_land_bcast_real(NLAKES, LAKEMAXH)
8593            call mpp_land_bcast_real(NLAKES, WEIRH)
8594            call mpp_land_bcast_real(NLAKES, WEIRC)
8595            call mpp_land_bcast_real(NLAKES, WEIRL)
8596            call mpp_land_bcast_real(NLAKES, DAML)
8597            call mpp_land_bcast_real(NLAKES, ORIFICEC)
8598            call mpp_land_bcast_real(NLAKES, ORIFICEA)
8599            call mpp_land_bcast_real(NLAKES, ORIFICEE)
8600            call mpp_land_bcast_int8(NLAKES, LAKEIDM)
8601            call mpp_land_bcast_real(NLAKES, ELEVLAKE)
8602            call mpp_land_bcast_int(NLAKES, reservoir_type)
8603         endif
8604
8605
8606         if(my_id .eq. io_id ) then
8607            if(allocated(tmpCHLON)) deallocate(tmpCHLON)
8608            if(allocated(tmpCHLAT)) deallocate(tmpCHLAT)
8609            if(allocated(tmpZELEV)) deallocate(tmpZELEV)
8610            if(allocated(tmpMUSK)) deallocate(tmpMUSK)
8611            if(allocated(tmpMUSX)) deallocate(tmpMUSX)
8612            if(allocated(tmpCHANLEN)) deallocate(tmpCHANLEN)
8613            if(allocated(tmpMannN)) deallocate(tmpMannN)
8614            if(allocated(tmpSo)) deallocate(tmpSo)
8615            if(allocated(tmpChSSlp)) deallocate(tmpChSSlp)
8616            if(allocated(tmpBw)) deallocate(tmpBw)
8617            if(allocated(tmpTw)) deallocate(tmpTw)
8618            if(allocated(tmpTw_CC)) deallocate(tmpTw_CC)
8619            if(allocated(tmpn_CC)) deallocate(tmpn_CC)
8620            if(allocated(tmpChannK)) deallocate(tmpChannK)
8621 !, tmpHRZAREA,&
8622 !                  tmpLAKEMAXH, tmpWEIRC, tmpWEIRL, tmpORIFICEC, &
8623 !                  tmpORIFICEA,tmpORIFICEE)
8624         endif
8625
8626 #else
8627        QLINK = 0
8628         if(routeLinkNetcdf) then
8629
8630           call read_route_link_netcdf(                      &
8631                  route_link_f,                              &
8632                  LINKID,     TO_NODE, CHLON,                &
8633                  CHLAT,      ZELEV,     TYPEL,    ORDER,    &
8634                  QLINK(:,1), MUSK,      MUSX,     CHANLEN,  &
8635                  MannN,      So,        ChSSlp,   Bw,       &
8636                  Tw,         Tw_CC,     n_CC,     ChannK, gages,    &
8637                  LAKEIDA                                     )
8638
8639         else
8640
8641           open(unit=17,file=trim(route_link_f),form='formatted',status='old')
8642           read(17,*)  header
8643 #ifdef HYDRO_D
8644           print *, "header ", header, "NLINKSL = ", NLINKSL
8645 #endif
8646           do i=1,NLINKSL
8647               read (17,*) LINKID(i), tmp_from_node, TO_NODE(i), CHLON(i),CHLAT(i),ZELEV(i), &
8648                    TYPEL(i), ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), &
8649                    MannN(i), So(i), ChSSlp(i), Bw(i), Tw(i), Tw_CC(i), n_CC(i), ChannK(i)
8650
8651               ! if (So(i).lt.0.005) So(i) = 0.005  !-- impose a minimum slope requireement
8652               if (ORDER(i) .gt. MAXORDER) MAXORDER = ORDER(i)
8653           end do
8654           close(17)
8655
8656         end if  ! routeLinkNetcdf
8657
8658 !!- initialize channel according to order if missing in input
8659         do i=1,NLINKSL
8660             if(QLINK(i,1) .le. 1e-3) then
8661               QLINK(i,1) = 20.0 * (1/(float(MAXORDER+1) - float(ORDER(i))))**3
8662               QLINK(i,2) = QLINK(i,1) !## initialize the current flow at each link
8663             endif
8664         end do
8665
8666 !!================================
8667 !!! need to add the sequential lake read here
8668 !!=================================
8669
8670
8671 #endif
8672
8673         do i=1,NLINKSL
8674 !           if(So(i) .lt. 0.001) So(i) = 0.001
8675            So(i) = max(So(i), 0.00001)
8676         end do
8677
8678 #ifdef HYDRO_D
8679        write(6,*) "finish read readLinkSL "
8680        call flush(6)
8681
8682 #endif
8683    end subroutine readLinkSL
8684
8685
8686
8687
8688 #ifdef MPP_LAND
8689
8690 !yw continue
8691
8692 subroutine MPP_READ_CHROUTING_new(&
8693      IXRT,         JXRT,              ELRT,           CH_NETRT,  &
8694      CH_LNKRT,     LAKE_MSKRT,        FROM_NODE,      TO_NODE,   &
8695      TYPEL,        ORDER,             MAXORDER,       NLINKS,    &
8696      NLAKES,       CHANLEN,           MannN,          So,        &
8697      ChSSlp,       Bw,                Tw,             Tw_CC,     &
8698      n_CC,         ChannK,            HRZAREA,        LAKEMAXH,  &
8699      WEIRH,        WEIRC,             WEIRL,          DAML,      &
8700      ORIFICEC,     ORIFICEA,          ORIFICEE,                  &
8701      reservoir_type_specified,        reservoir_type,            &
8702      reservoir_parameter_file,        LATLAKE,        LONLAKE,   &
8703      ELEVLAKE,     dist,              ZELEV,          LAKENODE,  &
8704      CH_NETLNK,    CHANXI,            CHANYJ,         CHLAT,     &
8705      CHLON,        channel_option,    LATVAL,         LONVAL,    &
8706      STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f,   LAKEIDM,   &
8707      UDMP_OPT,     g_ixrt,            g_jxrt,         gnlinks,   &
8708      GCH_NETLNK,   map_l2g,           link_location,  yw_mpp_nlinks, &
8709      lake_index,   nlinks_index                                       )
8710
8711 implicit none
8712 integer, intent(IN)                          :: IXRT,JXRT,g_IXRT,g_JXRT, GNLINKS, UDMP_OPT
8713 integer                                      :: CHANRTSWCRT, NLINKS, NLAKES
8714 integer                                      :: I,J,channel_option
8715 character(len=28)                            :: dir
8716
8717 character(len=155)       :: header
8718 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: FROM_NODE
8719 real, intent(INOUT),  dimension(NLINKS)      :: ZELEV
8720 real, intent(INOUT),  dimension(NLINKS)      :: CHLAT,CHLON
8721
8722 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: TO_NODE
8723 integer, intent(INOUT),  dimension(NLINKS)   :: TYPEL
8724 integer, intent(INOUT),  dimension(NLINKS)   :: ORDER
8725 integer, intent(INOUT),  dimension(NLINKS)   :: STRMFRXSTPTS
8726
8727 integer, intent(INOUT)                       :: MAXORDER
8728 real, intent(INOUT),  dimension(NLINKS)      :: CHANLEN   !channel length
8729 real, intent(INOUT),  dimension(NLINKS)      :: MannN, So !mannings N
8730 integer(kind=int64), intent(INOUT),  dimension(NLINKS)   :: LAKENODE  ! identifies which nodes pour into which lakes
8731 real, intent(IN)                             :: dist(ixrt,jxrt,9)
8732 integer, intent(INOUT),  dimension(NLINKS)   :: map_l2g
8733
8734 !-- store the location x,y location of the channel element
8735 integer, intent(INOUT), dimension(NLINKS)   :: CHANXI, CHANYJ
8736
8737 logical, intent(IN)                          :: reservoir_type_specified
8738 real, intent(INOUT),  dimension(NLAKES)      :: HRZAREA
8739 real, intent(INOUT),  dimension(NLAKES)      :: LAKEMAXH, WEIRH
8740 real, intent(INOUT),  dimension(NLAKES)      :: WEIRC
8741 real, intent(INOUT),  dimension(NLAKES)      :: WEIRL
8742 real, intent(INOUT),  dimension(NLAKES)      :: DAML
8743 real, intent(INOUT),  dimension(NLAKES)      :: ORIFICEC
8744 real, intent(INOUT),  dimension(NLAKES)      :: ORIFICEA
8745 real, intent(INOUT),  dimension(NLAKES)      :: ORIFICEE
8746 integer, intent(INOUT), dimension(NLAKES)    :: reservoir_type
8747 character(len=*), intent(in)                 :: reservoir_parameter_file
8748 real, intent(INOUT),  dimension(NLAKES)      :: LATLAKE,LONLAKE,ELEVLAKE
8749 real, intent(INOUT), dimension(NLINKS)       :: ChSSlp, Bw, Tw
8750 real, intent(INOUT), dimension(NLINKS)       :: Tw_CC, n_CC, ChannK
8751
8752 character(len=*  )                           :: geo_finegrid_flnm, route_lake_f
8753 character(len=256)                           :: var_name
8754
8755 integer                                      :: tmp, cnt, ncid
8756 real                                         :: gc,n
8757
8758 integer(kind=int64), intent(IN), dimension(IXRT,JXRT)    :: CH_NETLNK,GCH_NETLNK
8759 real, intent(IN), dimension(IXRT,JXRT)       :: ELRT
8760 integer, intent(IN), dimension(IXRT,JXRT)    :: CH_NETRT
8761 integer(kind=int64), intent(IN), dimension(IXRT,JXRT) :: CH_LNKRT
8762 integer, intent(OUT), dimension(IXRT,JXRT) :: LAKE_MSKRT
8763 integer(kind=int64), intent(OUT), dimension(IXRT,JXRT) :: link_location
8764 real, intent(OUT), dimension(IXRT,JXRT)    :: latval,lonval
8765 integer :: k
8766 integer, dimension(nlinks)            :: node_table, nlinks_index
8767 integer, dimension(nlakes)            :: lake_index
8768 integer(kind=int64), dimension(nlakes)    :: LAKEIDM
8769 integer :: yw_mpp_nlinks , l, mpp_nlinks
8770
8771
8772 call READ_CHROUTING1( &
8773      IXRT,         JXRT,              ELRT,      CH_NETRT,&
8774      CH_LNKRT,     LAKE_MSKRT,        FROM_NODE, TO_NODE, &
8775      TYPEL,        ORDER,             MAXORDER,  NLINKS,  &
8776      NLAKES,       CHANLEN,           MannN,     So,      &
8777      ChSSlp,       Bw,                Tw,        Tw_CC,   &
8778      n_CC,         ChannK,            HRZAREA,   LAKEMAXH, &
8779      WEIRH,        WEIRC,             WEIRL,     DAML,    &
8780      ORIFICEC,     ORIFICEA,          ORIFICEE,           &
8781      reservoir_type_specified,        reservoir_type,     &
8782      reservoir_parameter_file,        LATLAKE,   LONLAKE, &
8783      ELEVLAKE,     dist,              ZELEV,     LAKENODE,&
8784      CH_NETLNK,    CHANXI,            CHANYJ,    CHLAT,   &
8785      CHLON,        channel_option,    LATVAL,    LONVAL,  &
8786      STRMFRXSTPTS, geo_finegrid_flnm, route_lake_f, LAKEIDM, UDMP_OPT            &
8787 #ifdef MPP_LAND
8788      ,Link_Location  &
8789 #endif
8790      )
8791
8792 call mpp_land_max_int1(MAXORDER)
8793
8794 if(MAXORDER .eq. 0)  MAXORDER = -9999
8795
8796 lake_index = -99
8797 if(channel_option .eq. 3) then
8798    do j = 1, jxrt
8799       do i = 1, ixrt
8800          if (LAKE_MSKRT(i,j) .gt. 0) then
8801             lake_index(LAKE_MSKRT(i,j)) = LAKE_MSKRT(i,j)
8802          endif
8803       enddo
8804    enddo
8805 endif
8806
8807
8808 CHANXI = 0
8809 CHANYj = 0
8810 do j = 1, jxrt
8811    do i = 1, ixrt
8812       if(CH_NETLNK(i,j) .gt. 0) then
8813          CHANXI(CH_NETLNK(i,j)) = i
8814          CHANYJ(CH_NETLNK(i,j)) = j
8815       endif
8816    end do
8817 end do
8818
8819 node_table = 0
8820 yw_mpp_nlinks = 0
8821 do j = 1, jxrt
8822    do i = 1, ixrt
8823       if(CH_NETLNK(i,j) .ge. 0) then
8824          if( (i.eq.1) .and. (left_id .ge. 0) ) then
8825             continue
8826          elseif ( (i.eq. ixrt) .and. (right_id .ge. 0) ) then
8827             continue
8828          elseif ( (j.eq. 1) .and. (down_id .ge. 0) ) then
8829             continue
8830          elseif ( (j.eq. jxrt) .and. (up_id .ge. 0) ) then
8831             continue
8832          else
8833             l = CH_NETLNK(i,j)
8834             ! if(from_node(l) .gt. 0 .and. to_node(l) .gt. 0) then
8835             yw_mpp_nlinks = yw_mpp_nlinks + 1
8836             nlinks_index(yw_mpp_nlinks) = l
8837             ! endif
8838          endif
8839       endif
8840    end do
8841 end do
8842
8843 #ifdef HYDRO_D
8844 write(6,*) "nlinks=", nlinks, " yw_mpp_nlinks=", yw_mpp_nlinks," nlakes=", nlakes
8845 call flush(6)
8846 #endif
8847 if (NLAKES > 0) then
8848    call mpp_land_bcast_real(NLAKES,HRZAREA)
8849    call mpp_land_bcast_real(NLAKES,LAKEMAXH)
8850    call mpp_land_bcast_real(NLAKES,WEIRC)
8851    call mpp_land_bcast_real(NLAKES,WEIRC)
8852    call mpp_land_bcast_real(NLAKES,WEIRL)
8853    call mpp_land_bcast_real(NLAKES,DAML)
8854    call mpp_land_bcast_real(NLAKES,ORIFICEC)
8855    call mpp_land_bcast_real(NLAKES,ORIFICEA)
8856    call mpp_land_bcast_real(NLAKES,ORIFICEE)
8857    call mpp_land_bcast_real(NLAKES,LATLAKE)
8858    call mpp_land_bcast_real(NLAKES,LONLAKE)
8859    call mpp_land_bcast_real(NLAKES,ELEVLAKE)
8860    call mpp_land_bcast_int(NLAKES, reservoir_type)
8861 endif
8862
8863 link_location = CH_NETLNK
8864
8865 return
8866
8867 end subroutine MPP_READ_CHROUTING_new
8868
8869 #endif
8870
8871
8872 #ifdef MPP_LAND
8873        subroutine out_day_crt(dayMean,outFile)
8874            implicit none
8875            integer :: did
8876            real ::  dayMean(:)
8877            character(len=*) :: outFile
8878            integer:: ywflag
8879            ywflag = -999
8880            did = 1
8881            if((nlst(did)%olddate(12:13) .eq. "00") .and. (nlst(did)%olddate(15:16) .eq. "00") ) ywflag = 99
8882            call mpp_land_bcast_int1(ywflag)
8883            if(ywflag <0) return
8884            ! output daily
8885            call out_obs_crt(did,dayMean,outFile)
8886        end subroutine out_day_crt
8887
8888        subroutine out_obs_crt(did,dayMean,outFile)
8889            implicit none
8890            integer did, i, cnt
8891            real ::  dayMean(:)
8892            character(len=*) :: outFile
8893            real,dimension(rt_domain(did)%gnlinks) :: g_dayMean, chlat, chlon
8894            integer,dimension(rt_domain(did)%gnlinks) :: STRMFRXSTPTS
8895
8896            g_dayMean = -999
8897            chlat = -999
8898            chlon = -999
8899            STRMFRXSTPTS = 0
8900
8901            call write_chanel_int(RT_DOMAIN(did)%STRMFRXSTPTS,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,STRMFRXSTPTS)
8902
8903            call write_chanel_real(dayMean,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,g_dayMean)
8904
8905            call write_chanel_real(RT_DOMAIN(did)%CHLON,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlon)
8906
8907            call write_chanel_real(RT_DOMAIN(did)%CHLAT,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlat)
8908
8909
8910            open (unit=75,file=outFile,status='unknown',position='append')
8911            cnt = 0
8912            do i = 1, rt_domain(did)%gnlinks
8913               if(STRMFRXSTPTS(i) .gt. 0) then
8914                    write(75,114) nlst(did)%olddate(1:4),nlst(did)%olddate(6:7),nlst(did)%olddate(9:10), nlst(did)%olddate(12:13), &
8915                          cnt,chlon(i),chlat(i),g_dayMean(i)
8916                    cnt = cnt + 1
8917               endif
8918            end do
8919            close(75)
8920 114 FORMAT(1x,A4,A2,A2,A2,",",I7,", ",F10.5,",",F10.5,",",F12.3)
8921        end subroutine out_obs_crt
8922 #endif
8923
8924     subroutine outPutChanInfo(fromNode,toNode,chlon,chlat)
8925         implicit none
8926         integer, dimension(:) :: fromNode,toNode
8927         real, dimension(:) :: chlat,chlon
8928         integer :: iret, nodes, i, ncid, dimid_n, varid
8929
8930         nodes = size(chlon,1)
8931
8932        iret = nf90_create("nodeInfor.nc", OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
8933        iret = nf90_def_dim(ncid, "node", nodes, dimid_n)  !-- make a decimated grid
8934 !  define the varialbes
8935        iret = nf90_def_var(ncid, "fromNode", NF90_INT, (/dimid_n/), varid)
8936        iret = nf90_def_var(ncid, "toNode", NF90_INT, (/dimid_n/), varid)
8937        iret = nf90_def_var(ncid, "chlat", NF90_FLOAT, (/dimid_n/), varid)
8938           iret = nf90_put_att(ncid, varid, 'long_name', 'node latitude')
8939        iret = nf90_def_var(ncid, "chlon", NF90_FLOAT, (/dimid_n/), varid)
8940           iret = nf90_put_att(ncid, varid, 'long_name', 'node longitude')
8941        iret = nf90_enddef(ncid)
8942 !write to the file
8943            iret = nf90_inq_varid(ncid,"fromNode", varid)
8944            iret = nf90_put_var(ncid, varid, fromNode, (/1/), (/nodes/))
8945            iret = nf90_inq_varid(ncid,"toNode", varid)
8946            iret = nf90_put_var(ncid, varid, toNode, (/1/), (/nodes/))
8947            iret = nf90_inq_varid(ncid,"chlat", varid)
8948            iret = nf90_put_var(ncid, varid, chlat, (/1/), (/nodes/))
8949            iret = nf90_inq_varid(ncid,"chlon", varid)
8950            iret = nf90_put_var(ncid, varid, chlon, (/1/), (/nodes/))
8951           iret = nf90_close(ncid)
8952     end subroutine outPutChanInfo
8953
8954
8955 !===================================================================================================
8956 ! Program Name: read_route_link_netcdf
8957 ! Author(s)/Contact(s): James L McCreight <jamesmcc><ucar><edu>
8958 ! Abstract: Read in the "RouteLink.nc" netcdf file specifing the channel topology.
8959 ! History Log:
8960 ! 7/17/15 -Created, JLM.
8961 ! Usage:
8962 ! Parameters: <Specify typical arguments passed>
8963 ! Input Files: netcdf file RouteLink.nc or other name.
8964 ! Output Files: None.
8965 ! Condition codes: Currently incomplete error handling.
8966 !
8967 ! If appropriate, descriptive troubleshooting instructions or
8968 ! likely causes for failures could be mentioned here with the
8969 ! appropriate error code
8970 !
8971 ! User controllable options: None.
8972
8973 subroutine read_route_link_netcdf( route_link_file,                         &
8974                                    LINKID,   TO_NODE,   CHLON,              &
8975                                    CHLAT,    ZELEV,     TYPEL,    ORDER,    &
8976                                    QLINK,    MUSK,      MUSX,     CHANLEN,  &
8977                                    MannN,    So,        ChSSlp,   Bw,       &
8978                                    Tw,       Tw_CC,     n_CC,     ChannK,   &
8979                                    gages,   LAKEIDA                         )
8980
8981 implicit none
8982 character(len=*),        intent(in)  :: route_link_file
8983 integer(kind=int64), dimension(:),   intent(out) :: LAKEIDA, LINKID, TO_NODE
8984 real,    dimension(:),   intent(out) :: CHLON, CHLAT, ZELEV
8985 integer, dimension(:),   intent(out) :: TYPEL, ORDER
8986 real,    dimension(:),   intent(out) :: QLINK
8987 real,    dimension(:),   intent(out) :: MUSK, MUSX, CHANLEN
8988 real,    dimension(:),   intent(out) :: MannN, So, ChSSlp, Bw, Tw
8989 real,    dimension(:),   intent(out) :: Tw_CC, n_CC, ChannK
8990
8991 character(len=15), dimension(:), intent(inout) :: gages
8992
8993 integer :: iRet, ncid, ii, varid
8994 logical :: fatal_if_error
8995 fatal_if_error = .TRUE.  !! was thinking this would be a global variable...could become an input.
8996
8997 #ifdef HYDRO_D
8998 print*,"start read_route_link_netcdf"
8999 #endif
9000
9001 iRet = nf90_open(trim(route_link_file), nf90_nowrite, ncid)
9002 if (iRet /= nf90_noErr) then
9003    write(*,'("read_route_link_netcdf: Problem opening: ''", A, "''")') trim(route_link_file)
9004    if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem opening file.")
9005 endif
9006
9007
9008 call get_1d_netcdf_int64(ncid,  'link',     LINKID,    'read_route_link_netcdf', .TRUE.)
9009 call get_1d_netcdf_int64(ncid,  'NHDWaterbodyComID',  LAKEIDA, 'read_route_link_netcdf', .FALSE.)
9010 call get_1d_netcdf_int64(ncid,  'to',       TO_NODE,   'read_route_link_netcdf', .TRUE.)
9011 call get_1d_netcdf_real(ncid, 'lon',      CHLON,     'read_route_link_netcdf', .TRUE.)
9012 call get_1d_netcdf_real(ncid, 'lat',      CHLAT,     'read_route_link_netcdf', .TRUE.)
9013 call get_1d_netcdf_real(ncid, 'alt',      ZELEV,     'read_route_link_netcdf', .TRUE.)
9014 !yw call get_1d_netcdf_int(ncid,  'type',     TYPEL,     'read_route_link_netcdf', .TRUE.)
9015 call get_1d_netcdf_int(ncid,  'order',    ORDER,     'read_route_link_netcdf', .TRUE.)
9016 call get_1d_netcdf_real(ncid, 'Qi',       QLINK,     'read_route_link_netcdf', .TRUE.)
9017 call get_1d_netcdf_real(ncid, 'MusK',     MUSK,      'read_route_link_netcdf', .TRUE.)
9018 call get_1d_netcdf_real(ncid, 'MusX',     MUSX,      'read_route_link_netcdf', .TRUE.)
9019 call get_1d_netcdf_real(ncid, 'Length',   CHANLEN,   'read_route_link_netcdf', .TRUE.)
9020 call get_1d_netcdf_real(ncid, 'n',        MannN,     'read_route_link_netcdf', .TRUE.)
9021 call get_1d_netcdf_real(ncid, 'So',       So,        'read_route_link_netcdf', .TRUE.)
9022 !! impose a minimum as this sometimes fails in the file.
9023 where(So .lt. 0.00001) So=0.00001
9024 call get_1d_netcdf_real(ncid, 'ChSlp',    ChSSlp,    'read_route_link_netcdf', .TRUE.)
9025 call get_1d_netcdf_real(ncid, 'BtmWdth',  Bw,        'read_route_link_netcdf', .TRUE.)
9026 !! Loads channel infiltration, by default is zero, my need to add namelist option in future
9027 call get_1d_netcdf_real(ncid, 'Kchan',  ChannK,     'read_route_link_netcdf', .TRUE.)
9028
9029 ! Compound channel variables, contingent on nlst_rt(did)%compound_channel option
9030 if(nlst(did)%compound_channel) then
9031    print*, "compound_channel is TRUE in hydro.namelist."
9032    print*, "Variables are all required in route link: TopWdth, TopWdthCC, nCC."
9033    ! the fatal_if_error option is tru for all of these. An error in any will be a fatal error.
9034    call get_1d_netcdf_real(ncid, 'TopWdth',   Tw,     'read_route_link_netcdf', .true.)
9035    call get_1d_netcdf_real(ncid, 'TopWdthCC', Tw_CC,  'read_route_link_netcdf', .true.)
9036    call get_1d_netcdf_real(ncid, 'nCC',       n_CC,   'read_route_link_netcdf', .true.)
9037 else
9038    print*, "compound_channel is FALSE in hydro.namelist."
9039    Tw = 0.0  !force top width to 0.0, this deactivates the compound channel formulation.
9040 end if
9041
9042
9043 ! gages is optional, only get it if it's defined in the file.
9044 iRet = nf90_inq_varid(ncid, 'gages', varid)
9045 if (iret .eq. nf90_NoErr) then
9046    call get_1d_netcdf_text(ncid, 'gages', gages,  'read_route_link_netcdf', .true.)
9047 end if
9048
9049 iRet = nf90_close(ncId)
9050 if (iRet /= nf90_noErr) then
9051    write(*,'("read_route_link_netcdf: Problem closing: ''", A, "''")') trim(route_link_file)
9052    if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem closing file.")
9053 end if
9054
9055 #ifdef HYDRO_D
9056 ii = size(LINKID)
9057 print*,'last index=',ii
9058 print*, 'CHLON', CHLON(ii), 'CHLAT', CHLAT(ii), 'ZELEV', ZELEV(ii)
9059 print*,'TYPEL', TYPEL(ii), 'ORDER', ORDER(ii), 'QLINK', QLINK(ii), 'MUSK', MUSK(ii)
9060 print*, 'MUSX', MUSX(ii), 'CHANLEN', CHANLEN(ii), 'MannN', MannN(ii)
9061 print*,'So', So(ii), 'ChSSlp', ChSSlp(ii), 'Bw', Bw(ii), 'Tw', Tw(ii)
9062 print*,'TwCompund', Tw_CC(ii), 'Mann Compund', n_CC(ii), 'ChannK', ChannK(ii)
9063
9064 print*,'gages(ii): ',trim(gages(ii))
9065 print*,"finish read_route_link_netcdf"
9066 #endif
9067
9068 end subroutine read_route_link_netcdf
9069
9070
9071 !===================================================================================================
9072 ! Program Name: read_route_lake_netcdf
9073 ! Abstract: Read in the "LAKEPARM.nc" netcdf file specifing the channel topology.
9074 ! History Log:
9075 ! 7/17/15 -Created, JLM., then used by DNY
9076 ! Usage:
9077 ! Parameters: <Specify typical arguments passed>
9078 ! Input Files: netcdf file RouteLink.nc or other name.
9079 ! Output Files: None.
9080 ! Condition codes: Currently incomplete error handling.
9081 !
9082 subroutine read_route_lake_netcdf(route_lake_file,                         &
9083                                    HRZAREA,  LAKEMAXH, WEIRH,  WEIRC,    WEIRL, DAML,   &
9084                                    ORIFICEC, ORIFICEA,  ORIFICEE,  reservoir_type_specified, &
9085                                    reservoir_type, reservoir_parameter_file, &
9086                                    LAKEIDM, lakelat, lakelon, ELEVLAKE, NLAKES)
9087
9088     implicit none
9089     character(len=*),              intent(in)  :: route_lake_file
9090     integer,                       intent(in)  :: NLAKES
9091     logical,                       intent(in)  :: reservoir_type_specified
9092     character(len=*),              intent(in)  :: reservoir_parameter_file
9093     integer(kind=int64), dimension(:), intent(out) :: LAKEIDM
9094     real,    dimension(:),         intent(out) :: HRZAREA,  LAKEMAXH, WEIRC,    WEIRL, WEIRH, DAML
9095     real,    dimension(:),         intent(out) :: ORIFICEC, ORIFICEA, ORIFICEE, lakelat, lakelon
9096     real,    dimension(:),         intent(out) :: ELEVLAKE
9097     integer, dimension(:),         intent(out) :: reservoir_type
9098
9099     integer :: iRet, ncid, ii, varid
9100     logical :: fatal_if_error
9101     fatal_if_error = .TRUE.  !! was thinking this would be a global variable...could become an input.
9102
9103 #ifdef HYDRO_D
9104     print*,"start read_route_lake_netcdf"
9105 #endif
9106
9107     iRet = nf90_open(trim(route_lake_file), nf90_nowrite, ncid)
9108     if (iRet /= nf90_noErr) then
9109        write(*,'("read_route_lake_netcdf: Problem opening: ''", A, "''")') trim(route_lake_file)
9110        if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem opening file.")
9111     endif
9112
9113     call get_1d_netcdf_int64(ncid,  'lake_id',  LAKEIDM, 'read_route_lake_netcdf', .TRUE.)
9114     call get_1d_netcdf_real(ncid, 'LkArea',   HRZAREA,   'read_route_lake_netcdf', .TRUE.)
9115     !rename the LAKEPARM input vars for Elev instead of Ht, 08/23/17 LKR/DY
9116     call get_1d_netcdf_real(ncid, 'LkMxE',    LAKEMAXH,  'read_route_lake_netcdf', .TRUE.)
9117     !rename WeirH to WeirE
9118     call get_1d_netcdf_real(ncid, 'WeirE',    WEIRH,     'read_route_lake_netcdf', .TRUE.)
9119     call get_1d_netcdf_real(ncid, 'WeirC',    WEIRC,     'read_route_lake_netcdf', .TRUE.)
9120     call get_1d_netcdf_real(ncid, 'WeirL',    WEIRL,     'read_route_lake_netcdf', .TRUE.)
9121     call get_1d_netcdf_real(ncid, 'Dam_Length', DAML,    'read_route_lake_netcdf', .TRUE.)
9122     call get_1d_netcdf_real(ncid, 'OrificeC', ORIFICEC,  'read_route_lake_netcdf', .TRUE.)
9123     call get_1d_netcdf_real(ncid, 'OrificeA', ORIFICEA,  'read_route_lake_netcdf', .TRUE.)
9124     call get_1d_netcdf_real(ncid, 'OrificeE', ORIFICEE,  'read_route_lake_netcdf', .TRUE.)
9125     call get_1d_netcdf_real(ncid, 'lat', lakelat,        'read_route_lake_netcdf', .TRUE.)
9126     call get_1d_netcdf_real(ncid, 'lon', lakelon,        'read_route_lake_netcdf', .TRUE.)
9127     !remove the alt var. and add initial fractional depth var. LKR/DY
9128     call get_1d_netcdf_real(ncid, 'ifd', ELEVLAKE,       'read_route_lake_netcdf', .FALSE.)
9129
9130     iRet = nf90_close(ncId)
9131     if (iRet /= nf90_noErr) then
9132        write(*,'("read_route_lake_netcdf: Problem closing: ''", A, "''")') trim(route_lake_file)
9133        if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem closing file.")
9134     end if
9135
9136    ! If reservoir_type_specified is set to true, then call function to read reservoir_type
9137    ! from the reservoir parameter file
9138    if (reservoir_type_specified) then
9139        call read_reservoir_type(reservoir_parameter_file, LAKEIDM, NLAKES, reservoir_type)
9140    end if
9141
9142 #ifdef HYDRO_D
9143     ii = size(LAKEIDM)
9144     print*,'last index=',ii
9145     print*,'HRZAREA', HRZAREA(ii)
9146     print*,'LAKEMAXH', LAKEMAXH(ii), 'WEIRC', WEIRC(ii), 'WEIRL', WEIRL(ii), 'DAML', DAML(ii)
9147     print*,'ORIFICEC', ORIFICEC(ii), 'ORIFICEA', ORIFICEA(ii), 'ORIFICEE', ORIFICEE(ii)
9148     print*,"finish read_route_lake_netcdf"
9149 #endif
9150
9151 end subroutine read_route_lake_netcdf
9152
9153 !===================================================================================================
9154 ! Program Names: get_1d_netcdf_real, get_1d_netcdf_int, get_1d_netcdf_text
9155 ! Author(s)/Contact(s): James L McCreight <jamesmcc><ucar><edu>
9156 ! Abstract: Read a variable of real or integer type from an open netcdf file, respectively.
9157 ! History Log:
9158 ! 7/17/15 -Created, JLM.
9159 ! Usage:
9160 ! Parameters: See definitions.
9161 ! Input Files: This file is refered to by it's "ncid" obtained from nc_open
9162 !              prior to calling this routine.
9163 ! Output Files: None.
9164 ! Condition codes: hydro_stop is passed "get_1d_netcdf".
9165 !
9166 ! If appropriate, descriptive troubleshooting instructions or
9167 ! likely causes for failures could be mentioned here with the
9168 ! appropriate error code
9169 !
9170 ! User controllable options: None.
9171
9172 !! could define an interface for these.
9173 subroutine get_1d_netcdf_int(ncid, varName, var, callingRoutine, fatal_if_error)
9174 integer,               intent(in)  :: ncid !! the file identifier
9175 character(len=*),      intent(in)  :: varName
9176 integer, dimension(:), intent(out) :: var
9177 character(len=*),      intent(in)  :: callingRoutine
9178 logical,               intent(in)  :: fatal_if_error
9179 integer :: varid, iret
9180 iRet = nf90_inq_varid(ncid, varName, varid)
9181 if (iret /= nf90_noErr) then
9182    if (fatal_IF_ERROR) then
9183       print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
9184       call hydro_stop("get_1d_netcdf")
9185    end if
9186 end if
9187 iRet = nf90_get_var(ncid, varid, var)
9188 if (iRet /= nf90_NoErr) then
9189    print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName)
9190    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int")
9191 end if
9192 end subroutine get_1d_netcdf_int
9193
9194     subroutine get_1d_netcdf_int64(ncid, varName, var, callingRoutine, fatal_if_error)
9195         integer,                       intent(in)  :: ncid !! the file identifier
9196         character(len=*),              intent(in)  :: varName
9197         integer(kind=int64), dimension(:), intent(out) :: var
9198         character(len=*),              intent(in)  :: callingRoutine
9199         logical,                       intent(in)  :: fatal_if_error
9200         integer :: varid, iret
9201         iRet = nf90_inq_varid(ncid, varName, varid)
9202         if (iret /= nf90_noErr) then
9203             if (fatal_IF_ERROR) then
9204                 print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
9205                 call hydro_stop("get_1d_netcdf")
9206             end if
9207         end if
9208         iRet = nf90_get_var(ncid, varid, var)
9209         if (iRet /= nf90_NoErr) then
9210             print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName)
9211             if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int")
9212         end if
9213     end subroutine get_1d_netcdf_int64
9214
9215 subroutine get_1d_netcdf_real(ncid, varName, var, callingRoutine, fatal_if_error)
9216 integer,            intent(in)  :: ncid !! the file identifier
9217 character(len=*),   intent(in)  :: varName
9218 real, dimension(:), intent(out) :: var
9219 character(len=*),   intent(in)  :: callingRoutine
9220 logical,            intent(in)  :: fatal_if_error
9221
9222 integer :: varid, iret
9223 iRet = nf90_inq_varid(ncid, varName, varid)
9224 if (iret /= nf90_noErr) then
9225    if (fatal_IF_ERROR) then
9226       print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
9227       call hydro_stop("get_1d_netcdf")
9228    end if
9229 end if
9230 iRet = nf90_get_var(ncid, varid, var)
9231 if (iRet /= nf90_NoErr) then
9232    print*, trim(callingRoutine) // ": get_1d_netcdf_real: values: " // trim(varName)
9233    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_real")
9234 end if
9235 end subroutine get_1d_netcdf_real
9236
9237 subroutine get_1d_netcdf_text(ncid, varName, var, callingRoutine, fatal_if_error)
9238 integer,                        intent(in)  :: ncid !! the file identifier
9239 character(len=*),               intent(in)  :: varName
9240 character(len=*), dimension(:), intent(out) :: var
9241 character(len=*),               intent(in)  :: callingRoutine
9242 logical,                        intent(in)  :: fatal_if_error
9243 integer :: varId, iRet
9244 iRet = nf90_inq_varid(ncid, varName, varid)
9245 if (iret /= nf90_NoErr) then
9246    print*, trim(callingRoutine) // ": get_1d_netcdf_text: variable: " // trim(varName)
9247    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text")
9248 end if
9249 iRet = nf90_get_var(ncid, varid, var)
9250 if (iret /= nf90_NoErr) then
9251    print*, trim(callingRoutine) // ": get_1d_netcdf_text: values: " // trim(varName)
9252    if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text")
9253 end if
9254 end subroutine get_1d_netcdf_text
9255
9256 !===================================================================================================
9257 ! Program Names:
9258 !   get_netcdf_dim
9259 ! Author(s)/Contact(s):
9260 !   James L McCreight <jamesmcc><ucar><edu>
9261 ! Abstract:
9262 !   Get the length of a provided dimension.
9263 ! History Log:
9264 !   7/23/15 -Created, JLM.
9265 ! Usage:
9266 ! Parameters:
9267 !   file: character, the file to query
9268 !   dimName: character, the name of the dimension
9269 !   callingRoutine: character, the name of the calling routine for error messages
9270 !   fatalErr: Optional, Logical - all errors are fatal, calling hydro_stop()
9271 ! Input Files:
9272 !   Specified argument.
9273 ! Output Files:
9274 ! Condition codes:
9275 !   hydro_stop is called. .
9276 ! User controllable options:
9277 ! Notes:
9278
9279 function get_netcdf_dim(file, dimName, callingRoutine, fatalErr)
9280 implicit none
9281 integer :: get_netcdf_dim  !! return value
9282 character(len=*), intent(in)   :: file, dimName, callingRoutine
9283 integer :: ncId, dimId, iRet
9284 logical, optional, intent(in) :: fatalErr
9285 logical :: fatalErr_local
9286 character(len=256) :: errMsg
9287
9288 fatalErr_local = .false.
9289 if(present(fatalErr)) fatalErr_local=fatalErr
9290
9291 write(*,'("getting dimension from file: ", A)') trim(file)
9292 iRet = nf90_open(trim(file), nf90_NOWRITE, ncId)
9293 if (iret /= nf90_noerr) then
9294    write(*,'("Problem opening file: ", A)') trim(file)
9295    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9296    if(.not. fatalErr_local) get_netcdf_dim = -99
9297    if(.not. fatalErr_local) return
9298 endif
9299
9300 iRet = nf90_inq_dimid(ncId, trim(dimName), dimId)
9301 if (iret /= nf90_noerr) then
9302    write(*,'("Problem getting the dimension ID ", A)') &
9303         '"' // trim(dimName) // '" in file: ' // trim(file)
9304    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9305    if(.not. fatalErr_local) get_netcdf_dim = -99
9306    if(.not. fatalErr_local) return
9307 endif
9308
9309 iRet = nf90_inquire_dimension(ncId, dimId, len= get_netcdf_dim)
9310 if (iret /= nf90_noerr) then
9311    write(*,'("Problem getting the dimension length of ", A)') &
9312         '"' // trim(dimName) // '" in file: ' // trim(file)
9313    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9314    if(.not. fatalErr_local) get_netcdf_dim = -99
9315    if(.not. fatalErr_local) return
9316 endif
9317
9318 iRet = nf90_close(ncId)
9319 if (iret /= nf90_noerr) then
9320    write(*,'("Problem closing file: ", A)') trim(file)
9321    if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
9322    if(.not. fatalErr_local) get_netcdf_dim = -99
9323    if(.not. fatalErr_local) return
9324 endif
9325 end function get_netcdf_dim
9326
9327
9328 ! read the GWBUCKET Parm for NHDPlus
9329 subroutine readBucket_nhd(infile, numbasns, gw_buck_coeff, gw_buck_exp, &
9330                 gw_buck_loss, z_max, z_init, LINKID, nhdBuckMask)
9331     implicit none
9332     integer, intent(in) :: numbasns
9333     integer(kind=int64), dimension(numbasns) :: LINKID
9334     real, dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, gw_buck_loss
9335     real, dimension(numbasns) :: z_max, z_init
9336     integer, dimension(numbasns) :: nhdBuckMask
9337     character(len=*), intent(in) :: infile
9338 !   define temp array
9339     integer, volatile :: i,j,k, gnid, ncid, varid, ierr, dimid, iret
9340     integer(kind=int64), allocatable, dimension(:) :: tmpLinkid
9341     real, allocatable, dimension(:) :: tmpCoeff, tmpExp, tmpLoss
9342     real, allocatable, dimension(:) :: tmpz_max, tmpz_init
9343
9344 !   get gnid
9345     gnid = 0
9346 #ifdef MPP_LAND
9347     if(my_id .eq. io_id ) then
9348 #endif
9349        iret = nf90_open(trim(infile), NF90_NOWRITE, ncid)
9350 #ifdef MPP_LAND
9351        if(iret .ne. 0) then
9352            call hydro_stop("Failed to open GWBUCKET Parameter file.")
9353        endif
9354        iret = nf90_inq_dimid(ncid, "BasinDim", dimid)
9355        if (iret /= 0) then
9356                !print*, "nf90_inq_dimid:  BasinDim"
9357                call hydro_stop("Failed read GBUCKETPARM - nf90_inq_dimid:  BasinDim")
9358        endif
9359        iret = nf90_inquire_dimension(ncid, dimid, len=gnid)
9360     endif
9361     call mpp_land_bcast_int1(gnid)
9362 #endif
9363     allocate(tmpLinkid(gnid))
9364     allocate(tmpCoeff(gnid))
9365     allocate(tmpExp(gnid))
9366     allocate(tmpLoss(gnid))
9367     allocate(tmpz_max(gnid))
9368     allocate(tmpz_init(gnid))
9369 #ifdef MPP_LAND
9370     if(my_id .eq. io_id ) then
9371 #endif
9372 !      read the file data.
9373           iret = nf90_inq_varid(ncid,"Coeff",  varid)
9374           if(iret /= 0) then
9375                print * , "could not find Coeff from ", infile
9376                call hydro_stop("Failed to read BUCKETPARM")
9377           endif
9378           iret = nf90_get_var(ncid, varid, tmpCoeff)
9379
9380           iret = nf90_inq_varid(ncid,"Expon",  varid)
9381           if(iret /= 0) then
9382                print * , "could not find Expon from ", infile
9383                call hydro_stop("Failed to read BUCKETPARM")
9384           endif
9385           iret = nf90_get_var(ncid, varid, tmpExp)
9386
9387           if(nlst(did)%bucket_loss .eq. 1) then
9388                iret = nf90_inq_varid(ncid,"Loss",  varid)
9389                if(iret /= 0) then
9390                     print * , "could not find Loss from ", infile
9391                     call hydro_stop("Failed to read BUCKETPARM")
9392                endif
9393                iret = nf90_get_var(ncid, varid, tmpLoss)
9394           endif
9395
9396           iret = nf90_inq_varid(ncid,"Zmax",  varid)
9397           if(iret /= 0) then
9398                print * , "could not find Zmax from ", infile
9399                call hydro_stop("Failed to read BUCKETPARM")
9400           endif
9401           iret = nf90_get_var(ncid, varid, tmpz_max)
9402
9403           iret = nf90_inq_varid(ncid,"Zinit",  varid)
9404           if(iret /= 0) then
9405                print * , "could not find Zinit from ", infile
9406                call hydro_stop("Failed to read BUCKETPARM")
9407           endif
9408           iret = nf90_get_var(ncid, varid, tmpz_init)
9409
9410           iret = nf90_inq_varid(ncid, "ComID",  varid)
9411           if(iret /= 0) then
9412                print * , "could not find ComID from ", infile
9413                call hydro_stop("Failed to read BUCKETPARM")
9414           endif
9415           iret = nf90_get_var(ncid, varid, tmpLinkID)
9416 #ifdef MPP_LAND
9417     endif
9418        if(gnid .gt. 0) then
9419           call mpp_land_bcast_real_1d(tmpCoeff)
9420           call mpp_land_bcast_real_1d(tmpExp)
9421           if(nlst(did)%bucket_loss .eq. 1) then
9422              call mpp_land_bcast_real_1d(tmpLoss)
9423           endif
9424           call mpp_land_bcast_real_1d(tmpz_max)
9425           call mpp_land_bcast_real_1d(tmpz_init)
9426           call mpp_land_bcast_int8(gnid ,tmpLinkid)
9427        endif
9428 #endif
9429
9430        nhdBuckMask = -999
9431
9432        ! The following loops are replaced by a hashtable-based algorithm
9433        !   do k = 1, numbasns
9434        !         do i = 1, gnid
9435        !             if(LINKID(k) .eq. tmpLinkid(i)) then
9436        !                gw_buck_coeff(k) = tmpCoeff(i)
9437        !                gw_buck_exp(k) = tmpExp(i)
9438        !                z_max(k) = tmpz_max(i)
9439        !                z_init(k) = tmpz_init(i)
9440        !                nhdBuckMask(k) = 1
9441        !                goto 301
9442        !             endif
9443        !         end do
9444        ! 301     continue
9445        !     end do
9446
9447        block
9448          type(hash_t) :: hash_table
9449          integer(kind=int64) :: val,it
9450          logical :: found
9451
9452          call hash_table%set_all_idx(LINKID,numbasns)
9453          do it=1, gnid
9454             call hash_table%get(tmpLinkid(it), val, found)
9455             if((found .eqv. .true.)) then
9456                if((nhdBuckMask(val) == -999)) then
9457                   gw_buck_coeff(val) = tmpCoeff(it)
9458                   gw_buck_exp(val) = tmpExp(it)
9459                   if(nlst(did)%bucket_loss == 1) then
9460                      gw_buck_loss(val) = tmpLoss(it)
9461                   end if
9462                   z_max(val) = tmpz_max(it)
9463                   z_init(val) = tmpz_init(it)
9464                   nhdBuckMask(val) = 1
9465                end if
9466             end if
9467          end do
9468          call hash_table%clear()
9469        end block
9470
9471     if(allocated(tmpCoeff)) deallocate(tmpCoeff)
9472     if(allocated(tmpExp)) deallocate(tmpExp)
9473     if(allocated(tmpLoss)) deallocate(tmpLoss)
9474     if(allocated(tmpz_max)) deallocate(tmpz_max)
9475     if(allocated(tmpz_init)) deallocate(tmpz_init)
9476     if(allocated(tmpLinkid)) deallocate(tmpLinkid)
9477 end subroutine readBucket_nhd
9478
9479 !-- output the channel routine for fast output.
9480 !   subroutine mpp_output_chrt2(gnlinks,gnlinksl,map_l2g,igrid,                  &
9481 !        split_output_count, NLINKS, ORDER,                                     &
9482 !        startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch,              &
9483 !        K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, &
9484 !        lsmDt                                                                  &
9485 !        )
9486
9487 #ifdef MPP_LAND
9488    subroutine mpp_output_chrt2(                      &
9489         gnlinks,   gnlinksl,           map_l2g,      &
9490         igrid,     split_output_count,               &
9491         NLINKS,    ORDER,                            &
9492         startdate, date,                             &
9493         chlon,     chlat,                            &
9494         hlink,     zelev,                            &
9495         qlink,     dtrt_ch,  K,                      &
9496         NLINKSL,  channel_option,                    &
9497         linkid                                       &
9498 #ifdef WRF_HYDRO_NUDGING
9499         , nudge                                      &
9500 #endif
9501         ,         QLateral,    io_config_outputs               &
9502         ,                     velocity               &
9503         ,  accSfcLatRunoff,  accBucket               &
9504         ,    qSfcLatRunoff,    qBucket               &
9505         ,   qBtmVertRunoff,   UDMP_OPT               &
9506         )
9507
9508        USE module_mpp_land
9509
9510        implicit none
9511
9512 !!output the routing variables over just channel
9513      integer,                                  intent(in) :: igrid,K,NLINKSL
9514      integer,                                  intent(in) :: split_output_count
9515      integer,                                  intent(in) :: NLINKS
9516      real, dimension(:),               intent(in) :: chlon,chlat
9517      real, dimension(:),                  intent(in) :: hlink,zelev
9518
9519      integer, dimension(:),               intent(in) :: ORDER
9520      integer(kind=int64), dimension(:),       intent(in) :: linkid
9521
9522      real,                                     intent(in) :: dtrt_ch
9523      real, dimension(:,:),                intent(in) :: qlink
9524 #ifdef WRF_HYDRO_NUDGING
9525      real, dimension(:),                  intent(in) :: nudge
9526 #endif
9527      real, dimension(:), intent(in) :: QLateral, velocity
9528      integer, intent(in) :: io_config_outputs
9529      real*8, dimension(:), intent(in) :: accSfcLatRunoff, accBucket
9530      real  , dimension(:), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
9531      integer, intent(in) :: UDMP_OPT
9532
9533      integer :: channel_option
9534
9535      character(len=*),                         intent(in) :: startdate
9536      character(len=*),                         intent(in) :: date
9537
9538       integer  :: gnlinks, map_l2g(nlinks),  gnlinksl
9539       real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev
9540 #ifdef WRF_HYDRO_NUDGING
9541       real, allocatable,dimension(:) :: g_nudge
9542 #endif
9543       integer, allocatable,dimension(:) :: g_order
9544       integer(kind=int64), allocatable, dimension(:) :: g_linkid
9545       real,allocatable,dimension(:,:) :: g_qlink
9546       integer  :: gsize
9547       real*8, allocatable, dimension(:) :: g_accSfcLatRunoff, g_accBucket
9548       real  , allocatable, dimension(:) ::    g_qSfcLatRunoff,  g_qBucket, g_qBtmVertRunoff
9549       real, allocatable, dimension(:)   :: g_QLateral, g_velocity
9550
9551         gsize = gNLINKS
9552         if(gnlinksl .gt. gsize) gsize = gnlinksl
9553
9554
9555      if(my_id .eq. io_id ) then
9556         allocate(g_chlon(gsize  ))
9557         allocate(g_chlat(gsize  ))
9558         allocate(g_hlink(gsize  ))
9559         allocate(g_zelev(gsize  ))
9560         allocate(g_qlink(gsize  ,2))
9561 #ifdef WRF_HYDRO_NUDGING
9562         allocate(g_nudge(gsize))
9563 #endif
9564         allocate(g_order(gsize  ))
9565         allocate(g_linkid(gsize  ))
9566
9567         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9568            nlst(did)%output_channelBucket_influx .eq. 2      ) then
9569            allocate(g_qSfcLatRunoff(  gsize  ))
9570            allocate(g_qBucket(        gsize  ))
9571         end if
9572
9573         if(nlst(did)%output_channelBucket_influx .eq. 2) &
9574              allocate(g_qBtmVertRunoff(  gsize  ))
9575
9576         if(nlst(did)%output_channelBucket_influx .eq. 3) then
9577            allocate(g_accSfcLatRunoff(gsize  ))
9578            allocate(g_accBucket(      gsize  ))
9579         end if
9580
9581         allocate(g_QLateral(gsize  ))
9582         allocate(g_velocity(gsize  ))
9583
9584      else
9585
9586         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9587            nlst(did)%output_channelBucket_influx .eq. 2      ) then
9588            allocate(g_qSfcLatRunoff(  1))
9589            allocate(g_qBucket(        1))
9590         end if
9591
9592         if(nlst(did)%output_channelBucket_influx .eq. 2) &
9593              allocate(g_qBtmVertRunoff(  1))
9594
9595         if(nlst(did)%output_channelBucket_influx .eq. 3) then
9596            allocate(g_accSfcLatRunoff(1))
9597            allocate(g_accBucket(      1))
9598         end if
9599
9600        allocate(g_QLateral(1))
9601        allocate(g_velocity(1))
9602
9603         allocate(g_chlon(1))
9604         allocate(g_chlat(1))
9605         allocate(g_hlink(1))
9606         allocate(g_zelev(1))
9607         allocate(g_qlink(1,2))
9608 #ifdef WRF_HYDRO_NUDGING
9609         allocate(g_nudge(1))
9610 #endif
9611         allocate(g_order(1))
9612         allocate(g_linkid(1))
9613      endif
9614
9615      call mpp_land_sync()
9616      if(channel_option .eq. 1 .or. channel_option .eq. 2) then
9617         g_qlink = 0
9618         call ReachLS_write_io(qlink(:,1), g_qlink(:,1))
9619         call ReachLS_write_io(qlink(:,2), g_qlink(:,2))
9620 #ifdef WRF_HYDRO_NUDGING
9621         g_nudge=0
9622         call ReachLS_write_io(nudge,g_nudge)
9623 #endif
9624         call ReachLS_write_io(order, g_order)
9625         call ReachLS_write_io(linkid, g_linkid)
9626         call ReachLS_write_io(chlon, g_chlon)
9627         call ReachLS_write_io(chlat, g_chlat)
9628         call ReachLS_write_io(zelev, g_zelev)
9629
9630         if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9631            nlst(did)%output_channelBucket_influx .eq. 2      ) then
9632            call ReachLS_write_io(qSfcLatRunoff, g_qSfcLatRunoff)
9633            call ReachLS_write_io(qBucket,       g_qBucket)
9634         end if
9635
9636         if(nlst(did)%output_channelBucket_influx .eq. 2) &
9637              call ReachLS_write_io(qBtmVertRunoff, g_qBtmVertRunoff)
9638
9639         if(nlst(did)%output_channelBucket_influx .eq. 3) then
9640            call ReachLS_write_io(accSfcLatRunoff, g_accSfcLatRunoff)
9641            call ReachLS_write_io(accBucket,       g_accBucket)
9642         end if
9643
9644         call ReachLS_write_io(QLateral, g_QLateral)
9645         call ReachLS_write_io(velocity, g_velocity)
9646        !yw call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
9647        call  ReachLS_write_io(hlink,g_hlink)
9648
9649      else
9650
9651         call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
9652         call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
9653         call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order)
9654         call write_chanel_int8(linkid,map_l2g,gnlinks,nlinks,g_linkid)
9655         call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon)
9656         call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat)
9657         call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev)
9658         call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
9659      endif
9660
9661
9662      if(my_id .eq. IO_id) then
9663        call output_chrt2(igrid, split_output_count, GNLINKS, g_ORDER,                &
9664           startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K,     &
9665           gNLINKSL,channel_option, g_linkid  &
9666 #ifdef WRF_HYDRO_NUDGING
9667           , g_nudge                                     &
9668 #endif
9669           ,        g_QLateral,     io_config_outputs,      g_velocity  &
9670           , g_accSfcLatRunoff, g_accBucket                   &
9671           ,   g_qSfcLatRunoff,   g_qBucket, g_qBtmVertRunoff &
9672           ,          UDMP_OPT                                &
9673           )
9674      end if
9675
9676      call mpp_land_sync()
9677     if(allocated(g_order)) deallocate(g_order)
9678     if(allocated(g_chlon)) deallocate(g_chlon)
9679     if(allocated(g_chlat)) deallocate(g_chlat)
9680     if(allocated(g_hlink)) deallocate(g_hlink)
9681     if(allocated(g_zelev)) deallocate(g_zelev)
9682     if(allocated(g_qlink)) deallocate(g_qlink)
9683     if(allocated(g_linkid)) deallocate(g_linkid)
9684
9685 #ifdef WRF_HYDRO_NUDGING
9686     if(allocated(g_nudge)) deallocate(g_nudge)
9687 #endif
9688
9689     if(allocated(g_QLateral)) deallocate(g_QLateral)
9690     if(allocated(g_velocity)) deallocate(g_velocity)
9691
9692     if(allocated(g_qSfcLatRunoff)) deallocate(g_qSfcLatRunoff)
9693     if(allocated(g_qBucket)) deallocate(g_qBucket)
9694     if(allocated(g_qBtmVertRunoff)) deallocate(g_qBtmVertRunoff)
9695     if(allocated(g_accSfcLatRunoff)) deallocate(g_accSfcLatRunoff)
9696     if(allocated(g_accBucket)) deallocate(g_accBucket)
9697
9698 end subroutine mpp_output_chrt2
9699
9700 #endif
9701
9702
9703 !subroutine output_chrt2
9704 !For realtime output only when CHRTOUT_GRID = 2.
9705 !   subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER,             &
9706 !        startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
9707 !        STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, &
9708 !        lsmDt                                                                   &
9709 !        )
9710    subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER,             &
9711         startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
9712         NLINKSL, channel_option ,linkid &
9713 #ifdef WRF_HYDRO_NUDGING
9714         , nudge                                     &
9715 #endif
9716         ,        QLateral,   io_config_outputs,       velocity &
9717         , accSfcLatRunoff, accBucket                 &
9718         ,   qSfcLatRunoff,   qBucket, qBtmVertRunoff &
9719         ,        UDMP_OPT                            &
9720         )
9721
9722      implicit none
9723 !!output the routing variables over just channel
9724      integer,                                  intent(in) :: igrid,K,channel_option
9725      integer,                                  intent(in) :: split_output_count
9726      integer,                                  intent(in) :: NLINKS, NLINKSL
9727      real, dimension(:),                  intent(in) :: chlon,chlat
9728      real, dimension(:),                  intent(in) :: hlink,zelev
9729      integer, dimension(:),               intent(in) :: ORDER
9730
9731      real,                                     intent(in) :: dtrt_ch
9732      real, dimension(:,:),                intent(in) :: qlink
9733 #ifdef WRF_HYDRO_NUDGING
9734      real, dimension(:),                  intent(in) :: nudge
9735 #endif
9736      real, dimension(:), intent(in) :: QLateral, velocity
9737      integer, intent(in) :: io_config_outputs
9738      real*8, dimension(nlinks), intent(in) :: accSfcLatRunoff, accBucket
9739      real  , dimension(nlinks), intent(in) ::   qSfcLatRunoff,   qBucket, qBtmVertRunoff
9740      integer  :: UDMP_OPT
9741
9742      character(len=*),                         intent(in) :: startdate
9743      character(len=*),                         intent(in) :: date
9744
9745
9746
9747      integer(kind=int64), allocatable, dimension(:) :: linkid
9748
9749      integer, allocatable, DIMENSION(:)         :: rec_num_of_station
9750      integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
9751
9752      integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
9753
9754      integer, save  :: output_count
9755      integer, save  :: ncid
9756
9757      integer :: stationdim, dimdata, varid, charid, n
9758      integer :: timedim
9759
9760      integer :: iret,i !-- order_to_write is the lowest stream order to output
9761      integer :: start_posO, prev_posO, nlk
9762
9763      integer :: previous_pos  !-- used for the station model
9764      character(len=256) :: output_flnm
9765      character(len=34)  :: sec_since_date
9766      integer :: seconds_since,nstations,cnt,ObsStation
9767      character(len=32)  :: convention
9768      character(len=11),allocatable, DIMENSION(:)  :: stname
9769
9770      character(len=34) :: sec_valid_date
9771
9772     !--- all this for writing the station id string
9773      INTEGER   TDIMS, TXLEN
9774      PARAMETER (TDIMS=2)    ! number of TX dimensions
9775      PARAMETER (TXLEN = 11) ! length of example string
9776      INTEGER  TIMEID        ! record dimension id
9777      INTEGER  TXID          ! variable ID
9778      INTEGER  TXDIMS(TDIMS) ! variable shape
9779      INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
9780
9781      !--  observation point  ids
9782      INTEGER   OTDIMS, OTXLEN
9783      PARAMETER (OTDIMS=2)    ! number of TX dimensions
9784      PARAMETER (OTXLEN = 15) ! length of example string
9785      INTEGER  OTIMEID        ! record dimension id
9786      INTEGER  OTXID          ! variable ID
9787      INTEGER  OTXDIMS(OTDIMS) ! variable shape
9788      INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
9789      character(len=19)  :: date19, date19start
9790
9791
9792      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
9793
9794
9795      if(channel_option .ne. 3) then
9796         nstations = NLINKSL
9797      else
9798         nstations = NLINKS
9799      endif
9800
9801        if(split_output_count .ne. 1 ) then
9802             write(6,*) "WARNING: split_output_count need to be 1 for this output option."
9803        endif
9804 !-- have moved sec_since_date from above here..
9805         sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
9806                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
9807
9808         date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
9809                   //startdate(12:13)//':'//startdate(15:16)//':00'
9810
9811         seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
9812         sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
9813                       //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
9814
9815         write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
9816
9817 #ifdef HYDRO_D
9818         print*, 'output_flnm = "'//trim(output_flnm)//'"'
9819 #endif
9820
9821        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
9822        if (iret /= 0) then
9823            print*,  "Problem nf90_create points"
9824            call hydro_stop("In output_chrt2() - Problem nf90_create points.")
9825        endif
9826
9827        iret = nf90_def_dim(ncid, "station", nstations, stationdim)
9828        iret = nf90_def_dim(ncid, "time", 1, timedim)
9829
9830 if (io_config_outputs .le. 0) then
9831       !- station location definition all,  lat
9832         iret = nf90_def_var(ncid, "latitude", NF90_FLOAT, (/stationdim/), varid)
9833         iret = nf90_put_att(ncid, varid, 'long_name', 'Station latitude')
9834         iret = nf90_put_att(ncid, varid, 'units', 'degrees_north')
9835
9836       !- station location definition,  long
9837         iret = nf90_def_var(ncid, "longitude", NF90_FLOAT, (/stationdim/), varid)
9838         iret = nf90_put_att(ncid, varid, 'long_name', 'Station longitude')
9839         iret = nf90_put_att(ncid, varid, 'units', 'degrees_east')
9840
9841 !     !-- elevation is ZELEV
9842         iret = nf90_def_var(ncid, "altitude", NF90_FLOAT, (/stationdim/), varid)
9843         iret = nf90_put_att(ncid, varid, 'long_name', 'Station altitude')
9844         iret = nf90_put_att(ncid, varid, 'units', 'meters')
9845
9846 !-- parent index
9847 !        iret = nf90_def_var(ncid, "parent_index", NF90_INT, (/stationdim/), varid)
9848 !        iret = nf90_put_att(ncid, varid, 'long_name', 'index of the station for this record')
9849
9850
9851      !-- prevChild
9852 !        iret = nf90_def_var(ncid, "prevChild", NF90_INT, (/stationdim/), varid)
9853 !        iret = nf90_put_att(ncid, varid, 'long_name', 'record number of the previous record for the same station')
9854 !        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
9855
9856      !-- lastChild
9857 !        iret = nf90_def_var(ncid, "lastChild", NF90_INT, (/stationdim/), varid)
9858 !        iret = nf90_put_att(ncid, varid, 'long_name', 'latest report for this station')
9859 !        iret = nf90_put_att(ncid, varid, '_FillValue', -1)
9860 endif
9861
9862         iret = nf90_def_var(ncid, "time", NF90_INT, (/timedim/), varid)
9863         iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
9864         iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
9865
9866         !- flow definition, var
9867         iret = nf90_def_var(ncid, "streamflow", NF90_FLOAT, (/stationdim/), varid)
9868         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
9869         iret = nf90_put_att(ncid, varid, 'long_name', 'River Flow')
9870
9871 #ifdef WRF_HYDRO_NUDGING
9872         !- nudge definition
9873         iret = nf90_def_var(ncid, "nudge", NF90_FLOAT, (/stationdim/), varid)
9874         iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
9875         iret = nf90_put_att(ncid, varid, 'long_name', 'Amount of stream flow alteration')
9876 #endif
9877
9878
9879 !     !- head definition, var
9880       if(channel_option .eq. 3) then
9881         iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/stationdim/), varid)
9882         iret = nf90_put_att(ncid, varid, 'units', 'meter')
9883         iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
9884       endif
9885 !#ifdef HYDRO_REALTIME
9886 !      if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
9887 !       iret = nf90_def_var(ncid, "head", NF90_FLOAT, (/stationdim/), varid)
9888 !        iret = nf90_put_att(ncid, varid, 'units', 'meter')
9889 !        iret = nf90_put_att(ncid, varid, 'long_name', 'River Stage')
9890 !      endif
9891 !#endif
9892
9893
9894         !-- NEW lateral inflow definition, var
9895         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
9896                 iret = nf90_def_var(ncid, "q_lateral", NF90_FLOAT, (/stationdim/), varid)
9897                 iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
9898                 iret = nf90_put_att(ncid, varid, 'long_name', 'Runoff into channel reach')
9899         endif
9900
9901         !-- NEW velocity definition, var
9902         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then
9903                 iret = nf90_def_var(ncid, "velocity", NF90_FLOAT, (/stationdim/), varid)
9904                 iret = nf90_put_att(ncid, varid, 'units', 'meter/sec')
9905                 iret = nf90_put_att(ncid, varid, 'long_name', 'River Velocity')
9906         endif
9907
9908 if (io_config_outputs .le. 0) then
9909 !     !- order definition, var
9910         iret = nf90_def_var(ncid, "order", NF90_INT, (/stationdim/), varid)
9911         iret = nf90_put_att(ncid, varid, 'long_name', 'Strahler Stream Order')
9912         iret = nf90_put_att(ncid, varid, '_FillValue', -1)
9913 endif
9914
9915      !-- station  id
9916      ! define character-position dimension for strings of max length 11
9917         iret = nf90_def_var(ncid, "station_id", NF90_INT, (/stationdim/), varid)
9918         iret = nf90_put_att(ncid, varid, 'long_name', 'Station id')
9919
9920        !! JLM: Write/define a global attribute of the file as the LSM timestep. Enforce
9921        !! JLM: force_type=9 only reads these discharges to the channel if the LSM timesteps match.
9922
9923         if(UDMP_OPT .eq. 1 .and. nlst(did)%output_channelBucket_influx .ne. 0) then
9924            !! channel & channelBucketOnly global atts
9925            iret = nf90_put_att(ncid, NF90_GLOBAL, 'OVRTSWCRT', nlst(1)%OVRTSWCRT )
9926            iret = nf90_put_att(ncid, NF90_GLOBAL, 'NOAH_TIMESTEP', int(nlst(1)%dt) )
9927            iret = nf90_put_att(ncid, NF90_GLOBAL, "channel_only", nlst(did)%channel_only )
9928            iret = nf90_put_att(ncid, NF90_GLOBAL, "channelBucket_only", nlst(did)%channelBucket_only )
9929
9930            !! FLUXES to channel
9931            if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
9932               nlst(did)%output_channelBucket_influx .eq. 2      ) then
9933               iret = nf90_def_var(ncid, "qSfcLatRunoff", NF90_FLOAT, (/stationdim/), varid)
9934               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
9935               if(nlst(did)%OVRTSWCRT .eq. 1) then              !123456789112345678921234567
9936                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from terrain routing')
9937               else
9938                  iret = nf90_put_att(ncid, varid, 'long_name', 'runoff')
9939               end if
9940               iret = nf90_def_var(ncid, "qBucket", NF90_FLOAT, (/stationdim/), varid)
9941               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
9942               !                                                 1234567891234567892
9943               iret = nf90_put_att(ncid, varid, 'long_name', 'flux from gw bucket')
9944            end if
9945
9946            !! Bucket influx
9947            !! In channel_only mode, there are not valie qBtmVertRunoff values
9948            if(nlst(did)%output_channelBucket_influx .eq. 2 .and. &
9949               nlst(did)%channel_only                .eq. 0         ) then
9950               iret = nf90_def_var(ncid, "qBtmVertRunoff", NF90_FLOAT, (/stationdim/), varid)
9951               iret = nf90_put_att(ncid, varid, 'units', 'meter^3/s')
9952               iret = nf90_put_att(ncid, varid, 'long_name', 'runoff from bottom of soil to bucket')
9953            endif
9954
9955            !! ACCUMULATIONS
9956            if(nlst(did)%output_channelBucket_influx .eq. 3) then
9957               iret = nf90_def_var(ncid, "accSfcLatRunoff", NF90_DOUBLE, (/stationdim/), varid)
9958               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
9959               if(nlst(did)%OVRTSWCRT .eq. 1) then
9960                  iret = nf90_put_att(ncid,varid,'long_name',&
9961                                         'ACCUMULATED runoff from terrain routing')
9962               else
9963                  iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED runoff from land')
9964               end if
9965
9966               iret = nf90_def_var(ncid, "accBucket", NF90_DOUBLE, (/stationdim/), varid)
9967               iret = nf90_put_att(ncid, varid, 'units', 'meter^3')
9968               iret = nf90_put_att(ncid, varid, 'long_name', 'ACCUMULATED flux from gw bucket')
9969            endif
9970         endif
9971
9972          convention(1:32) = "Unidata Observation Dataset v1.0"
9973          iret = nf90_put_att(ncid, NF90_GLOBAL, "Conventions", convention)
9974          iret = nf90_put_att(ncid, NF90_GLOBAL, "cdm_datatype", "Station")
9975
9976 if (io_config_outputs .le. 0) then
9977          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_max", "90.0")
9978          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lat_min", "-90.0")
9979          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_max", "180.0")
9980          iret = nf90_put_att(ncid, NF90_GLOBAL, "geospatial_lon_min", "-180.0")
9981 endif
9982          iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
9983          iret = nf90_put_att(ncid, NF90_GLOBAL, "station_dimension", "station")
9984          iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
9985          iret = nf90_put_att(ncid, NF90_GLOBAL, "stream_order_output", 1)
9986
9987         !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9988         !! END DEF
9989          iret = nf90_enddef(ncid)
9990
9991          iret = nf90_inq_varid(ncid,"time", varid)
9992          iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
9993
9994 if (io_config_outputs .le. 0) then
9995         !-- write latitudes
9996          iret = nf90_inq_varid(ncid,"latitude", varid)
9997          iret = nf90_put_var(ncid, varid, chlat, (/1/), (/nstations/))
9998
9999         !-- write longitudes
10000          iret = nf90_inq_varid(ncid,"longitude", varid)
10001          iret = nf90_put_var(ncid, varid, chlon, (/1/), (/nstations/))
10002
10003         !-- write elevations
10004          iret = nf90_inq_varid(ncid,"altitude", varid)
10005          iret = nf90_put_var(ncid, varid, zelev, (/1/), (/nstations/))
10006
10007         !-- write order
10008          iret = nf90_inq_varid(ncid,"order", varid)
10009          iret = nf90_put_var(ncid, varid, ORDER, (/1/), (/nstations/))
10010 endif
10011
10012         !-- write stream flow
10013          iret = nf90_inq_varid(ncid,"streamflow", varid)
10014          iret = nf90_put_var(ncid, varid, qlink(:,1), (/1/), (/nstations/))
10015
10016 #ifdef WRF_HYDRO_NUDGING
10017         !-- write nudge
10018          iret = nf90_inq_varid(ncid,"nudge", varid)
10019          iret = nf90_put_var(ncid, varid, nudge, (/1/), (/nstations/))
10020 #endif
10021
10022         !-- write head
10023         if(channel_option .eq. 3) then
10024            iret = nf90_inq_varid(ncid,"head", varid)
10025            iret = nf90_put_var(ncid, varid, hlink, (/1/), (/nstations/))
10026         endif
10027 !#ifdef HYDRO_REALTIME
10028 !       if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
10029 !             ! dummy value for now
10030 !              iret = nf90_inq_varid(ncid,"head", varid)
10031 !              iret = nf90_put_vara_real(ncid, varid, (/1/), (/nstations/), chlon*0.-9999.)
10032 !        endif
10033 !#endif
10034
10035         !-- write lateral inflow
10036         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) ) then
10037                 iret = nf90_inq_varid(ncid,"q_lateral", varid)
10038                 iret = nf90_put_var(ncid, varid, QLateral, (/1/), (/nstations/))
10039         endif
10040
10041         !-- writelvelocity (dummy value for now)
10042         if ( (channel_option .ne. 3) .and. (io_config_outputs .ge. 0) .and. (io_config_outputs .ne. 4) ) then
10043                 iret = nf90_inq_varid(ncid,"velocity", varid)
10044                 iret = nf90_put_var(ncid, varid, velocity, (/1/), (/nstations/))
10045         endif
10046
10047        !! JLM: Write/define a global attribute of the file as the LSM timestep. Enforce
10048        !! JLM:   force_type=9 only reads these discharges to the channel if the LSM timesteps match.
10049        if(UDMP_OPT .eq. 1 .and. nlst(did)%output_channelBucket_influx .ne. 0) then
10050              !! FLUXES
10051              if(nlst(did)%output_channelBucket_influx .eq. 1 .or. &
10052                 nlst(did)%output_channelBucket_influx .eq. 2      ) then
10053                 iret = nf90_inq_varid(ncid,"qSfcLatRunoff", varid)
10054                 iret = nf90_put_var(ncid, varid, qSfcLatRunoff, (/1/), (/nstations/))
10055
10056                 iret = nf90_inq_varid(ncid,"qBucket", varid)
10057                 iret = nf90_put_var(ncid, varid, qBucket, (/1/), (/nstations/))
10058              end if
10059
10060              !! Bucket model influxes
10061              if(nlst(did)%output_channelBucket_influx .eq. 2 .and. &
10062                 nlst(did)%channel_only                .eq. 0         ) then
10063                 iret = nf90_inq_varid(ncid,"qBtmVertRunoff", varid)
10064                 iret = nf90_put_var(ncid, varid, qBtmVertRunoff, (/1/), (/nstations/))
10065              endif
10066
10067             !! ACCUMULATIONS
10068             if(nlst(did)%output_channelBucket_influx .eq. 3) then
10069                iret = nf90_inq_varid(ncid,"accSfcLatRunoff", varid)
10070                iret = nf90_put_var(ncid, varid, accSfcLatRunoff, (/1/), (/nstations/))
10071
10072                iret = nf90_inq_varid(ncid,"accBucket", varid)
10073                iret = nf90_put_var(ncid, varid, accBucket, (/1/), (/nstations/))
10074             end if
10075          endif
10076
10077         !-- write id
10078         iret = nf90_inq_varid(ncid,"station_id", varid)
10079         iret = nf90_put_var(ncid, varid, linkid, (/1/), (/nstations/))
10080
10081
10082       iret = nf90_redef(ncid)
10083       date19(1:19) = "0000-00-00_00:00:00"
10084       date19(1:len_trim(date)) = date
10085       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
10086       iret = nf90_enddef(ncid)
10087
10088       iret = nf90_sync(ncid)
10089       iret = nf90_close(ncid)
10090
10091 #ifdef HYDRO_D
10092      print *, "Exited Subroutine output_chrt"
10093 #endif
10094
10095
10096 end subroutine output_chrt2
10097
10098
10099    subroutine output_GW_Diag(did)
10100        implicit none
10101        integer :: i , did, gnbasns
10102
10103 #ifdef MPP_LAND
10104        real, allocatable, dimension(:) :: g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas
10105        integer(kind=int64), allocatable, dimension(:) :: g_basnsInd
10106        if(my_id .eq. io_id) then
10107           if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then
10108                allocate(g_qin_gwsubbas(rt_domain(did)%gnumbasns))
10109                allocate(g_qout_gwsubbas(rt_domain(did)%gnumbasns))
10110                allocate(g_z_gwsubbas(rt_domain(did)%gnumbasns))
10111                allocate(g_basnsInd(rt_domain(did)%gnumbasns))
10112                gnbasns = rt_domain(did)%gnumbasns
10113           else
10114                allocate(g_qin_gwsubbas(rt_domain(did)%gnlinksl))
10115                allocate(g_qout_gwsubbas(rt_domain(did)%gnlinksl))
10116                allocate(g_z_gwsubbas(rt_domain(did)%gnlinksl))
10117                allocate(g_basnsInd(rt_domain(did)%gnlinksl))
10118                gnbasns = rt_domain(did)%gnlinksl
10119           endif
10120        endif
10121
10122        if(nlst(did)%channel_option .ne. 3) then
10123           call ReachLS_write_io(rt_domain(did)%qin_gwsubbas,g_qin_gwsubbas)
10124           call ReachLS_write_io(rt_domain(did)%qout_gwsubbas,g_qout_gwsubbas)
10125           call ReachLS_write_io(rt_domain(did)%z_gwsubbas,g_z_gwsubbas)
10126           call ReachLS_write_io(rt_domain(did)%linkid,g_basnsInd)
10127        else
10128           call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,  &
10129                  rt_domain(did)%basnsInd,g_qin_gwsubbas)
10130           call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,  &
10131                  rt_domain(did)%basnsInd,g_qout_gwsubbas)
10132           call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,  &
10133                  rt_domain(did)%basnsInd,g_z_gwsubbas)
10134           call gw_write_io_int(rt_domain(did)%numbasns,rt_domain(did)%basnsInd,  &
10135                  rt_domain(did)%basnsInd,g_basnsInd)
10136        endif
10137        if(my_id .eq. io_id) then
10138 !          open (unit=51,file='GW_inflow.txt',form='formatted',&
10139 !                status='unknown',position='append')
10140 !          open (unit=52,file='GW_outflow.txt',form='formatted',&
10141 !                status='unknown',position='append')
10142 !          open (unit=53,file='GW_zlev.txt',form='formatted',&
10143 !                status='unknown',position='append')
10144 !          do i=1,RT_DOMAIN(did)%gnumbasns
10145 !             write (51,951) i,nlst_rt(did)%olddate,g_qin_gwsubbas(i)
10146 951        FORMAT(I3,1X,A19,1X,F11.3)
10147 !            write (52,951) i,nlst_rt(did)%olddate,g_qout_gwsubbas(i)
10148 !            write (53,951) i,nlst_rt(did)%olddate,g_z_gwsubbas(i)
10149 !         end do
10150 !         close(51)
10151 !         close(52)
10152 !         close(53)
10153
10154           call   output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, gnbasns, &
10155                   trim(nlst(did)%sincedate), trim(nlst(did)%olddate), &
10156                   g_basnsInd,g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas )
10157           deallocate(g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas, g_basnsInd)
10158
10159        endif
10160           if(allocated(g_qin_gwsubbas))  deallocate(g_qin_gwsubbas)
10161           if(allocated(g_qout_gwsubbas))  deallocate(g_qout_gwsubbas)
10162           if(allocated(g_z_gwsubbas))  deallocate(g_z_gwsubbas)
10163
10164 # else
10165 !       open (unit=51,file='GW_inflow.txt',form='formatted',&
10166 !             status='unknown',position='append')
10167 !       open (unit=52,file='GW_outflow.txt',form='formatted',&
10168 !             status='unknown',position='append')
10169 !       open (unit=53,file='GW_zlev.txt',form='formatted',&
10170 !             status='unknown',position='append')
10171 !       do i=1,RT_DOMAIN(did)%numbasns
10172 !          write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i)
10173 951        FORMAT(I3,1X,A19,1X,F11.3)
10174 !          write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i)
10175 !          write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i)
10176 !       end do
10177 !       close(51)
10178 !       close(52)
10179 !       close(53)
10180         if(nlst(did)%GWBASESWCRT.EQ.1 .OR. nlst(did)%GWBASESWCRT.GE.4) then
10181           call   output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, RT_DOMAIN(did)%numbasns, &
10182                   trim(nlst(did)%sincedate), trim(nlst(did)%olddate), &
10183                   rt_domain(did)%basnsInd,rt_domain(did)%qin_gwsubbas, &
10184                   rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas  )
10185         else
10186           call   output_gw_netcdf( nlst(did)%igrid, nlst(did)%split_output_count, RT_DOMAIN(did)%nlinksl, &
10187                   trim(nlst(did)%sincedate), trim(nlst(did)%olddate), &
10188                   rt_domain(did)%linkid,rt_domain(did)%qin_gwsubbas, &
10189                   rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas  )
10190         endif
10191 #endif
10192     end subroutine output_GW_Diag
10193
10194
10195 !----------------------------------- gw netcdf output
10196
10197    subroutine output_gw_netcdf(igrid, split_output_count, nbasns, &
10198         startdate, date, &
10199         gw_id_var, gw_in_var, gw_out_var, gw_z_var)
10200
10201      integer,                                  intent(in) :: igrid
10202      integer,                                  intent(in) :: split_output_count
10203      integer,                                  intent(in) :: nbasns
10204      real, dimension(:),                  intent(in) :: gw_in_var, gw_out_var, gw_z_var
10205      integer(kind=int64), dimension(:),               intent(in) :: gw_id_var
10206
10207      character(len=*),                         intent(in) :: startdate
10208      character(len=*),                         intent(in) :: date
10209
10210
10211      integer, save  :: output_count
10212      integer, save :: ncid
10213
10214      integer :: basindim, varid,  n, nstations
10215      integer :: iret,i    !--
10216      character(len=256) :: output_flnm
10217      character(len=19)  :: date19, date19start
10218      character(len=32)  :: convention
10219      integer :: timedim
10220      integer :: seconds_since
10221      character(len=34)  :: sec_since_date
10222      character(len=34)  :: sec_valid_date
10223
10224      if(split_output_count .ne. 1 ) then
10225             write(6,*) "WARNING: split_output_count need to be 1 for this output option."
10226      endif
10227
10228      sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
10229                   //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
10230
10231      date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
10232                   //startdate(12:13)//':'//startdate(15:16)//':00'
10233
10234      seconds_since = int(nlst(1)%out_dt*60*(rt_domain(1)%out_counts-1))
10235
10236      sec_valid_date = 'seconds since '//nlst(1)%startdate(1:4)//'-'//nlst(1)%startdate(6:7)//'-'//nlst(1)%startdate(9:10) &
10237                       //' '//nlst(1)%startdate(12:13)//':'//nlst(1)%startdate(15:16)//' UTC'
10238
10239      write(output_flnm, '(A12,".GWOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
10240
10241 #ifdef HYDRO_D
10242       print*, 'output_flnm = "'//trim(output_flnm)//'"'
10243 #endif
10244
10245       iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
10246
10247       if (iret /= 0) then
10248           print*, "Problem nf90_create"
10249           call hydro_stop("output_gw_netcdf")
10250       endif
10251
10252 !!! Define dimensions
10253
10254         nstations =nbasns
10255
10256       iret = nf90_def_dim(ncid, "basin", nstations, basindim)
10257
10258       iret = nf90_def_dim(ncid, "time", 1, timedim)
10259
10260 !!! Define variables
10261
10262
10263       !- gw basin ID
10264       iret = nf90_def_var(ncid, "gwbas_id", NF90_INT, (/basindim/), varid)
10265       iret = nf90_put_att(ncid, varid, 'long_name', 'GW basin ID')
10266
10267       !- gw inflow
10268       iret = nf90_def_var(ncid, "gw_inflow", NF90_FLOAT, (/basindim/), varid)
10269       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
10270
10271       !- gw outflow
10272       iret = nf90_def_var(ncid, "gw_outflow", NF90_FLOAT, (/basindim/), varid)
10273       iret = nf90_put_att(ncid, varid, 'units', 'meter^3 / sec')
10274
10275       !- depth in gw bucket
10276       iret = nf90_def_var(ncid, "gw_zlev", NF90_FLOAT, (/basindim/), varid)
10277       iret = nf90_put_att(ncid, varid, 'units', 'mm')
10278
10279       ! Time variable
10280       iret = nf90_def_var(ncid, "time", NF90_INT, (/timeDim/), varid)
10281       iret = nf90_put_att(ncid, varid, 'units', sec_valid_date)
10282       iret = nf90_put_att(ncid, varid, 'long_name', 'valid output time')
10283
10284       date19(1:19) = "0000-00-00_00:00:00"
10285       date19(1:len_trim(startdate)) = startdate
10286
10287       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_initialization_time", trim(nlst(1)%startdate))
10288       iret = nf90_put_att(ncid, NF90_GLOBAL, "model_output_valid_time", trim(nlst(1)%olddate))
10289       iret = nf90_put_att(ncid, NF90_GLOBAL, "missing_value", -9E15)
10290
10291       iret = nf90_enddef(ncid)
10292
10293 !!! Input variables
10294
10295         !-- write lake id
10296         iret = nf90_inq_varid(ncid,"gwbas_id", varid)
10297         iret = nf90_put_var(ncid, varid, gw_id_var, (/1/), (/nstations/))
10298
10299         !-- write gw inflow
10300         iret = nf90_inq_varid(ncid,"gw_inflow", varid)
10301         iret = nf90_put_var(ncid, varid, gw_in_var, (/1/), (/nstations/))
10302
10303         !-- write elevation  of inflow
10304         iret = nf90_inq_varid(ncid,"gw_outflow", varid)
10305         iret = nf90_put_var(ncid, varid, gw_out_var, (/1/), (/nstations/))
10306
10307         !-- write elevation  of inflow
10308         iret = nf90_inq_varid(ncid,"gw_zlev", varid)
10309         iret = nf90_put_var(ncid, varid, gw_z_var, (/1/), (/nstations/))
10310
10311         !-- write time variable
10312         iret = nf90_inq_varid(ncid,"time", varid)
10313         iret = nf90_put_var(ncid, varid, seconds_since, (/1/))
10314
10315         iret = nf90_close(ncid)
10316
10317     end subroutine output_gw_netcdf
10318
10319 !------------------------------- end gw netcdf output
10320
10321     subroutine read_NSIMLAKES(NLAKES,route_lake_f)
10322         integer                     :: NLAKES
10323         CHARACTER(len=*  )          :: route_lake_f
10324
10325         character(len=256)          :: route_lake_f_r
10326         integer                     :: lenRouteLakeFR, iRet, ncid, dimId
10327         logical                     :: routeLakeNetcdf
10328
10329       !! is RouteLake file netcdf (*.nc) or  from the LAKEPARM.TBL ascii
10330 #ifdef MPP_LAND
10331     if(my_id .eq. io_id) then
10332 #endif
10333       route_lake_f_r = adjustr(route_lake_f)
10334       lenRouteLakeFR = len(route_Lake_f_r)
10335       routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc'
10336
10337
10338       write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f)
10339       write(6,*) "routeLakeNetcdf TF Name Len",routeLakeNetcdf, route_lake_f,lenRouteLakeFR
10340       call flush(6)
10341
10342        if(routeLakeNetcdf) then
10343           write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f)
10344           NLAKES = -99
10345           NLAKES = get_netcdf_dim(trim(route_lake_f), 'feature_id',  &
10346                                    'read_NSIMLAKES', fatalErr=.false.)
10347           if (NLAKES .eq. -99) then
10348                  ! We were unsucessful in getting feature_id, try linkDim
10349                  NLAKES = get_netcdf_dim(trim(route_lake_f), 'nlakes',  &
10350                                    'read_NSIMLAKES', fatalErr=.false.)
10351           endif
10352           if (NLAKES .eq. -99) then
10353                  ! Neither the feature_id nor nlakes dimensions were found in
10354                  ! the LAKEPARM file. Throw an error...
10355                  call hydro_stop("Could not find either feature_id or nlakes in LAKEPARM netcdf file.")
10356           endif
10357        else
10358 !yw for IOC reach based routing, if netcdf lake file is not set from the hydro.namelist,
10359 !    we will assume that no lake will be assimulated.
10360           write(6,*) "No lake nectdf file defined. NLAKES is set to be zero."
10361           NLAKES = 0
10362       endif
10363 #ifdef MPP_LAND
10364     endif ! end if block of my_id .eq. io_id
10365          call mpp_land_bcast_int1(NLAKES)
10366 #endif
10367
10368     end subroutine read_NSIMLAKES
10369
10370 ! sequential code: not used.!!!!!!
10371     subroutine nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, gTO_NODE,LINKID, LAKEIDM, LAKEIDA)
10372         !--- get the lake configuration here.
10373         implicit none
10374         integer, dimension(:),         intent(inout) :: TYPEL, LAKEIDX
10375         integer(kind=int64), dimension(:), intent(inout) :: LINKID, LAKEIDA, LAKELINKID, LAKEIDM, gTO_NODE
10376         integer, intent(in) :: NLAKES, NLINKSL
10377         integer, dimension(NLINKSL) :: OUTLAKEID
10378         integer :: i,j,k, kk
10379
10380         TYPEL = -999
10381
10382 !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach
10383 #ifdef MPP_LAND
10384      call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, gTO_NODE,LINKID, LAKEIDM, LAKEIDA,NLINKSL)
10385 #endif
10386
10387         OUTLAKEID = gTO_NODE
10388         DO i = 1, NLAKES
10389           DO j = 1, NLINKSL
10390             DO k = 1, NLINKSL
10391
10392               if( (gTO_NODE(j) .eq. LINKID(k) ) .and. &
10393                   (LAKEIDA(k) .lt. 0 .and. LAKEIDA(j) .eq. LAKEIDM(i))) then
10394                   TYPEL(j) = 1  !this is the link flowing out of the lake
10395                   OUTLAKEID(j) = LAKEIDA(j) ! LINKID(j)
10396                   LAKELINKID(i) = j
10397 !                    write(61,*) gTO_NODE(j),LAKEIDA(j),LAKEIDA(k),LAKELINKID(i) , j
10398 !                    call flush(61)
10399               elseif( (gTO_NODE(j) .eq. LINKID(k)) .and. &
10400                   (LAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. &
10401                   (LAKEIDA(k) .eq. LAKEIDM(i)) ) then
10402                   TYPEL(j) = 3 !type_3 inflow link to lake
10403                   OUTLAKEID(j) = LAKEIDM(i)
10404               elseif (LAKEIDA(j) .eq. LAKEIDM(i) .and. .not. TYPEL(j) .eq. 1) then
10405                   TYPEL(j) = 2 ! internal lake linkd
10406               endif
10407             END DO
10408           END DO
10409        END DO
10410
10411        DO i = 1, NLAKES
10412             if(LAKELINKID(i) .gt. 0) then
10413                 LAKEIDX(LAKELINKID(i)) = i
10414             endif
10415        ENDDO
10416
10417  ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
10418        DO i = 1, NLINKSL
10419         DO j = 1, NLINKSL
10420             if(TYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. OUTLAKEID(i))) then
10421               gTO_NODE(i) = LINKID(j)  !   OUTLAKEID(i)
10422             endif
10423         ENDDO
10424        ENDDO
10425
10426 !     do k = 1, NLINKSL
10427 !         write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k)
10428 !         call flush(60+my_id)
10429 !     end do
10430
10431 !     DO i = 1, NLINKSL
10432 !        write(61,*) i,LAKEIDX(i), TYPEL(i)
10433 !     end do
10434 !     DO i = 1, NLAKES
10435 !        write(62,*) i,LAKELINKID(i)
10436 !        write(63,*) i,LAKEIDM(i)
10437 !     end do
10438 !     close(61)
10439 !     close(62)
10440 !     close(63)
10441 !     call hydro_finish()
10442
10443 !   write(60,*) TYPEL
10444 !   write(63,*) LAKELINKID, LAKEIDX
10445 !   write(64,*) gTO_NODE
10446 !   write(61,*) LINKID
10447 !   write(62,*) LAKEIDM, LAKEIDA
10448 !   close(60)
10449 !   close(61)
10450 !   close(62)
10451 !   close(63)
10452 !   close(64)
10453 !   call hydro_finish()
10454
10455
10456     end subroutine nhdLakeMap
10457
10458 #ifdef MPP_LAND
10459     subroutine nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
10460         !--- get the lake configuration here.
10461         implicit none
10462         integer, dimension(:),           intent(out)   :: TYPEL
10463         integer, dimension(:),   intent(out)   :: LAKEIDX
10464         integer(kind=int64), dimension(:),   intent(inout) :: TO_NODE
10465         integer(kind=int64), dimension(:),   intent(out)   :: LAKELINKID
10466         integer(kind=int64), dimension(:),   intent(in)    :: LINKID, LAKEIDA
10467         integer(kind=int64), dimension(:),   intent(inout) :: LAKEIDM
10468         integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL
10469 !yw        integer, dimension(NLINKSL) :: OUTLAKEID
10470         integer(kind=int64), allocatable, dimension(:) :: OUTLAKEID
10471         integer :: i,size2 ,j,k, kk, num, maxNum, m, mm, tmpSize
10472         integer, allocatable, dimension(:) :: tmpTYPEL, ind, gLAKEIDX
10473         integer(kind=int64), allocatable, dimension(:) :: gLINKID, tmpLINKID, tmplakeida, tmpoutlakeid, gLAKEIDA
10474         integer(kind=int64), allocatable, dimension(:,:) :: gtonodeout
10475
10476         integer, allocatable, dimension(:) ::  gTYPEL
10477         integer(kind=int64), allocatable, dimension(:) ::  tmpLAKELINKID, gOUTLAKEID, tmpTO_NODE, gto
10478
10479       integer(kind=int64) tmpBuf(GNLINKSL)
10480
10481       tmpSize = size(TO_NODE,1)
10482       allocate(OUTLAKEID(tmpSize))
10483
10484       allocate (gto(GNLINKSL))
10485
10486       if(my_id .eq. io_id) then
10487          allocate (tmpLAKELINKID(nlakes) )
10488       else
10489          allocate (tmpLAKELINKID(1))
10490       endif
10491
10492
10493 !     prescan the data and remove the LAKEIDM which point to two links.
10494 #ifdef MPP_LAND
10495      call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
10496 #endif
10497
10498       call gBcastValue(TO_NODE,gto)
10499
10500       maxNum = 0
10501       kk = 0
10502
10503             ! The following loops are replaced by a hashtable-based algorithm
10504       ! do m = 1, NLINKSL
10505       !       num = 0
10506       !       do k = 1, gnlinksl
10507       !          if(gto(k) .eq. LINKID(m) ) then
10508       !              kk = kk +1
10509       !              num = num + 1
10510       !          endif
10511       !       end do
10512       !       if(num .gt. maxNum) maxNum = num
10513       ! end do
10514
10515
10516
10517       block
10518         type(hash_t) :: hash_table
10519         integer(kind=int64) :: val,it
10520         integer(kind=int64), allocatable :: num_a(:)
10521         logical :: found
10522
10523         allocate(num_a(NLINKSL))
10524         num_a = 0
10525         kk = 0
10526
10527         call hash_table%set_all_idx(linkid, NLINKSL)
10528         do it=1, gnlinksl
10529            call hash_table%get(gto(it), val, found)
10530            if(found .eqv. .true.) then
10531               kk = kk + 1
10532               num_a(val) = num_a(val) + 1
10533            end if
10534         end do
10535         maxNum = maxval(num_a)
10536         num_a = 1
10537
10538         allocate(ind(kk))
10539         allocate(gToNodeOut(NLINKSL,maxNum+1))
10540         gToNodeOut = -99
10541         allocate(tmpTYPEL(kk))
10542         allocate(tmpLINKID(kk))
10543         allocate(tmpLAKEIDA(kk))
10544         allocate(tmpOUTLAKEID(kk))
10545         allocate(tmpTO_NODE(kk))
10546
10547         if(kk .gt. 0) then
10548            tmpOUTLAKEID = -999
10549            tmpTYPEL = -999
10550            tmpTO_NODE = -999
10551         endif
10552         if(NLINKSL .gt. 0) then
10553            OUTLAKEID = -999
10554            TYPEL = -999
10555         endif
10556
10557         kk = 0
10558
10559         ! The following loops are replaced by a hashtable-based algorithm
10560         ! do m = 1, NLINKSL
10561         !          num = 1
10562         !          do k = 1, gnlinksl
10563         !              if(gto(k) .eq. LINKID(m) ) then
10564         !                  kk = kk +1
10565         !                  ind(kk) = k
10566         !                  tmpTO_NODE(kk) = gto(k)
10567         !                  gToNodeOut(m,num+1) = kk
10568         !                  gToNodeOut(m,1) = num
10569         !                  num = num + 1
10570         !              endif
10571         !           end do
10572         ! enddo
10573
10574         do it=1, gnlinksl
10575            call hash_table%get(gto(it), val, found)
10576            if(found .eqv. .true.) then
10577               kk = kk + 1
10578               ind(kk) = it
10579               tmpTO_NODE(kk) = gto(it)
10580               gToNodeOut(val,num_a(val)+1) = kk
10581               gToNodeOut(val,1) = num_a(val)
10582               num_a(val) = num_a(val) + 1
10583            end if
10584         end do
10585
10586         deallocate(num_a)
10587         call hash_table%clear()
10588
10589       end block
10590
10591       size2 = kk
10592       deallocate (gto)
10593
10594       allocate(gLINKID(gnlinksl))
10595       call gBcastValue(LINKID,gLINKID)
10596       do i = 1, size2
10597             k = ind(i)
10598             tmpLINKID(i) = gLINKID(k)
10599       enddo
10600
10601       allocate(gLAKEIDA(gnlinksl))
10602       call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) )
10603       do i = 1, size2
10604             k = ind(i)
10605             tmpLAKEIDA(i) = gLAKEIDA(k)
10606       enddo
10607       if(allocated(gLAKEIDA)) deallocate(gLAKEIDA)
10608
10609 !yw LAKELINKID = 0
10610       tmpLAKELINKID = LAKELINKID
10611       tmpOUTLAKEID  = tmpTO_NODE
10612       OUTLAKEID(1:NLINKSL)  = TO_NODE(1:NLINKSL)
10613
10614  !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach
10615         DO i = 1, NLAKES
10616           DO k = 1, NLINKSL
10617              do m = 1, gToNodeOut(k,1)
10618                  j = gToNodeOut(k,m+1)
10619                  if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. &
10620                      (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then
10621                      tmpTYPEL(j) = 1  !this is the link flowing out of the lake
10622                      tmpOUTLAKEID(j) = tmpLAKEIDA(j) !tmpLINKID(j) ! Wei Check
10623                      LAKELINKID(i) = ind(j)
10624 !                    write(61,*) tmpTO_NODE(j),tmpLAKEIDA(j),LAKEIDA(k),LAKELINKID(i)
10625 !                    call flush(61)
10626                  elseif( (tmpTO_NODE(j) .eq. LINKID(k)) .and. &
10627                      (tmpLAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. &
10628                      (LAKEIDA(k) .eq. LAKEIDM(i)) ) then
10629                      tmpTYPEL(j) = 3 !type_3 inflow link to lake
10630                      tmpOUTLAKEID(j) = LAKEIDM(i) !Wei Check
10631 !                    write(62,*) tmpTO_NODE(j),tmpOUTLAKEID(j),LAKEIDM(i)
10632 !                    call flush(62)
10633                  elseif (tmpLAKEIDA(j) .eq. LAKEIDM(i) .and. tmpTYPEL(j) .ne. 1) then
10634                      tmpTYPEL(j) = 2 ! internal lake linkd
10635                      !! print the following to get the list of links which are ignored bc they are internal to lakes.
10636                      !print*,'Ndg: tmpLAKEIDA(j):', tmpLAKEIDA(j)
10637                  endif
10638             END DO
10639           END DO
10640        END DO
10641
10642 !yw       call sum_int1d(LAKELINKID, NLAKES)
10643        call updateLake_seqInt8(LAKELINKID,nlakes,tmpLAKELINKID)
10644
10645        if(allocated(tmplakelinkid))  deallocate(tmpLAKELINKID)
10646
10647        if(gNLINKSL .gt. 0) then
10648           if(my_id .eq. 0) then
10649               allocate(gLAKEIDX(gNLINKSL))
10650               gLAKEIDX = -999
10651               DO i = 1, NLAKES
10652                    if(LAKELINKID(i) .gt. 0) then
10653                       gLAKEIDX(LAKELINKID(i)) = i
10654                    endif
10655               ENDDO
10656           else
10657               allocate(gLAKEIDX(1))
10658           endif
10659           call ReachLS_decomp(gLAKEIDX, LAKEIDX)
10660           if(allocated(gLAKEIDX)) deallocate(gLAKEIDX)
10661        endif
10662
10663 !     do k = 1, size
10664 !         write(70+my_id,*) "k, ind(k), typel, lakeidx", k, ind(k),tmpTYPEL(k), lakeidx(ind(k))
10665 !         call flush(70+my_id)
10666 !     end do
10667
10668        call TONODE2RSL(ind,tmpTYPEL,size2,gNLINKSL,NLINKSL,TYPEL(1:NLINKSL), -999 )
10669        call TONODE2RSL8(ind,tmpOUTLAKEID,size2,gNLINKSL,NLINKSL,OUTLAKEID(1:NLINKSL), -999 )
10670
10671
10672  ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
10673 !yw       DO i = 1, NLINKSL
10674 !yw 105
10675 !     DO k = 1, NLINKSL
10676 !       do m = 1, gToNodeOut(k,1)
10677 !                i = gToNodeOut(k,m+1)
10678 !          DO j = 1, NLINKSL
10679 !             if (tmpTYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. tmpOUTLAKEID(i)) &
10680 !                  .and. tmpOUTLAKEID(i) .ne. -999) then
10681 !                    !yw tmpTO_NODE(i) = tmpOUTLAKEID(i)  !Wei Check
10682 !                    tmpTO_NODE(i) = LINKID(j)  !Wei Check
10683 !             endif
10684 !          END DO
10685 !        END DO
10686 !     END DO
10687 !     call TONODE2RSL(ind,tmpTO_NODE,size,gNLINKSL,NLINKSL,TO_NODE(1:NLINKSL), -999 )
10688
10689  ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
10690       allocate(gTYPEL(gNLINKSL))
10691       allocate(gOUTLAKEID(gNLINKSL))
10692       call gBcastValue(TYPEL,gTYPEL)
10693       call gBcastValue(OUTLAKEID,gOUTLAKEID)
10694        DO i = 1, NLINKSL
10695         DO j = 1, gNLINKSL
10696             if(TYPEL(i) .eq. 3 .and. gTYPEL(j) .eq. 1 .and. (gOUTLAKEID(j) .eq. OUTLAKEID(i))) then
10697               TO_NODE(i) = gLINKID(j)  !   OUTLAKEID(i)
10698             endif
10699         ENDDO
10700        ENDDO
10701       deallocate(gLINKID)
10702       deallocate(gTYPEL)
10703       deallocate(gOUTLAKEID)
10704
10705       deallocate(tmpTYPEL,tmpLINKID, tmpTO_NODE, tmpLAKEIDA, tmpOUTLAKEID,OUTLAKEID)
10706
10707
10708 !     do k = 1, NLINKSL
10709 !         write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k)
10710 !         call flush(60+my_id)
10711 !     end do
10712
10713
10714 !     call ReachLS_write_io(TO_NODE(1:NLINKSL), tmpBuf(1:gNLINKSL) )
10715 !     if(my_id .eq. io_id ) then
10716 !       write(70,*) tmpBuf(1:gNLINKSL)
10717 !       call flush(70)
10718 !     endif
10719 !     call ReachLS_write_io(TYPEL(1:NLINKSL), tmpBuf(1:gNLINKSL) )
10720 !     if(my_id .eq. io_id ) then
10721 !       write(71,*) tmpBuf
10722 !       call flush(71)
10723 !     endif
10724 !     call ReachLS_write_io(LAKEIDX(1:NLINKSL), tmpBuf(1:gNLINKSL))
10725 !     if(my_id .eq. io_id ) then
10726 !       write(72,*) tmpBuf
10727 !       call flush(72)
10728 !       close(72)
10729 !     endif
10730 !     call ReachLS_write_io(OUTLAKEID(1:NLINKSL), tmpBuf(1:gNLINKSL))
10731 !     if(my_id .eq. io_id ) then
10732 !       write(73,*) tmpBuf
10733 !       call flush(73)
10734 !     endif
10735 !     call hydro_finish()
10736
10737 !     DO i = 1, NLINKSL
10738 !        write(61,*) i,LAKEIDX(i), TYPEL(i)
10739 !     end do
10740 !     DO i = 1, NLAKES
10741 !        write(63,*) i,LAKEIDM(i)
10742 !        write(62,*) i,LAKELINKID(i)
10743 !     end do
10744 !     close(61)
10745 !     close(62)
10746 !     close(63)
10747
10748 !   write(60,*) TYPEL
10749 !   write(63,*) LAKELINKID, LAKEIDX
10750 !   write(64,*) TO_NODE
10751 !   write(61,*) LINKID
10752 !   write(62,*) LAKEIDM, LAKEIDA
10753 !   close(60)
10754 !   close(61)
10755 !   close(62)
10756 !   close(63)
10757 !   close(64)
10758 !   call hydro_finish()
10759
10760     end subroutine nhdLakeMap_mpp
10761
10762     subroutine nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
10763         !--- get the lake configuration here.
10764         implicit none
10765         integer(kind=int64), dimension(:), intent(in) :: TO_NODE
10766         integer(kind=int64), dimension(NLAKES) :: LAKELINKID
10767         integer(kind=int64), dimension(:),   intent(in) :: LINKID, LAKEIDA
10768         integer(kind=int64), dimension(:),   intent(inout) :: LAKEIDM
10769         integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL
10770         integer :: i,size ,j,k, kk, num, maxNum, m, mm
10771         integer(kind=int64), allocatable, dimension(:) :: tmplakeida, tmpoutlakeid, gLAKEIDA, tmpTO_NODE, gto
10772         integer(kind=int64), allocatable, dimension(:) :: ind
10773         integer(kind=int64), allocatable, dimension(:,:) :: gtonodeout
10774         integer(kind=int64), allocatable, dimension(:) ::  tmpLAKELINKID, gtoLakeId_g, gtoLakeId
10775
10776 !       integer tmpBuf(GNLINKSL)
10777         integer, dimension(nlakes) :: lakemask
10778         integer ii
10779
10780       allocate (gto(GNLINKSL))
10781       allocate (gtoLakeId_g(GNLINKSL))
10782       allocate (gtoLakeId(NLINKSL))
10783       if(my_id .eq. io_id) then
10784          allocate(tmpLAKELINKID(nlakes))
10785       else
10786          allocate(tmpLAKELINKID(1))
10787       endif
10788
10789       gtoLakeId_g=-999
10790
10791       call gBcastValue(TO_NODE,gto)
10792
10793       maxNum = 0
10794       kk = 0
10795
10796       ! The following loops are replaced by a hashtable-based algorithm
10797       ! do m = 1, NLINKSL
10798       !    num = 0
10799       !    do k = 1, gnlinksl
10800       !       if(gto(k) .eq. LINKID(m) ) then
10801       !          gtoLakeId_g(k) = lakeida(m)
10802       !          kk = kk +1
10803       !          num = num + 1
10804       !       endif
10805       !    end do
10806       !    if(num .gt. maxNum) maxNum = num
10807       ! end do
10808
10809       block
10810         type(hash_t) :: hash_table
10811         integer(kind=int64) :: val,it
10812         integer(kind=int64), allocatable :: num_a(:)
10813         logical :: found
10814
10815         allocate(num_a(NLINKSL))
10816         num_a = 0
10817         kk = 0
10818
10819         call hash_table%set_all_idx(linkid, NLINKSL)
10820         do it=1, gnlinksl
10821            call hash_table%get(gto(it), val, found)
10822            if(found .eqv. .true.) then
10823               gtoLakeId_g(it) = lakeida(val)
10824               kk = kk + 1
10825               num_a(val) = num_a(val) + 1
10826            end if
10827         end do
10828         maxNum = maxval(num_a)
10829         num_a = 1
10830
10831         allocate(ind(kk))
10832         allocate(gToNodeOut(NLINKSL,maxNum+1))
10833         gToNodeOut = -99
10834         allocate(tmpLAKEIDA(kk))
10835         allocate(tmpTO_NODE(kk))
10836
10837         kk = 0
10838
10839         ! The following loops are replaced by a hashtable-based algorithm
10840         ! do m = 1, NLINKSL
10841         !    num = 1
10842         !    do k = 1, gnlinksl
10843         !       if(gto(k) .eq. LINKID(m) ) then
10844         !          kk = kk +1
10845         !          ind(kk) = k
10846         !          tmpTO_NODE(kk) = gto(k)
10847         !          gToNodeOut(m,num+1) = kk
10848         !          gToNodeOut(m,1) = num
10849         !          num = num + 1
10850         !       endif
10851         !    end do
10852         ! end do
10853
10854         do it=1, gnlinksl
10855            call hash_table%get(gto(it), val, found)
10856            if(found .eqv. .true.) then
10857               kk = kk + 1
10858               ind(kk) = it
10859               tmpTO_NODE(kk) = gto(it)
10860               gToNodeOut(val,num_a(val)+1) = kk
10861               gToNodeOut(val,1) = num_a(val)
10862               num_a(val) = num_a(val) + 1
10863            end if
10864         end do
10865
10866         deallocate(num_a)
10867         call hash_table%clear()
10868
10869       end block
10870
10871       size = kk
10872       if(allocated(gto)) deallocate (gto)
10873
10874
10875       allocate(gLAKEIDA(gnlinksl))
10876       call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) )
10877       do i = 1, size
10878             k = ind(i)
10879             tmpLAKEIDA(i) = gLAKEIDA(k)
10880       enddo
10881       if(allocated(gLAKEIDA)) deallocate(gLAKEIDA)
10882
10883         tmpLAKELINKID = LAKELINKID
10884 !       LAKELINKID = 0
10885         DO i = 1, NLAKES
10886           DO k = 1, NLINKSL
10887              do m = 1, gToNodeOut(k,1)
10888                  j = gToNodeOut(k,m+1)
10889                  if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. &
10890                      (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then
10891                      if(LAKELINKID(i) .gt. 0) then
10892                          LAKELINKID(i) = -999
10893 #ifdef HYDRO_D
10894                          write(6,*) "remove the lake  LAKEIDM(i) ", i, LAKEIDM(i)
10895                          call flush(6)
10896 #endif
10897                      endif
10898                      if(LAKELINKID(i) .eq. 0) LAKELINKID(i) = ind(j)
10899                  endif
10900             END DO
10901           END DO
10902        END DO
10903 !yw        call match1dLake(LAKELINKID, NLAKES, -999)
10904
10905 !yw double check
10906       call combine_int8_1d(gtoLakeId_g,gnlinksl, -999)
10907       call ReachLS_decomp(gtoLakeId_g,gtoLakeId)
10908
10909        lakemask = 0
10910        DO k = 1, NLINKSL
10911           if(LAKEIDA(k) .gt. 0) then
10912              DO i = 1, NLAKES
10913                 if(gtoLakeId(k) .eq. LAKEIDM(i) )  then
10914                     goto 992
10915                 endif
10916              enddo
10917              DO i = 1, NLAKES
10918                 if(LAKEIDA(k) .eq. LAKEIDM(i) )  then
10919                      lakemask(i) = lakemask(i) + 1
10920                       goto 992
10921                 endif
10922              enddo
10923 992          continue
10924           endif
10925        enddo
10926
10927        if(allocated(gtoLakeId_g)) deallocate(gtoLakeId_g)
10928        if(allocated(gtoLakeId)) deallocate(gtoLakeId)
10929        call sum_int1d(lakemask, NLAKES)
10930
10931        do i = 1, nlakes
10932            if(lakemask(i) .ne. 1) then
10933                LAKELINKID(i) = -999
10934 #ifdef HYDRO_D
10935                if(my_id .eq. IO_id) then
10936                   write(6,*) "double check remove the lake : ",LAKEIDM(i)
10937                   call flush(6)
10938                endif
10939 #endif
10940            endif
10941        enddo
10942
10943
10944 !end double check
10945
10946
10947        call updateLake_seqInt8(LAKELINKID,nlakes,tmpLAKELINKID)
10948
10949 !      if(my_id .eq. 0) then
10950 !          write(65,*) "check LAKEIDM   *****,"
10951 !          write(65,*) LAKEIDM
10952 !          call flush(6)
10953 !      endif
10954
10955        do k = 1, NLAKES
10956            if(LAKELINKID(k) .eq. -999) LAKEIDM(k) = -999
10957        end do
10958
10959 !      if(my_id .eq. 0) then
10960 !          write(65,*) "check LAKEIDM   *****,"
10961 !          write(65,*) LAKEIDM
10962 !          call flush(6)
10963 !      endif
10964
10965        close(65)
10966       if(allocated(tmpTO_NODE)) deallocate(tmpTO_NODE)
10967       if(allocated(tmpLAKEIDA)) deallocate(tmpLAKEIDA)
10968       if(allocated(tmplakelinkid)) deallocate(tmplakelinkid)
10969
10970     end subroutine nhdLakeMap_scan
10971 #endif
10972
10973 !ADCHANGE: New output lake types routine
10974     subroutine output_lake_types( inNLINKS, inLINKID, inTYPEL )
10975
10976 #ifdef MPP_LAND
10977     use module_mpp_land
10978 #endif
10979
10980     implicit none
10981
10982     integer, dimension(:),  intent(in) :: inTYPEL
10983     integer(kind=int64), dimension(:), intent(in) :: inLINKID
10984     integer, intent(in) :: inNLINKS
10985
10986     integer            :: iret
10987     integer            :: ncid, varid
10988     integer            :: linkdim
10989     character(len=256), parameter :: output_flnm = "LAKE_TYPES.nc"
10990
10991     integer, allocatable, dimension(:) :: typeL
10992     integer(kind=int64), allocatable, dimension(:) :: linkId
10993
10994 #ifdef MPP_LAND
10995
10996     if(my_id .eq. io_id) then
10997        allocate( linkId(inNLINKS)  )
10998        allocate( typeL(inNLINKS)   )
10999     else
11000        allocate(linkId(1), typeL(1))
11001     end if
11002
11003     call mpp_land_sync()
11004     call ReachLS_write_io(inLINKID, linkId)
11005     call ReachLS_write_io(inTYPEL, typeL)
11006
11007 #else
11008
11009     allocate( linkId(inNLINKS) )
11010     allocate( typeL(inNLINKS)  )
11011
11012     linkId    = inLINKID
11013     typeL     = inTYPEL
11014
11015 #endif
11016
11017 #ifdef MPP_LAND
11018     if(my_id .eq. io_id) then
11019 #endif
11020
11021        ! Create the channel connectivity file
11022 #ifdef HYDRO_D
11023        print*,'Lakes: output_flnm = "'//trim(output_flnm)//'"'
11024        flush(6)
11025 #endif
11026
11027        iret = nf90_create(trim(output_flnm), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
11028
11029        if (iret /= 0) then
11030           print*,"Lakes: Problem nf90_create"
11031           call hydro_stop("output_lake_types")
11032        endif
11033
11034        iret = nf90_def_dim(ncid, "link", inNLINKS, linkdim)
11035
11036        !-- link  id
11037        iret = nf90_def_var(ncid, "LINKID", NF90_INT64, (/linkdim/), varid)
11038        iret = nf90_put_att(ncid, varid, 'long_name', 'Link ID')
11039
11040        !- lake reach type, var
11041        iret = nf90_def_var(ncid, "TYPEL", NF90_INT, (/linkdim/), varid)
11042        iret = nf90_put_att(ncid, varid, 'long_name', 'Lake reach type')
11043
11044        iret = nf90_enddef(ncid)
11045
11046        !-- write id
11047        iret = nf90_inq_varid(ncid,"LINKID", varid)
11048        iret = nf90_put_var(ncid, varid, linkId, (/1/), (/inNLINKS/))
11049
11050        !-- write type
11051        iret = nf90_inq_varid(ncid,"TYPEL", varid)
11052        iret = nf90_put_var(ncid, varid, typeL, (/1/), (/inNLINKS/))
11053
11054        iret = nf90_close(ncid)
11055
11056 #ifdef MPP_LAND
11057     endif
11058 #endif
11059     if(allocated(linkId)) deallocate(linkId)
11060     if(allocated(typeL)) deallocate(typeL)
11061
11062 #ifdef MPP_LAND
11063     if(my_id .eq. io_id) then
11064 #endif
11065 #ifdef HYDRO_D
11066     write(6,*) "end of output_lake_types"
11067     flush(6)
11068 #endif
11069 #ifdef MPP_LAND
11070     endif
11071 #endif
11072
11073 end subroutine output_lake_types
11074
11075 subroutine hdtbl_out_nc(did,ncid,count,count_flag,varName,varIn,descrip,ixd,jxd)
11076    implicit none
11077    integer :: did, iret, ncid, ixd,jxd, ix,jx, err_flag,count_flag, count,varid
11078    real, allocatable, dimension(:,:) :: xdump
11079    real, dimension(:,:) :: varIn
11080    character(len=*) :: descrip
11081    character(len=*) ::varName
11082
11083 #ifdef MPP_LAND
11084    ix=global_nx
11085    jx=global_ny
11086 #else
11087    ix=RT_DOMAIN(did)%ix
11088    jx=RT_DOMAIN(did)%jx
11089 #endif
11090    if( count == 0 .and. count_flag == 0) then
11091       count_flag = 1
11092 #ifdef MPP_LAND
11093      if(my_id .eq. IO_id) then
11094 #endif
11095      iret = nf90_create(trim(nlst(did)%hydrotbl_f), OR(NF90_CLOBBER, NF90_NETCDF4), ncid)
11096 #ifdef MPP_LAND
11097      endif
11098      call mpp_land_bcast_int1(iret)
11099 #endif
11100        if (iret /= 0) then
11101           call hydro_stop("FATAL ERROR:   - Problem nf90_create  in nc of hydrotab_f file")
11102        endif
11103
11104 #ifdef MPP_LAND
11105      if(my_id .eq. IO_id) then
11106 #endif
11107        iret = nf90_def_dim(ncid, "west_east", ix, ixd)  !-- make a decimated grid
11108        iret = nf90_def_dim(ncid, "south_north", jx, jxd)
11109 #ifdef MPP_LAND
11110      endif
11111 #endif
11112    endif ! count == 0
11113
11114
11115    if( count == 1 ) then  ! define variables
11116 #ifdef MPP_LAND
11117      if(my_id .eq. io_id) then
11118 #endif
11119        iret = nf90_def_var(ncid, trim(varName), NF90_FLOAT, (/ixd,jxd/), varid)
11120        ! iret = nf90_put_att(ncid, varid, 'description', trim(descrip))
11121        iret = nf90_put_att(ncid, varid, 'description', "test")
11122 #ifdef MPP_LAND
11123      endif
11124 #endif
11125    endif  !!! end of count == 1
11126
11127    if (count == 2) then ! write out the variables
11128        if(count_flag == 2) iret = nf90_enddef(ncid)
11129        count_flag = 3
11130 #ifdef MPP_LAND
11131      if(my_id .eq. io_id) then
11132 #endif
11133        allocate (xdump(ix, jx))
11134 #ifdef MPP_LAND
11135      else
11136        allocate (xdump(1, 1))
11137      endif
11138 #endif
11139
11140 #ifdef MPP_LAND
11141      call write_io_real(varIn,xdump)
11142      if(my_id .eq. io_id) iret = nf90_inq_varid(ncid,trim(varName), varid)
11143      if(my_id .eq. io_id)  iret = nf90_put_var(ncid, varid, xdump, (/1,1/), (/ix,jx/))
11144 #else
11145      iret = nf90_inq_varid(ncid,trim(varName), varid)
11146      iret = nf90_put_var(ncid, varid, varIn, (/1,1/), (/ix,jx/))
11147 #endif
11148
11149       deallocate(xdump)
11150     endif !! end of count == 2
11151     if(count == 3 .and. count_flag == 3) then
11152        count_flag = 4
11153 #ifdef MPP_LAND
11154        if(my_id .eq. io_id ) &
11155 #endif
11156        iret = nf90_close(ncid)
11157     endif !! end of count == 3
11158
11159
11160 end subroutine hdtbl_out_nc
11161 subroutine hdtbl_out(did)
11162    implicit none
11163    integer :: did, ncid, count,count_flag, i, ixd,jxd
11164    do i = 0,3
11165       count = i
11166       count_flag = i
11167       call hdtbl_out_nc(did,ncid, count,count_flag,"SMCMAX1",rt_domain(did)%SMCMAX1,"",ixd,jxd)
11168       call hdtbl_out_nc(did,ncid, count,count_flag,"SMCREF1",rt_domain(did)%SMCREF1,"",ixd,jxd)
11169       call hdtbl_out_nc(did,ncid, count,count_flag,"SMCWLT1",rt_domain(did)%SMCWLT1,"",ixd,jxd)
11170       call hdtbl_out_nc(did,ncid, count,count_flag,"OV_ROUGH2D",rt_domain(did)%OV_ROUGH2D,"",ixd,jxd)
11171       call hdtbl_out_nc(did,ncid, count,count_flag,"LKSAT",rt_domain(did)%LKSAT,"",ixd,jxd)
11172       call hdtbl_out_nc(did,ncid, count,count_flag,"NEXP",rt_domain(did)%NEXP,"",ixd,jxd)
11173    end do
11174 end subroutine hdtbl_out
11175
11176 subroutine hdtbl_in_nc(did)
11177    implicit none
11178    integer :: did
11179    integer :: ierr
11180    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCMAX1",rt_domain(did)%SMCMAX1,ierr)
11181    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCREF1",rt_domain(did)%SMCREF1,ierr)
11182    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"SMCWLT1",rt_domain(did)%SMCWLT1,ierr)
11183    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"OV_ROUGH2D",rt_domain(did)%overland%properties%roughness,ierr, rt=.true.)
11184    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"LKSAT",rt_domain(did)%LKSAT,ierr)
11185    call read2dlsm(did,trim(nlst(did)%hydrotbl_f),"NEXP",rt_domain(did)%NEXP,ierr)
11186    ! Letting this variable be optional and setting to global default value if not found
11187    if (ierr /= 0) then
11188      write(6,*)  "WARNING (hydtbl_in_nc): NEXP not found so setting to global 1.0"
11189      rt_domain(did)%NEXP = 1.0
11190    endif
11191 end subroutine hdtbl_in_nc
11192
11193 subroutine read2dlsm(did,file,varName,varOut,ierr,rt)
11194 use module_mpp_land,only: mpp_land_bcast_int1
11195   implicit none
11196   integer :: did, ncid , iret
11197   character(len=*) :: file,varName
11198   real,dimension(:,:) :: varOut
11199   character(len=256) :: units
11200   integer, intent(out) :: ierr
11201   logical, optional, intent(in) :: rt
11202   logical :: regrid
11203
11204   real,allocatable,dimension(:,:) :: tmpArr
11205
11206 #ifdef MPP_LAND
11207   if(my_id .eq. io_id) then
11208 #endif
11209      allocate(tmpArr(global_nx,global_ny))
11210      iret = nf90_open(trim(file), NF90_NOWRITE, ncid)
11211      call get_2d_netcdf(trim(varName), ncid, tmpArr, units, global_nx, global_ny, &
11212           .false., ierr)
11213      iret = nf90_close(ncid)
11214 #ifdef MPP_LAND
11215   else
11216      allocate(tmpArr(1,1))
11217   endif
11218 #endif
11219
11220   if (present(rt)) then
11221     regrid = rt
11222   else
11223     regrid = .false.
11224   endif
11225
11226   if (regrid) then
11227     call regrid_lowres_to_highres(did, tmpArr, varOut, rt_domain(did)%ixrt, rt_domain(did)%jxrt)
11228   else
11229     call decompose_data_real (tmpArr,varOut)
11230   endif
11231
11232 #ifdef MPP_LAND
11233   call mpp_land_bcast_int1(ierr)
11234 #endif
11235
11236   deallocate(tmpArr)
11237 end subroutine read2dlsm
11238
11239 subroutine regrid_lowres_to_highres(did, lowres_grid, highres_grid, ixrt, jxrt)
11240
11241   implicit none
11242   integer :: did
11243   integer :: ixrt, jxrt
11244   real, dimension(global_nx, global_ny) :: lowres_grid
11245   real, dimension(ixrt,jxrt) :: highres_grid
11246   ! Local variables
11247   integer :: i, j, irt, jrt, aggfacxrt, aggfacyrt
11248
11249 #ifdef MPP_LAND
11250   real,allocatable,dimension(:,:) :: tmpArr
11251   if(my_id .eq. io_id) then
11252      allocate(tmpArr(global_rt_nx, global_rt_ny))
11253 #endif
11254
11255       do j = 1,global_ny ! Start coarse grid j loop
11256          do i = 1,global_nx ! Start coarse grid i loop
11257
11258             do aggfacyrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid j loop
11259             do aggfacxrt = nlst(did)%AGGFACTRT-1,0,-1 ! Start disagg fine grid i loop
11260
11261                irt = i * nlst(did)%AGGFACTRT - aggfacxrt ! Define fine grid i
11262                jrt = j * nlst(did)%AGGFACTRT - aggfacyrt ! Define fine grid j
11263 #ifdef MPP_LAND
11264                ! if(left_id.ge.0) irt = irt + 1
11265                ! if(down_id.ge.0) jrt = jrt + 1
11266                tmpArr(irt,jrt) = lowres_grid(i,j)
11267 #else
11268                highres_grid(irt,jrt) = lowres_grid(i,j)
11269 #endif
11270
11271             end do
11272             end do
11273
11274          end do
11275       end do
11276
11277 #ifdef MPP_LAND
11278   else
11279      allocate(tmpArr(1,1))
11280   endif
11281   call decompose_RT_real(tmpArr, highres_grid, global_rt_nx, global_rt_ny, ixrt, jxrt)
11282   deallocate(tmpArr)
11283 #endif
11284
11285 end subroutine regrid_lowres_to_highres
11286
11287 subroutine read_channel_only (olddateIn, hgrid, indir, dtbl)
11288 !use module_HYDRO_io, only: read_rst_crt_reach_nc
11289 use module_RT_data, only: rt_domain
11290 use module_mpp_land,only: mpp_land_bcast_int1, my_id, io_id
11291 use Module_Date_utilities_rt, only: geth_newdate
11292 use config_base, only: nlst
11293 implicit none
11294 integer :: iret, did, len, ncid
11295 integer :: dtbl
11296 character :: hgrid
11297 character(len=*):: olddateIn,indir
11298 character(len=19) :: olddate
11299 character(len=256):: fileName
11300 real*8, allocatable, dimension(:):: accBucket_in, accSfcLatRunoff_in
11301 real  , allocatable, dimension(:)::   qBucket_in,   qSfcLatRunoff_in
11302 integer, parameter :: r8 = selected_real_kind(8)
11303 real*8,  parameter :: zeroDbl=0.0000000000000000000_r8
11304 integer :: ovrtswcrt_in, noah_timestep_in, channel_only_in, channelBucket_only_in
11305 character(len=86) :: attNotInFileMsg
11306
11307 did = 1
11308 len = size(rt_domain(did)%QLATERAL,1)
11309 !! if len is .le. 0, this whole thing is pointless. huh?
11310
11311 if(my_id .eq. io_id) then
11312    call geth_newdate(olddate,olddateIn,dtbl)
11313    fileName = trim(indir)//"/"//&
11314         olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
11315         olddate(15:16)//".CHRTOUT_DOMAIN"//hgrid
11316 #ifdef HYDRO_D
11317    print*, " Channel only input forcing file: ",trim(fileName)
11318 #endif /* HYDRO_D */
11319    iret = nf90_open(trim(fileName), NF90_NOWRITE, ncid)
11320 endif
11321
11322 call mpp_land_bcast_int1(iret)
11323 if (iret .ne. 0) then
11324    call hydro_stop( "FATAL ERROR: read forcing data for CHANNEL_ONLY failed. ")
11325 endif
11326
11327 !! ---------------------------------------------------------------------------
11328 !! Consistency checks - global att checking.
11329 if(my_id .eq. io_id) then
11330
11331    attNotInFileMsg=&  !! lenght fixed above
11332         'Fatal error for channel only: the following global attribute not in the forcing file: '
11333
11334    !! 1) overland routing v squeegee??
11335    !!if(nlst_rt(did)%OVRTSWCRT .eq. 1) then
11336    iret = nf90_get_att(ncid, NF90_GLOBAL, 'OVRTSWCRT', ovrtswcrt_in)
11337    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_OVRTSWCRT', ovrtswcrt_in)
11338    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'OVRTSWCRT & dev_OVRTSWCRT not in ' // trim(fileName) )
11339    if(nlst(1)%ovrtswcrt .ne. ovrtswcrt_in) &
11340         call hydro_stop('Channel only: OVRTSWCRT or dev_OVRSWCRT in forcing file does not match run config.')
11341
11342    !! 2) NOAH_TIMESTEP same?
11343    iret = nf90_get_att(ncid, NF90_GLOBAL, 'NOAH_TIMESTEP', noah_timestep_in)
11344    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, 'dev_NOAH_TIMESTEP', noah_timestep_in)
11345    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'NOAH_TIMESTEP & dev_NOAH_TIMESTEP not in ' // trim(fileName) )
11346    if(nlst(1)%dt .ne. noah_timestep_in) &
11347         call hydro_stop('Channel only: NOAH_TIMESTEP or dev_NOAH_TIMESTEP in forcing file does not match run config.')
11348
11349    !! 3) channel_only or channelBucket_only?
11350    iret = nf90_get_att(ncid, NF90_GLOBAL, "channel_only",       channel_only_in)
11351    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, "dev_channel_only",       channel_only_in)
11352    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'channel_only not in ' // trim(fileName) )
11353
11354    iret = nf90_get_att(ncid, NF90_GLOBAL, "channelBucket_only", channelBucket_only_in)
11355    if(iret .ne. 0) iret = nf90_get_att(ncid, NF90_GLOBAL, "dev_channelBucket_only", channel_only_in)
11356    if(iret .ne. 0) call hydro_stop(attNotInFileMsg // 'channelBucket_only not in ' // trim(fileName) )
11357    !! See table of fatal combinations on wiki: https://wiki.ucar.edu/display/wrfhydro/Channel+Only
11358    !! First row: Can it even get to this combination? NO.
11359    !if( (nlst_rt(did)%channel_only .eq. 0 .and. nlst_rt(did)%channelBucket_only .eq. 0) .and. &
11360    !    (channel_only_in .eq. 1 .or.  channelBucket_only_in .eq. 1)        ) &
11361    !    call hydro_stop('Channel Only: Forcing files in consistent with forcing type.')
11362    !! Second row:
11363    if(nlst(did)%channel_only .eq. 1 .and. channelBucket_only_in .eq. 1) &
11364         write(6,*) "Warning: channelBucket_only output forcing channel_only run"
11365
11366 end if
11367
11368    !! ---------------------------------------------------------------------------
11369    !! FLUXES or accumulations? NOT SUPPORTING accumulations to be read in.
11370 !! FLUXES
11371 if(nlst(did)%channel_only       .eq. 1 .or. &
11372    nlst(did)%channelBucket_only .eq. 1      ) then
11373
11374    allocate(qBucket_in(len))
11375    allocate(qSfcLatRunoff_in(len))
11376    qBucket_in   = 0.0
11377    qSfcLatRunoff_in = 0.0
11378
11379    !! Surface Lateral Fluxes (currenly include exfiltration from subsurface)
11380    call read_rst_crt_reach_nc(ncid, qSfcLatRunoff_in, "qSfcLatRunoff", &
11381                               rt_domain(did)%GNLINKSL, fatalErr=.true. )
11382
11383    !! Fluxes from (channel only) or to (channelBucket only) bucket?
11384    !! Fluxes from bucket.
11385    if(nlst(did)%channel_only .eq. 1) then
11386       call read_rst_crt_reach_nc(ncid, qBucket_in, "qBucket",            &
11387                                  rt_domain(did)%GNLINKSL, fatalErr=.true.)
11388       rt_domain(did)%qout_gwsubbas = qBucket_in
11389       rt_domain(did)%QLateral      = qBucket_in + qSfcLatRunoff_in
11390    endif
11391
11392    !! Fluxes to bucket
11393    if(nlst(did)%channelBucket_only .eq. 1) then
11394       call read_rst_crt_reach_nc(ncid, qBucket_in, "qBtmVertRunoff",     &
11395                                  rt_domain(did)%GNLINKSL, fatalErr=.true.)
11396       rt_domain(did)%qin_gwsubbas = qBucket_in
11397       rt_domain(did)%QLateral     = qSfcLatRunoff_in
11398    end if
11399
11400    deallocate(qBucket_in, qSfcLatRunoff_in)
11401 end if
11402
11403 !! Accumulations - NOT SUPPORTED, MAY NEVER BE.
11404 !! How to figure out if fluxes or accums force??
11405 if(.FALSE.) then
11406    allocate(accBucket_in(len))
11407    allocate(accSfcLatRunoff_in(len))
11408    accBucket_in   = zeroDbl
11409    accSfcLatRunoff_in = zeroDbl
11410
11411    call read_rst_crt_reach_nc(ncid, accSfcLatRunoff_in, "accSfcLatRunoff", &
11412         rt_domain(did)%GNLINKSL, fatalErr=.true.)
11413    !! Could worry about bucket being off or not output...
11414    call read_rst_crt_reach_nc(ncid, accBucket_in,         "accBucket",       &
11415         rt_domain(did)%GNLINKSL, fatalErr=.true.)
11416
11417    !! Calculate the current
11418    if(len .gt. 0) then  !! would the length be zero on some images?
11419       rt_domain(did)%qout_gwsubbas = &
11420            real( (accBucket_in - rt_domain(did)%accBucket)/nlst(did)%DT )
11421       rt_domain(did)%QLateral      = &
11422            real( rt_domain(did)%qout_gwsubbas +     &
11423                  (accSfcLatRunoff_in - rt_domain(did)%accSfcLatRunoff)/nlst(did)%DT )
11424
11425       !! Negative accumulations imply accumulations were zeroed, e.g. the code was restarted
11426       if(any(rt_domain(did)%QLateral .lt. 0)) &
11427            rt_domain(did)%QLateral      = real( (accSfcLatRunoff_in)/nlst(did)%DT )
11428       if(any(rt_domain(did)%qout_gwsubbas .lt. 0)) &
11429            rt_domain(did)%qout_gwsubbas = real( (accBucket_in)/nlst(did)%DT )
11430
11431       !! /\ ORDER MATTERS \/ because the pre-input accumulations are needed above.
11432       !! else below would be zero.
11433       rt_domain(did)%accBucket     = accBucket_in
11434       rt_domain(did)%accSfcLatRunoff = accSfcLatRunoff_in
11435
11436    end if
11437
11438    deallocate(accBucket_in, accSfcLatRunoff_in)
11439 end if
11440
11441 if(my_id .eq. io_id) then
11442    iret = nf90_close(ncid)
11443 #ifdef HYDRO_D
11444    print*, "finish read channel only forcing "
11445 #endif /* HYDRO_D */
11446 endif
11447 call flush(6)
11448
11449 end subroutine read_channel_only
11450
11451
11452 !---------------------------------------------------------------------------
11453 end module module_HYDRO_io