diff --git a/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 b/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 index e6882f74eb..8721200ffd 100644 --- a/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 +++ b/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: module module_WRF_HYDRO @@ -106,7 +86,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) #ifdef MPP_LAND - call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + call MPI_Comm_dup(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) call MPP_LAND_INIT(grid%e_we - grid%s_we - 1, grid%e_sn - grid%s_sn - 1) call mpp_land_bcast_int1 (nlst(did)%nsoil) @@ -214,9 +194,9 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) #endif else do k = 1, nlst(did)%nsoil - RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) - RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) - RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) + RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) + RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) + RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) end do rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte) rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte) @@ -235,7 +215,7 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) ! update WRF variable after running routing model. grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%overland%control%surface_water_head_lsm -! provide groundwater soil flux to WRF for fully coupled simulations (FERSCH 09/2014) +! provide groundwater soil flux to WRF for fully coupled simulations (FERSCH 09/2014) if(nlst(did)%GWBASESWCRT .eq. 3 ) then !Wei Yu: comment the following two lines. Not ready for WRF3.7 release !yw grid%qsgw(its:ite,jts:jte) = gw2d(did)%qsgw @@ -269,7 +249,7 @@ subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) do j = 1, jx do i = 1, ix do k = 1, kk - call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) + call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) end do end do end do @@ -291,7 +271,7 @@ subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) do j = 1, jx do i = 1, ix do k = 1, kk - call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) + call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) end do end do end do diff --git a/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 b/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 index 4dceba6af5..40ed2ed228 100644 --- a/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 +++ b/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: module module_WRF_HYDRO diff --git a/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 b/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 index db86a573e7..1a40920326 100644 --- a/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 +++ b/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: !2345678 !ywGW subroutine wrf_drv_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte) diff --git a/hydro/Data_Rec/module_RT_data.F90 b/hydro/Data_Rec/module_RT_data.F90 index 01a608d46c..aa2ea32a7c 100644 --- a/hydro/Data_Rec/module_RT_data.F90 +++ b/hydro/Data_Rec/module_RT_data.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - Module module_RT_data use module_rt_inc, only: rt_field implicit none diff --git a/hydro/Data_Rec/module_gw_gw2d_data.F90 b/hydro/Data_Rec/module_gw_gw2d_data.F90 index 1784a9950c..6fd2cecb65 100644 --- a/hydro/Data_Rec/module_gw_gw2d_data.F90 +++ b/hydro/Data_Rec/module_gw_gw2d_data.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: module module_gw_gw2d_data implicit none diff --git a/hydro/Data_Rec/module_namelist.F90 b/hydro/Data_Rec/module_namelist.F90 index 51303619c7..c72a4275d3 100644 --- a/hydro/Data_Rec/module_namelist.F90 +++ b/hydro/Data_Rec/module_namelist.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_namelist #ifdef MPP_LAND @@ -574,7 +554,6 @@ subroutine read_rt_nlst(nlst) if(channel_option .eq. 4) nlst%rtFlag = 0 ! if(CHANRTSWCRT .eq. 0 .and. SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0 if(SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0 - return end subroutine read_rt_nlst subroutine rt_nlst_check(nlst) diff --git a/hydro/HYDRO_drv/module_HYDRO_drv.F90 b/hydro/HYDRO_drv/module_HYDRO_drv.F90 index 63959f0cd0..a5a6a37df3 100644 --- a/hydro/HYDRO_drv/module_HYDRO_drv.F90 +++ b/hydro/HYDRO_drv/module_HYDRO_drv.F90 @@ -1,148 +1,128 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_HYDRO_drv #ifdef MPP_LAND - use module_HYDRO_io, only: output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd, & - restart_out_bi, restart_in_bi, mpp_output_chrt2, mpp_output_lakes2, & - hdtbl_in_nc, hdtbl_out + use module_HYDRO_io, only: output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd, & + restart_out_bi, restart_in_bi, mpp_output_chrt2, mpp_output_lakes2, & + hdtbl_in_nc, hdtbl_out USE module_mpp_land #else - use module_HYDRO_io, only: output_rt, output_chrt, output_chrt2, output_lakes + use module_HYDRO_io, only: output_rt, output_chrt, output_chrt2, output_lakes #endif - use module_NWM_io, only: output_chrt_NWM, output_rt_NWM, output_lakes_NWM,& - output_chrtout_grd_NWM, output_lsmOut_NWM, & - output_frxstPts, output_chanObs_NWM, output_gw_NWM - use module_HYDRO_io, only: sub_output_gw, restart_out_nc, restart_in_nc, & + use module_NWM_io, only: output_chrt_NWM, output_rt_NWM, output_lakes_NWM,& + output_chrtout_grd_NWM, output_lsmOut_NWM, & + output_frxstPts, output_chanObs_NWM, output_gw_NWM + use module_HYDRO_io, only: sub_output_gw, restart_out_nc, restart_in_nc, & get_file_dimension , get_file_globalatts, get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, & output_lsm, output_GW_Diag - use module_HYDRO_io, only : output_lakes2 - use module_rt_data, only: rt_domain - use module_GW_baseflow - use module_gw_gw2d - use module_gw_gw2d_data, only: gw2d - use module_channel_routing, only: drive_channel, drive_channel_rsl - use orchestrator_base - use config_base, only: nlst, noah_lsm - use module_routing, only: getChanDim, landrt_ini - use module_HYDRO_utils - use module_lsm_forcing, only: geth_newdate + use module_HYDRO_io, only : output_lakes2 + use module_rt_data, only: rt_domain + use module_GW_baseflow + use module_gw_gw2d + use module_gw_gw2d_data, only: gw2d + use module_channel_routing, only: drive_channel, drive_channel_rsl + use orchestrator_base + use config_base, only: nlst, noah_lsm + use module_routing, only: getChanDim, landrt_ini + use module_HYDRO_utils + use module_lsm_forcing, only: geth_newdate #ifdef WRF_HYDRO_NUDGING - use module_stream_nudging, only: init_stream_nudging + use module_stream_nudging, only: init_stream_nudging #endif - use module_hydro_stop, only: HYDRO_stop - use module_UDMAP, only: get_basn_area_nhd - use netcdf + use module_hydro_stop, only: HYDRO_stop + use module_UDMAP, only: get_basn_area_nhd + use netcdf - implicit none + implicit none #ifdef HYDRO_D - real :: timeOr = 0 - real :: timeSr = 0 - real :: timeCr = 0 - real :: timeGW = 0 - integer :: clock_count_1 = 0 - integer :: clock_count_2 = 0 - integer :: clock_rate = 0 -#endif - integer :: rtout_factor = 0 - - integer, parameter :: r4 = selected_real_kind(4) - real, parameter :: zeroFlt=0.0000000000000000000_r4 - integer, parameter :: r8 = selected_real_kind(8) - real*8, parameter :: zeroDbl=0.0000000000000000000_r8 - - contains - subroutine HYDRO_rst_out(did) + real :: timeOr = 0 + real :: timeSr = 0 + real :: timeCr = 0 + real :: timeGW = 0 + integer :: clock_count_1 = 0 + integer :: clock_count_2 = 0 + integer :: clock_rate = 0 +#endif + integer :: rtout_factor = 0 + + integer, parameter :: r4 = selected_real_kind(4) + real, parameter :: zeroFlt=0.0000000000000000000_r4 + integer, parameter :: r8 = selected_real_kind(8) + real*8, parameter :: zeroDbl=0.0000000000000000000_r8 + +contains + subroutine HYDRO_rst_out(did) #ifdef WRF_HYDRO_NUDGING - use module_stream_nudging, only: output_nudging_last_obs + use module_stream_nudging, only: output_nudging_last_obs #endif - implicit none - integer:: rst_out - integer did, outflag - character(len=19) out_date + implicit none + integer:: rst_out + integer did, outflag + character(len=19) out_date #ifdef MPP_LAND - character(len=19) str_tmp + character(len=19) str_tmp #endif - rst_out = -99 + rst_out = -99 #ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if(nlst(did)%dt .gt. nlst(did)%rst_dt*60) then - call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%dt*rt_domain(did)%rst_counts)) - else - call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%rst_dt*60*rt_domain(did)%rst_counts)) - endif - if ( (nlst(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst(did)%olddate(1:19)) ) then - rst_out = 99 - rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 - endif + if(IO_id .eq. my_id) then +#endif + if(nlst(did)%dt .gt. nlst(did)%rst_dt*60) then + call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%dt*rt_domain(did)%rst_counts)) + else + call geth_newdate(out_date, nlst(did)%startdate, nint(nlst(did)%rst_dt*60*rt_domain(did)%rst_counts)) + endif + if ( (nlst(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst(did)%olddate(1:19)) ) then + rst_out = 99 + rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 + endif ! restart every month automatically. - if ( (nlst(did)%olddate(9:10) == "01") .and. (nlst(did)%olddate(12:13) == "00") .and. & - (nlst(did)%olddate(15:16) == "00").and. (nlst(did)%olddate(18:19) == "00") .and. & - (nlst(did)%rst_dt .le. 0) ) then - if(nlst(did)%startdate(1:16) .ne. nlst(did)%olddate(1:16) ) then - rst_out = 99 - endif - endif + if ( (nlst(did)%olddate(9:10) == "01") .and. (nlst(did)%olddate(12:13) == "00") .and. & + (nlst(did)%olddate(15:16) == "00").and. (nlst(did)%olddate(18:19) == "00") .and. & + (nlst(did)%rst_dt .le. 0) ) then + if(nlst(did)%startdate(1:16) .ne. nlst(did)%olddate(1:16) ) then + rst_out = 99 + endif + endif #ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rst_out) + endif + call mpp_land_bcast_int1(rst_out) #endif - if(rst_out .gt. 0) then - write(6,*) "yw check output restart at ",nlst(did)%olddate(1:16) + if(rst_out .gt. 0) then + write(6,*) "yw check output restart at ",nlst(did)%olddate(1:16) #ifdef MPP_LAND - if(nlst(did)%rst_bi_out .eq. 1) then - if(my_id .lt. 10) then - write(str_tmp,'(I1)') my_id - else if(my_id .lt. 100) then - write(str_tmp,'(I2)') my_id - else if(my_id .lt. 1000) then - write(str_tmp,'(I3)') my_id - else if(my_id .lt. 10000) then - write(str_tmp,'(I4)') my_id - else if(my_id .lt. 100000) then - write(str_tmp,'(I5)') my_id - else - continue - endif - call mpp_land_bcast_char(16,nlst(did)%olddate(1:16)) - call RESTART_OUT_bi(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst(did)%hgrid)//"."//trim(str_tmp)), did) - else -#endif - call RESTART_OUT_nc(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst(did)%hgrid)), did) + if(nlst(did)%rst_bi_out .eq. 1) then + if(my_id .lt. 10) then + write(str_tmp,'(I1)') my_id + else if(my_id .lt. 100) then + write(str_tmp,'(I2)') my_id + else if(my_id .lt. 1000) then + write(str_tmp,'(I3)') my_id + else if(my_id .lt. 10000) then + write(str_tmp,'(I4)') my_id + else if(my_id .lt. 100000) then + write(str_tmp,'(I5)') my_id + else + continue + endif + call mpp_land_bcast_char(16,nlst(did)%olddate(1:16)) + call RESTART_OUT_bi(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst(did)%hgrid)//"."//trim(str_tmp)), did) + else +#endif + call RESTART_OUT_nc(trim("HYDRO_RST."//nlst(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst(did)%hgrid)), did) #ifdef MPP_LAND - endif + endif #endif #ifdef WRF_HYDRO_NUDGING - call output_nudging_last_obs + call output_nudging_last_obs #endif - endif + endif - end subroutine HYDRO_rst_out + end subroutine HYDRO_rst_out subroutine HYDRO_out(did, rstflag) @@ -154,11 +134,11 @@ subroutine HYDRO_out(did, rstflag) real, dimension(RT_DOMAIN(did)%NLINKS,2) :: str_out real, dimension(RT_DOMAIN(did)%NLINKS) :: vel_out - ! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & - ! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & - ! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & - ! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & - ! qfx_tmp, prcp_out_tmp, etpndx_tmp +! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & +! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & +! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & +! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & +! qfx_tmp, prcp_out_tmp, etpndx_tmp outflag = -99 @@ -209,13 +189,13 @@ subroutine HYDRO_out(did, rstflag) kt = rt_domain(did)%his_out_counts endif - ! jump the ouput for the initial time when it has restart file from routing. +! jump the ouput for the initial time when it has restart file from routing. rtflag = -99 iniflag = -99 #ifdef MPP_LAND if(IO_id .eq. my_id) then #endif - ! if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then +! if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then !#ifndef NCEP_WCOSS ! print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) !#else @@ -223,7 +203,7 @@ subroutine HYDRO_out(did, rstflag) !#endif if ( nlst(did)%startdate(1:19) == nlst(did)%olddate(1:19) ) iniflag = 1 if ( (trim(nlst(did)%restart_file) /= "") .and. ( nlst(did)%startdate(1:19) == nlst(did)%olddate(1:19) ) ) rtflag = 1 - ! endif +! endif #ifdef MPP_LAND endif call mpp_land_bcast_int1(rtflag) @@ -231,7 +211,7 @@ subroutine HYDRO_out(did, rstflag) #endif - !yw keep the initial time otuput for debug +!yw keep the initial time otuput for debug if(rtflag == 1) then rt_domain(did)%restQSTRM = .false. !!! do not reset QSTRM.. at initial time. if(nlst(did)%t0OutputFlag .eq. 0) return @@ -241,35 +221,35 @@ subroutine HYDRO_out(did, rstflag) if(nlst(did)%t0OutputFlag .eq. 0) return endif - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if(nlst(did)%LSMOUT_DOMAIN .eq. 1) then - if(nlst(did)%io_form_outputs .eq. 0) then - call output_lsm(trim(nlst(did)%olddate(1:4)//nlst(did)%olddate(6:7)//nlst(did)%olddate(9:10) & - //nlst(did)%olddate(12:13)//nlst(did)%olddate(15:16)// & - ".LSMOUT_DOMAIN"//trim(nlst(did)%hgrid)), & - did) - else - call output_lsmOut_NWM(did) + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(nlst(did)%LSMOUT_DOMAIN .eq. 1) then + if(nlst(did)%io_form_outputs .eq. 0) then + call output_lsm(trim(nlst(did)%olddate(1:4)//nlst(did)%olddate(6:7)//nlst(did)%olddate(9:10) & + //nlst(did)%olddate(12:13)//nlst(did)%olddate(15:16)// & + ".LSMOUT_DOMAIN"//trim(nlst(did)%hgrid)), & + did) + else + call output_lsmOut_NWM(did) + endif endif - endif - end if + end if if(nlst(did)%SUBRTSWCRT .gt. 0 .or. & - nlst(did)%OVRTSWCRT .gt. 0 .or. & - nlst(did)%GWBASESWCRT .gt. 0 .or. & - nlst(did)%CHANRTSWCRT .gt. 0 .or. & - nlst(did)%channel_only .gt. 0 .or. & - nlst(did)%channelBucket_only .gt. 0 ) then + nlst(did)%OVRTSWCRT .gt. 0 .or. & + nlst(did)%GWBASESWCRT .gt. 0 .or. & + nlst(did)%CHANRTSWCRT .gt. 0 .or. & + nlst(did)%channel_only .gt. 0 .or. & + nlst(did)%channelBucket_only .gt. 0 ) then if(nlst(did)%RTOUT_DOMAIN .eq. 1 .and. & - nlst(did)%channel_only .eq. 0 .and. & - nlst(did)%channelBucket_only .eq. 0 ) then + nlst(did)%channel_only .eq. 0 .and. & + nlst(did)%channelBucket_only .eq. 0 ) then if(mod(rtout_factor,3) .eq. 2 .or. & - nlst(did)%io_config_outputs .ne. 5 .and. & - nlst(did)%io_config_outputs .ne. 3) then - ! Output gridded routing variables on National Water Model - ! high-res routing grid + nlst(did)%io_config_outputs .ne. 5 .and. & + nlst(did)%io_config_outputs .ne. 3) then +! Output gridded routing variables on National Water Model +! high-res routing grid if(nlst(did)%io_form_outputs .ne. 0) then call output_rt_NWM(did,nlst(did)%igrid) else @@ -277,8 +257,8 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%igrid, nlst(did)%split_output_count, & RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & nlst(did)%nsoil, & - ! nlst_rt(did)%startdate, nlst_rt(did)%olddate, - ! rt_domain(did)%subsurface%state%qsubrt,& +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, +! rt_domain(did)%subsurface%state%qsubrt,& nlst(did)%sincedate, nlst(did)%olddate, rt_domain(did)%subsurface%state%qsubrt,& rt_domain(did)%subsurface%properties%zwattablrt,RT_DOMAIN(did)%subsurface%grid_transform%smcrt,& RT_DOMAIN(did)%SUB_RESID, & @@ -295,8 +275,8 @@ subroutine HYDRO_out(did, rstflag) endif ! End check for rtout_factor rtout_factor = rtout_factor + 1 endif - !! JLM disable GW output for NWM. Bring this line back when runtime output options avail. - !! JLM This seems like a more logical place? +!! JLM disable GW output for NWM. Bring this line back when runtime output options avail. +!! JLM This seems like a more logical place? if(nlst(did)%io_form_outputs .ne. 0) then if(nlst(did)%GWBASESWCRT .ne. 0) then if(nlst(did)%channel_only .eq. 0) then @@ -321,7 +301,7 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%igrid, nlst(did)%split_output_count, & RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & nlst(did)%nsoil, & - ! nlst(did)%startdate, nlst(did)%olddate, & +! nlst(did)%startdate, nlst(did)%olddate, & nlst(did)%sincedate, nlst(did)%olddate, & gw2d(did)%h, rt_domain(did)%subsurface%grid_transform%smcrt, & gw2d(did)%convgw, gw2d(did)%excess, & @@ -332,7 +312,7 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%output_gw) endif - ! BF end gw2d output section +! BF end gw2d output section #ifdef HYDRO_D #ifndef NCEP_WCOSS @@ -345,7 +325,7 @@ subroutine HYDRO_out(did, rstflag) if (nlst(did)%CHANRTSWCRT.eq.1.or.nlst(did)%CHANRTSWCRT.eq.2) then - !ADCHANGE: Change values for within lake reaches to NA +!ADCHANGE: Change values for within lake reaches to NA str_out = RT_DOMAIN(did)%QLINK vel_out = RT_DOMAIN(did)%velocity @@ -357,51 +337,51 @@ subroutine HYDRO_out(did, rstflag) endif end do endif - !ADCHANGE: End +!ADCHANGE: End if(nlst(did)%io_form_outputs .ne. 0) then - ! Call National Water Model output routine for output on NHD forecast points. +! Call National Water Model output routine for output on NHD forecast points. if(nlst(did)%CHRTOUT_DOMAIN .ne. 0) then call output_chrt_NWM(did) endif - ! Call the subroutine to output frxstPts. +! Call the subroutine to output frxstPts. if(nlst(did)%frxst_pts_out .ne. 0) then call output_frxstPts(did) endif - ! Call the subroutine to output CHANOBS +! Call the subroutine to output CHANOBS if(nlst(did)%CHANOBS_DOMAIN .ne. 0) then call output_chanObs_NWM(did) endif else - ! Call traditional output routines - !ADCHANGE: We suspect this routine is broken so default is now output_chrtout2 - ! if(nlst_rt(did)%CHRTOUT_DOMAIN .eq. 1) then - !#ifdef MPP_LAND - ! call mpp_output_chrt( & - ! rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, & - !#else - ! call output_chrt( & - !#endif - ! nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - ! RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & - ! nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& - ! RT_DOMAIN(did)%CHLAT, & - ! RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & - ! !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & - ! str_out, nlst_rt(did)%DT,Kt, & - ! RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write, & - ! RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option, & - ! rt_domain(did)%gages, rt_domain(did)%gageMiss, & - ! nlst_rt(did)%dt & - !#ifdef WRF_HYDRO_NUDGING - ! , RT_DOMAIN(did)%nudge & - !#endif - ! , RT_DOMAIN(did)%accSfcLatRunoff, RT_DOMAIN(did)%accBucket & - ! , RT_DOMAIN(did)%qSfcLatRunoff, RT_DOMAIN(did)%qBucket & - ! , RT_DOMAIN(did)%qin_gwsubbas & - ! , nlst_rt(did)%UDMP_OPT & - ! ) - ! else +! Call traditional output routines +!ADCHANGE: We suspect this routine is broken so default is now output_chrtout2 +! if(nlst_rt(did)%CHRTOUT_DOMAIN .eq. 1) then +!#ifdef MPP_LAND +! call mpp_output_chrt( & +! rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, & +!#else +! call output_chrt( & +!#endif +! nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & +! RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & +! nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& +! RT_DOMAIN(did)%CHLAT, & +! RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & +! !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & +! str_out, nlst_rt(did)%DT,Kt, & +! RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write, & +! RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option, & +! rt_domain(did)%gages, rt_domain(did)%gageMiss, & +! nlst_rt(did)%dt & +!#ifdef WRF_HYDRO_NUDGING +! , RT_DOMAIN(did)%nudge & +!#endif +! , RT_DOMAIN(did)%accSfcLatRunoff, RT_DOMAIN(did)%accBucket & +! , RT_DOMAIN(did)%qSfcLatRunoff, RT_DOMAIN(did)%qBucket & +! , RT_DOMAIN(did)%qin_gwsubbas & +! , nlst_rt(did)%UDMP_OPT & +! ) +! else if(nlst(did)%CHRTOUT_DOMAIN .gt. 0) then #ifdef MPP_LAND call mpp_output_chrt2(& @@ -414,15 +394,15 @@ subroutine HYDRO_out(did, rstflag) nlst(did)%sincedate,nlst(did)%olddate, & RT_DOMAIN(did)%CHLON, RT_DOMAIN(did)%CHLAT, & RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & - !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & +!RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & str_out, nlst(did)%DT,Kt, & RT_DOMAIN(did)%NLINKSL,nlst(did)%channel_option, & rt_domain(did)%linkid & #ifdef WRF_HYDRO_NUDGING , RT_DOMAIN(did)%nudge & #endif - !, RT_DOMAIN(did)%QLateral, nlst_rt(did)%io_config_outputs, - !RT_DOMAIN(did)%velocity & +!, RT_DOMAIN(did)%QLateral, nlst_rt(did)%io_config_outputs, +!RT_DOMAIN(did)%velocity & , RT_DOMAIN(did)%QLateral, nlst(did)%io_config_outputs, vel_out & , RT_DOMAIN(did)%accSfcLatRunoff, RT_DOMAIN(did)%accBucket & , RT_DOMAIN(did)%qSfcLatRunoff, RT_DOMAIN(did)%qBucket & @@ -440,7 +420,7 @@ subroutine HYDRO_out(did, rstflag) RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & RT_DOMAIN(did)%GCH_NETLNK, & nlst(did)%startdate, nlst(did)%olddate, & - !RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & +!RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & str_out, nlst(did)%dt, nlst(did)%geo_finegrid_flnm, & RT_DOMAIN(did)%gnlinks,RT_DOMAIN(did)%map_l2g, & RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) @@ -451,7 +431,7 @@ subroutine HYDRO_out(did, rstflag) endif if (RT_DOMAIN(did)%NLAKES.gt.0) then if(nlst(did)%io_form_outputs .ne. 0) then - ! Output lakes in NWM format +! Output lakes in NWM format if(nlst(did)%outlake .ne. 0) then call output_lakes_NWM(did,nlst(did)%igrid) endif @@ -501,83 +481,83 @@ subroutine HYDRO_out(did, rstflag) end subroutine HYDRO_out - subroutine HYDRO_rst_in(did) + subroutine HYDRO_rst_in(did) integer :: did integer:: flag - flag = -1 + flag = -1 #ifdef MPP_LAND - if(my_id.eq.IO_id) then + if(my_id.eq.IO_id) then #endif - if (trim(nlst(did)%restart_file) /= "") then - flag = 99 - rt_domain(did)%timestep_flag = 99 ! continue run - endif + if (trim(nlst(did)%restart_file) /= "") then + flag = 99 + rt_domain(did)%timestep_flag = 99 ! continue run + endif #ifdef MPP_LAND - endif - call mpp_land_bcast_int1(flag) + endif + call mpp_land_bcast_int1(flag) #endif - nlst(did)%sincedate = nlst(did)%startdate + nlst(did)%sincedate = nlst(did)%startdate - if (flag.eq.99) then + if (flag.eq.99) then #ifdef MPP_LAND - if(my_id.eq.IO_id) then + if(my_id.eq.IO_id) then #endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*** read restart data: ",trim(nlst(did)%restart_file) + write(6,*) "*** read restart data: ",trim(nlst(did)%restart_file) #else - write(78,*) "*** read restart data: ",trim(nlst(did)%restart_file) + write(78,*) "*** read restart data: ",trim(nlst(did)%restart_file) #endif #endif #ifdef MPP_LAND - endif + endif #endif #ifdef MPP_LAND - if(nlst(did)%rst_bi_in .eq. 1) then - call RESTART_IN_bi(trim(nlst(did)%restart_file), did) - else + if(nlst(did)%rst_bi_in .eq. 1) then + call RESTART_IN_bi(trim(nlst(did)%restart_file), did) + else #endif - call RESTART_IN_nc(trim(nlst(did)%restart_file), did) + call RESTART_IN_nc(trim(nlst(did)%restart_file), did) #ifdef MPP_LAND - endif + endif #endif !yw if (trim(nlst_rt(did)%restart_file) /= "") then !yw nlst_rt(did)%restart_file = "" !yw endif - endif - end subroutine HYDRO_rst_in + endif + end subroutine HYDRO_rst_in - subroutine HYDRO_time_adv(did) + subroutine HYDRO_time_adv(did) implicit none character(len = 19) :: newdate integer did #ifdef MPP_LAND - if(IO_id.eq.my_id) then + if(IO_id.eq.my_id) then #endif - call geth_newdate(newdate, nlst(did)%olddate, nint( nlst(did)%dt)) - nlst(did)%olddate = newdate + call geth_newdate(newdate, nlst(did)%olddate, nint( nlst(did)%dt)) + nlst(did)%olddate = newdate #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "current time is ",newdate + write(6,*) "current time is ",newdate #else - write(78,*) "current time is ",newdate + write(78,*) "current time is ",newdate #endif #endif #ifdef MPP_LAND - endif + endif #endif - end subroutine HYDRO_time_adv + end subroutine HYDRO_time_adv - subroutine HYDRO_exe(did) + subroutine HYDRO_exe(did) implicit none @@ -601,159 +581,159 @@ subroutine HYDRO_exe(did) ! endif -if (nlst(did)%GWBASESWCRT .ne. 0 .or. & - nlst(did)%SUBRTSWCRT .ne. 0 .or. & - nlst(did)%OVRTSWCRT .ne. 0 .or. & - nlst(did)%channel_only .ne. 0 .or. & - nlst(did)%channelBucket_only .ne. 0 ) then + if (nlst(did)%GWBASESWCRT .ne. 0 .or. & + nlst(did)%SUBRTSWCRT .ne. 0 .or. & + nlst(did)%OVRTSWCRT .ne. 0 .or. & + nlst(did)%channel_only .ne. 0 .or. & + nlst(did)%channelBucket_only .ne. 0 ) then - ! step 1) disaggregate specific fields from LSM to Hydro grid - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then +! step 1) disaggregate specific fields from LSM to Hydro grid + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - RT_DOMAIN(did)%overland%streams_and_lakes%surface_water_to_channel = zeroFlt - RT_DOMAIN(did)%LAKE_INFLORT_DUM = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake + RT_DOMAIN(did)%overland%streams_and_lakes%surface_water_to_channel = zeroFlt + RT_DOMAIN(did)%LAKE_INFLORT_DUM = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake - if(nlst(did)%SUBRTSWCRT .ne. 0 .or. nlst(did)%OVRTSWCRT .ne. 0) then - call disaggregateDomain_drv(did) - endif - if(nlst(did)%OVRTSWCRT .eq. 0) then - if(nlst(did)%UDMP_OPT .eq. 1) then - call RunOffDisag(RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%landRunOff, & - rt_domain(did)%dist_lsm(:,:,9),rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), & - RT_DOMAIN(did)%INFXSWGT, nlst(did)%AGGFACTRT, RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) - endif - endif + if(nlst(did)%SUBRTSWCRT .ne. 0 .or. nlst(did)%OVRTSWCRT .ne. 0) then + call disaggregateDomain_drv(did) + endif + if(nlst(did)%OVRTSWCRT .eq. 0) then + if(nlst(did)%UDMP_OPT .eq. 1) then + call RunOffDisag(RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%landRunOff, & + rt_domain(did)%dist_lsm(:,:,9),rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), & + RT_DOMAIN(did)%INFXSWGT, nlst(did)%AGGFACTRT, RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) + endif + endif #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) + call system_clock(count=clock_count_1, count_rate=clock_rate) #endif - endif !! channel_only & channelBucket_only == 0 + endif !! channel_only & channelBucket_only == 0 - ! step 2) - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if(nlst(did)%SUBRTSWCRT .ne.0) then - call SubsurfaceRouting_drv(did) - endif +! step 2) + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(nlst(did)%SUBRTSWCRT .ne.0) then + call SubsurfaceRouting_drv(did) + endif #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeSr = timeSr + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeSr = timeSr + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: Subsurface Routing accumulated time--", timeSr + write(6,*) "Timing: Subsurface Routing accumulated time--", timeSr #else - write(78,*) "Timing: Subsurface Routing accumulated time--", timeSr + write(78,*) "Timing: Subsurface Routing accumulated time--", timeSr #endif #endif - end if !! channel_only & channelBucket_only == 0 + end if !! channel_only & channelBucket_only == 0 - ! step 3) todo split - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then +! step 3) todo split + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) -#endif - if(nlst(did)%OVRTSWCRT .ne. 0) then - call OverlandRouting_drv(did) - else - !ADCHANGE: Updating landRunoff instead of surface_water_head_routing. This now allows - ! landRunoff to include both infxsrt from the LSM and exfiltration (if subsfc - ! is active) and prevents surface_water_head_routing from inadvertently being - ! passed back to the LSM. - if (nlst(did)%UDMP_OPT .eq. 1) then - ! If subsurface is on, we update landRunOff to include the updated term w/ exfiltration. - ! If subsurface is off, landRunOff does not change from original value so we leave as-is. - if (nlst(did)%SUBRTSWCRT .ne. 0) then - rt_domain(did)%landRunOff = rt_domain(did)%overland%control%infiltration_excess - endif - else - ! If overland is off and subsurface is on, we need to update INFXSRT (LSM grid) - ! since that is what gets fed through the buckets into the channels. So we aggregate - ! the high-res infiltration_excess back to coarse grid. - if (nlst(did)%SUBRTSWCRT .ne. 0) then - call RunoffAggregate(rt_domain(did)%overland%control%infiltration_excess, & - rt_domain(did)%INFXSRT, nlst(did)%AGGFACTRT, & - rt_domain(did)%ix, rt_domain(did)%jx) - endif - endif - ! In either case, if overland is off we need to zero-out surface_water_head since this - ! water is being scraped into channel and should NOT be passed back to the LSM. - rt_domain(did)%overland%control%infiltration_excess = 0. - rt_domain(did)%overland%control%surface_water_head_routing = 0. - endif + call system_clock(count=clock_count_1, count_rate=clock_rate) +#endif + if(nlst(did)%OVRTSWCRT .ne. 0) then + call OverlandRouting_drv(did) + else +!ADCHANGE: Updating landRunoff instead of surface_water_head_routing. This now allows +! landRunoff to include both infxsrt from the LSM and exfiltration (if subsfc +! is active) and prevents surface_water_head_routing from inadvertently being +! passed back to the LSM. + if (nlst(did)%UDMP_OPT .eq. 1) then +! If subsurface is on, we update landRunOff to include the updated term w/ exfiltration. +! If subsurface is off, landRunOff does not change from original value so we leave as-is. + if (nlst(did)%SUBRTSWCRT .ne. 0) then + rt_domain(did)%landRunOff = rt_domain(did)%overland%control%infiltration_excess + endif + else +! If overland is off and subsurface is on, we need to update INFXSRT (LSM grid) +! since that is what gets fed through the buckets into the channels. So we aggregate +! the high-res infiltration_excess back to coarse grid. + if (nlst(did)%SUBRTSWCRT .ne. 0) then + call RunoffAggregate(rt_domain(did)%overland%control%infiltration_excess, & + rt_domain(did)%INFXSRT, nlst(did)%AGGFACTRT, & + rt_domain(did)%ix, rt_domain(did)%jx) + endif + endif +! In either case, if overland is off we need to zero-out surface_water_head since this +! water is being scraped into channel and should NOT be passed back to the LSM. + rt_domain(did)%overland%control%infiltration_excess = 0. + rt_domain(did)%overland%control%surface_water_head_routing = 0. + endif #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeOr = timeOr + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeOr = timeOr + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: Overland Routing accumulated time--", timeOr + write(6,*) "Timing: Overland Routing accumulated time--", timeOr #else - write(78,*) "Timing: Overland Routing accumulated time--", timeOr + write(78,*) "Timing: Overland Routing accumulated time--", timeOr #endif #endif - RT_DOMAIN(did)%QSTRMVOLRT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_channel - RT_DOMAIN(did)%QSTRMVOLRT_ACC = RT_DOMAIN(did)%QSTRMVOLRT_ACC + RT_DOMAIN(did)%QSTRMVOLRT_TS + RT_DOMAIN(did)%QSTRMVOLRT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_channel + RT_DOMAIN(did)%QSTRMVOLRT_ACC = RT_DOMAIN(did)%QSTRMVOLRT_ACC + RT_DOMAIN(did)%QSTRMVOLRT_TS - RT_DOMAIN(did)%LAKE_INFLORT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake-RT_DOMAIN(did)%LAKE_INFLORT_DUM + RT_DOMAIN(did)%LAKE_INFLORT_TS = rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake-RT_DOMAIN(did)%LAKE_INFLORT_DUM #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) + call system_clock(count=clock_count_1, count_rate=clock_rate) #endif - end if !! channel_only & channelBucket_only == 0 + end if !! channel_only & channelBucket_only == 0 - ! step 4) baseflow or groundwater physics - !! channelBucket_only can be anything: the only time you dont run this is if channel_only=1 - if(nlst(did)%channel_only .eq. 0) then - if (nlst(did)%GWBASESWCRT .gt. 0) then - call driveGwBaseflow(did) - endif +! step 4) baseflow or groundwater physics +!! channelBucket_only can be anything: the only time you dont run this is if channel_only=1 + if(nlst(did)%channel_only .eq. 0) then + if (nlst(did)%GWBASESWCRT .gt. 0) then + call driveGwBaseflow(did) + endif #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeGw = timeGw + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeGw = timeGw + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: GwBaseflow accumulated time--", timeGw + write(6,*) "Timing: GwBaseflow accumulated time--", timeGw #else - write(78,*) "Timing: GwBaseflow accumulated time--", timeGw + write(78,*) "Timing: GwBaseflow accumulated time--", timeGw #endif #endif #ifdef HYDRO_D - call system_clock(count=clock_count_1, count_rate=clock_rate) + call system_clock(count=clock_count_1, count_rate=clock_rate) #endif - end if !! channel_only == 0 + end if !! channel_only == 0 - ! step 5) river channel physics - call driveChannelRouting(did) +! step 5) river channel physics + call driveChannelRouting(did) #ifdef HYDRO_D - call system_clock(count=clock_count_2, count_rate=clock_rate) - timeCr = timeCr + float(clock_count_2-clock_count_1)/float(clock_rate) + call system_clock(count=clock_count_2, count_rate=clock_rate) + timeCr = timeCr + float(clock_count_2-clock_count_1)/float(clock_rate) #ifndef NCEP_WCOSS - write(6,*) "Timing: Channel Routing accumulated time--", timeCr + write(6,*) "Timing: Channel Routing accumulated time--", timeCr #else - write(78,*) "Timing: Channel Routing accumulated time--", timeCr + write(78,*) "Timing: Channel Routing accumulated time--", timeCr #endif #endif - !! if not channel_only - if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then +!! if not channel_only + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - ! step 6) aggregate specific fields from Hydro to LSM grid - if (nlst(did)%SUBRTSWCRT .ne.0 .or. nlst(did)%OVRTSWCRT .ne. 0 ) then - call aggregateDomain(did) - endif +! step 6) aggregate specific fields from Hydro to LSM grid + if (nlst(did)%SUBRTSWCRT .ne.0 .or. nlst(did)%OVRTSWCRT .ne. 0 ) then + call aggregateDomain(did) + endif - end if !! channel_only & channelBucket_only == 0 + end if !! channel_only & channelBucket_only == 0 -end if + end if !yw if (nlst_rt(did)%sys_cpl .eq. 2) then - ! advance to next time step +! advance to next time step ! call HYDRO_time_adv(did) - ! output for history +! output for history ! call HYDRO_out(did) !yw endif - call HYDRO_time_adv(did) - call HYDRO_out(did, 1) + call HYDRO_time_adv(did) + call HYDRO_out(did, 1) ! write(90 + my_id,*) "finish calling hydro_exe" @@ -762,292 +742,295 @@ subroutine HYDRO_exe(did) - !! Under channel-only, these variables are not allocated - if(allocated(RT_DOMAIN(did)%SOLDRAIN)) RT_DOMAIN(did)%SOLDRAIN = 0 - if(allocated(rt_domain(did)%subsurface%state%qsubrt)) RT_DOMAIN(did)%subsurface%state%qsubrt = 0 +!! Under channel-only, these variables are not allocated + if(allocated(RT_DOMAIN(did)%SOLDRAIN)) RT_DOMAIN(did)%SOLDRAIN = 0 + if(allocated(rt_domain(did)%subsurface%state%qsubrt)) RT_DOMAIN(did)%subsurface%state%qsubrt = 0 - end subroutine HYDRO_exe + end subroutine HYDRO_exe !---------------------------------------------------- -subroutine driveGwBaseflow(did) + subroutine driveGwBaseflow(did) - implicit none - integer, intent(in) :: did + implicit none + integer, intent(in) :: did - integer :: i, jj, ii + integer :: i, jj, ii - !------------------------------------------------------------------ - !DJG Begin GW/Baseflow Routines - !------------------------------------------------------------------- +!------------------------------------------------------------------ +!DJG Begin GW/Baseflow Routines +!------------------------------------------------------------------- - if (nlst(did)%GWBASESWCRT.ge.1) then ! Switch to activate/specify GW/Baseflow + if (nlst(did)%GWBASESWCRT.ge.1) then ! Switch to activate/specify GW/Baseflow - ! IF (nlst(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow +! IF (nlst(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow - if (nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.eq.2 .or. nlst(did)%GWBASESWCRT.ge.4) then ! Call simple bucket baseflow scheme + if (nlst(did)%GWBASESWCRT.eq.1 .or. nlst(did)%GWBASESWCRT.eq.2 .or. nlst(did)%GWBASESWCRT.ge.4) then ! Call simple bucket baseflow scheme #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****yw******start simp_gw_buck " + write(6,*) "*****yw******start simp_gw_buck " #else - write(78,*) "*****yw******start simp_gw_buck " -#endif -#endif - - if(nlst(did)%UDMP_OPT .eq. 1) then - call simp_gw_buck_nhd( & - RT_DOMAIN(did)%ix, RT_DOMAIN(did)%jx, & - RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & - RT_DOMAIN(did)%numbasns, nlst(did)%AGGFACTRT, & - nlst(did)%DT, RT_DOMAIN(did)%INFXSWGT, & - RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%SOLDRAIN, & - rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), rt_domain(did)%dist_lsm(:,:,9), & - RT_DOMAIN(did)%gw_buck_coeff, RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%gw_buck_loss, & - RT_DOMAIN(did)%z_max, RT_DOMAIN(did)%z_gwsubbas, & - RT_DOMAIN(did)%qout_gwsubbas, RT_DOMAIN(did)%qin_gwsubbas, & - RT_DOMAIN(did)%qloss_gwsubbas, & - nlst(did)%GWBASESWCRT, nlst(did)%OVRTSWCRT, & + write(78,*) "*****yw******start simp_gw_buck " +#endif +#endif + + if(nlst(did)%UDMP_OPT .eq. 1) then + call simp_gw_buck_nhd( & + RT_DOMAIN(did)%ix, RT_DOMAIN(did)%jx, & + RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & + RT_DOMAIN(did)%numbasns, nlst(did)%AGGFACTRT, & + nlst(did)%DT, RT_DOMAIN(did)%INFXSWGT, & + RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%SOLDRAIN, & + rt_domain(did)%overland%properties%distance_to_neighbor(:,:,9), rt_domain(did)%dist_lsm(:,:,9), & + RT_DOMAIN(did)%gw_buck_coeff, RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%gw_buck_loss, & + RT_DOMAIN(did)%z_max, RT_DOMAIN(did)%z_gwsubbas, & + RT_DOMAIN(did)%qout_gwsubbas, RT_DOMAIN(did)%qin_gwsubbas, & + RT_DOMAIN(did)%qloss_gwsubbas, & + nlst(did)%GWBASESWCRT, nlst(did)%OVRTSWCRT, & #ifdef MPP_LAND - RT_DOMAIN(did)%LNLINKSL, & + RT_DOMAIN(did)%LNLINKSL, & #else - RT_DOMAIN(did)%numbasns, & + RT_DOMAIN(did)%numbasns, & #endif - rt_domain(did)%basns_area, & - rt_domain(did)%nhdBuckMask, nlst(did)%bucket_loss, & - nlst(did)%channelBucket_only ) + rt_domain(did)%basns_area, & + rt_domain(did)%nhdBuckMask, nlst(did)%bucket_loss, & + nlst(did)%channelBucket_only ) - else - call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& - RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%gnumbasns,& - RT_DOMAIN(did)%basns_area,& - RT_DOMAIN(did)%basnsInd, RT_DOMAIN(did)%gw_strm_msk_lind, & - RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & - RT_DOMAIN(did)%SOLDRAIN, & - RT_DOMAIN(did)%z_gwsubbas,& - RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& - RT_DOMAIN(did)%qinflowbase,& - RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & - rt_domain(did)%overland%properties%distance_to_neighbor,nlst(did)%DT,& - RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%z_max,& - nlst(did)%GWBASESWCRT,nlst(did)%OVRTSWCRT) - endif + else + call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& + RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%gnumbasns,& + RT_DOMAIN(did)%basns_area,& + RT_DOMAIN(did)%basnsInd, RT_DOMAIN(did)%gw_strm_msk_lind, & + RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & + RT_DOMAIN(did)%SOLDRAIN, & + RT_DOMAIN(did)%z_gwsubbas,& + RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& + RT_DOMAIN(did)%qinflowbase,& + RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & + rt_domain(did)%overland%properties%distance_to_neighbor,nlst(did)%DT,& + RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%z_max,& + nlst(did)%GWBASESWCRT,nlst(did)%OVRTSWCRT) + endif - !! JLM: There's *perhaps* a better location for this output above. - !! If above is better, remove this when runtime output options are avail. - !#ifndef HYDRO_REALTIME - ! call output_GW_Diag(did) - !#endif +!! JLM: There's *perhaps* a better location for this output above. +!! If above is better, remove this when runtime output options are avail. +!#ifndef HYDRO_REALTIME +! call output_GW_Diag(did) +!#endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****yw******end simp_gw_buck " + write(6,*) "*****yw******end simp_gw_buck " #else - write(78,*) "*****yw******end simp_gw_buck " + write(78,*) "*****yw******end simp_gw_buck " #endif #endif - !!!For parameter setup runs output the percolation for each basin, - !!!otherwise comment out this output... - else if (nlst(did)%gwBaseSwCRT .eq. 3) then +!!!For parameter setup runs output the percolation for each basin, +!!!otherwise comment out this output... + else if (nlst(did)%gwBaseSwCRT .eq. 3) then #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****bf******start 2d_gw_model " + write(6,*) "*****bf******start 2d_gw_model " #else - write(78,*) "*****bf******start 2d_gw_model " + write(78,*) "*****bf******start 2d_gw_model " #endif #endif - ! compute qsgwrt between lsm and gw with namelist selected coupling method - ! qsgwrt is defined on the routing grid and needs to be aggregated for SFLX - if (nlst(did)%gwsoilcpl .GT. 0) THEN +! compute qsgwrt between lsm and gw with namelist selected coupling method +! qsgwrt is defined on the routing grid and needs to be aggregated for SFLX + if (nlst(did)%gwsoilcpl .GT. 0) THEN - call gwSoilFlux(did) + call gwSoilFlux(did) - end if + end if - gw2d(did)%excess = 0. + gw2d(did)%excess = 0. - call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & - gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & - gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & - gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & - gw2d(did)%excess, & - gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & - gw2d(did)%istep) + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & + gw2d(did)%excess, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + gw2d(did)%istep) - gw2d(did)%ho = gw2d(did)%h + gw2d(did)%ho = gw2d(did)%h - ! put surface exceeding groundwater to surface routing inflow - rt_domain(did)%overland%control%surface_water_head_routing = rt_domain(did)%overland%control%surface_water_head_routing & - + gw2d(did)%excess*1000. ! convert to mm +! put surface exceeding groundwater to surface routing inflow + rt_domain(did)%overland%control%surface_water_head_routing = rt_domain(did)%overland%control%surface_water_head_routing & + + gw2d(did)%excess*1000. ! convert to mm - ! aggregate qsgw from routing to lsm grid - call aggregateQsgw(did) +! aggregate qsgw from routing to lsm grid + call aggregateQsgw(did) - gw2d(did)%istep = gw2d(did)%istep + 1 + gw2d(did)%istep = gw2d(did)%istep + 1 #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****bf******end 2d_gw_model " + write(6,*) "*****bf******end 2d_gw_model " #else - write(78,*) "*****bf******end 2d_gw_model " + write(78,*) "*****bf******end 2d_gw_model " #endif #endif - end if + end if - end if !DJG (End if for RTE SWC activation) - !------------------------------------------------------------------ - !DJG End GW/Baseflow Routines - !------------------------------------------------------------------- -end subroutine driveGwBaseflow + end if !DJG (End if for RTE SWC activation) +!------------------------------------------------------------------ +!DJG End GW/Baseflow Routines +!------------------------------------------------------------------- + end subroutine driveGwBaseflow !------------------------------------------- - subroutine driveChannelRouting(did) + subroutine driveChannelRouting(did) - implicit none - integer, intent(in) :: did + implicit none + integer, intent(in) :: did !------------------------------------------------------------------- !------------------------------------------------------------------- !DJG,DNY Begin Channel and Lake Routing Routines !------------------------------------------------------------------- -if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT.eq.2) then - - if(nlst(did)%UDMP_OPT .eq. 1) then - !!! for user defined Reach based Routing method. - - call drive_CHANNEL_RSL(did, nlst(did)%UDMP_OPT,RT_DOMAIN(did)%timestep_flag, RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS, RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, & - RT_DOMAIN(did)%TYPEL, RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%CH_LNKRT, & - rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH, & - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%CHANLEN, RT_DOMAIN(did)%MannN, RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp,RT_DOMAIN(did)%Bw, & - RT_DOMAIN(did)%Tw, RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & - RT_DOMAIN(did)%ChannK,& - RT_DOMAIN(did)%RESHT, & - RT_DOMAIN(did)%CVOL, RT_DOMAIN(did)%QLAKEI, & - RT_DOMAIN(did)%QLAKEO, RT_DOMAIN(did)%LAKENODE, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & - RT_DOMAIN(did)%nlinks, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, RT_DOMAIN(did)%node_area, & - RT_DOMAIN(did)%qout_gwsubbas, & - RT_DOMAIN(did)%LAKEIDA, RT_DOMAIN(did)%LAKEIDM, RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%LAKEIDX & + if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT.eq.2) then + + if(nlst(did)%UDMP_OPT .eq. 1) then +!!! for user defined Reach based Routing method. + + call drive_CHANNEL_RSL(did, nlst(did)%UDMP_OPT,RT_DOMAIN(did)%timestep_flag, RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS, RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, & + RT_DOMAIN(did)%TYPEL, RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%CH_LNKRT, & + rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH, & + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%CHANLEN, RT_DOMAIN(did)%MannN, RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp,RT_DOMAIN(did)%Bw, & + RT_DOMAIN(did)%Tw, RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & + RT_DOMAIN(did)%ChannK,& + RT_DOMAIN(did)%RESHT, & + RT_DOMAIN(did)%CVOL, RT_DOMAIN(did)%QLAKEI, & + RT_DOMAIN(did)%QLAKEO, RT_DOMAIN(did)%LAKENODE, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & + RT_DOMAIN(did)%nlinks, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, RT_DOMAIN(did)%node_area, & + RT_DOMAIN(did)%qout_gwsubbas, & + RT_DOMAIN(did)%LAKEIDA, RT_DOMAIN(did)%LAKEIDM, RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%LAKEIDX & #ifdef MPP_LAND - , RT_DOMAIN(did)%nlinks_index, RT_DOMAIN(did)%mpp_nlinks, RT_DOMAIN(did)%yw_mpp_nlinks & - , RT_DOMAIN(did)%LNLINKSL & - , RT_DOMAIN(did)%gtoNode, RT_DOMAIN(did)%toNodeInd, RT_DOMAIN(did)%nToInd & + , RT_DOMAIN(did)%nlinks_index, RT_DOMAIN(did)%mpp_nlinks, RT_DOMAIN(did)%yw_mpp_nlinks & + , RT_DOMAIN(did)%LNLINKSL & + , RT_DOMAIN(did)%gtoNode, RT_DOMAIN(did)%toNodeInd, RT_DOMAIN(did)%nToInd & #endif - , RT_DOMAIN(did)%CH_LNKRT_SL, RT_DOMAIN(did)%landRunOff & + , RT_DOMAIN(did)%CH_LNKRT_SL, RT_DOMAIN(did)%landRunOff & #ifdef WRF_HYDRO_NUDGING - , RT_DOMAIN(did)%nudge & -#endif - , rt_domain(did)%accSfcLatRunoff, rt_domain(did)%accBucket & - , rt_domain(did)%qSfcLatRunoff, rt_domain(did)%qBucket & - , rt_domain(did)%QLateral, rt_domain(did)%velocity & - , rt_domain(did)%qloss & - , RT_DOMAIN(did)%HLINK & - , rt_domain(did)%nlinksize, nlst(did)%OVRTSWCRT & - , nlst(did)%SUBRTSWCRT & - , nlst(did)%channel_only , nlst(did)%channelBucket_only & - , nlst(did)%channel_bypass ) - -else - - call drive_CHANNEL(did, RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & - RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - nlst(did)%SUBRTSWCRT, rt_domain(did)%subsurface%state%qsubrt, & - RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& - RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& - RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& - RT_DOMAIN(did)%CH_NETLNK, rt_domain(did)%overland%streams_and_lakes%ch_netrt,RT_DOMAIN(did)%CH_LNKRT,& - rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH,& - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%QLateral, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& - RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & - RT_DOMAIN(did)%Bw,RT_DOMAIN(did)%Tw,RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & - RT_DOMAIN(did)%ChannK,& - RT_DOMAIN(did)%RESHT, & - RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & - RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& - RT_DOMAIN(did)%LAKENODE, rt_domain(did)%overland%properties%distance_to_neighbor, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & - RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & - RT_DOMAIN(did)%RETDEP_CHAN, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, & - RT_DOMAIN(did)%node_area & + , RT_DOMAIN(did)%nudge & +#endif + , rt_domain(did)%accSfcLatRunoff, rt_domain(did)%accBucket & + , rt_domain(did)%qSfcLatRunoff, rt_domain(did)%qBucket & + , rt_domain(did)%QLateral, rt_domain(did)%velocity & + , rt_domain(did)%qloss & + , RT_DOMAIN(did)%HLINK & + , rt_domain(did)%nlinksize, nlst(did)%OVRTSWCRT & + , nlst(did)%SUBRTSWCRT & + , nlst(did)%channel_only , nlst(did)%channelBucket_only & + , nlst(did)%channel_bypass ) + + else + + call drive_CHANNEL(did, RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & + RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + nlst(did)%SUBRTSWCRT, rt_domain(did)%subsurface%state%qsubrt, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& + RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& + RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& + RT_DOMAIN(did)%CH_NETLNK, rt_domain(did)%overland%streams_and_lakes%ch_netrt,RT_DOMAIN(did)%CH_LNKRT,& + rt_domain(did)%overland%streams_and_lakes%lake_mask, nlst(did)%DT, nlst(did)%DTCT, nlst(did)%DTRT_CH,& + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%QLateral, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& + RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & + RT_DOMAIN(did)%Bw,RT_DOMAIN(did)%Tw,RT_DOMAIN(did)%Tw_CC, RT_DOMAIN(did)%n_CC, & + RT_DOMAIN(did)%ChannK, & + RT_DOMAIN(did)%RESHT, & + RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH, & + RT_DOMAIN(did)%WEIRH, RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, & + RT_DOMAIN(did)%ORIFICEC, RT_DOMAIN(did)%ORIFICEA, RT_DOMAIN(did)%ORIFICEE, & + RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & + RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& + RT_DOMAIN(did)%LAKENODE, rt_domain(did)%overland%properties%distance_to_neighbor, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & + RT_DOMAIN(did)%CHANYJ, nlst(did)%channel_option, & + RT_DOMAIN(did)%RETDEP_CHAN, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, & + RT_DOMAIN(did)%node_area, RT_DOMAIN(did)%LAKEIDX & #ifdef MPP_LAND - ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& - RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & - RT_DOMAIN(did)%yw_mpp_nlinks & - , RT_DOMAIN(did)%LNLINKSL & - , rt_domain(did)%gtoNode,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd & -#endif - , rt_domain(did)%CH_LNKRT_SL & - ,nlst(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, & - nlst(did)%gwChanCondSw, nlst(did)%gwChanCondConstIn, & - nlst(did)%gwChanCondConstOut, rt_domain(did)%velocity, rt_domain(did)%qloss & - ) -endif + ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& + RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & + RT_DOMAIN(did)%yw_mpp_nlinks, & + RT_DOMAIN(did)%LNLINKSL, RT_DOMAIN(did)%LLINKID, & + rt_domain(did)%gtoNode, rt_domain(did)%toNodeInd,rt_domain(did)%nToInd & +#endif + , rt_domain(did)%CH_LNKRT_SL, & + nlst(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, & + nlst(did)%gwChanCondSw, nlst(did)%gwChanCondConstIn, & + nlst(did)%gwChanCondConstOut, rt_domain(did)%velocity, rt_domain(did)%qloss & + ) + endif - if((nlst(did)%gwBaseSwCRT == 3) .and. (nlst(did)%gwChanCondSw .eq. 1)) then + if((nlst(did)%gwBaseSwCRT == 3) .and. (nlst(did)%gwChanCondSw .eq. 1)) then - ! add/rm channel-aquifer exchange contribution +! add/rm channel-aquifer exchange contribution - gw2d(did)%ho = gw2d(did)%ho & - +(((gw2d(did)%qgw_chanrt*(-1)) * gw2d(did)%dt / gw2d(did)%dx**2) & - / gw2d(did)%poros) + gw2d(did)%ho = gw2d(did)%ho & + +(((gw2d(did)%qgw_chanrt*(-1)) * gw2d(did)%dt / gw2d(did)%dx**2) & + / gw2d(did)%poros) - endif - endif + endif + endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "*****yw******end drive_CHANNEL " + write(6,*) "*****yw******end drive_CHANNEL " #else - write(78,*) "*****yw******end drive_CHANNEL " + write(78,*) "*****yw******end drive_CHANNEL " #endif #endif - end subroutine driveChannelRouting + end subroutine driveChannelRouting !------------------------------------------------ - subroutine aggregateDomain(did) + subroutine aggregateDomain(did) #ifdef MPP_LAND use module_mpp_land, only: sum_real1, my_id, io_id, numprocs #endif - implicit none - integer, intent(in) :: did + implicit none + integer, intent(in) :: did - integer :: i, j, krt, ixxrt, jyyrt, & - AGGFACYRT, AGGFACXRT + integer :: i, j, krt, ixxrt, jyyrt, & + AGGFACYRT, AGGFACXRT #ifdef HYDRO_D ! ADCHANGE: Water balance variables - integer :: kk - real :: smcrttot1,smctot2,sicetot2 - real :: suminfxsrt1,suminfxs2 + integer :: kk + real :: smcrttot1,smctot2,sicetot2 + real :: suminfxsrt1,suminfxs2 #endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "Beginning Aggregation..." + print *, "Beginning Aggregation..." #else - write(78,*) "Beginning Aggregation..." + write(78,*) "Beginning Aggregation..." #endif #endif @@ -1057,14 +1040,14 @@ subroutine aggregateDomain(did) suminfxsrt1 = 0. smcrttot1 = 0. do i=1,RT_DOMAIN(did)%IXRT - do j=1,RT_DOMAIN(did)%JXRT - suminfxsrt1 = suminfxsrt1 + rt_domain(did)%overland%control%surface_water_head_routing(I,J) & - / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) - do kk=1,nlst(did)%NSOIL - smcrttot1 = smcrttot1 + rt_domain(did)%subsurface%grid_transform%smcrt(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & - / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + do j=1,RT_DOMAIN(did)%JXRT + suminfxsrt1 = suminfxsrt1 + rt_domain(did)%overland%control%surface_water_head_routing(I,J) & + / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + do kk=1,nlst(did)%NSOIL + smcrttot1 = smcrttot1 + rt_domain(did)%subsurface%grid_transform%smcrt(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & + / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT) + end do end do - end do end do #ifdef MPP_LAND ! not tested @@ -1077,26 +1060,26 @@ subroutine aggregateDomain(did) #endif do J=1,RT_DOMAIN(did)%JX - do I=1,RT_DOMAIN(did)%IX + do I=1,RT_DOMAIN(did)%IX - RT_DOMAIN(did)%SFCHEADAGGRT = 0. + RT_DOMAIN(did)%SFCHEADAGGRT = 0. !DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL=0. - do KRT=1,nlst(did)%NSOIL + RT_DOMAIN(did)%LSMVOL=0. + do KRT=1,nlst(did)%NSOIL ! SMCAGGRT(KRT) = 0. - RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. - end do + RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. + end do - do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 + do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 - IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT + IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT #ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 #else !yw ???? ! IXXRT=IXXRT+1 @@ -1104,144 +1087,144 @@ subroutine aggregateDomain(did) #endif !State Variables - RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & - + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) + RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & + + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) !DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & - + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & - * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) + RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & + + rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & + * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) - do KRT=1,nlst(did)%NSOIL + do KRT=1,nlst(did)%NSOIL !DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) - RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) - end do + RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) + end do - end do - end do + end do + end do - rt_domain(did)%overland%control%surface_water_head_lsm(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & - / (nlst(did)%AGGFACTRT**2) + rt_domain(did)%overland%control%surface_water_head_lsm(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & + / (nlst(did)%AGGFACTRT**2) - do KRT=1,nlst(did)%NSOIL + do KRT=1,nlst(did)%NSOIL !DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) - RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - / (nlst(did)%AGGFACTRT**2) - end do + RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + / (nlst(did)%AGGFACTRT**2) + end do !DJG Calculate subgrid weighting array... - do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 - IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT + do AGGFACYRT=nlst(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst(did)%AGGFACTRT-1,0,-1 + IXXRT=I*nlst(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst(did)%AGGFACTRT-AGGFACYRT #ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 #else !yw ??? ! IXXRT=IXXRT+1 ! JYYRT=JYYRT+1 #endif - if (RT_DOMAIN(did)%LSMVOL.gt.0.) then - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & - * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) & - / RT_DOMAIN(did)%LSMVOL - else - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = 1./FLOAT(nlst(did)%AGGFACTRT**2) - end if + if (RT_DOMAIN(did)%LSMVOL.gt.0.) then + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = rt_domain(did)%overland%control%surface_water_head_routing(IXXRT,JYYRT) & + * rt_domain(did)%overland%properties%distance_to_neighbor(IXXRT,JYYRT,9) & + / RT_DOMAIN(did)%LSMVOL + else + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = 1./FLOAT(nlst(did)%AGGFACTRT**2) + end if - do KRT=1,nlst(did)%NSOIL + do KRT=1,nlst(did)%NSOIL !!!yw added for debug - if(rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) .lt. 0) then + if(rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) .lt. 0) then #ifndef NCEP_WCOSS - print*, "Error negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print*, "Error negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #else - write(78,*) "WARNING: negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + write(78,*) "WARNING: negative SMCRT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif - endif - if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then + endif + if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then #ifndef NCEP_WCOSS - print *, "Error negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print *, "Error negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #else - write(78,*) "WARNING: negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + write(78,*) "WARNING: negative SH2OWGT", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif - endif + endif - IF ( (rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) - & - rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT)) .GT. 0.000001 ) THEN + IF ( (rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) - & + rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT)) .GT. 0.000001 ) THEN #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "SMCMAX exceeded upon aggregation...", & - rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & - rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) + print *, "SMCMAX exceeded upon aggregation...", & + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & + rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) #else - write(78,*) "FATAL ERROR: SMCMAX exceeded upon aggregation...", & - rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & - rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) + write(78,*) "FATAL ERROR: SMCMAX exceeded upon aggregation...", & + rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT), & + rt_domain(did)%subsurface%grid_transform%smcmaxrt(IXXRT,JYYRT,KRT) #endif #endif - call hydro_stop("In module_HYDRO_drv.F aggregateDomain() - "// & - "SMCMAX exceeded upon aggregation.") - END IF - IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LT.0.) THEN + call hydro_stop("In module_HYDRO_drv.F aggregateDomain() - "// & + "SMCMAX exceeded upon aggregation.") + END IF + IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LT.0.) THEN #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "Erroneous value of SH2O...", & - RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT - print *, "Error negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print *, "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + print *, "Error negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #else - write(78,*) "Erroneous value of SH2O...", & - RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT - write(78,*) "FATAL ERROR: negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + write(78,*) "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + write(78,*) "FATAL ERROR: negative SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif #endif - call hydro_stop("In module_HYDRO_drv.F aggregateDomain() "// & - "- Error negative SH2OX") - END IF + call hydro_stop("In module_HYDRO_drv.F aggregateDomain() "// & + "- Error negative SH2OX") + END IF - IF ( RT_DOMAIN(did)%SH2OX(I,J,KRT) .gt. 0 ) THEN - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & - = rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) & - / RT_DOMAIN(did)%SH2OX(I,J,KRT) - ELSE + IF ( RT_DOMAIN(did)%SH2OX(I,J,KRT) .gt. 0 ) THEN + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & + = rt_domain(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT) & + / RT_DOMAIN(did)%SH2OX(I,J,KRT) + ELSE #ifdef HYDRO_D - print *, "Error zero SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + print *, "Error zero SH2OX", rt_domain(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%subsurface%grid_transform%smcrt(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) #endif - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = 0.0 - ENDIF + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = 0.0 + ENDIF !?yw - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-05, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) - end do + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-05, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) + end do + end do end do - end do - end do + end do end do #ifdef MPP_LAND call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) do i = 1, nlst(did)%NSOIL - call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) end do #endif !DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... - RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE + RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE #ifdef HYDRO_D ! ADCHANGE: START Final water balance variables @@ -1250,16 +1233,16 @@ subroutine aggregateDomain(did) smctot2 = 0. sicetot2 = 0. do i=1,RT_DOMAIN(did)%IX - do j=1,RT_DOMAIN(did)%JX - suminfxs2 = suminfxs2 + rt_domain(did)%overland%control%surface_water_head_lsm(I,J) & - / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) - do kk=1,nlst(did)%NSOIL - smctot2 = smctot2 + rt_domain(did)%SMC(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & - / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) - sicetot2 = sicetot2 + rt_domain(did)%SICE(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & - / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + do j=1,RT_DOMAIN(did)%JX + suminfxs2 = suminfxs2 + rt_domain(did)%overland%control%surface_water_head_lsm(I,J) & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + do kk=1,nlst(did)%NSOIL + smctot2 = smctot2 + rt_domain(did)%SMC(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + sicetot2 = sicetot2 + rt_domain(did)%SICE(I,J,KK)*RT_DOMAIN(did)%subsurface%properties%sldpth(KK)*1000. & + / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX) + end do end do - end do end do #ifdef MPP_LAND @@ -1273,104 +1256,104 @@ subroutine aggregateDomain(did) #endif #ifdef MPP_LAND - if (my_id .eq. IO_id) then -#endif - print *, "Agg Mass Bal: " - print *, "WB_AGG!InfxsDiff", suminfxs2-suminfxsrt1 - print *, "WB_AGG!Infxs1", suminfxsrt1 - print *, "WB_AGG!Infxs2", suminfxs2 - print *, "WB_AGG!SMCDiff", smctot2-smcrttot1-sicetot2 - print *, "WB_AGG!SMC1", smcrttot1 - print *, "WB_AGG!SMC2", smctot2 - print *, "WB_AGG!SICE2", sicetot2 - print *, "WB_AGG!Residual", (suminfxs2-suminfxsrt1) + & - (smctot2-smcrttot1-sicetot2) + if (my_id .eq. IO_id) then +#endif + print *, "Agg Mass Bal: " + print *, "WB_AGG!InfxsDiff", suminfxs2-suminfxsrt1 + print *, "WB_AGG!Infxs1", suminfxsrt1 + print *, "WB_AGG!Infxs2", suminfxs2 + print *, "WB_AGG!SMCDiff", smctot2-smcrttot1-sicetot2 + print *, "WB_AGG!SMC1", smcrttot1 + print *, "WB_AGG!SMC2", smctot2 + print *, "WB_AGG!SICE2", sicetot2 + print *, "WB_AGG!Residual", (suminfxs2-suminfxsrt1) + & + (smctot2-smcrttot1-sicetot2) #ifdef MPP_LAND - endif + endif #endif ! END Final water balance variables #endif #ifdef HYDRO_D #ifndef NCEP_WCOSS - print *, "Finished Aggregation..." + print *, "Finished Aggregation..." #else - write(78,*) "Finished Aggregation..." + write(78,*) "Finished Aggregation..." #endif #endif - end subroutine aggregateDomain + end subroutine aggregateDomain - subroutine RunOffDisag(runoff1x_in, runoff1x, area_lsm,cellArea, infxswgt, AGGFACTRT, ix,jx) + subroutine RunOffDisag(runoff1x_in, runoff1x, area_lsm,cellArea, infxswgt, AGGFACTRT, ix,jx) implicit none real, dimension(:,:) :: runoff1x_in, runoff1x, area_lsm, cellArea, infxswgt integer :: i,j,ix,jx,AGGFACYRT, AGGFACXRT, AGGFACTRT, IXXRT, JYYRT do J=1,JX - do I=1,IX - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT + do I=1,IX + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT #ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 #endif !DJG Implement subgrid weighting routine... - if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then - runoff1x(IXXRT,JYYRT) = 0 - else - runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J) & - *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT) - endif - - enddo - enddo - enddo + if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then + runoff1x(IXXRT,JYYRT) = 0 + else + runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J) & + *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT) + endif + + enddo + enddo + enddo enddo - end subroutine RunOffDisag + end subroutine RunOffDisag ! This routine was extracted from the aggregateDomain routine above to do simple depth aggregation. ! There might be a simpler way. -subroutine RunoffAggregate(runoff_in, runoff_out, aggfactrt, ix, jx) - implicit none - ! Input variables - integer, intent(in) :: aggfactrt, ix, jx - real, intent(in), dimension(:,:) :: runoff_in - real, intent(inout), dimension(:,:) :: runoff_out - ! Local variables - integer :: i, j, aggfacyrt, aggfacxrt, ixxrt, jyyrt - real :: runoffagg - do j=1,jx - do i=1,ix - runoffagg = 0. - do aggfacyrt=aggfactrt-1,0,-1 - do aggfacxrt=aggfactrt-1,0,-1 - ixxrt = i * aggfactrt - aggfacxrt - jyyrt = j * aggfactrt - aggfacyrt + subroutine RunoffAggregate(runoff_in, runoff_out, aggfactrt, ix, jx) + implicit none +! Input variables + integer, intent(in) :: aggfactrt, ix, jx + real, intent(in), dimension(:,:) :: runoff_in + real, intent(inout), dimension(:,:) :: runoff_out +! Local variables + integer :: i, j, aggfacyrt, aggfacxrt, ixxrt, jyyrt + real :: runoffagg + do j=1,jx + do i=1,ix + runoffagg = 0. + do aggfacyrt=aggfactrt-1,0,-1 + do aggfacxrt=aggfactrt-1,0,-1 + ixxrt = i * aggfactrt - aggfacxrt + jyyrt = j * aggfactrt - aggfacyrt #ifdef MPP_LAND - if(left_id.ge.0) ixxrt = ixxrt+1 - if(down_id.ge.0) jyyrt = jyyrt+1 -#endif - runoffagg = runoffagg + runoff_in(ixxrt,jyyrt) - end do - end do - runoff_out(i,j) = runoffagg / (aggfactrt**2) - end do -end do -end subroutine RunoffAggregate - -subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) -implicit none -integer ntime, did -integer rst_out, ix,jx + if(left_id.ge.0) ixxrt = ixxrt+1 + if(down_id.ge.0) jyyrt = jyyrt+1 +#endif + runoffagg = runoffagg + runoff_in(ixxrt,jyyrt) + end do + end do + runoff_out(i,j) = runoffagg / (aggfactrt**2) + end do + end do + end subroutine RunoffAggregate + + subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) + implicit none + integer ntime, did + integer rst_out, ix,jx ! integer, OPTIONAL:: ix0,jx0 -integer:: ix0,jx0 -integer, dimension(ix0,jx0),optional :: vegtyp, soltyp -integer :: iret, ncid, ascIndId + integer:: ix0,jx0 + integer, dimension(ix0,jx0),optional :: vegtyp, soltyp + integer :: iret, ncid, ascIndId @@ -1379,120 +1362,120 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) !call read_rt_nlst(nlst(did) ) ! Some field of this structure are already initialized by the CPL component (e.g. DT) -call orchestrator%config%init_nlst(did) + call orchestrator%config%init_nlst(did) -if(nlst(did)%rtFlag .eq. 0) return + if(nlst(did)%rtFlag .eq. 0) return !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! get the dimension -call get_file_dimension(trim(nlst(did)%geo_static_flnm), ix,jx) + call get_file_dimension(trim(nlst(did)%geo_static_flnm), ix,jx) #ifdef MPP_LAND -if (nlst(did)%sys_cpl .eq. 1 .or. nlst(did)%sys_cpl .eq. 4) then - !sys_cpl: 1-- coupling with HRLDAS but running offline lsm; - ! 2-- coupling with WRF but do not run offline lsm - ! 3-- coupling with LIS and do not run offline lsm - ! 4: coupling with CLM + if (nlst(did)%sys_cpl .eq. 1 .or. nlst(did)%sys_cpl .eq. 4) then +!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; +! 2-- coupling with WRF but do not run offline lsm +! 3-- coupling with LIS and do not run offline lsm +! 4: coupling with CLM - ! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. - call log_map2d() +! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. + call log_map2d() - global_nx = ix ! get from land model - global_ny = jx ! get from land model + global_nx = ix ! get from land model + global_ny = jx ! get from land model - call mpp_land_bcast_int1(global_nx) - call mpp_land_bcast_int1(global_ny) + call mpp_land_bcast_int1(global_nx) + call mpp_land_bcast_int1(global_ny) !!! temp set global_nx to ix - rt_domain(did)%ix = global_nx - rt_domain(did)%jx = global_ny + rt_domain(did)%ix = global_nx + rt_domain(did)%jx = global_ny - ! over write the ix and jx - call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& - nlst(did)%AGGFACTRT) -else - ! coupled with WRF, LIS - numprocs = node_info(1,1) +! over write the ix and jx + call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& + nlst(did)%AGGFACTRT) + else +! coupled with WRF, LIS + numprocs = node_info(1,1) - call wrf_LAND_set_INIT(node_info,numprocs,nlst(did)%AGGFACTRT) + call wrf_LAND_set_INIT(node_info,numprocs,nlst(did)%AGGFACTRT) - rt_domain(did)%ix = local_nx - rt_domain(did)%jx = local_ny -endif + rt_domain(did)%ix = local_nx + rt_domain(did)%jx = local_ny + endif -rt_domain(did)%g_IXRT=global_rt_nx -rt_domain(did)%g_JXRT=global_rt_ny -rt_domain(did)%ixrt = local_rt_nx -rt_domain(did)%jxrt = local_rt_ny + rt_domain(did)%g_IXRT=global_rt_nx + rt_domain(did)%g_JXRT=global_rt_ny + rt_domain(did)%ixrt = local_rt_nx + rt_domain(did)%jxrt = local_rt_ny #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" -write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt -write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " -write(6,*) rt_domain(did)%ix, rt_domain(did)%jx -write(6,*) "global_nx, global_ny, local_nx, local_ny" -write(6,*) global_nx, global_ny, local_nx, local_ny + write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" + write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt + write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " + write(6,*) rt_domain(did)%ix, rt_domain(did)%jx + write(6,*) "global_nx, global_ny, local_nx, local_ny" + write(6,*) global_nx, global_ny, local_nx, local_ny #else -write(78,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" -write(78,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt -write(78,*) "rt_domain(did)%ix, rt_domain(did)%jx " -write(78,*) rt_domain(did)%ix, rt_domain(did)%jx -write(78,*) "global_nx, global_ny, local_nx, local_ny" -write(78,*) global_nx, global_ny, local_nx, local_ny + write(78,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" + write(78,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt + write(78,*) "rt_domain(did)%ix, rt_domain(did)%jx " + write(78,*) rt_domain(did)%ix, rt_domain(did)%jx + write(78,*) "global_nx, global_ny, local_nx, local_ny" + write(78,*) global_nx, global_ny, local_nx, local_ny #endif #endif #else ! sequential -rt_domain(did)%ix = ix -rt_domain(did)%jx = jx -rt_domain(did)%ixrt = ix*nlst(did)%AGGFACTRT -rt_domain(did)%jxrt = jx*nlst(did)%AGGFACTRT + rt_domain(did)%ix = ix + rt_domain(did)%jx = jx + rt_domain(did)%ixrt = ix*nlst(did)%AGGFACTRT + rt_domain(did)%jxrt = jx*nlst(did)%AGGFACTRT #endif ! allocate rt arrays -call getChanDim(did) + call getChanDim(did) #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "finish getChanDim " + write(6,*) "finish getChanDim " #else -write(78,*) "finish getChanDim " + write(78,*) "finish getChanDim " #endif #endif ! ADCHANGE: get global attributes ! need to set these after getChanDim since it allocates rt_domain vals to 0 - call get_file_globalatts(trim(nlst(did)%geo_static_flnm), & - rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater) + call get_file_globalatts(trim(nlst(did)%geo_static_flnm), & + rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "hydro_ini: rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater" - write(6,*) rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater + write(6,*) "hydro_ini: rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater" + write(6,*) rt_domain(did)%iswater, rt_domain(did)%islake, rt_domain(did)%isurban, rt_domain(did)%isoilwater #endif #endif -if(nlst(did)%GWBASESWCRT .eq. 3 ) then - call gw2d_allocate(did,& - rt_domain(did)%ixrt,& - rt_domain(did)%jxrt,& - nlst(did)%nsoil) + if(nlst(did)%GWBASESWCRT .eq. 3 ) then + call gw2d_allocate(did,& + rt_domain(did)%ixrt,& + rt_domain(did)%jxrt,& + nlst(did)%nsoil) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "finish gw2d_allocate" + write(6,*) "finish gw2d_allocate" #else - write(78,*) "finish gw2d_allocate" + write(78,*) "finish gw2d_allocate" #endif #endif -endif + endif ! calculate the distance between grids for routing. ! decompose the land parameter/data @@ -1500,104 +1483,104 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) ! ix0= rt_domain(did)%ix ! jx0= rt_domain(did)%jx -if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if(present(vegtyp)) then - call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) - else - call lsm_input(did,ix0=ix0,jx0=jx0) - endif -endif + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(present(vegtyp)) then + call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) + else + call lsm_input(did,ix0=ix0,jx0=jx0) + endif + endif #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "finish decomposion" + write(6,*) "finish decomposion" #else -write(78,*) "finish decomposion" -#endif -#endif - -if((nlst(did)%channel_only .eq. 1 .or. nlst(did)%channelBucket_only .eq. 1) .and. & - nlst(1)%io_form_outputs .ne. 0) then - !! This is the "decoder ring" for reading channel-only forcing from io_form_outputs=1,2 CHRTOUT files. - !! Only needed on io_id - if(my_id .eq. io_id) then - allocate(rt_domain(did)%ascendIndex(rt_domain(did)%gnlinksl)) - iret = nf90_open(trim(nlst(1)%route_link_f),NF90_NOWRITE,ncid=ncid) - !if(iret .ne. 0) call hdyro_stop - if(iret .ne. 0) call hydro_stop('ERROR: Unable to open RouteLink file for index extraction') - iret = nf90_inq_varid(ncid,'ascendingIndex',ascIndId) - if(iret .ne. 0) call hydro_stop('ERROR: Unable to find ascendingIndex from RouteLink file.') - iret = nf90_get_var(ncid,ascIndId,rt_domain(did)%ascendIndex) - if(iret .ne. 0) call hydro_stop('ERROR: Unable to extract ascendingIndex from RouteLink file.') - iret = nf90_close(ncid) - if(iret .ne. 0) call hydro_stop('ERROR: Unable to close RouteLink file.') - else - allocate(rt_domain(did)%ascendIndex(1)) - rt_domain(did)%ascendIndex(1)=-9 - endif -endif - - -call get_dist_lsm(did) !! always needed (channel_only and channelBucket_only) -if(nlst(did)%channel_only .ne. 1) call get_dist_lrt(did) !! needed forchannelBucket_only + write(78,*) "finish decomposion" +#endif +#endif + + if((nlst(did)%channel_only .eq. 1 .or. nlst(did)%channelBucket_only .eq. 1) .and. & + nlst(1)%io_form_outputs .ne. 0) then +!! This is the "decoder ring" for reading channel-only forcing from io_form_outputs=1,2 CHRTOUT files. +!! Only needed on io_id + if(my_id .eq. io_id) then + allocate(rt_domain(did)%ascendIndex(rt_domain(did)%gnlinksl)) + iret = nf90_open(trim(nlst(1)%route_link_f),NF90_NOWRITE,ncid=ncid) +!if(iret .ne. 0) call hdyro_stop + if(iret .ne. 0) call hydro_stop('ERROR: Unable to open RouteLink file for index extraction') + iret = nf90_inq_varid(ncid,'ascendingIndex',ascIndId) + if(iret .ne. 0) call hydro_stop('ERROR: Unable to find ascendingIndex from RouteLink file.') + iret = nf90_get_var(ncid,ascIndId,rt_domain(did)%ascendIndex) + if(iret .ne. 0) call hydro_stop('ERROR: Unable to extract ascendingIndex from RouteLink file.') + iret = nf90_close(ncid) + if(iret .ne. 0) call hydro_stop('ERROR: Unable to close RouteLink file.') + else + allocate(rt_domain(did)%ascendIndex(1)) + rt_domain(did)%ascendIndex(1)=-9 + endif + endif + + + call get_dist_lsm(did) !! always needed (channel_only and channelBucket_only) + if(nlst(did)%channel_only .ne. 1) call get_dist_lrt(did) !! needed forchannelBucket_only ! rt model initilization -call LandRT_ini(did) + call LandRT_ini(did) -if(nlst(did)%GWBASESWCRT .eq. 3 ) then + if(nlst(did)%GWBASESWCRT .eq. 3 ) then - call gw2d_ini(did,& - nlst(did)%dt,& - nlst(did)%dxrt0) + call gw2d_ini(did,& + nlst(did)%dt,& + nlst(did)%dxrt0) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) "finish gw2d_ini" + write(6,*) "finish gw2d_ini" #else - write(78,*) "finish gw2d_ini" + write(78,*) "finish gw2d_ini" #endif #endif -endif + endif #ifdef HYDRO_D #ifndef NCEP_WCOSS -write(6,*) "finish LandRT_ini" + write(6,*) "finish LandRT_ini" #else -write(78,*) "finish LandRT_ini" + write(78,*) "finish LandRT_ini" #endif #endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then + if(nlst(did)%channel_only .eq. 0 .and. nlst(did)%channelBucket_only .eq. 0) then - if (nlst(did)%TERADJ_SOLAR.eq.1 .and. nlst(did)%CHANRTSWCRT.ne.2) then ! Perform ter rain adjustment of incoming solar + if (nlst(did)%TERADJ_SOLAR.eq.1 .and. nlst(did)%CHANRTSWCRT.ne.2) then ! Perform ter rain adjustment of incoming solar #ifdef MPP_LAND - call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) + call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) #else - call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx) + call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx) #endif - endif -endif + endif + endif -if (nlst(did)%GWBASESWCRT .gt. 0) then - if(nlst(did)%UDMP_OPT .eq. 1) then - call get_basn_area_nhd(rt_domain(did)%basns_area) - else - call get_basn_area(did) - endif -endif + if (nlst(did)%GWBASESWCRT .gt. 0) then + if(nlst(did)%UDMP_OPT .eq. 1) then + call get_basn_area_nhd(rt_domain(did)%basns_area) + else + call get_basn_area(did) + endif + endif -if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT .eq. 2 ) then - call get_node_area(did) -endif + if (nlst(did)%CHANRTSWCRT.eq.1 .or. nlst(did)%CHANRTSWCRT .eq. 2 ) then + call get_node_area(did) + endif #ifdef WRF_HYDRO_NUDGING -if(nlst(did)%CHANRTSWCRT .ne. 0) call init_stream_nudging + if(nlst(did)%CHANRTSWCRT .ne. 0) call init_stream_nudging #endif @@ -1609,18 +1592,18 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) ! restart the file - ! jummp the initial time output +! jummp the initial time output ! rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 ! rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 -call HYDRO_rst_in(did) + call HYDRO_rst_in(did) !#ifdef HYDRO_REALTIME -if (trim(nlst(did)%restart_file) == "") then - call HYDRO_out(did, 0) -else - call HYDRO_out(did, 1) -endif + if (trim(nlst(did)%restart_file) == "") then + call HYDRO_out(did, 0) + else + call HYDRO_out(did, 1) + endif !! JLM: This is only currently part 1/2 of a better accumulation tracking strategy. !! The parts: !! 1) (this) zero accumulations on restart/init after any t=0 outputs are written. @@ -1630,25 +1613,25 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) !! This was previously done in HYDRO_rst_in and so output accumulations at time !! zero were getting zeroed and then writtent to file, which looses information. !! Note that nlst_rt(did)%rstrt_swc is not changed at any point in between here and the rst_in. -if(nlst(did)%rstrt_swc.eq.1) then !Switch for rest of restart accum vars... - print *, "Resetting RESTART Accumulation Variables to 0...",nlst(did)%rstrt_swc - ! Under channel-only , these first three variables are not allocated. - if(allocated(rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake)) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake = zeroFlt - if(allocated(rt_domain(did)%QSTRMVOLRT_ACC)) rt_domain(did)%QSTRMVOLRT_ACC = zeroFlt - ! These variables are optionally allocated, if their output is requested. - if(allocated(rt_domain(did)%accSfcLatRunoff)) rt_domain(did)%accSfcLatRunoff = zeroDbl - if(allocated(rt_domain(did)%accBucket)) rt_domain(did)%accBucket = zeroDbl -end if - -end subroutine HYDRO_ini - - subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) - implicit none - integer did, leng, ncid, ierr_flg - parameter(leng=100) - integer :: i,j, nn - integer, allocatable, dimension(:,:) :: soltyp - real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc + if(nlst(did)%rstrt_swc.eq.1) then !Switch for reset of restart accum vars... + print *, "Resetting RESTART Accumulation Variables to 0...",nlst(did)%rstrt_swc +! Under channel-only , these first three variables are not allocated. + if(allocated(rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake)) rt_domain(did)%overland%streams_and_lakes%surface_water_to_lake = zeroFlt + if(allocated(rt_domain(did)%QSTRMVOLRT_ACC)) rt_domain(did)%QSTRMVOLRT_ACC = zeroFlt +! These variables are optionally allocated, if their output is requested. + if(allocated(rt_domain(did)%accSfcLatRunoff)) rt_domain(did)%accSfcLatRunoff = zeroDbl + if(allocated(rt_domain(did)%accBucket)) rt_domain(did)%accBucket = zeroDbl + end if + + end subroutine HYDRO_ini + + subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) + implicit none + integer did, leng, ncid, ierr_flg + parameter(leng=100) + integer :: i,j, nn + integer, allocatable, dimension(:,:) :: soltyp + real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc integer :: ix0,jx0 integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0 @@ -1656,200 +1639,194 @@ subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) #ifdef HYDRO_D #ifndef NCEP_WCOSS - write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx + write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx #else - write(78,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx + write(78,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx #endif #endif - allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) + allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) - soltyp = 0 - call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + soltyp = 0 + call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) + call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst(did)%geo_static_flnm)) - if(nlst(did)%sys_cpl .eq. 2 ) then - ! coupling with WRF - if(present(soltyp0) ) then - where(VEGTYP0 == rt_domain(did)%iswater .or. VEGTYP0 == rt_domain(did)%islake) soltyp0 = rt_domain(did)%isoilwater - where(soltyp0 == rt_domain(did)%isoilwater) VEGTYP0 = rt_domain(did)%iswater - soltyp = soltyp0 - RT_DOMAIN(did)%VEGTYP = VEGTYP0 - endif + if(nlst(did)%sys_cpl .eq. 2 ) then +! coupling with WRF + if(present(soltyp0) ) then + where(VEGTYP0 == rt_domain(did)%iswater .or. VEGTYP0 == rt_domain(did)%islake) soltyp0 = rt_domain(did)%isoilwater + where(soltyp0 == rt_domain(did)%isoilwater) VEGTYP0 = rt_domain(did)%iswater + soltyp = soltyp0 + RT_DOMAIN(did)%VEGTYP = VEGTYP0 endif + endif - where(RT_DOMAIN(did)%VEGTYP == rt_domain(did)%iswater .or. RT_DOMAIN(did)%VEGTYP == rt_domain(did)%islake) soltyp = rt_domain(did)%isoilwater - where(soltyp == rt_domain(did)%isoilwater) RT_DOMAIN(did)%VEGTYP = rt_domain(did)%iswater + where(RT_DOMAIN(did)%VEGTYP == rt_domain(did)%iswater .or. RT_DOMAIN(did)%VEGTYP == rt_domain(did)%islake) soltyp = rt_domain(did)%isoilwater + where(soltyp == rt_domain(did)%isoilwater) RT_DOMAIN(did)%VEGTYP = rt_domain(did)%iswater ! LKSAT, ! temporary set - RT_DOMAIN(did)%SMCRTCHK = 0 - RT_DOMAIN(did)%SMCAGGRT = 0 - RT_DOMAIN(did)%STCAGGRT = 0 - RT_DOMAIN(did)%SH2OAGGRT = 0 + RT_DOMAIN(did)%SMCRTCHK = 0 + RT_DOMAIN(did)%SMCAGGRT = 0 + RT_DOMAIN(did)%STCAGGRT = 0 + RT_DOMAIN(did)%SH2OAGGRT = 0 - rt_domain(did)%subsurface%properties%zsoil(1:nlst(did)%nsoil) = nlst(did)%zsoil8(1:nlst(did)%nsoil) + rt_domain(did)%subsurface%properties%zsoil(1:nlst(did)%nsoil) = nlst(did)%zsoil8(1:nlst(did)%nsoil) - rt_domain(did)%subsurface%properties%sldpth(1) = abs( RT_DOMAIN(did)%subsurface%properties%zsoil(1) ) - do i = 2, nlst(did)%nsoil - rt_domain(did)%subsurface%properties%sldpth(i) = RT_DOMAIN(did)%subsurface%properties%zsoil(i-1)-RT_DOMAIN(did)%subsurface%properties%zsoil(i) - enddo - rt_domain(did)%subsurface%properties%soldeprt = -1.0*RT_DOMAIN(did)%subsurface%properties%zsoil(nlst(did)%NSOIL) + rt_domain(did)%subsurface%properties%sldpth(1) = abs( RT_DOMAIN(did)%subsurface%properties%zsoil(1) ) + do i = 2, nlst(did)%nsoil + rt_domain(did)%subsurface%properties%sldpth(i) = RT_DOMAIN(did)%subsurface%properties%zsoil(i-1)-RT_DOMAIN(did)%subsurface%properties%zsoil(i) + enddo + rt_domain(did)%subsurface%properties%soldeprt = -1.0*RT_DOMAIN(did)%subsurface%properties%zsoil(nlst(did)%NSOIL) - ierr_flg = 99 - if(trim(nlst(did)%hydrotbl_f) == "") then - call hydro_stop("FATAL ERROR: hydrotbl_f is empty. Please input a netcdf file. ") - endif + ierr_flg = 99 + if(trim(nlst(did)%hydrotbl_f) == "") then + call hydro_stop("FATAL ERROR: hydrotbl_f is empty. Please input a netcdf file. ") + endif #ifdef MPP_LAND - if(my_id .eq. IO_id) then + if(my_id .eq. IO_id) then #endif - ierr_flg = nf90_open(trim(nlst(did)%hydrotbl_f), nf90_NOWRITE, ncid) + ierr_flg = nf90_open(trim(nlst(did)%hydrotbl_f), nf90_NOWRITE, ncid) #ifdef MPP_LAND - endif - call mpp_land_bcast_int1(ierr_flg) + endif + call mpp_land_bcast_int1(ierr_flg) #endif - if( ierr_flg .ne. 0) then - ! input from HYDRO.tbl FILE + if( ierr_flg .ne. 0) then +! input from HYDRO.tbl FILE ! input OV_ROUGH from OVROUGH.TBL #ifdef MPP_LAND - if(my_id .eq. IO_id) then + if(my_id .eq. IO_id) then #endif #ifndef NCEP_WCOSS - open(71,file="HYDRO.TBL", form="formatted") + open(71,file="HYDRO.TBL", form="formatted") !read OV_ROUGH first - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do !read parameter for LKSAT - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(71) + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(71) #else - open(13, form="formatted") + open(13, form="formatted") !read OV_ROUGH first - read(13,*) nn - read(13,*) - do i = 1, nn - read(13,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do !read parameter for LKSAT - read(13,*) nn - read(13,*) - do i = 1, nn - read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(13) + read(13,*) nn + read(13,*) + do i = 1, nn + read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(13) #endif #ifdef MPP_LAND - endif - call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) - call mpp_land_bcast_real(leng,xdum1) - call mpp_land_bcast_real(leng,MAXSMC) - call mpp_land_bcast_real(leng,refsmc) - call mpp_land_bcast_real(leng,wltsmc) -#endif - - rt_domain(did)%lksat = 0.0 - do j = 1, RT_DOMAIN(did)%jx - do i = 1, RT_DOMAIN(did)%ix - !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 - rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) - rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) - rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) - rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) - !ADCHANGE: Add some sanity checks in case calibration knocks the order of these out of sequence. - !The min diffs were pulled from the existing HYDRO.TBL defaults. - !Currently water is 0, so enforcing 0 as the absolute min. - rt_domain(did)%SMCMAX1(i,j) = min(rt_domain(did)%SMCMAX1(i,j), 1.0) - rt_domain(did)%SMCREF1(i,j) = max(min(rt_domain(did)%SMCREF1(i,j), rt_domain(did)%SMCMAX1(i,j) - 0.01), 0.0) - rt_domain(did)%SMCWLT1(i,j) = max(min(rt_domain(did)%SMCWLT1(i,j), rt_domain(did)%SMCREF1(i,j) - 0.01), 0.0) - IF(rt_domain(did)%VEGTYP(i,j) > 0 ) THEN ! created 2d ov_rough - rt_domain(did)%OV_ROUGH2d(i,j) = RT_DOMAIN(did)%OV_ROUGH(rt_domain(did)%VEGTYP(I,J)) - endif - end do - end do - - call hdtbl_out(did) - else - ! input from HYDRO.TBL.nc file - print*, "reading from hydrotbl_f(HYDRO.TBL.nc) file ...." - call hdtbl_in_nc(did) - if (noah_lsm%imperv_option .eq. 9) then - !ADCHANGE: For consistency, mirror urban and param value checks used in table read - where (rt_domain(did)%VEGTYP == rt_domain(did)%isurban) - rt_domain(did)%SMCMAX1 = 0.45 - rt_domain(did)%SMCREF1 = 0.42 - rt_domain(did)%SMCWLT1 = 0.40 - endwhere - endif - where (rt_domain(did)%SMCMAX1 .gt. 1.0) rt_domain(did)%SMCMAX1 = 1.0 - rt_domain(did)%SMCREF1 = max(min(rt_domain(did)%SMCREF1, rt_domain(did)%SMCMAX1 - 0.01), 0.0) - rt_domain(did)%SMCWLT1 = max(min(rt_domain(did)%SMCWLT1, rt_domain(did)%SMCREF1 - 0.01), 0.0) - endif - - rt_domain(did)%soiltyp = soltyp - - if(allocated(soltyp)) deallocate(soltyp) - + endif + call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) + call mpp_land_bcast_real(leng,xdum1) + call mpp_land_bcast_real(leng,MAXSMC) + call mpp_land_bcast_real(leng,refsmc) + call mpp_land_bcast_real(leng,wltsmc) +#endif + + rt_domain(did)%lksat = 0.0 + do j = 1, RT_DOMAIN(did)%jx + do i = 1, RT_DOMAIN(did)%ix +!yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) + rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) + rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) + rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) +!ADCHANGE: Add some sanity checks in case calibration knocks the order of these out of sequence. +!The min diffs were pulled from the existing HYDRO.TBL defaults. +!Currently water is 0, so enforcing 0 as the absolute min. + rt_domain(did)%SMCMAX1(i,j) = min(rt_domain(did)%SMCMAX1(i,j), 1.0) + rt_domain(did)%SMCREF1(i,j) = max(min(rt_domain(did)%SMCREF1(i,j), rt_domain(did)%SMCMAX1(i,j) - 0.01), 0.0) + rt_domain(did)%SMCWLT1(i,j) = max(min(rt_domain(did)%SMCWLT1(i,j), rt_domain(did)%SMCREF1(i,j) - 0.01), 0.0) + IF(rt_domain(did)%VEGTYP(i,j) > 0 ) THEN ! created 2d ov_rough + rt_domain(did)%OV_ROUGH2d(i,j) = RT_DOMAIN(did)%OV_ROUGH(rt_domain(did)%VEGTYP(I,J)) + endif + end do + end do - end subroutine lsm_input + call hdtbl_out(did) + else +! input from HYDRO.TBL.nc file + print*, "reading from hydrotbl_f(HYDRO.TBL.nc) file ...." + call hdtbl_in_nc(did) + if (noah_lsm%imperv_option .eq. 9) then +!ADCHANGE: For consistency, mirror urban and param value checks used in table read + where (rt_domain(did)%VEGTYP == rt_domain(did)%isurban) + rt_domain(did)%SMCMAX1 = 0.45 + rt_domain(did)%SMCREF1 = 0.42 + rt_domain(did)%SMCWLT1 = 0.40 + endwhere + endif + where (rt_domain(did)%SMCMAX1 .gt. 1.0) rt_domain(did)%SMCMAX1 = 1.0 + rt_domain(did)%SMCREF1 = max(min(rt_domain(did)%SMCREF1, rt_domain(did)%SMCMAX1 - 0.01), 0.0) + rt_domain(did)%SMCWLT1 = max(min(rt_domain(did)%SMCWLT1, rt_domain(did)%SMCREF1 - 0.01), 0.0) + endif + rt_domain(did)%soiltyp = soltyp -end module module_HYDRO_drv + if(allocated(soltyp)) deallocate(soltyp) + end subroutine lsm_input -! stop the job due to the fatal error. -subroutine HYDRO_finish() + subroutine HYDRO_finish() #ifdef MPP_LAND - USE module_mpp_land + use module_mpp_land #endif #ifdef WRF_HYDRO_NUDGING - use module_stream_nudging, only: finish_stream_nudging + use module_stream_nudging, only: finish_stream_nudging #endif - integer :: ierr + integer :: ierr #ifdef WRF_HYDRO_NUDGING - call finish_stream_nudging() + call finish_stream_nudging() #endif #ifndef NCEP_WCOSS - print*, "The model finished successfully......." + print*, "The model finished successfully......." #else - write(78,*) "The model finished successfully......." + write(78,*) "The model finished successfully......." #endif #ifdef MPP_LAND -! call mpp_land_abort() #ifndef NCEP_WCOSS - call flush(6) + call flush(6) #else - call flush(78) - close(78) + call flush(78) + close(78) #endif - call mpp_land_sync() - call MPI_finalize(ierr) - stop + call mpp_land_sync() + call MPI_Finalize(ierr) + stop #else #ifndef WRF_HYDRO_NUDGING - stop !!JLM want to time at the top NoahMP level. + stop !!JLM want to time at the top NoahMP level. #endif #endif + return + end subroutine HYDRO_finish - return -end subroutine HYDRO_finish +end module module_HYDRO_drv diff --git a/hydro/IO/netcdf_layer.F90 b/hydro/IO/netcdf_layer.F90 index 850f2e8266..286e9122e0 100644 --- a/hydro/IO/netcdf_layer.F90 +++ b/hydro/IO/netcdf_layer.F90 @@ -43,7 +43,7 @@ end function create_file_signature end type NetCDF_serial_ type, extends(NetCDF_layer_) :: NetCDF_parallel_ - integer :: MPI_communicator + integer :: MPI_Communicator integer :: default_info = MPI_INFO_NULL contains procedure, pass(object) :: create_file => create_file_parallel diff --git a/hydro/MPP/CPL_WRF.F90 b/hydro/MPP/CPL_WRF.F90 index e0e0207870..04332d4113 100644 --- a/hydro/MPP/CPL_WRF.F90 +++ b/hydro/MPP/CPL_WRF.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This is used as a coupler with the WRF model. MODULE MODULE_CPL_LAND @@ -67,17 +47,17 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) data cyclic/.false.,.false./ ! not cyclic data reorder/.false./ - CALL mpi_initialized( mpi_inited, ierr ) + call MPI_Initialized( mpi_inited, ierr ) if ( .NOT. mpi_inited ) then - call mpi_init(ierr) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_INIT failed") - call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_DUP failed") + call MPI_Init(ierr) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Init failed") + call MPI_Comm_dup(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_dup failed") endif - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_global_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, total_pe_num, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_RANK and/or MPI_COMM_SIZE failed") + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_global_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, total_pe_num, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_rank and/or MPI_Comm_size failed") allocate(node_info(9,total_pe_num)) @@ -103,12 +83,12 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) dims(0) = 0 dims(1) = 0 do xx=1,total_pe_num - if(node_info(2,xx) .eq. (-1)) then - dims(0) = dims(0)+1 - endif - if(node_info(4,xx) .eq. (-1)) then - dims(1) = dims(1)+1 - endif + if(node_info(2,xx) .eq. (-1)) then + dims(0) = dims(0)+1 + endif + if(node_info(4,xx) .eq. (-1)) then + dims(1) = dims(1)+1 + endif enddo ndim = 2 @@ -118,13 +98,12 @@ subroutine CPL_LAND_INIT(istart,iend,jstart,jend) call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & cyclic, reorder, cartGridComm, ierr) - call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) + call MPI_Cart_get(cartGridComm, 2, dims, cyclic, coords, ierr) p_up_down = coords(0) p_left_right = coords(1) initialized = .false. ! land model need to be initialized. - return END subroutine CPL_LAND_INIT subroutine send_info() @@ -137,23 +116,22 @@ subroutine send_info() if(my_global_id .eq. 0) then do i = 1, total_pe_num-1 - call mpi_recv(node_info(:,i+1),size,MPI_INTEGER, & + call MPI_Recv(node_info(:,i+1),size,MPI_INTEGER, & i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) enddo else - call mpi_send(node_info(:,my_global_id+1),size, & + call MPI_Send(node_info(:,my_global_id+1),size, & MPI_INTEGER,0,tag,HYDRO_COMM_WORLD,ierr) endif - call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + call MPI_Barrier( HYDRO_COMM_WORLD ,ierr) size = 9 * total_pe_num - call mpi_bcast(node_info,size,MPI_INTEGER, & + call MPI_Bcast(node_info,size,MPI_INTEGER, & 0,HYDRO_COMM_WORLD,ierr) - call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + call MPI_Barrier( HYDRO_COMM_WORLD ,ierr) - return end subroutine send_info subroutine find_left() @@ -170,7 +148,6 @@ subroutine find_left() return endif end do - return end subroutine find_left subroutine find_right() @@ -187,7 +164,6 @@ subroutine find_right() return endif end do - return end subroutine find_right subroutine find_up() @@ -204,7 +180,6 @@ subroutine find_up() return endif end do - return end subroutine find_up subroutine find_down() @@ -221,7 +196,6 @@ subroutine find_down() return endif end do - return end subroutine find_down ! stop the job due to the fatal error. @@ -232,6 +206,5 @@ subroutine fatal_error_stop(msg) call flush(error_unit) CALL MPI_Abort(HYDRO_COMM_WORLD, 1, ierr) call MPI_Finalize(ierr) - return end subroutine fatal_error_stop END MODULE MODULE_CPL_LAND diff --git a/hydro/MPP/module_mpp_GWBUCKET.F90 b/hydro/MPP/module_mpp_GWBUCKET.F90 index 0b121dcf89..a69f800c0c 100644 --- a/hydro/MPP/module_mpp_GWBUCKET.F90 +++ b/hydro/MPP/module_mpp_GWBUCKET.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This is used as a coupler with the WRF model. MODULE MODULE_mpp_GWBUCKET @@ -57,7 +37,7 @@ subroutine collectSizeInd(numbasns) if(my_id .ne. IO_id) then tag = 66 - call mpi_send(numbasns,1,MPI_INTEGER, IO_id, & + call MPI_Send(numbasns,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -65,7 +45,7 @@ subroutine collectSizeInd(numbasns) sizeInd(i+1) = numbasns else tag = 66 - call mpi_recv(rcv,1,& + call MPI_Recv(rcv,1,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) sizeInd(i+1) = rcv @@ -101,10 +81,10 @@ subroutine gw_write_io_real(numbasns,inV,ind,outV) if(my_id .ne. IO_id) then if(numbasns .gt. 0) then tag = 62 - call mpi_send(inV,numbasns,MPI_REAL, IO_id, & + call MPI_Send(inV,numbasns,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag2 = 63 - call mpi_send(ind,numbasns,MPI_INTEGER8, IO_id, & + call MPI_Send(ind,numbasns,MPI_INTEGER8, IO_id, & tag2,HYDRO_COMM_WORLD,ierr) endif else @@ -117,10 +97,10 @@ subroutine gw_write_io_real(numbasns,inV,ind,outV) if(i .ne. IO_id) then if(sizeInd(i+1) .gt. 0) then tag = 62 - call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag2 = 63 - call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, sizeInd(i+1) outV(ibuff(k)) = vbuff(k) @@ -159,10 +139,10 @@ subroutine gw_write_io_int(numbasns,inV,ind,outV) if(my_id .ne. IO_id) then if(numbasns .gt. 0) then tag = 62 - call mpi_send(inV,numbasns,MPI_INTEGER8, IO_id, & + call MPI_Send(inV,numbasns,MPI_INTEGER8, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag2 = 63 - call mpi_send(ind,numbasns,MPI_INTEGER8, IO_id, & + call MPI_Send(ind,numbasns,MPI_INTEGER8, IO_id, & tag2,HYDRO_COMM_WORLD,ierr) endif else @@ -175,10 +155,10 @@ subroutine gw_write_io_int(numbasns,inV,ind,outV) if(i .ne. IO_id) then if(sizeInd(i+1) .gt. 0) then tag = 62 - call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag2 = 63 - call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& + call MPI_Recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),& MPI_INTEGER8,i,tag2,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, sizeInd(i+1) outV(ibuff(k)) = vbuff(k) diff --git a/hydro/MPP/module_mpp_ReachLS.F90 b/hydro/MPP/module_mpp_ReachLS.F90 index ef027c1c33..a5fd079e82 100644 --- a/hydro/MPP/module_mpp_ReachLS.F90 +++ b/hydro/MPP/module_mpp_ReachLS.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This is used as a coupler with the WRF model. MODULE MODULE_mpp_ReachLS @@ -102,30 +82,30 @@ subroutine updateLinkV8_mem(LinkV, outV) if(my_id .ne. IO_id) then tag = 101 - call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKLEN,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) if(LLINKLEN .gt. 0) then tag = 102 - call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 103 - call mpi_send(LinkV,LLINKLEN,MPI_DOUBLE_PRECISION, IO_id, & + call MPI_Send(LinkV,LLINKLEN,MPI_DOUBLE_PRECISION, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif else do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 101 - call mpi_recv(lsize,1,MPI_INTEGER, i, & + call MPI_Recv(lsize,1,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(lsize .gt. 0) then allocate(lindex(lsize) ) allocate(tmpBuf(lsize) ) tag = 102 - call mpi_recv(lindex,lsize,MPI_INTEGER, i, & + call MPI_Recv(lindex,lsize,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 103 - call mpi_recv(tmpBuf,lsize,& + call MPI_Recv(tmpBuf,lsize,& MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, lsize gLinkV_r8(lindex(k)) = gLinkV_r8(lindex(k)) + tmpBuf(k) @@ -166,30 +146,30 @@ subroutine updateLinkV4_mem(LinkV, outV) if(my_id .ne. IO_id) then tag = 101 - call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKLEN,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) if(LLINKLEN .gt. 0) then tag = 102 - call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & + call MPI_Send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 103 - call mpi_send(LinkV,LLINKLEN,MPI_REAL, IO_id, & + call MPI_Send(LinkV,LLINKLEN,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif else do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 101 - call mpi_recv(lsize,1,MPI_INTEGER, i, & + call MPI_Recv(lsize,1,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(lsize .gt. 0) then allocate(lindex(lsize) ) allocate(tmpBuf(lsize) ) tag = 102 - call mpi_recv(lindex,lsize,MPI_INTEGER, i, & + call MPI_Recv(lindex,lsize,MPI_INTEGER, i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 103 - call mpi_recv(tmpBuf,lsize,& + call MPI_Recv(tmpBuf,lsize,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, lsize gLinkV_r4(lindex(k)) = gLinkV_r4(lindex(k)) + tmpBuf(k) @@ -224,14 +204,14 @@ subroutine updateLinkV8(LinkV, outV) if(my_id .ne. IO_id) then tag = 102 - call mpi_send(gLinkV,gnlinksl,MPI_DOUBLE_PRECISION, IO_id, & + call MPI_Send(gLinkV,gnlinksl,MPI_DOUBLE_PRECISION, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else gLinkV_r = gLinkV do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 102 - call mpi_recv(gLinkV,gnlinksl,& + call MPI_Recv(gLinkV,gnlinksl,& MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) gLinkV_r = gLinkV_r + gLinkV end if @@ -257,14 +237,14 @@ subroutine updateLinkV4(LinkV, outV) if(my_id .ne. IO_id) then tag = 102 - call mpi_send(gLinkV,gnlinksl,MPI_REAL, IO_id, & + call MPI_Send(gLinkV,gnlinksl,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else gLinkV_r = gLinkV do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 102 - call mpi_recv(gLinkV,gnlinksl,& + call MPI_Recv(gLinkV,gnlinksl,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) gLinkV_r = gLinkV_r + gLinkV end if @@ -280,7 +260,7 @@ subroutine gbcastReal(inV, outV) real, dimension(:) :: inV integer :: ierr call ReachLS_write_io(inV,outV) - call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_REAL, & + call MPI_Bcast(outV(1:gnlinksl),gnlinksl,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) end subroutine gbcastReal @@ -297,7 +277,7 @@ subroutine gbcastReal2_old(index,size1,inV, insize, outV) bsize = linkls_e(i+1) - linkls_s(i+1) + 1 if(linkls_e(i+1) .gt. 0) then if(my_id .eq. i) tmpV(1:bsize) = inV(1:bsize) - call mpi_bcast(tmpV(1:bsize),bsize,MPI_REAL, & + call MPI_Bcast(tmpV(1:bsize),bsize,MPI_REAL, & i,HYDRO_COMM_WORLD,ierr) do j = 1, size1 do k = 1, bsize @@ -324,7 +304,7 @@ subroutine gbcastReal2(index,size1,inV, insize, outV) integer :: ierr, k, i, m, j, bsize outV = 0 call ReachLS_write_io(inV,gbuf) - call mpi_bcast(gbuf,gnlinksl,MPI_REAL, & + call MPI_Bcast(gbuf,gnlinksl,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) do j = 1, size1 outV(j) = gbuf(index(j)) @@ -340,7 +320,7 @@ subroutine gbcastInt(inV, outV) integer, dimension(:) :: inV integer :: ierr call ReachLS_write_io(inV,outV) - call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER, & + call MPI_Bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) end subroutine gbcastInt @@ -350,7 +330,7 @@ subroutine gbcastInt8(inV, outV) integer(kind=int64), dimension(:) :: inV integer :: ierr call ReachLS_write_io(inV,outV) - call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER8, & + call MPI_Bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) end subroutine gbcastInt8 @@ -367,7 +347,7 @@ subroutine getLocalIndx(glinksl,LINKID, LLINKID) call ReachLS_write_io(LINKID,gLinkId) - call mpi_bcast(gLinkId(1:glinksl),glinksl,MPI_INTEGER8, & + call MPI_Bcast(gLinkId(1:glinksl),glinksl,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) ! The following loops are replaced by a hashtable-based algorithm @@ -406,8 +386,8 @@ subroutine ReachLS_ini(glinksl,nlinksl,linklsS, linklsE) integer :: i, ii, ierr ! get my_id and numprocs - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) nlinksl = glinksl / numprocs @@ -473,7 +453,7 @@ subroutine MapGrid2ReachIni(in2d) if(my_id .eq. n-1) then tmpS = sDataRec endif - call mpi_bcast(tmpS,numprocs,MPI_INTEGER, & + call MPI_Bcast(tmpS,numprocs,MPI_INTEGER, & n-1,HYDRO_COMM_WORLD,ierr) rDataRec(n) = tmpS(n) enddo @@ -495,7 +475,7 @@ subroutine ReachLS_decompReal(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL, i-1 ,tag,HYDRO_COMM_WORLD,ierr) endif @@ -503,7 +483,7 @@ subroutine ReachLS_decompReal(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! + call MPI_Recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! aLinksl(my_id+1), & MPI_REAL, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -525,7 +505,7 @@ subroutine ReachLS_decompReal8(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL8, i-1 ,tag,HYDRO_COMM_WORLD,ierr) endif @@ -533,7 +513,7 @@ subroutine ReachLS_decompReal8(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! + call MPI_Recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !! this one has +1! aLinksl(my_id+1), & MPI_REAL8, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -555,7 +535,7 @@ subroutine ReachLS_decompInt(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr) endif @@ -563,7 +543,7 @@ subroutine ReachLS_decompInt(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & + call MPI_Recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & alinksl(my_id+1), & MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -587,7 +567,7 @@ subroutine ReachLS_decompInt8(inV,outV) endif else if(aLinksl(i) .gt. 0) then - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER8, i-1,tag,HYDRO_COMM_WORLD,ierr) endif @@ -595,7 +575,7 @@ subroutine ReachLS_decompInt8(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - call mpi_recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & + call MPI_Recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), & alinksl(my_id+1), & MPI_INTEGER8, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -622,8 +602,8 @@ subroutine ReachLS_decompChar(inV,outV) endif else if(aLinksl(i) .gt. 0) then - ! The mpi_send takes what you give it and THEN treats each caracter as an array element. - call mpi_send(inV(linkls_s(i):linkls_e(i)), & + ! The MPI_Send takes what you give it and THEN treats each caracter as an array element. + call MPI_Send(inV(linkls_s(i):linkls_e(i)), & strLen*aLinksl(i), & MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, ierr) endif @@ -631,8 +611,8 @@ subroutine ReachLS_decompChar(inV,outV) end do else if(aLinksl(my_id+1) .gt. 0) then - ! The mpi_recv treats each caracter as an array element. - call mpi_recv(outV(1 : (linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !jlm should have +1 + ! The MPI_Recv treats each caracter as an array element. + call MPI_Recv(outV(1 : (linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), & !jlm should have +1 strLen*alinksl(my_id+1), & MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, mpp_status,ierr ) endif @@ -657,7 +637,7 @@ subroutine ReachLS_wReal(inV,outV) else if(aLinksl(i) .gt. 0) then - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -667,7 +647,7 @@ subroutine ReachLS_wReal(inV,outV) if(aLinksl(my_id+1) .gt. 0) then tag = 12 ss = size(inv,1) - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -691,7 +671,7 @@ subroutine ReachLS_wReal8(inV,outV) else if(aLinksl(i) .gt. 0) then - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL8,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -701,7 +681,7 @@ subroutine ReachLS_wReal8(inV,outV) if(aLinksl(my_id+1) .gt. 0) then tag = 12 ss = size(inv,1) - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_REAL8,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -725,7 +705,7 @@ subroutine ReachLS_wInt(inV,outV) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -734,7 +714,7 @@ subroutine ReachLS_wInt(inV,outV) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -757,7 +737,7 @@ subroutine ReachLS_wInt8(inV,outV) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER8,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -766,7 +746,7 @@ subroutine ReachLS_wInt8(inV,outV) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_INTEGER8,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -790,7 +770,7 @@ subroutine ReachLS_wInt2(inV,outV,len,glen) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -799,7 +779,7 @@ subroutine ReachLS_wInt2(inV,outV,len,glen) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -823,7 +803,7 @@ subroutine ReachLS_wReal2(inV,outV,len,glen) else if(aLinksl(i) .gt. 0) then tag = 12 - call mpi_recv(outV(linkls_s(i):linkls_e(i)), & + call MPI_Recv(outV(linkls_s(i):linkls_e(i)), & aLinksl(i), & MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -832,7 +812,7 @@ subroutine ReachLS_wReal2(inV,outV,len,glen) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - call mpi_send(inV(1:aLinksl(my_id+1) ), & + call MPI_Send(inV(1:aLinksl(my_id+1) ), & aLinksl(my_id+1), & MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr) endif @@ -857,8 +837,8 @@ subroutine ReachLS_wChar(inV,outV) if(aLinksl(i) .gt. 0) then tag = 12 ! ? seems asymmetric with ReachLS_decompChar - call mpi_recv(outV( linkls_s(i) : linkls_e(i) ), & -! call mpi_recv(outV( ((linkls_s(i)-1)+1) : (linkls_e(i)) ), & + call MPI_Recv(outV( linkls_s(i) : linkls_e(i) ), & +! call MPI_Recv(outV( ((linkls_s(i)-1)+1) : (linkls_e(i)) ), & aLinksl(i), & MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, mpp_status, ierr ) endif @@ -867,8 +847,8 @@ subroutine ReachLS_wChar(inV,outV) else if(aLinksl(my_id+1) .gt. 0) then tag = 12 - ! The mpi_send takes what you give it and THEN treats each caracter as an array element. - call mpi_send(inV(1:aLinksl(my_id+1)), & + ! The MPI_Send takes what you give it and THEN treats each caracter as an array element. + call MPI_Send(inV(1:aLinksl(my_id+1)), & aLinksl(my_id+1), & MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, ierr) endif @@ -1004,7 +984,7 @@ subroutine getToInd(from,to,ind,indLen,gToNodeOut) ToInd(my_id+1) = kk do i = 0, numprocs - 1 - call mpi_bcast(ToInd(i+1),1,MPI_INTEGER8, & + call MPI_Bcast(ToInd(i+1),1,MPI_INTEGER8, & i,HYDRO_COMM_WORLD,ierr) end do @@ -1045,7 +1025,7 @@ subroutine com_decomp1dInt(inV,gsize,outV,lsize) endif else if(ssize .gt. 0 ) then - call mpi_send(inV(start:start+ssize-1), ssize, & + call MPI_Send(inV(start:start+ssize-1), ssize, & MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1058,7 +1038,7 @@ subroutine com_decomp1dInt(inV,gsize,outV,lsize) endif if( lsize .gt. 0) then allocate(outV(lsize) ) - call mpi_recv(outV,lsize, & + call MPI_Recv(outV,lsize, & MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1102,7 +1082,7 @@ subroutine com_decomp1dInt8(inV,gsize,outV,lsize) endif else if(ssize .gt. 0 ) then - call mpi_send(inV(start:start+ssize-1), ssize, & + call MPI_Send(inV(start:start+ssize-1), ssize, & MPI_INTEGER8, i-1,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1115,7 +1095,7 @@ subroutine com_decomp1dInt8(inV,gsize,outV,lsize) endif if( lsize .gt. 0) then allocate(outV(lsize) ) - call mpi_recv(outV,lsize, & + call MPI_Recv(outV,lsize, & MPI_INTEGER8, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1154,7 +1134,7 @@ subroutine com_write1dInt(inV,lsize,outV,gsize) endif else if(rsize .gt. 0 ) then - call mpi_recv(outV(start:start+rsize-1), rsize, & + call MPI_Recv(outV(start:start+rsize-1), rsize, & MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1166,7 +1146,7 @@ subroutine com_write1dInt(inV,lsize,outV,gsize) lsize = ncomsize endif if( lsize .gt. 0) then - call mpi_send(inV, lsize, & + call MPI_Send(inV, lsize, & MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1205,7 +1185,7 @@ subroutine com_write1dInt8(inV,lsize,outV,gsize) endif else if(rsize .gt. 0 ) then - call mpi_recv(outV(start:start+rsize-1), rsize, & + call MPI_Recv(outV(start:start+rsize-1), rsize, & MPI_INTEGER8, i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif @@ -1217,7 +1197,7 @@ subroutine com_write1dInt8(inV,lsize,outV,gsize) lsize = ncomsize endif if( lsize .gt. 0) then - call mpi_send(inV, lsize, & + call MPI_Send(inV, lsize, & MPI_INTEGER8, io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1259,7 +1239,7 @@ subroutine pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(my_id .ne. IO_id) then tag = 72 if(lnsizes(my_id + 1) .gt. 0) then - call mpi_recv(bufid,lnsizes(my_id + 1),& + call MPI_Recv(bufid,lnsizes(my_id + 1),& MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif else @@ -1267,7 +1247,7 @@ subroutine pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(i .ne. my_id) then tag = 72 if(lnsizes(i+1) .gt. 0) then - call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + call MPI_Send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & lnsizes(i+1),MPI_INTEGER,i, tag,HYDRO_COMM_WORLD,ierr) endif else @@ -1315,7 +1295,7 @@ subroutine pack_decomp_int8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(my_id .ne. IO_id) then tag = 72 if(lnsizes(my_id + 1) .gt. 0) then - call mpi_recv(bufid,lnsizes(my_id + 1),& + call MPI_Recv(bufid,lnsizes(my_id + 1),& MPI_INTEGER8,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif else @@ -1323,7 +1303,7 @@ subroutine pack_decomp_int8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(i .ne. my_id) then tag = 72 if(lnsizes(i+1) .gt. 0) then - call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + call MPI_Send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & lnsizes(i+1),MPI_INTEGER8,i, tag,HYDRO_COMM_WORLD,ierr) endif else @@ -1363,7 +1343,7 @@ subroutine pack_decomp_real8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(my_id .ne. IO_id) then tag = 72 if(lnsizes(my_id + 1) .gt. 0) then - call mpi_recv(bufid,lnsizes(my_id + 1),& + call MPI_Recv(bufid,lnsizes(my_id + 1),& MPI_DOUBLE_PRECISION,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif else @@ -1371,7 +1351,7 @@ subroutine pack_decomp_real8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid) if(i .ne. my_id) then tag = 72 if(lnsizes(i+1) .gt. 0) then - call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & + call MPI_Send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1), & lnsizes(i+1),MPI_DOUBLE_PRECISION,i, tag,HYDRO_COMM_WORLD,ierr) endif else @@ -1415,15 +1395,15 @@ subroutine TONODE2RSL (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + call MPI_Recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(tmpSize .gt. 0) then allocate(buf(tmpSize)) allocate(tmpInd(tmpSize)) tag = 83 - call mpi_recv(tmpInd, tmpSize , & + call MPI_Recv(tmpInd, tmpSize , & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 84 - call mpi_recv(buf, tmpSize , & + call MPI_Recv(buf, tmpSize , & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, tmpSize if(buf(k) .ne. flag) then @@ -1437,13 +1417,13 @@ subroutine TONODE2RSL (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + call MPI_Send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) if(size .gt. 0) then tag = 83 - call mpi_send(ind(1:size),size, & + call MPI_Send(ind(1:size),size, & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) tag = 84 - call mpi_send(inVar(1:size),size, & + call MPI_Send(inVar(1:size),size, & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -1480,15 +1460,15 @@ subroutine TONODE2RSL8 (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) + call MPI_Recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(tmpSize .gt. 0) then allocate(buf(tmpSize)) allocate(tmpInd(tmpSize)) tag = 83 - call mpi_recv(tmpInd, tmpSize , & + call MPI_Recv(tmpInd, tmpSize , & MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 84 - call mpi_recv(buf, tmpSize , & + call MPI_Recv(buf, tmpSize , & MPI_INTEGER8,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, tmpSize if(buf(k) .ne. flag) then @@ -1502,13 +1482,13 @@ subroutine TONODE2RSL8 (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag) end do else tag = 82 - call mpi_send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) + call MPI_Send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) if(size .gt. 0) then tag = 83 - call mpi_send(ind(1:size),size, & + call MPI_Send(ind(1:size),size, & MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr) tag = 84 - call mpi_send(inVar(1:size),size, & + call MPI_Send(inVar(1:size),size, & MPI_INTEGER8,io_id,tag,HYDRO_COMM_WORLD,ierr) endif endif diff --git a/hydro/MPP/mpp_land.F90 b/hydro/MPP/mpp_land.F90 index 0084a2d166..41698e2b7e 100644 --- a/hydro/MPP/mpp_land.F90 +++ b/hydro/MPP/mpp_land.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - !#### This is a module for parallel Land model. MODULE MODULE_MPP_LAND @@ -34,7 +14,7 @@ MODULE MODULE_MPP_LAND integer, public :: global_nx, global_ny, local_nx,local_ny integer, public :: global_rt_nx, global_rt_ny integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT - integer, public :: numprocs ! total process, get by mpi initialization. + integer, public :: numprocs ! total process, get by MPI initialization. integer :: local_startx, local_starty integer :: local_startx_rt, local_starty_rt, local_endx_rt, local_endy_rt @@ -86,8 +66,8 @@ subroutine LOG_MAP2d() data cyclic/.false.,.false./ ! not cyclic data reorder/.false./ - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) call getNX_NY(numprocs, left_right_np,up_down_np) if(my_id.eq.IO_id) then @@ -131,14 +111,13 @@ subroutine LOG_MAP2d() call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, & cyclic, reorder, cartGridComm, ierr) - call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr) + call MPI_Cart_get(cartGridComm, 2, dims, cyclic, coords, ierr) p_up_down = coords(0) p_left_right = coords(1) np_up_down = up_down_np np_left_right = left_right_np - return end subroutine log_map2d subroutine MPP_LAND_INIT(in_global_nx,in_global_ny) @@ -154,21 +133,20 @@ subroutine MPP_LAND_INIT(in_global_nx,in_global_ny) global_ny = in_global_ny end if - call mpi_initialized( mpi_inited, ierr ) + call MPI_Initialized( mpi_inited, ierr ) if ( .not. mpi_inited ) then - call MPI_INIT_THREAD( MPI_THREAD_FUNNELED, provided, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_INIT failed") - call MPI_COMM_DUP(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_DUP failed") + call MPI_Init_thread( MPI_THREAD_FUNNELED, provided, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Init failed") + call MPI_Comm_dup(MPI_COMM_WORLD, HYDRO_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_dup failed") endif - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) - if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_COMM_RANK and/or MPI_COMM_SIZE failed") + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) + if (ierr /= MPI_SUCCESS) call fatal_error_stop("MPI Error: MPI_Comm_rank and/or MPI_Comm_size failed") ! create 2d logical mapping of the CPU. call log_map2d() - return end subroutine MPP_LAND_INIT @@ -233,7 +211,6 @@ subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) write(6,*) "my_id=",my_id,"global_nx=",global_nx write(6,*) "my_id=",my_id,"global_nx=",global_ny #endif - return end subroutine MPP_LAND_PAR_INI subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) @@ -247,26 +224,26 @@ subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & + call MPI_Send(in_out_data(nx-1,:),size,MPI_REAL, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = ny - call mpi_recv(in_out_data(1,:),size,MPI_REAL, & + call MPI_Recv(in_out_data(1,:),size,MPI_REAL, & left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif if(left_id .ge. 0 ) then ! ### send to left second. size = ny tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_REAL, & + call MPI_Send(in_out_data(2,:),size,MPI_REAL, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& + call MPI_Recv(in_out_data(nx,:),size,MPI_REAL,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif @@ -275,13 +252,13 @@ subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & + call MPI_Send(in_out_data(nx-1:nx,:),size,MPI_REAL, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = 2*ny - call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & + call MPI_Recv(data_r,size,MPI_REAL,left_id,tag, & HYDRO_COMM_WORLD,mpp_status,ierr) in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) @@ -290,18 +267,17 @@ subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) if(left_id .ge. 0 ) then ! ### send to left second. size = 2*ny tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & + call MPI_Send(in_out_data(1:2,:),size,MPI_REAL, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& + call MPI_Recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif endif ! end if black for flag. - return end subroutine MPP_LAND_LR_COM subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) @@ -315,26 +291,26 @@ subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = ny - call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif if(left_id .ge. 0 ) then ! ### send to left second. size = ny tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& + call MPI_Recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif @@ -343,13 +319,13 @@ subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) if(right_id .ge. 0) then ! ### send to right first. tag = 11 size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & right_id,tag,HYDRO_COMM_WORLD,ierr) end if if(left_id .ge. 0) then ! receive from left tag = 11 size = 2*ny - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & + call MPI_Recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & HYDRO_COMM_WORLD,mpp_status,ierr) in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) @@ -358,18 +334,17 @@ subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) if(left_id .ge. 0 ) then ! ### send to left second. size = 2*ny tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & left_id,tag,HYDRO_COMM_WORLD,ierr) endif if(right_id .ge. 0) then ! receive from right tag = 21 size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& + call MPI_Recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif endif ! end if black for flag. - return end subroutine MPP_LAND_LR_COM8 @@ -393,7 +368,7 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) if(i .ne. my_id) then !block receive from other node. tag = 1 - call mpi_recv(s_r,2,MPI_INTEGER,i, & + call MPI_Recv(s_r,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) local_nx_size(i+1) = s_r(1) local_ny_size(i+1) = s_r(2) @@ -406,7 +381,7 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) tag = 1 s_r(1) = local_nx s_r(2) = local_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + call MPI_Send(s_r,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if @@ -416,7 +391,7 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) if(i .ne. my_id) then !block receive from other node. tag = 2 - call mpi_recv(s_r,2,MPI_INTEGER,i, & + call MPI_Recv(s_r,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) local_rt_nx_size(i+1) = s_r(1) local_rt_ny_size(i+1) = s_r(2) @@ -429,11 +404,10 @@ subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) tag = 2 s_r(1) = rt_nx s_r(2) = rt_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + call MPI_Send(s_r,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if - return end subroutine get_local_size @@ -450,26 +424,26 @@ subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & + call MPI_Send(in_out_data(:,ny-1),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx - call mpi_recv(in_out_data(:,1),size,MPI_REAL, & + call MPI_Recv(in_out_data(:,1),size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx - call mpi_send(in_out_data(:,2),size,MPI_REAL, & + call MPI_Send(in_out_data(:,2),size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & + call MPI_Recv(in_out_data(:,ny),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -478,13 +452,13 @@ subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & + call MPI_Send(in_out_data(:,ny-1:ny),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx*2 - call mpi_recv(data_r,size,MPI_REAL, & + call MPI_Recv(data_r,size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) @@ -493,17 +467,16 @@ subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & + call MPI_Send(in_out_data(:,1:2),size,MPI_REAL, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & + call MPI_Recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif ! end of block flag - return end subroutine MPP_LAND_UB_COM subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) @@ -519,26 +492,26 @@ subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx - call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) endif if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx - call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif @@ -547,13 +520,13 @@ subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) if(up_id .ge. 0 ) then ! ### send to up first. tag = 31 size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,ierr) endif if(down_id .ge. 0 ) then ! receive from down tag = 31 size = nx*2 - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(data_r,size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr) in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) @@ -562,17 +535,16 @@ subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) if(down_id .ge. 0 ) then ! send down. tag = 41 size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & + call MPI_Send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & down_id,tag,HYDRO_COMM_WORLD,ierr) endif if(up_id .ge. 0 ) then ! receive from upper tag = 41 size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + call MPI_Recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif endif ! end of block flag - return end subroutine MPP_LAND_UB_COM8 subroutine calculate_start_p() @@ -622,7 +594,7 @@ subroutine calculate_start_p() ! block receive from other node. if(i.ne.my_id) then tag = 1 - call mpi_recv(r_s,2,MPI_INTEGER,i, & + call MPI_Recv(r_s,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) startx(i+1) = r_s(1) starty(i+1) = r_s(2) @@ -630,7 +602,7 @@ subroutine calculate_start_p() end do else tag = 1 - call mpi_send(r_s,2,MPI_INTEGER, IO_id, & + call MPI_Send(r_s,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if @@ -643,7 +615,6 @@ subroutine calculate_start_p() local_endx_rt = local_startx_rt + local_rt_nx -1 local_endy_rt = local_starty_rt + local_rt_ny -1 - return end subroutine calculate_start_p subroutine calculate_offset_vectors() @@ -672,7 +643,6 @@ subroutine calculate_offset_vectors() last_offset = last_offset + size_vectors_rt(i) end do - return end subroutine calculate_offset_vectors subroutine decompose_data_real3d (in_buff,out_buff,klevel) @@ -695,8 +665,8 @@ subroutine decompose_data_real (in_buff,out_buff) if(my_id .eq. IO_id) then - ! allocate the buffer to hold data as required by mpi_scatterv - ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + ! allocate the buffer to hold data as required by MPI_Scatterv + ! be careful with the index range if using array prepared for MPI in fortran (offset_vectors) allocate(send_buff(0: (global_nx*global_ny) -1),stat = ierr) ! for each sub region in the global buffer linearize the data and place it in the @@ -725,19 +695,18 @@ subroutine decompose_data_real (in_buff,out_buff) ! send the to each process size_vector(mpi_rank+1) data elements ! and store the results in out_buff - call mpi_scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & + call MPI_Scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & out_buff, size_vectors(my_id+1), MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) ! remove the send buffer deallocate(send_buff) else - ! other processes only need to make mpi_scatterv call - call mpi_scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & + ! other processes only need to make MPI_Scatterv call + call MPI_Scatterv(send_buff, size_vectors, offset_vectors, MPI_REAL, & out_buff, local_nx*local_ny, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) end if - return end subroutine decompose_data_real @@ -760,16 +729,15 @@ subroutine decompose_data_int (in_buff,out_buff) else ! send data to the rest process. size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + call MPI_Recv(out_buff,size,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_data_int subroutine write_IO_int(in_buff,out_buff) @@ -780,7 +748,7 @@ subroutine write_IO_int(in_buff,out_buff) if(my_id .ne. IO_id) then size = local_nx*local_ny tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & + call MPI_Send(in_buff,size,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -793,12 +761,11 @@ subroutine write_IO_int(in_buff,out_buff) else size = local_nx_size(i+1)*local_ny_size(i+1) tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do end if - return end subroutine write_IO_int subroutine write_IO_char_head(in, out, imageHead) @@ -819,7 +786,7 @@ subroutine write_IO_char_head(in, out, imageHead) if(my_id .ne. IO_id) then lenSize = imageHead(my_id+1)*len(in(1)) !! some times necessary for character arrays? if(lenSize .eq. 0) return - call mpi_send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr) + call MPI_Send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs-1 lenSize = imageHead(i+1)*len(in(1)) !! necessary? @@ -833,7 +800,7 @@ subroutine write_IO_char_head(in, out, imageHead) if(i .eq. IO_id) then out(theStart:theEnd) = in(1:imageHead(i+1)) else - call mpi_recv(out(theStart:theEnd),lenSize,& + call MPI_Recv(out(theStart:theEnd),lenSize,& MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do @@ -859,7 +826,7 @@ subroutine write_IO_real(in_buff,out_buff) if(my_id .ne. IO_id) then size = local_nx*local_ny tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & + call MPI_Send(in_buff,size,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -872,12 +839,11 @@ subroutine write_IO_real(in_buff,out_buff) else size = local_nx_size(i+1)*local_ny_size(i+1) tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do end if - return end subroutine write_IO_real ! subroutine write_IO_RT_real_prev(in_buff,out_buff) @@ -888,7 +854,7 @@ end subroutine write_IO_real ! if(my_id .ne. IO_id) then ! size = local_rt_nx*local_rt_ny ! tag = 2 -! call mpi_send(in_buff,size,MPI_REAL, IO_id, & +! call MPI_Send(in_buff,size,MPI_REAL, IO_id, & ! tag,HYDRO_COMM_WORLD,ierr) ! else ! do i = 0, numprocs - 1 @@ -903,12 +869,11 @@ end subroutine write_IO_real ! else ! size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) ! tag = 2 -! call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& +! call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& ! MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) ! end if ! end do ! end if -! return ! end subroutine write_IO_RT_real_prev subroutine write_IO_RT_real (in_buff,out_buff) @@ -922,14 +887,14 @@ subroutine write_IO_RT_real (in_buff,out_buff) if(my_id .eq. IO_id) then - ! allocate the buffer to hold data as required by mpi_scatterv + ! allocate the buffer to hold data as required by MPI_Scatterv ! (this will be larger than out_buff due to halo cell overlap) - ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + ! be careful with the index range if using array prepared for MPI in fortran (offset_vectors) allocate(recv_buff(0: sum(size_vectors_rt) -1),stat = ierr) ! recieve from each process size_vector(mpi_rank+1) data elements ! and store the results in recv_buffer - call mpi_gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & + call MPI_Gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) @@ -953,12 +918,11 @@ subroutine write_IO_RT_real (in_buff,out_buff) deallocate(recv_buff) else - ! other processes only need to make mpi_gatherv call - call mpi_gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_REAL, & + ! other processes only need to make MPI_Gatherv call + call MPI_Gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_REAL, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) end if - return end subroutine write_IO_RT_real subroutine write_IO_RT_int (in_buff,out_buff) @@ -972,14 +936,14 @@ subroutine write_IO_RT_int (in_buff,out_buff) if(my_id .eq. IO_id) then - ! allocate the buffer to hold data as required by mpi_scatterv + ! allocate the buffer to hold data as required by MPI_Scatterv ! (this will be larger than out_buff due to halo cell overlap) - ! be careful with the index range if using array prepared for mpi in fortran (offset_vectors) + ! be careful with the index range if using array prepared for MPI in fortran (offset_vectors) allocate(recv_buff(0: sum(size_vectors_rt) -1),stat = ierr) ! recieve from each process size_vector(mpi_rank+1) data elements ! and store the results in recv_buffer - call mpi_gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & + call MPI_Gatherv(in_buff, size_vectors_rt(my_id+1), MPI_REAL, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) @@ -1003,12 +967,11 @@ subroutine write_IO_RT_int (in_buff,out_buff) deallocate(recv_buff) else - ! other processes only need to make mpi_gatherv call - call mpi_gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_INTEGER, & + ! other processes only need to make MPI_Gatherv call + call MPI_Gatherv(in_buff, local_rt_nx*local_rt_ny, MPI_INTEGER, & recv_buff, size_vectors_rt, offset_vectors_rt, MPI_INTEGER, & IO_id, HYDRO_COMM_WORLD, ierr) end if - return end subroutine write_IO_RT_int ! subroutine write_IO_RT_int (in_buff,out_buff) @@ -1020,7 +983,7 @@ end subroutine write_IO_RT_int ! if(my_id .ne. IO_id) then ! size = local_rt_nx*local_rt_ny ! tag = 2 -! call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & +! call MPI_Send(in_buff,size,MPI_INTEGER, IO_id, & ! tag,HYDRO_COMM_WORLD,ierr) ! else ! do i = 0, numprocs - 1 @@ -1035,12 +998,11 @@ end subroutine write_IO_RT_int ! else ! size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) ! tag = 2 -! call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& +! call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& ! MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) ! end if ! end do ! end if -! return ! end subroutine write_IO_RT_int subroutine write_IO_RT_int8(in_buff,out_buff) @@ -1052,7 +1014,7 @@ subroutine write_IO_RT_int8(in_buff,out_buff) if(my_id .ne. IO_id) then size = local_rt_nx*local_rt_ny tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER8, IO_id, & + call MPI_Send(in_buff,size,MPI_INTEGER8, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 @@ -1067,20 +1029,18 @@ subroutine write_IO_RT_int8(in_buff,out_buff) else size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Recv(out_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if end do end if - return end subroutine write_IO_RT_int8 subroutine mpp_land_bcast_log1(inout) logical inout integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & + call MPI_Bcast(inout,1,MPI_LOGICAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_log1 @@ -1088,18 +1048,16 @@ subroutine mpp_land_bcast_int(size,inout) integer size integer inout(size) integer ierr - call mpi_bcast(inout,size,MPI_INTEGER, & + call MPI_Bcast(inout,size,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int subroutine mpp_land_bcast_int8(size,inout) integer size integer(kind=int64) inout(size) integer ierr - call mpi_bcast(inout,size,MPI_INTEGER8, & + call MPI_Bcast(inout,size,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int8 subroutine mpp_land_bcast_int8_1d(inout) @@ -1107,9 +1065,8 @@ subroutine mpp_land_bcast_int8_1d(inout) integer(kind=int64) inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER8, & + call MPI_Bcast(inout,len,MPI_INTEGER8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int8_1d subroutine mpp_land_bcast_int1d(inout) @@ -1117,9 +1074,8 @@ subroutine mpp_land_bcast_int1d(inout) integer inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER, & + call MPI_Bcast(inout,len,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int1d subroutine mpp_land_bcast_int1d_root(inout, rootId) @@ -1128,56 +1084,49 @@ subroutine mpp_land_bcast_int1d_root(inout, rootId) integer, intent(in) :: rootId integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_int1d_root subroutine mpp_land_bcast_int1(inout) integer inout integer ierr - call mpi_bcast(inout,1,MPI_INTEGER, & + call MPI_Bcast(inout,1,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_int1 subroutine mpp_land_bcast_int1_root(inout, rootId) integer inout integer ierr integer, intent(in) :: rootId - call mpi_bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_int1_root subroutine mpp_land_bcast_logical(inout) logical :: inout integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & + call MPI_Bcast(inout,1,MPI_LOGICAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_logical subroutine mpp_land_bcast_logical_root(inout, rootId) logical :: inout integer, intent(in) :: rootId integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_logical_root subroutine mpp_land_bcast_real1(inout) real inout integer ierr - call mpi_bcast(inout,1,MPI_REAL, & + call MPI_Bcast(inout,1,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real1 subroutine mpp_land_bcast_real1_double(inout) real*8 inout integer ierr - call mpi_bcast(inout,1,MPI_REAL8, & + call MPI_Bcast(inout,1,MPI_REAL8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real1_double subroutine mpp_land_bcast_real_1d(inout) @@ -1185,9 +1134,8 @@ subroutine mpp_land_bcast_real_1d(inout) real inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_real, & + call MPI_Bcast(inout,len,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real_1d subroutine mpp_land_bcast_real_1d_root(inout, rootId) @@ -1196,8 +1144,7 @@ subroutine mpp_land_bcast_real_1d_root(inout, rootId) integer, intent(in) :: rootId integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_real,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,len,MPI_REAL,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_real_1d_root subroutine mpp_land_bcast_real8_1d(inout) @@ -1205,9 +1152,8 @@ subroutine mpp_land_bcast_real8_1d(inout) real*8 inout(:) integer ierr len = size(inout,1) - call mpi_bcast(inout,len,MPI_double, & + call MPI_Bcast(inout,len,MPI_DOUBLE, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real8_1d subroutine mpp_land_bcast_real(size1,inout) @@ -1215,9 +1161,8 @@ subroutine mpp_land_bcast_real(size1,inout) ! real inout(size1) real , dimension(:) :: inout integer ierr, len - call mpi_bcast(inout,size1,MPI_real, & + call MPI_Bcast(inout,size1,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_real subroutine mpp_land_bcast_int2d(inout) @@ -1227,10 +1172,9 @@ subroutine mpp_land_bcast_int2d(inout) length1 = size(inout,1) length2 = size(inout,2) do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & + call MPI_Bcast(inout(:,k),length1,MPI_INTEGER, & IO_id,HYDRO_COMM_WORLD,ierr) end do - return end subroutine mpp_land_bcast_int2d subroutine mpp_land_bcast_real2(inout) @@ -1240,10 +1184,9 @@ subroutine mpp_land_bcast_real2(inout) length1 = size(inout,1) length2 = size(inout,2) do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_real, & + call MPI_Bcast(inout(:,k),length1,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) end do - return end subroutine mpp_land_bcast_real2 subroutine mpp_land_bcast_real3d(inout) @@ -1255,29 +1198,26 @@ subroutine mpp_land_bcast_real3d(inout) length3 = size(inout,3) do k = 1, length3 do j = 1, length2 - call mpi_bcast(inout(:,j,k), length1, MPI_real, & + call MPI_Bcast(inout(:,j,k), length1, MPI_REAL, & IO_id, HYDRO_COMM_WORLD, ierr) end do end do - return end subroutine mpp_land_bcast_real3d subroutine mpp_land_bcast_rd(size,inout) integer size real*8 inout(size) integer ierr - call mpi_bcast(inout,size,MPI_REAL8, & + call MPI_Bcast(inout,size,MPI_REAL8, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_rd subroutine mpp_land_bcast_char(size,inout) integer size character inout(*) integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER, & + call MPI_Bcast(inout,size,MPI_CHARACTER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_char subroutine mpp_land_bcast_char_root(size,inout,rootId) @@ -1285,8 +1225,7 @@ subroutine mpp_land_bcast_char_root(size,inout,rootId) character inout(*) integer, intent(in) :: rootId integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_char_root subroutine mpp_land_bcast_char1d(inout) @@ -1294,9 +1233,8 @@ subroutine mpp_land_bcast_char1d(inout) integer :: lenSize integer :: ierr lenSize = size(inout,1)*len(inout) - call mpi_bcast(inout,lenSize,MPI_CHARACTER, & + call MPI_Bcast(inout,lenSize,MPI_CHARACTER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_char1d subroutine mpp_land_bcast_char1d_root(inout,rootId) @@ -1305,8 +1243,7 @@ subroutine mpp_land_bcast_char1d_root(inout,rootId) integer :: lenSize integer :: ierr lenSize = size(inout,1)*len(inout) - call mpi_bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) - return + call MPI_Bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr) end subroutine mpp_land_bcast_char1d_root subroutine mpp_land_bcast_char1(inout) @@ -1314,9 +1251,8 @@ subroutine mpp_land_bcast_char1(inout) character(len=*) inout integer ierr len = LEN_TRIM(inout) - call mpi_bcast(inout,len,MPI_CHARACTER, & + call MPI_Bcast(inout,len,MPI_CHARACTER, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine mpp_land_bcast_char1 subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) @@ -1329,7 +1265,6 @@ subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - return end subroutine MPP_LAND_COM_REAL subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) @@ -1342,7 +1277,6 @@ subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) - return end subroutine MPP_LAND_COM_REAL8 subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) @@ -1358,7 +1292,6 @@ subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) data = in_out_data + 0 - return end subroutine MPP_LAND_COM_INTEGER @@ -1375,7 +1308,6 @@ subroutine MPP_LAND_COM_INTEGER8(data,NX,NY,flag) call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) data = in_out_data + 0 - return end subroutine MPP_LAND_COM_INTEGER8 subroutine read_restart_3(unit,nz,out) @@ -1386,7 +1318,6 @@ subroutine read_restart_3(unit,nz,out) do i = 1,nz call decompose_data_real (buf3(:,:,i),out(:,:,i)) end do - return end subroutine read_restart_3 subroutine read_restart_2(unit,out) @@ -1399,7 +1330,6 @@ subroutine read_restart_2(unit,out) if(ierr2 .ne. 0) return call decompose_data_real (buf2,out) - return end subroutine read_restart_2 subroutine read_restart_rt_2(unit,out) @@ -1413,7 +1343,6 @@ subroutine read_restart_rt_2(unit,out) call decompose_RT_real(buf2,out, & global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - return end subroutine read_restart_rt_2 subroutine read_restart_rt_3(unit,nz,out) @@ -1429,7 +1358,6 @@ subroutine read_restart_rt_3(unit,nz,out) call decompose_RT_real (buf3(:,:,i),out(:,:,i),& global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) end do - return end subroutine read_restart_rt_3 subroutine write_restart_3(unit,nz,in) @@ -1440,7 +1368,6 @@ subroutine write_restart_3(unit,nz,in) call write_IO_real(in(:,:,i),buf3(:,:,i)) end do if(my_id.eq.IO_id) write(unit) buf3 - return end subroutine write_restart_3 subroutine write_restart_2(unit,in) @@ -1449,7 +1376,6 @@ subroutine write_restart_2(unit,in) in(local_nx,local_ny) call write_IO_real(in,buf2) if(my_id.eq.IO_id) write(unit) buf2 - return end subroutine write_restart_2 subroutine write_restart_rt_2(unit,in) @@ -1458,7 +1384,6 @@ subroutine write_restart_rt_2(unit,in) in(local_rt_nx,local_rt_ny) call write_IO_RT_real(in,buf2) if(my_id.eq.IO_id) write(unit) buf2 - return end subroutine write_restart_rt_2 subroutine write_restart_rt_3(unit,nz,in) @@ -1469,7 +1394,6 @@ subroutine write_restart_rt_3(unit,nz,in) call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) end do if(my_id.eq.IO_id) write(unit) buf3 - return end subroutine write_restart_rt_3 subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) @@ -1496,16 +1420,15 @@ subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) else ! send data to the rest process. size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = nx*ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & + call MPI_Recv(out_buff,size,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_RT_real subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) @@ -1532,16 +1455,15 @@ subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) else ! send data to the rest process. size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + call MPI_Recv(out_buff,size,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_RT_int subroutine decompose_RT_int8 (in_buff,out_buff,g_nx,g_ny,nx,ny) @@ -1568,16 +1490,15 @@ subroutine decompose_RT_int8 (in_buff,out_buff,g_nx,g_ny,nx,ny) else ! send data to the rest process. size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + call MPI_Send(in_buff(ibegin:iend,jbegin:jend),size,& MPI_INTEGER8, i,tag,HYDRO_COMM_WORLD,ierr) end if end do else size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER8,IO_id, & + call MPI_Recv(out_buff,size,MPI_INTEGER8,IO_id, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) end if - return end subroutine decompose_RT_int8 subroutine getNX_NY(nprocs,nx,ny) @@ -1605,7 +1526,6 @@ subroutine getNX_NY(nprocs,nx,ny) end if end if end do - return end subroutine getNX_NY subroutine pack_global_22(in, & @@ -1616,7 +1536,6 @@ subroutine pack_global_22(in, & do i = 1, k call write_IO_real(in(:,:,i),out(:,:,i)) enddo - return end subroutine pack_global_22 @@ -1627,8 +1546,8 @@ subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) integer :: ierr, status integer i - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) + call MPI_Comm_size( HYDRO_COMM_WORLD, numprocs, ierr ) if(numprocs .ne. total_pe) then write(6,*) "FATAL ERROR: In wrf_LAND_set_INIT() - numprocs .ne. total_pe ",numprocs, total_pe @@ -1687,13 +1606,11 @@ subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) enddo call calculate_offset_vectors() - return end subroutine wrf_LAND_set_INIT subroutine getMy_global_id() integer ierr - call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr ) - return + call MPI_Comm_rank( HYDRO_COMM_WORLD, my_id, ierr ) end subroutine getMy_global_id subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) @@ -1897,7 +1814,6 @@ subroutine print_2(unit,in,fm) in(local_nx,local_ny) call write_IO_real(in,buf2) if(my_id.eq.IO_id) write(unit,*) buf2 - return end subroutine print_2 subroutine print_rt_2(unit,in) @@ -1906,7 +1822,6 @@ subroutine print_rt_2(unit,in) in(local_nx,local_ny) call write_IO_real(in,buf2) if(my_id.eq.IO_id) write(unit,*) buf2 - return end subroutine print_rt_2 subroutine mpp_land_max_int1(v) @@ -1919,19 +1834,18 @@ subroutine mpp_land_max_int1(v) if(i .ne. my_id) then !block receive from other node. tag = 101 - call mpi_recv(r1,1,MPI_INTEGER,i, & + call MPI_Recv(r1,1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(max <= r1) max = r1 end if end do else tag = 101 - call mpi_send(v,1,MPI_INTEGER, IO_id, & + call MPI_Send(v,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if call mpp_land_bcast_int1(max) v = max - return end subroutine mpp_land_max_int1 subroutine mpp_land_max_real1(v) @@ -1944,19 +1858,18 @@ subroutine mpp_land_max_real1(v) if(i .ne. my_id) then !block receive from other node. tag = 101 - call mpi_recv(r1,1,MPI_REAL,i, & + call MPI_Recv(r1,1,MPI_REAL,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(max <= r1) max = r1 end if end do else tag = 101 - call mpi_send(v,1,MPI_REAL, IO_id, & + call MPI_Send(v,1,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if call mpp_land_bcast_real1(max) v = max - return end subroutine mpp_land_max_real1 subroutine mpp_same_int1(v) @@ -1968,14 +1881,14 @@ subroutine mpp_same_int1(v) if(i .ne. my_id) then !block receive from other node. tag = 109 - call mpi_recv(r1,1,MPI_INTEGER,i, & + call MPI_Recv(r1,1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(v .ne. r1) v = -99 end if end do else tag = 109 - call mpi_send(v,1,MPI_INTEGER, IO_id, & + call MPI_Send(v,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if call mpp_land_bcast_int1(v) @@ -2014,11 +1927,11 @@ subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) !block receive from other node. tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & + call MPI_Recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,message_len @@ -2047,10 +1960,10 @@ subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) end do else tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 119 - call mpi_send(v,nlinks,MPI_REAL,IO_id, & + call MPI_Send(v,nlinks,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if @@ -2088,11 +2001,11 @@ subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) !block receive from other node. tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,message_len @@ -2121,10 +2034,10 @@ subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) end do else tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & + call MPI_Send(v,nlinks,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if if(allocated(tmp_map)) deallocate(tmp_map) @@ -2162,10 +2075,10 @@ subroutine write_chanel_int8(v,map_l2g,gnlinks,nlinks,g_v) !block receive from other node. tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + call MPI_Recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER8,i, & + call MPI_Recv(tmp_v(1:message_len),message_len,MPI_INTEGER8,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,message_len @@ -2194,10 +2107,10 @@ subroutine write_chanel_int8(v,map_l2g,gnlinks,nlinks,g_v) end do else tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER8,IO_id, & + call MPI_Send(v,nlinks,MPI_INTEGER8,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if if(allocated(tmp_map)) deallocate(tmp_map) @@ -2218,10 +2131,10 @@ subroutine write_lake_real(v,nodelist_in,nlakes) if(i .ne. my_id) then !block receive from other node. tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + call MPI_Recv(nodelist,nlakes,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 139 - call mpi_recv(recv(:),nlakes,MPI_REAL,i, & + call MPI_Recv(recv(:),nlakes,MPI_REAL,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,nlakes @@ -2234,10 +2147,10 @@ subroutine write_lake_real(v,nodelist_in,nlakes) end do else tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + call MPI_Send(nodelist,nlakes,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 139 - call mpi_send(v,nlakes,MPI_REAL,IO_id, & + call MPI_Send(v,nlakes,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if end subroutine write_lake_real @@ -2258,10 +2171,10 @@ subroutine write_lake_char(v,nodelist_in,nlakes) if(i .ne. my_id) then !block receive from other node. tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + call MPI_Recv(nodelist,nlakes,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 139 - call mpi_recv(recv(:),in_len,MPI_CHARACTER,i, & + call MPI_Recv(recv(:),in_len,MPI_CHARACTER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1,nlakes @@ -2274,10 +2187,10 @@ subroutine write_lake_char(v,nodelist_in,nlakes) end do else tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + call MPI_Send(nodelist,nlakes,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 139 - call mpi_send(v,in_len,MPI_CHARACTER,IO_id, & + call MPI_Send(v,in_len,MPI_CHARACTER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if end subroutine write_lake_char @@ -2294,9 +2207,8 @@ subroutine read_rst_crt_r(unit,out,size) 99 continue call mpp_land_bcast_int1(ierr2) if(ierr2 .ne. 0) return - call mpi_bcast(out,size,MPI_REAL, & + call MPI_Bcast(out,size,MPI_REAL, & IO_id,HYDRO_COMM_WORLD,ierr) - return end subroutine read_rst_crt_r subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) @@ -2305,7 +2217,6 @@ subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) real g_cd (gnlinks) call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) write(unit) g_cd - return end subroutine write_rst_crt_r subroutine sum_int1d(vin,nsize) @@ -2317,17 +2228,16 @@ subroutine sum_int1d(vin,nsize) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) vin(:) = vin(:) + recv(:) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vin) - return end subroutine sum_int1d subroutine combine_int1d(vin,nsize, flag) @@ -2339,7 +2249,7 @@ subroutine combine_int1d(vin,nsize, flag) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(recv(k) .ne. flag) then @@ -2349,11 +2259,10 @@ subroutine combine_int1d(vin,nsize, flag) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vin) - return end subroutine combine_int1d subroutine combine_int8_1d(vin,nsize, flag) @@ -2365,7 +2274,7 @@ subroutine combine_int8_1d(vin,nsize, flag) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER8,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER8,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(recv(k) .ne. flag) then @@ -2375,11 +2284,10 @@ subroutine combine_int8_1d(vin,nsize, flag) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER8,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER8,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int8_1d(vin) - return end subroutine combine_int8_1d subroutine sum_real1d(vin,nsize) @@ -2401,19 +2309,18 @@ subroutine sum_real8(vin,nsize) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & + call MPI_Recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) vin(:) = vin(:) + recv(:) endif end do v = vin else - call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & + call MPI_Send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_real(nsize,v) vin = v - return end subroutine sum_real8 ! subroutine get_globalDim(ix,g_ix) @@ -2422,15 +2329,14 @@ end subroutine sum_real8 ! ! if ( my_id .eq. IO_id ) then ! g_ix = ix -! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & +! call MPI_Reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & ! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) ! else -! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & +! call MPI_Reduce( ix, 0, 4, MPI_INTEGER, & ! MPI_SUM, 0, HYDRO_COMM_WORLD, ierr ) ! endif ! call mpp_land_bcast_int1(g_ix) ! -! return ! ! end subroutine get_globalDim @@ -2456,28 +2362,27 @@ subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) if(i .ne. my_id) then !block receive from other node. tag = 202 - call mpi_recv(index_s,2,MPI_INTEGER,i, & + call MPI_Recv(index_s,2,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 203 e = index_s(2) s = index_s(1) size = e - s + 1 - call mpi_recv(vg(s:e),size,MPI_REAL, & + call MPI_Recv(vg(s:e),size,MPI_REAL, & i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) endif end do else tag = 202 - call mpi_send(index_s,2,MPI_INTEGER, IO_id, & + call MPI_Send(index_s,2,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 203 - call mpi_send(vl,size,MPI_REAL,IO_id, & + call MPI_Send(vl,size,MPI_REAL,IO_id, & tag,HYDRO_COMM_WORLD,ierr) end if - return end subroutine gather_1d_real_tmp subroutine sum_real1(inout) @@ -2485,7 +2390,7 @@ subroutine sum_real1(inout) real:: inout, send integer :: ierr send = inout - CALL MPI_ALLREDUCE(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr) + call MPI_Allreduce(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr) end subroutine sum_real1 subroutine sum_double(inout) @@ -2493,8 +2398,8 @@ subroutine sum_double(inout) real*8:: inout, send integer :: ierr send = inout - !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr) - CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr) + !yw call MPI_Allreduce(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr) + call MPI_Allreduce(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr) end subroutine sum_double subroutine mpp_chrt_nlinks_collect(nlinks) @@ -2508,14 +2413,14 @@ subroutine mpp_chrt_nlinks_collect(nlinks) if(my_id .eq. IO_id) then do i = 0,numprocs -1 if(i .ne. my_id) then - call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & + call MPI_Recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) else mpp_nlinks(i+1) = 0 end if end do else - call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & + call MPI_Send(nlinks,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif @@ -2589,13 +2494,13 @@ subroutine mpp_collect_1d_int(nlinks,vinout) if(my_id .eq. IO_id) then do i = 0,numprocs -1 if(i .ne. my_id) then - call mpi_recv(buf,nlinks,MPI_INTEGER,i, & + call MPI_Recv(buf,nlinks,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) vinout = vinout + buf end if end do else - call mpi_send(vinout,nlinks,MPI_INTEGER, IO_id, & + call MPI_Send(vinout,nlinks,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vinout) @@ -2618,11 +2523,11 @@ subroutine mpp_collect_1d_int_mem(nlinks,vinout) do i = 0,numprocs -1 if(i .ne. my_id) then tag = 120 - call mpi_recv(lsize,1,MPI_INTEGER,i, & + call MPI_Recv(lsize,1,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) if(lsize .gt. 0) then tag = 121 - call mpi_recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, & + call MPI_Recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, lsize m = tmpBuf(k) @@ -2641,11 +2546,11 @@ subroutine mpp_collect_1d_int_mem(nlinks,vinout) end if end do tag = 120 - call mpi_send(lsize,1,MPI_INTEGER, IO_id, & + call MPI_Send(lsize,1,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) if(lsize .gt. 0) then tag = 121 - call mpi_send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id, & + call MPI_Send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif endif @@ -2664,12 +2569,12 @@ subroutine updateLake_seqInt(in,nsize,in0) tag = 29 if(my_id .ne. IO_id) then - call mpi_send(in,nsize,MPI_INTEGER, IO_id, & + call MPI_Send(in,nsize,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then - call mpi_recv(tmp,nsize,& + call MPI_Recv(tmp,nsize,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(in0(k) .ne. tmp(k)) in(k) = tmp(k) @@ -2692,12 +2597,12 @@ subroutine updateLake_seqInt8(in,nsize,in0) tag = 29 if(my_id .ne. IO_id) then - call mpi_send(in,nsize,MPI_INTEGER8, IO_id, & + call MPI_Send(in,nsize,MPI_INTEGER8, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then - call mpi_recv(tmp,nsize,& + call MPI_Recv(tmp,nsize,& MPI_INTEGER8,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(in0(k) .ne. tmp(k)) in(k) = tmp(k) @@ -2729,7 +2634,7 @@ subroutine updateLake_seq(in,nsize,in0) allocate(prev(nsize)) if (my_id == IO_id) prev = in0 - call mpi_bcast(prev, nsize, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Bcast(prev, nsize, MPI_REAL, IO_id, HYDRO_COMM_WORLD, ierr) if (my_id == IO_id) then adjustment = in @@ -2737,7 +2642,7 @@ subroutine updateLake_seq(in,nsize,in0) adjustment = in - prev end if - call mpi_allreduce(adjustment, in, nsize, MPI_REAL, MPI_SUM, HYDRO_COMM_WORLD, ierr) ! TODO: check ierr! + call MPI_Allreduce(adjustment, in, nsize, MPI_REAL, MPI_SUM, HYDRO_COMM_WORLD, ierr) ! TODO: check ierr! deallocate(adjustment) deallocate(prev) @@ -2758,12 +2663,12 @@ subroutine updateLake_seq_char(in,nsize,in0) tag = 29 if(my_id .ne. IO_id) then - call mpi_send(in,in_len,MPI_CHARACTER, IO_id, & + call MPI_Send(in,in_len,MPI_CHARACTER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then - call mpi_recv(tmp,in_len,& + call MPI_Recv(tmp,in_len,& MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(in0(k) .ne. tmp(k)) in(k) = tmp(k) @@ -2787,19 +2692,19 @@ subroutine updateLake_grid(in,nsize,lake_index) if(my_id .ne. IO_id) then tag = 29 - call mpi_send(in,nsize,MPI_REAL, IO_id, & + call MPI_Send(in,nsize,MPI_REAL, IO_id, & tag,HYDRO_COMM_WORLD,ierr) tag = 30 - call mpi_send(lake_index,nsize,MPI_INTEGER, IO_id, & + call MPI_Send(lake_index,nsize,MPI_INTEGER, IO_id, & tag,HYDRO_COMM_WORLD,ierr) else do i = 0, numprocs - 1 if(i .ne. IO_id) then tag = 29 - call mpi_recv(tmp,nsize,& + call MPI_Recv(tmp,nsize,& MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) tag = 30 - call mpi_recv(lake_index,nsize,& + call MPI_Recv(lake_index,nsize,& MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(lake_index(k) .gt. 0) in(k) = tmp(k) @@ -2824,7 +2729,7 @@ subroutine match1dLake(vin,nsize,flag) if(my_id .eq. IO_id) then do i = 0, numprocs - 1 if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_INTEGER,i, & + call MPI_Recv(recv,nsize,MPI_INTEGER,i, & tag,HYDRO_COMM_WORLD,mpp_status,ierr) do k = 1, nsize if(recv(k) .eq. flag) vin(k) = flag @@ -2839,25 +2744,23 @@ subroutine match1dLake(vin,nsize,flag) endif end do else - call mpi_send(vin,nsize,MPI_INTEGER,IO_id, & + call MPI_Send(vin,nsize,MPI_INTEGER,IO_id, & tag,HYDRO_COMM_WORLD,ierr) endif call mpp_land_bcast_int1d(vin) - return end subroutine match1dLake subroutine mpp_land_abort() implicit none integer ierr - CALL MPI_ABORT(HYDRO_COMM_WORLD,1,IERR) + call MPI_Abort(HYDRO_COMM_WORLD,1,ierr) end subroutine mpp_land_abort ! mpp_land_abort subroutine mpp_land_sync() implicit none integer ierr - call MPI_barrier( HYDRO_COMM_WORLD ,ierr) + call MPI_Barrier( HYDRO_COMM_WORLD ,ierr) if(ierr .ne. 0) call mpp_land_abort() - return end subroutine mpp_land_sync ! mpp_land_sync subroutine mpp_comm_scalar_real(scalar, fromImage, toImage) @@ -2867,10 +2770,10 @@ subroutine mpp_comm_scalar_real(scalar, fromImage, toImage) integer:: ierr, tag tag=2 if(my_id .eq. fromImage) & - call mpi_send(scalar, 1, MPI_REAL, & + call MPI_Send(scalar, 1, MPI_REAL, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(scalar, 1, MPI_REAL, & + call MPI_Recv(scalar, 1, MPI_REAL, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) end subroutine mpp_comm_scalar_real @@ -2882,10 +2785,10 @@ subroutine mpp_comm_scalar_char(scalar, fromImage, toImage) tag=2 length=len(scalar) if(my_id .eq. fromImage) & - call mpi_send(scalar, length, MPI_CHARACTER, & + call MPI_Send(scalar, length, MPI_CHARACTER, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(scalar, length, MPI_CHARACTER, & + call MPI_Recv(scalar, length, MPI_CHARACTER, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) end subroutine mpp_comm_scalar_char @@ -2897,14 +2800,14 @@ subroutine mpp_comm_1d_real(vector, fromImage, toImage) integer:: ierr, tag integer:: my_id, numprocs tag=2 - call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) - call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) + call MPI_Comm_rank(HYDRO_COMM_WORLD,my_id,ierr) + call MPI_Comm_size(HYDRO_COMM_WORLD,numprocs,ierr) if(numprocs > 1) then if(my_id .eq. fromImage) & - call mpi_send(vector, size(vector), MPI_REAL, & + call MPI_Send(vector, size(vector), MPI_REAL, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(vector, size(vector), MPI_REAL, & + call MPI_Recv(vector, size(vector), MPI_REAL, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) endif end subroutine mpp_comm_1d_real @@ -2917,15 +2820,15 @@ subroutine mpp_comm_1d_char(vector, fromImage, toImage) integer:: ierr, tag, totalLength integer:: my_id,numprocs tag=2 - call MPI_COMM_RANK(HYDRO_COMM_WORLD,my_id,ierr) - call MPI_COMM_SIZE(HYDRO_COMM_WORLD,numprocs,ierr) + call MPI_Comm_rank(HYDRO_COMM_WORLD,my_id,ierr) + call MPI_Comm_size(HYDRO_COMM_WORLD,numprocs,ierr) totalLength=len(vector(1))*size(vector,1) if(numprocs > 1) then if(my_id .eq. fromImage) & - call mpi_send(vector, totalLength, MPI_CHARACTER, & + call MPI_Send(vector, totalLength, MPI_CHARACTER, & toImage, tag, HYDRO_COMM_WORLD, ierr) if(my_id .eq. toImage) & - call mpi_recv(vector, totalLength, MPI_CHARACTER, & + call MPI_Recv(vector, totalLength, MPI_CHARACTER, & fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr) endif end subroutine mpp_comm_1d_char diff --git a/hydro/OrchestratorLayer/config.F90 b/hydro/OrchestratorLayer/config.F90 index 8188579658..e600e1d289 100644 --- a/hydro/OrchestratorLayer/config.F90 +++ b/hydro/OrchestratorLayer/config.F90 @@ -39,6 +39,17 @@ module config_base integer :: glacier_option integer :: surface_resistance_option + character(len=256) :: forcing_name_T + character(len=256) :: forcing_name_Q + character(len=256) :: forcing_name_U + character(len=256) :: forcing_name_V + character(len=256) :: forcing_name_P + character(len=256) :: forcing_name_LW + character(len=256) :: forcing_name_SW + character(len=256) :: forcing_name_PR + character(len=256) :: forcing_name_SN + character(len=256) :: forcing_name_LF + integer :: soil_data_option = 1 integer :: pedotransfer_option = 0 integer :: crop_option = 0 @@ -112,6 +123,7 @@ module config_base character(len=256) :: route_chan_f="" character(len=256) :: route_link_f="" character(len=256) :: route_lake_f="" + integer :: lake_option logical :: reservoir_persistence_usgs logical :: reservoir_persistence_usace character(len=256) :: reservoir_parameter_file="" @@ -212,168 +224,208 @@ subroutine rt_nlst_check(self) ! ! Go through and make some logical checks for each hydro.namelist option. ! ! Some of these checks will depend on specific options chosen by the user. - if( (self%sys_cpl .lt. 1) .or. (self%sys_cpl .gt. 4) ) then + if ( (self%sys_cpl .lt. 1) .or. (self%sys_cpl .gt. 4) ) then call hydro_stop("hydro.namelist ERROR: Invalid sys_cpl value specified.") - endif - if(len(trim(self%geo_static_flnm)) .eq. 0) then + endif + + if (len(trim(self%geo_static_flnm)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a GEO_STATIC_FLNM file.") else inquire(file=trim(self%geo_static_flnm),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: GEO_STATIC_FLNM not found.') endif - if(len(trim(self%geo_finegrid_flnm)) .eq. 0) then + + if (len(trim(self%geo_finegrid_flnm)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a GEO_FINEGRID_FLNM file.") else inquire(file=trim(self%geo_finegrid_flnm),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: GEO_FINEGRID_FLNM not found.') endif + !if(len(trim(self%land_spatial_meta_flnm)) .eq. 0) then ! call hydro_stop("hydro.namelist ERROR: Please specify a LAND_SPATIAL_META_FLNM file.") !else ! inquire(file=trim(self%land_spatial_meta_flnm),exist=fileExists) ! if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: LAND_SPATIAL_META_FLNM not found.') !endif - if(len(trim(self%RESTART_FILE)) .ne. 0) then + + if (len(trim(self%RESTART_FILE)) .ne. 0) then inquire(file=trim(self%RESTART_FILE),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR:= Hydro RESTART_FILE not found.') endif - if(self%igrid .le. 0) call hydro_stop('hydro.namelist ERROR: Invalid IGRID specified.') - if(self%out_dt .le. 0) call hydro_stop('hydro_namelist ERROR: Invalid out_dt specified.') - if( (self%split_output_count .lt. 0 ) .or. (self%split_output_count .gt. 1) ) then + + if (self%igrid .le. 0) call hydro_stop('hydro.namelist ERROR: Invalid IGRID specified.') + + if (self%out_dt .le. 0) call hydro_stop('hydro_namelist ERROR: Invalid out_dt specified.') + + if ((self%split_output_count .lt. 0 ) .or. (self%split_output_count .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid SPLIT_OUTPUT_COUNT specified') endif - if( (self%rst_typ .lt. 0 ) .or. (self%rst_typ .gt. 1) ) then + + if ((self%rst_typ .lt. 0 ) .or. (self%rst_typ .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid rst_typ specified') endif - if( (self%rst_bi_in .lt. 0 ) .or. (self%rst_bi_in .gt. 1) ) then + + if ((self%rst_bi_in .lt. 0 ) .or. (self%rst_bi_in .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid rst_bi_in specified') endif - if( (self%rst_bi_out .lt. 0 ) .or. (self%rst_bi_out .gt. 1) ) then + + if ((self%rst_bi_out .lt. 0 ) .or. (self%rst_bi_out .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid rst_bi_out specified') endif - if( (self%RSTRT_SWC .lt. 0 ) .or. (self%RSTRT_SWC .gt. 1) ) then + + if ((self%RSTRT_SWC .lt. 0 ) .or. (self%RSTRT_SWC .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid RSTRT_SWC specified') endif - if( (self%GW_RESTART .lt. 0 ) .or. (self%GW_RESTART .gt. 1) ) then + + if ((self%GW_RESTART .lt. 0 ) .or. (self%GW_RESTART .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid GW_RESTART specified') endif - if( (self%order_to_write .lt. 1 ) .or. (self%order_to_write .gt. 12) ) then + + if ((self%order_to_write .lt. 1 ) .or. (self%order_to_write .gt. 12) ) then call hydro_stop('hydro.namelist ERROR: Invalid order_to_write specified') endif - if( (self%io_form_outputs .lt. 0 ) .or. (self%io_form_outputs .gt. 4) ) then + + if ((self%io_form_outputs .lt. 0 ) .or. (self%io_form_outputs .gt. 4) ) then call hydro_stop('hydro.namelist ERROR: Invalid io_form_outputs specified') endif - if( (self%io_config_outputs .lt. 0 ) .or. (self%io_config_outputs .gt. 6) ) then + + if ((self%io_config_outputs .lt. 0 ) .or. (self%io_config_outputs .gt. 6) ) then call hydro_stop('hydro.namelist ERROR: Invalid io_config_outputs specified') endif - if( (self%t0OutputFlag .lt. 0 ) .or. (self%t0OutputFlag .gt. 1) ) then + + if ((self%t0OutputFlag .lt. 0 ) .or. (self%t0OutputFlag .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid t0OutputFlag specified') endif - if( (self%output_channelBucket_influx .lt. 0 ) .or. (self%output_channelBucket_influx .gt. 3) ) then + + if ((self%output_channelBucket_influx .lt. 0 ) .or. (self%output_channelBucket_influx .gt. 3) ) then call hydro_stop('hydro.namelist ERROR: Invalid output_channelBucket_influx specified') endif - if( (self%CHRTOUT_DOMAIN .lt. 0 ) .or. (self%CHRTOUT_DOMAIN .gt. 1) ) then + + if ((self%CHRTOUT_DOMAIN .lt. 0 ) .or. (self%CHRTOUT_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHRTOUT_DOMAIN specified') endif - if( (self%CHANOBS_DOMAIN .lt. 0 ) .or. (self%CHANOBS_DOMAIN .gt. 1) ) then + + if ((self%CHANOBS_DOMAIN .lt. 0 ) .or. (self%CHANOBS_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHANOBS_DOMAIN specified') endif - if( (self%CHRTOUT_GRID .lt. 0 ) .or. (self%CHRTOUT_GRID .gt. 1) ) then + + if ((self%CHRTOUT_GRID .lt. 0 ) .or. (self%CHRTOUT_GRID .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHRTOUT_GRID specified') endif - if( (self%LSMOUT_DOMAIN .lt. 0 ) .or. (self%LSMOUT_DOMAIN .gt. 1) ) then + + if ((self%LSMOUT_DOMAIN .lt. 0 ) .or. (self%LSMOUT_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid LSMOUT_DOMAIN specified') endif - if( (self%RTOUT_DOMAIN .lt. 0 ) .or. (self%RTOUT_DOMAIN .gt. 1) ) then + + if ((self%RTOUT_DOMAIN .lt. 0 ) .or. (self%RTOUT_DOMAIN .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid RTOUT_DOMAIN specified') endif - if( (self%output_gw .lt. 0 ) .or. (self%output_gw .gt. 2) ) then + + if ((self%output_gw .lt. 0 ) .or. (self%output_gw .gt. 2) ) then call hydro_stop('hydro.namelist ERROR: Invalid output_gw specified') endif - if( (self%outlake .lt. 0 ) .or. (self%outlake .gt. 2) ) then + + if ((self%outlake .lt. 0 ) .or. (self%outlake .gt. 2) ) then call hydro_stop('hydro.namelist ERROR: Invalid outlake specified') endif - if( (self%frxst_pts_out .lt. 0 ) .or. (self%frxst_pts_out .gt. 1) ) then + + if ((self%frxst_pts_out .lt. 0 ) .or. (self%frxst_pts_out .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid frxst_pts_out specified') endif - if(self%TERADJ_SOLAR .ne. 0) then + + if (self%TERADJ_SOLAR .ne. 0) then call hydro_stop('hydro.namelist ERROR: Invalid TERADJ_SOLAR specified') endif ! The default value of nsoil == -999. When channel-only is used, ! nsoil == -999999. In the case of channel-only, skip following block of code. - if(self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then + if (self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then call hydro_stop('hydro.namelist ERROR: Invalid NSOIL specified.') endif + do i = 1,self%NSOIL - if(self%ZSOIL8(i) .gt. 0) then + if (self%ZSOIL8(i) .gt. 0) then call hydro_stop('hydro.namelist ERROR: Invalid ZSOIL layer depth specified.') endif - if(i .gt. 1) then - if(self%ZSOIL8(i) .ge. self%ZSOIL8(i-1)) then + if (i .gt. 1) then + if (self%ZSOIL8(i) .ge. self%ZSOIL8(i-1)) then call hydro_stop('hydro.namelist ERROR: Invalid ZSOIL layer depth specified.') endif endif end do - if(self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then + if (self%NSOIL .le. 0 .and. self%NSOIL .ne. -999999) then call hydro_stop('hydro.namelist ERROR: Invalid NSOIL specified.') endif - if(self%dxrt0 .le. 0) then + if (self%dxrt0 .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid DXRT specified.') endif - if(self%AGGFACTRT .le. 0) then + + if (self%AGGFACTRT .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid AGGFACTRT specified.') endif - if(self%DTRT_CH .le. 0) then + + if (self%DTRT_CH .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid DTRT_CH specified.') endif - if(self%DTRT_TER .le. 0) then + + if (self%DTRT_TER .le. 0) then call hydro_stop('hydro.namelist ERROR: Invalid DTRT_TER specified.') endif - if( (self%SUBRTSWCRT .lt. 0 ) .or. (self%SUBRTSWCRT .gt. 1) ) then + + if ((self%SUBRTSWCRT .lt. 0 ) .or. (self%SUBRTSWCRT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid SUBRTSWCRT specified') endif - if( (self%OVRTSWCRT .lt. 0 ) .or. (self%OVRTSWCRT .gt. 1) ) then + + if ((self%OVRTSWCRT .lt. 0 ) .or. (self%OVRTSWCRT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid OVRTSWCRT specified') endif - if( (self%OVRTSWCRT .eq. 1 ) .or. (self%SUBRTSWCRT .eq. 1) ) then + + if ((self%OVRTSWCRT .eq. 1 ) .or. (self%SUBRTSWCRT .eq. 1) ) then if( (self%rt_option .lt. 1 ) .or. (self%rt_option .gt. 2) ) then !if(self%rt_option .ne. 1) then call hydro_stop('hydro.namelist ERROR: Invalid rt_option specified') endif endif - if( (self%CHANRTSWCRT .lt. 0 ) .or. (self%CHANRTSWCRT .gt. 1) ) then + + if ((self%CHANRTSWCRT .lt. 0 ) .or. (self%CHANRTSWCRT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid CHANRTSWCRT specified') endif - if(self%CHANRTSWCRT .eq. 1) then - if ( self%channel_option .eq. 5 ) then + + if (self%CHANRTSWCRT .eq. 1) then + if (self%channel_option .eq. 5 ) then self%channel_option = 2 self%channel_bypass = .TRUE. endif - if( (self%channel_option .lt. 1 ) .or. (self%channel_option .gt. 3) ) then + if ((self%channel_option .lt. 1 ) .or. (self%channel_option .gt. 3) ) then call hydro_stop('hydro.namelist ERROR: Invalid channel_option specified') endif endif - if( (self%CHANRTSWCRT .eq. 1) .and. (self%channel_option .lt. 3) ) then - if(len(trim(self%route_link_f)) .eq. 0) then + + if ((self%CHANRTSWCRT .eq. 1) .and. (self%channel_option .lt. 3) ) then + if (len(trim(self%route_link_f)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a route_link_f file.") else inquire(file=trim(self%route_link_f),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: route_link_f not found.') endif endif - if( (self%bucket_loss .lt. 0 ) .or. (self%bucket_loss .gt. 1) ) then + + if ((self%bucket_loss .lt. 0 ) .or. (self%bucket_loss .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid bucket_loss specified') endif - if( (self%bucket_loss .eq. 1 ) .and. (self%UDMP_OPT .ne. 1) ) then + + if ((self%bucket_loss .eq. 1 ) .and. (self%UDMP_OPT .ne. 1) ) then call hydro_stop('hydro.namelist ERROR: Bucket loss only available when UDMP=1') endif - if( (self%GWBASESWCRT .lt. 0 ) .or. (self%GWBASESWCRT .gt. 4) ) then + + if ((self%GWBASESWCRT .lt. 0 ) .or. (self%GWBASESWCRT .gt. 4) ) then call hydro_stop('hydro.namelist ERROR: Invalid GWBASESWCRT specified') endif - if( (self%GWBASESWCRT .eq. 1 ) .or. (self%GWBASESWCRT .eq. 4) ) then + + if ((self%GWBASESWCRT .eq. 1 ) .or. (self%GWBASESWCRT .eq. 4) ) then if(len(trim(self%GWBUCKPARM_file)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a GWBUCKPARM_file file.") else @@ -381,7 +433,8 @@ subroutine rt_nlst_check(self) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: GWBUCKPARM_file not found.') endif endif - if( (self%GWBASESWCRT .gt. 0) .and. (self%UDMP_OPT .ne. 1) ) then + + if ((self%GWBASESWCRT .gt. 0) .and. (self%UDMP_OPT .ne. 1) ) then if(len(trim(self%gwbasmskfil)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a gwbasmskfil file.") else @@ -389,10 +442,12 @@ subroutine rt_nlst_check(self) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: gwbasmskfil not found.') endif endif - if( (self%UDMP_OPT .lt. 0 ) .or. (self%UDMP_OPT .gt. 1) ) then + + if ((self%UDMP_OPT .lt. 0 ) .or. (self%UDMP_OPT .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid UDMP_OPT specified') endif - if(self%UDMP_OPT .gt. 0) then + + if (self%UDMP_OPT .gt. 0) then if(len(trim(self%udmap_file)) .eq. 0) then call hydro_stop("hydro.namelist ERROR: Please specify a udmap_file file.") else @@ -400,70 +455,78 @@ subroutine rt_nlst_check(self) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: udmap_file not found.') endif endif - if( (self%UDMP_OPT .eq. 1) .and. (self%CHANRTSWCRT .eq. 0) ) then + + if ((self%UDMP_OPT .eq. 1) .and. (self%CHANRTSWCRT .eq. 0) ) then call hydro_stop('hydro.namelist ERROR: User-defined mapping requires channel routing on.') endif - if(self%outlake .ne. 0) then - if(len(trim(self%route_lake_f)) .eq. 0) then - call hydro_stop('hydro.namelist ERROR: You MUST specify a route_lake_f to ouptut and run lakes.') + + if ((self%outlake .ne. 0) .or. (self%lake_option > 0)) then + if (len(trim(self%route_lake_f)) .eq. 0) then + call hydro_stop('hydro.namelist ERROR: You MUST specify a route_lake_f to output and/or run lakes.') endif endif - if(len(trim(self%route_lake_f)) .ne. 0) then + + if (len(trim(self%route_lake_f)) .ne. 0) then inquire(file=trim(self%route_lake_f),exist=fileExists) - if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: route_lake_f not found.') + if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: specified route_lake_f ('//trim(self%route_lake_f)//') not found.') endif - if((self%channel_option .eq. 3) .and. (self%compound_channel)) then + if ((self%channel_option .eq. 3) .and. (self%compound_channel)) then call hydro_stop("Compound channel option not available for diffusive wave routing. ") end if - if(self%reservoir_type_specified) then - if(len(trim(self%reservoir_parameter_file)) .eq. 0) then + if ((self%lake_option .lt. 0) .or. (self%lake_option .gt. 3)) then + print *, self%lake_option + call hydro_stop("Lake Option must be 0 [lakes off], 1 [level pool], or 2 [passthrough], or 3 [reservoir DA]") + end if + + if (self%reservoir_type_specified) then + if (len(trim(self%reservoir_parameter_file)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_parameter_file for & inputs to reservoirs that are not level pool type.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if(self%reservoir_persistence_usgs) then - if(len(trim(self%reservoir_usgs_timeslice_path)) .eq. 0) then + if (self%reservoir_persistence_usgs) then + if (len(trim(self%reservoir_usgs_timeslice_path)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_usgs_timeslice_path for & reservoir USGS persistence capability.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if(self%reservoir_persistence_usace) then - if(len(trim(self%reservoir_usace_timeslice_path)) .eq. 0) then + if (self%reservoir_persistence_usace) then + if (len(trim(self%reservoir_usace_timeslice_path)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_usace_timeslice_path for & reservoir USACE persistence capability.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if(self%reservoir_rfc_forecasts) then - if(len(trim(self%reservoir_parameter_file)) .eq. 0) then + if (self%reservoir_rfc_forecasts) then + if (len(trim(self%reservoir_parameter_file)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_parameter_file for inputs to rfc forecast type reservoirs.') endif - if(len(trim(self%reservoir_rfc_forecasts_time_series_path)) .eq. 0) then + if (len(trim(self%reservoir_rfc_forecasts_time_series_path)) .eq. 0) then call hydro_stop('hydro.namelist ERROR: You MUST specify a reservoir_rfc_forecasts_time_series_path for reservoir rfc forecast capability.') endif - if(len(trim(self%reservoir_parameter_file)) .ne. 0) then + if (len(trim(self%reservoir_parameter_file)) .ne. 0) then inquire(file=trim(self%reservoir_parameter_file),exist=fileExists) if (.not. fileExists) call hydro_stop('hydro.namelist ERROR: reservoir_parameter_file not found.') endif end if - if( (self%imperv_adj .lt. 0 ) .or. (self%imperv_adj .gt. 1) ) then + if ((self%imperv_adj .lt. 0 ) .or. (self%imperv_adj .gt. 1) ) then call hydro_stop('hydro.namelist ERROR: Invalid imperv_adj specified') endif @@ -475,6 +538,8 @@ subroutine init_namelist_rt_field(did) integer, intent(in) :: did integer ierr + character(len=512) :: msg + integer:: RT_OPTION, CHANRTSWCRT, channel_option, & SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & @@ -488,6 +553,7 @@ subroutine init_namelist_rt_field(did) logical :: compound_channel integer :: channel_loss_option = 0 character(len=256) :: route_lake_f="" + integer :: lake_option !0: lakes off 1: level pool 2: passthrough, 3: reservoir da logical :: reservoir_persistence_usgs logical :: reservoir_persistence_usace character(len=256) :: reservoir_parameter_file="" @@ -562,11 +628,8 @@ subroutine init_namelist_rt_field(did) SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt_ter,dtrt_ch,dxrt,& GwSpinCycles, GwPreCycles, GwSpinUp, GwPreDiag, GwPreDiagInterval, gwIhShift, & GWBASESWCRT, gwChanCondSw, gwChanCondConstIn, gwChanCondConstOut , & - route_topo_f,route_chan_f,route_link_f, compound_channel, channel_loss_option, route_lake_f, & - reservoir_persistence_usgs, reservoir_persistence_usace, reservoir_parameter_file, reservoir_usgs_timeslice_path, & - reservoir_usace_timeslice_path, reservoir_observation_lookback_hours, reservoir_observation_update_time_interval_seconds, & - reservoir_rfc_forecasts, reservoir_rfc_forecasts_time_series_path, reservoir_rfc_forecasts_lookback_hours, & - reservoir_type_specified, route_direction_f,route_order_f,gwbasmskfil, & + route_topo_f,route_chan_f,route_link_f, compound_channel, channel_loss_option, lake_option, route_lake_f, & + route_direction_f,route_order_f,gwbasmskfil, & geo_finegrid_flnm, gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, & order_to_write , rst_typ, rst_bi_in, rst_bi_out, gwsoilcpl, & CHRTOUT_DOMAIN,CHANOBS_DOMAIN,CHRTOUT_GRID,LSMOUT_DOMAIN,& @@ -574,6 +637,12 @@ subroutine init_namelist_rt_field(did) frxst_pts_out, udmap_file, UDMP_OPT, GWBUCKPARM_file, bucket_loss, & io_config_outputs, io_form_outputs, hydrotbl_f, t0OutputFlag, output_channelBucket_influx, imperv_adj + namelist /reservoir_nlist/ & + reservoir_persistence_usgs, reservoir_persistence_usace, reservoir_parameter_file, reservoir_usgs_timeslice_path, & + reservoir_usace_timeslice_path, reservoir_observation_lookback_hours, reservoir_observation_update_time_interval_seconds, & + reservoir_rfc_forecasts, reservoir_rfc_forecasts_time_series_path, reservoir_rfc_forecasts_lookback_hours, & + reservoir_type_specified + #ifdef WRF_HYDRO_NUDGING namelist /NUDGING_nlist/ nudgingParamFile, netwkReExFile, & readTimesliceParallel, temporalPersistence, & @@ -601,6 +670,7 @@ subroutine init_namelist_rt_field(did) compound_channel = .FALSE. channel_loss_option = 0 bucket_loss = 0 + lake_option = -99 reservoir_persistence_usgs = .FALSE. reservoir_persistence_usace = .FALSE. reservoir_observation_lookback_hours = 18 @@ -635,17 +705,23 @@ subroutine init_namelist_rt_field(did) #else open(12, form="FORMATTED") #endif - read(12, HYDRO_nlist, iostat=ierr) - if(ierr .ne. 0) call hydro_stop("HYDRO_nlst namelist error in read_rt_nlst") + read(12, HYDRO_nlist, iostat=ierr, iomsg=msg) + if(ierr .ne. 0) call hydro_stop("HYDRO_nlst namelist error in read_rt_nlst: " // trim(msg)) + + if (lake_option == 3) then + read(12, reservoir_nlist, iostat=ierr, iomsg=msg) + if (ierr /= 0) call hydro_stop("reservoir_nlist namelist error in read_rt_nlst: " // trim(msg)) + end if #ifdef WRF_HYDRO_NUDGING - read(12, NUDGING_nlist, iostat=ierr) - if(ierr .ne. 0) call hydro_stop("NUDGING_nlst namelist error in read_rt_nlst") + read(12, NUDGING_nlist, iostat=ierr, iomsg=msg) + if(ierr .ne. 0) call hydro_stop("NUDGING_nlst namelist error in read_rt_nlst: " // trim(msg)) !! Conditional default values for nuding_nlist if(maxAgePairsBiasPersist .eq. -99999) maxAgePairsBiasPersist = -1*nLastObs #endif close(12) - if (sys_cpl == 1) call read_crocus_namelist(crocus_opts) + + call read_crocus_namelist(crocus_opts) ! #ifdef MPP_LAND ! endif ! #endif @@ -683,6 +759,21 @@ subroutine init_namelist_rt_field(did) nlst(did)%SOLVEG_INITSWC = SOLVEG_INITSWC nlst(did)%reservoir_obs_dir = "testDirectory" + if ((lake_option == 3) .and. (reservoir_persistence_usgs .or. reservoir_persistence_usace .or. reservoir_rfc_forecasts)) then + reservoir_type_specified = .TRUE. + lake_option = 1 + end if + + if (lake_option == -99) then + if (route_lake_f /= "") then + print *, "WARNING: lake_option not specified, but route_lake_f specified. Setting lake_option to 1." + lake_option = 1 + else + lake_option = 0 + end if + end if + + nlst(did)%lake_option = lake_option nlst(did)%reservoir_persistence_usgs = reservoir_persistence_usgs nlst(did)%reservoir_persistence_usace = reservoir_persistence_usace nlst(did)%reservoir_parameter_file = reservoir_parameter_file @@ -694,10 +785,6 @@ subroutine init_namelist_rt_field(did) nlst(did)%reservoir_rfc_forecasts_time_series_path = reservoir_rfc_forecasts_time_series_path nlst(did)%reservoir_rfc_forecasts_lookback_hours = reservoir_rfc_forecasts_lookback_hours - if (reservoir_persistence_usgs .or. reservoir_persistence_usace .or. reservoir_rfc_forecasts) then - reservoir_type_specified = .TRUE. - end if - nlst(did)%reservoir_type_specified = reservoir_type_specified write(nlst(did)%hgrid,'(I1)') igrid @@ -827,6 +914,12 @@ subroutine init_namelist_rt_field(did) nlst(did)%noConstInterfBias = noConstInterfBias #endif + ! if lakes have been disabled (lake_option == 0), clear the route_lake_f and output_lakes options + if (nlst(did)%lake_option == 0) then + nlst(did)%route_lake_f = '' + nlst(did)%outlake = 0 + end if + call nlst(did)%check() ! derive rtFlag @@ -888,6 +981,16 @@ subroutine init_noah_lsm_and_wrf_hydro() character(len=256) :: restart_filename_requested = " " integer :: restart_frequency_hours integer :: output_timestep + character(len=256) :: forcing_name_T = "T2D" + character(len=256) :: forcing_name_Q = "Q2D" + character(len=256) :: forcing_name_U = "U2D" + character(len=256) :: forcing_name_V = "V2D" + character(len=256) :: forcing_name_P = "PSFC" + character(len=256) :: forcing_name_LW = "LWDOWN" + character(len=256) :: forcing_name_SW = "SWDOWN" + character(len=256) :: forcing_name_PR = "RAINRATE" + character(len=256) :: forcing_name_SN = "" + character(len=256) :: forcing_name_LF = "" integer :: dynamic_veg_option integer :: canopy_stomatal_resistance_option integer :: btr_option @@ -932,6 +1035,9 @@ subroutine init_noah_lsm_and_wrf_hydro() outdir, & restart_filename_requested, restart_frequency_hours, output_timestep, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN,forcing_name_LF, & + dynamic_veg_option, canopy_stomatal_resistance_option, & btr_option, runoff_option, surface_drag_option, supercooled_water_option, & frozen_soil_option, radiative_transfer_option, snow_albedo_option, & @@ -1030,6 +1136,16 @@ subroutine init_noah_lsm_and_wrf_hydro() noah_lsm%restart_filename_requested = restart_filename_requested noah_lsm%restart_frequency_hours = restart_frequency_hours noah_lsm%output_timestep = output_timestep + noah_lsm%forcing_name_T = forcing_name_T + noah_lsm%forcing_name_Q = forcing_name_Q + noah_lsm%forcing_name_U = forcing_name_U + noah_lsm%forcing_name_V = forcing_name_V + noah_lsm%forcing_name_P = forcing_name_P + noah_lsm%forcing_name_LW = forcing_name_LW + noah_lsm%forcing_name_SW = forcing_name_SW + noah_lsm%forcing_name_PR = forcing_name_PR + noah_lsm%forcing_name_SN = forcing_name_SN + noah_lsm%forcing_name_LF = forcing_name_LF noah_lsm%dynamic_veg_option = dynamic_veg_option noah_lsm%canopy_stomatal_resistance_option = canopy_stomatal_resistance_option noah_lsm%btr_option = btr_option diff --git a/hydro/Routing/Noah_distr_routing.F90 b/hydro/Routing/Noah_distr_routing.F90 index 46631cd67b..3de5c5339b 100644 --- a/hydro/Routing/Noah_distr_routing.F90 +++ b/hydro/Routing/Noah_distr_routing.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - !DJG ------------------------------------------------ !DJG SUBROUTINE RT_PARM !DJG ------------------------------------------------ @@ -147,7 +127,6 @@ SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY) IXX8 = I-1 JYY8 = J+1 call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) - RETURN END SUBROUTINE GETMAX8DIR SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox & @@ -207,7 +186,6 @@ SUBROUTINE GETSUB8(I, J, XX, YY, wattbl, terrslpNeighbors, distNeighbors, & terrslpNeighbors(I,J,neighIndx), distNeighbors(neighIndx), & maxneighI, maxneighJ, maxneighIndx, maxneighSlp) enddo - RETURN END SUBROUTINE GETSUB8 SUBROUTINE GETSUB8DIR(I, J, selfWattbl, & @@ -341,7 +319,6 @@ SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) SHORT = SOLDN - return end SUBROUTINE TER_ADJ_SOL !DJG----------------------------------------------------------------------- !DJG END SUBROUTINE TER_ADJ_SOL @@ -507,7 +484,6 @@ subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) end do !i-loop end do !j-loop - return end subroutine !DJG----------------------------------------------------------------------- @@ -542,7 +518,6 @@ subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) JULDAY = LPJULM(MM) + DD end if - RETURN END subroutine JULDAY_CALC !DJG----------------------------------------------------------------------- !DJG END SUBROUTINE JULDAY @@ -595,7 +570,6 @@ subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) END DO END DO - RETURN END subroutine SLOPE_ASPECT !DJG----------------------------------------------------------------------- !DJG END SUBROUTINE SLOPE_ASPECT @@ -761,7 +735,6 @@ SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & END IF ! End if for daily vs instantaneous values... !DJG----------------------------------------------------------------------- - RETURN END SUBROUTINE SOLSUB !DJG----------------------------------------------------------------------- @@ -833,7 +806,6 @@ subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) enddo enddo Vmax = TANH(Vmax) - return end subroutine seq_land_SO8 #ifdef MPP_LAND @@ -870,7 +842,6 @@ subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& endif call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) call decompose_data_real(g_Vmax,Vmax) - return end subroutine MPP_seq_land_SO8 #endif @@ -1335,5 +1306,4 @@ subroutine time_seconds(i3) call date_and_time(values=time_array) i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & time_array(7) + 0.001 * time_array(8) - return end subroutine time_seconds diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 index 6e82367516..02bce4f985 100644 --- a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 +++ b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool.F90 @@ -56,7 +56,8 @@ module module_levelpool subroutine levelpool_init(this, water_elevation, & lake_area, weir_elevation, weir_coeffecient, & weir_length, dam_length, orifice_elevation, orifice_coefficient, & - orifice_area, max_depth, lake_number) + orifice_area, max_depth, lake_number, lake_opt) + implicit none class(levelpool), intent(inout) :: this ! object being initialized real, intent(inout) :: water_elevation ! meters AMSL @@ -69,7 +70,9 @@ subroutine levelpool_init(this, water_elevation, & real, intent(in) :: orifice_coefficient ! orifice coefficient real, intent(in) :: orifice_area ! orifice area (meters^2) real, intent(in) :: max_depth ! max depth of reservoir before overtop (meters) - integer(kind=int64), intent(in) :: lake_number ! lake number + integer(kind=int64), intent(in) :: lake_number ! lake number + integer, intent(in) :: lake_opt ! bypass lake physics (2 to use pass-through) + character(len=15) :: lake_number_string #ifdef RESERVOIR_D @@ -114,7 +117,7 @@ subroutine levelpool_init(this, water_elevation, & call this%properties%init( lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, & orifice_elevation, orifice_coefficient, & - orifice_area, max_depth, lake_number ) + orifice_area, max_depth, lake_number, lake_opt ) end if this%pointer_allocation_guard = .true. @@ -169,6 +172,7 @@ subroutine run_levelpool_reservoir(this, previous_timestep_inflow, inflow, & this%state%water_elevation = water_elevation call LEVELPOOL_PHYSICS(this%properties%lake_number, & + this%properties%lake_opt, & previous_timestep_inflow, & this%input%inflow, & this%output%outflow, & @@ -217,7 +221,7 @@ end subroutine run_levelpool_reservoir ! SUBROUTINE LEVELPOOL ! ------------------------------------------------ - subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa) + subroutine LEVELPOOL_PHYSICS(ln,lake_opt,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa) !! ---------------------------- argument variables !! All elevations should be relative to a common base (often belev(k)) @@ -238,9 +242,8 @@ subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa real, intent(IN) :: oa ! orifice area (m^2) real, intent(IN) :: maxh ! max depth of reservoir before overtop (m) integer(kind=int64), intent(IN) :: ln ! lake number + integer, intent(in) :: lake_opt ! reservoir physics options (1: levelpool, 2: passthrough) - !!DJG Add lake option switch here...move up to namelist in future versions... - integer :: LAKE_OPT ! Lake model option (move to namelist later) real :: Htmp ! Temporary assign of incoming lake el. (m) !! ---------------------------- local variables @@ -254,22 +257,20 @@ subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa !! ---------------------------- subroutine body: from chow, mad mays. pg. 252 !! -- determine from inflow hydrograph - - !!DJG Set hardwire for LAKE_OPT...move specification of this to namelist in - !future versions... - LAKE_OPT = 2 Htmp = H !temporary set of incoming lake water elevation... !hdiff_vol = 0.0 !qdiff_vol = 0.0 !!DJG IF-block for lake model option 1 - outflow=inflow, 2 - Chow et al level !pool, ..... - if (LAKE_OPT == 1) then ! If-block for simple pass through scheme.... - + if (LAKE_OPT == 2) then ! If-block for simple pass through scheme.... +#ifdef RESERVOIR_D + write(6,*) "LEVELPOOL LAKE_OPT=2, using reservoir passthrough" +#endif qo1 = qi1 ! Set outflow equal to inflow at current time H = Htmp ! Set new lake water elevation to incoming lake el. - else if (LAKE_OPT == 2) then ! If-block for Chow et al level pool scheme + else if (LAKE_OPT == 1) then ! If-block for Chow et al level pool scheme It = qi0 Itdt_3 = qi0 + ((qi1 + ql - qi0) * 0.33) @@ -406,6 +407,7 @@ subroutine LEVELPOOL_PHYSICS(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,dl,oe,oc,oa else ! ELSE for LAKE_OPT.... + call hydro_stop("Invalid lake option supplied to LEVELPOOL_PHYSICS()") endif ! ENDIF for LAKE_OPT.... return diff --git a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 index 0e4a9dfc00..7f6b5e0ca7 100644 --- a/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 +++ b/hydro/Routing/Reservoirs/Level_Pool/module_levelpool_properties.F90 @@ -23,6 +23,7 @@ module module_levelpool_properties real :: orifice_area ! orifice area (meters^2) real :: max_depth ! max depth of reservoir before overtop (meters) integer(kind=int64) :: lake_number ! lake number + integer :: lake_opt ! reservoir physics options (1: levelpool, 2: passthrough) contains @@ -36,7 +37,7 @@ module module_levelpool_properties !Level Pool Properties Constructor subroutine levelpool_properties_init(this, lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, orifice_elevation, & - orifice_coefficient, orifice_area, max_depth, lake_number) + orifice_coefficient, orifice_area, max_depth, lake_number, lake_opt) implicit none class(levelpool_properties_interface), intent(inout) :: this ! the type object being initialized real, intent(in) :: lake_area ! area of lake (km^2) @@ -49,6 +50,7 @@ subroutine levelpool_properties_init(this, lake_area, & real, intent(in) :: orifice_area ! orifice area (meters^2) real, intent(in) :: max_depth ! max depth of reservoir before overtop (meters) integer(kind=int64), intent(in) :: lake_number ! lake number + integer :: lake_opt ! reservoir physics options (1: levelpool, 2: passthrough) ! Assign the values passed in to a particular level pool reservoir ! properties object's variables. @@ -62,6 +64,7 @@ subroutine levelpool_properties_init(this, lake_area, & this%max_depth = max_depth this%lake_number = lake_number this%dam_length = dam_length + this%lake_opt = lake_opt end subroutine levelpool_properties_init diff --git a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 index 6d4b599b7e..2c475333ab 100644 --- a/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 +++ b/hydro/Routing/Reservoirs/Persistence_Level_Pool_Hybrid/module_persistence_levelpool_hybrid.F90 @@ -201,7 +201,7 @@ subroutine hybrid_init(this, water_elevation, & ! Initialize level pool reservoir call this%state%levelpool_ptr%init(water_elevation, lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, orifice_elevation, & - orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number) + orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number, 1) end if end subroutine hybrid_init diff --git a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 index d78d056f8f..127d2badb0 100644 --- a/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 +++ b/hydro/Routing/Reservoirs/RFC_Forecasts/module_rfc_forecasts.F90 @@ -156,7 +156,7 @@ subroutine rfc_forecasts_init(this, water_elevation, & ! Initialize level pool reservoir call this%state%levelpool_ptr%init(water_elevation, lake_area, & weir_elevation, weir_coeffecient, weir_length, dam_length, orifice_elevation, & - orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number) + orifice_coefficient, orifice_area, lake_max_water_elevation, lake_number, 1) ! Call to initialize time series data object call time_series_data%init(start_date, time_series_path, forecast_lookback_hours, & diff --git a/hydro/Routing/module_GW_baseflow.F90 b/hydro/Routing/module_GW_baseflow.F90 index 0ad973bb60..34c346a078 100644 --- a/hydro/Routing/module_GW_baseflow.F90 +++ b/hydro/Routing/module_GW_baseflow.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_GW_baseflow ! use overland_data @@ -234,7 +214,7 @@ subroutine simp_gw_buck_nhd( & if (bucket_loss .eq. 1) then qloss_gwsubbas(bas) = qout_gwsubbas(bas)*loss_fraction(bas) - qout_gwsubbas(bas) = qout_gwsubbas(bas)-qloss_gwsubbas(bas) + qout_gwsubbas(bas) = qout_gwsubbas(bas)-qloss_gwsubbas(bas) endif elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket @@ -251,7 +231,7 @@ subroutine simp_gw_buck_nhd( & !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (bucket_loss .eq. 1) then - z_gwsubbas(bas) = z_gwsubbas(bas) - (qout_gwsubbas(bas)+qloss_gwsubbas(bas))*DT/( basns_area(bas) ) ! units (meters) + z_gwsubbas(bas) = z_gwsubbas(bas) - (qout_gwsubbas(bas)+qloss_gwsubbas(bas))*DT/( basns_area(bas) ) ! units (meters) else z_gwsubbas(bas) = z_gwsubbas(bas) - (qout_gwsubbas(bas))*DT/( basns_area(bas) ) ! units (meters) endif @@ -270,7 +250,6 @@ subroutine simp_gw_buck_nhd( & z_gwsubbas_tmp(1:numbasns) = z_gwsubbas(1:numbasns) ! units (meters) - return !------------------------------------------------------------------------------ End subroutine simp_gw_buck_nhd @@ -459,7 +438,7 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g !DJG bug adjust output to be mm and correct area bug... / (ct_bas(bas)*basns_area(bas)) !units(m) z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & - ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) !DJG...Combine calculated bucket discharge and amount spilled from bucket... !ADCHANGE: Add in surface runoff as direct pass-through @@ -508,7 +487,6 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,g z_gwsubbas = z_gwsubbas_tmp - return !------------------------------------------------------------------------------ End subroutine simp_gw_buck @@ -569,7 +547,6 @@ subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns,gnumbasns,bas end do - return end subroutine pix_ct_1 #endif diff --git a/hydro/Routing/module_HYDRO_io.F90 b/hydro/Routing/module_HYDRO_io.F90 index c8dfc4388c..06083c73b4 100644 --- a/hydro/Routing/module_HYDRO_io.F90 +++ b/hydro/Routing/module_HYDRO_io.F90 @@ -1,24 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: -! - module module_HYDRO_io #ifdef MPP_LAND use module_mpp_land @@ -695,7 +674,6 @@ subroutine get_2d_netcdf_cows(var_name,ncid,var, & endif iret = nf90_get_var(ncid, varid, var, start, count) - return end subroutine get_2d_netcdf_cows !--------------------------------------------------------- @@ -1082,7 +1060,6 @@ subroutine get_NLINKSL(NLINKSL, channel_option, route_link_f) end if !end-if is now for channel_option just above, not IF from further up - return end subroutine get_NLINKSL subroutine nreadRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) @@ -1357,7 +1334,6 @@ subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& if(allocated(g_ch_netrt)) deallocate(g_ch_netrt) if(allocated(g_GWSUBBASMSK)) deallocate(g_GWSUBBASMSK) - return end subroutine MPP_READ_SIMP_GW #endif @@ -1437,7 +1413,6 @@ subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& write(6,*) "numbasns = ", numbasns #endif - return !DJG ----------------------------------------------------- END SUBROUTINE READ_SIMP_GW @@ -1507,7 +1482,6 @@ subroutine SIMP_GW_IND(ix,jx,GWSUBBASMSK,numbasns,gnumbasns,basnsInd) write(6,*) "check numbasns, gnumbasns : ", numbasns, gnumbasns #endif - return end subroutine SIMP_GW_IND subroutine read_GWBUCKPARM (inFile, numbasns, gnumbasns, basnsInd, & @@ -1760,7 +1734,6 @@ subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype, ihShift) !bftodo: make filename accessible in namelist - return end subroutine readGW2d !BF @@ -4773,7 +4746,6 @@ subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, & qlakei,qlakeo, resht,dtrt_ch,K) end if call mpp_land_sync() - return end subroutine mpp_output_lakes subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, & @@ -4808,7 +4780,6 @@ subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, & qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM) end if call mpp_land_sync() - return end subroutine mpp_output_lakes2 #endif @@ -5275,7 +5246,6 @@ subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & if(allocated(g_qlink)) deallocate(g_qlink) if(allocated(CH_NETLNK)) deallocate(CH_NETLNK) - return end subroutine mpp_output_chrtgrd #endif @@ -5501,7 +5471,6 @@ subroutine get2d_int(var_name,out_buff,ix,jx,fileName, fatalErr) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif - return end subroutine get2d_int subroutine get2d_int8(var_name,out_buff,ix,jx,fileName, fatalErr) @@ -5548,7 +5517,6 @@ subroutine get2d_int8(var_name,out_buff,ix,jx,fileName, fatalErr) if(fatalErr_local) call hydro_stop(trim(errMsg)) endif - return end subroutine get2d_int8 #ifdef MPP_LAND @@ -5632,7 +5600,6 @@ SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & end do call mpp_chrt_nlinks_collect(NLINKS) - return end SUBROUTINE MPP_READ_ROUTEDIM @@ -5729,7 +5696,6 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo write(6,*) "finish READ_ROUTING_seq" #endif - return !DJG ----------------------------------------------------- END SUBROUTINE READ_ROUTING_seq @@ -5829,7 +5795,6 @@ subroutine output_lsm(outFile,did) endif #endif - return end subroutine output_lsm @@ -6219,7 +6184,6 @@ subroutine RESTART_OUT_nc(outFile,did) #endif iret = nf90_close(ncid) - return end subroutine RESTART_OUT_nc #ifdef MPP_LAND @@ -6426,7 +6390,6 @@ subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) endif #endif - return end subroutine w_rst_rt_nc2 subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) @@ -6461,7 +6424,6 @@ subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/)) end do #endif - return end subroutine w_rst_rt_nc3 subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) @@ -6482,7 +6444,6 @@ subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) iret = nf90_put_var(ncid, varid, invar, (/1,1/), (/ix,jx/)) #endif - return end subroutine w_rst_nc2 subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) @@ -6518,7 +6479,6 @@ subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) iret = nf90_put_var(ncid, varid, inVar(:,:,k), (/1,1/), (/ix,jx/)) end do #endif - return end subroutine w_rst_nc3 subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & @@ -6542,7 +6502,6 @@ subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & #ifdef MPP_LAND endif #endif - return end subroutine w_rst_crt_nc1_lake subroutine w_rst_crt_reach_real(ncid,inVar,varName & @@ -6576,7 +6535,6 @@ subroutine w_rst_crt_reach_real(ncid,inVar,varName & iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #endif - return end subroutine w_rst_crt_reach_real @@ -6611,7 +6569,6 @@ subroutine w_rst_crt_reach_real8(ncid,inVar,varName & iret = nf90_inq_varid(ncid,varName, varid) iret = nf90_put_var(ncid, varid, inVar, (/1/), (/n/)) #endif - return end subroutine w_rst_crt_reach_real8 @@ -6639,7 +6596,6 @@ subroutine w_rst_crt_nc1(ncid,n,inVar,varName & #ifdef MPP_LAND endif #endif - return end subroutine w_rst_crt_nc1 subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) @@ -6655,7 +6611,6 @@ subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) #ifdef MPP_LAND endif #endif - return end subroutine w_rst_crt_nc1g subroutine w_rst_gwbucket_real(ncid,numbasns,gnumbasns, & @@ -6936,7 +6891,6 @@ subroutine RESTART_IN_NC(inFile,did) call flush(6) #endif -return end subroutine RESTART_IN_nc @@ -6986,7 +6940,6 @@ subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr) #endif end do - return end subroutine read_rst_nc3 subroutine read_rst_nc2(ncid,ix,jx,var,varStr) @@ -7022,7 +6975,6 @@ subroutine read_rst_nc2(ncid,ix,jx,var,varStr) var = 0.0 iret = nf90_get_var(ncid, varid, var) #endif - return end subroutine read_rst_nc2 subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) @@ -7064,7 +7016,6 @@ subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) iret = nf90_get_var(ncid, varid, var(:,:,i)) #endif end do - return end subroutine read_rst_rt_nc3 subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) @@ -7095,7 +7046,6 @@ subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) #else iret = nf90_get_var(ncid, varid, var) #endif - return end subroutine read_rst_rt_nc2 subroutine read_rt_nc2(ncid,ix,jx,var,varStr) @@ -7138,7 +7088,6 @@ subroutine read_rt_nc2(ncid,ix,jx,var,varStr) #else iret = nf90_get_var(ncid, varid, var) #endif - return end subroutine read_rt_nc2 subroutine read_rst_crt_nc(ncid,var,n,varStr) @@ -7174,7 +7123,6 @@ subroutine read_rst_crt_nc(ncid,var,n,varStr) call mpp_land_bcast_real(n,var) endif #endif - return end subroutine read_rst_crt_nc subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) @@ -7228,7 +7176,6 @@ subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) #else var_out = var #endif - return end subroutine read_rst_crt_stream_nc subroutine read_rst_crt_reach_nc_real(ncid,var_out,varStr,gnlinksl, fatalErr) @@ -7327,7 +7274,6 @@ subroutine read_rst_crt_reach_nc_real(ncid,var_out,varStr,gnlinksl, fatalErr) if(allocated(var)) deallocate(var) #endif - return end subroutine read_rst_crt_reach_nc_real @@ -7408,7 +7354,6 @@ subroutine read_rst_crt_reach_nc_real8(ncid, var_out, varStr, gnlinksl, fatalErr iret = nf90_get_var(ncid, varid, var_out) if(allocated(var)) deallocate(var) #endif - return end subroutine read_rst_crt_reach_nc_real8 @@ -8864,7 +8809,6 @@ subroutine MPP_READ_CHROUTING_new(& link_location = CH_NETLNK -return end subroutine MPP_READ_CHROUTING_new @@ -10358,8 +10302,8 @@ subroutine read_NSIMLAKES(NLAKES,route_lake_f) endif else !yw for IOC reach based routing, if netcdf lake file is not set from the hydro.namelist, -! we will assume that no lake will be assimulated. - write(6,*) "No lake nectdf file defined. NLAKES is set to be zero." +! we will assume that no lake will be assimilated. + write(6,*) "Lakes have been disabled -- NLAKES will be set to zero." NLAKES = 0 endif #ifdef MPP_LAND diff --git a/hydro/Routing/module_HYDRO_utils.F90 b/hydro/Routing/module_HYDRO_utils.F90 index 2ff1748952..981b852e19 100644 --- a/hydro/Routing/module_HYDRO_utils.F90 +++ b/hydro/Routing/module_HYDRO_utils.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_HYDRO_utils use module_RT_data, only: rt_domain use config_base, only: nlst diff --git a/hydro/Routing/module_NWM_io.F90 b/hydro/Routing/module_NWM_io.F90 index efaa6c74a4..43e7da4352 100644 --- a/hydro/Routing/module_NWM_io.F90 +++ b/hydro/Routing/module_NWM_io.F90 @@ -172,7 +172,7 @@ subroutine output_chrt_NWM(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -1144,7 +1144,7 @@ subroutine output_NoahMP_NWM(outDir,iGrid,output_timestep,itime,startdate,date,i ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -1857,7 +1857,7 @@ subroutine output_rt_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -2433,7 +2433,7 @@ subroutine output_lakes_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -3125,7 +3125,7 @@ subroutine output_chrtout_grd_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -3613,7 +3613,7 @@ subroutine output_lsmOut_NWM(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -4067,7 +4067,7 @@ subroutine output_frxstPts(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -4375,7 +4375,7 @@ subroutine output_chanObs_NWM(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -5090,7 +5090,7 @@ subroutine output_gw_NWM(domainId,iGrid) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else diff --git a/hydro/Routing/module_RT.F90 b/hydro/Routing/module_RT.F90 index fa3ef00c01..c11be2ca50 100644 --- a/hydro/Routing/module_RT.F90 +++ b/hydro/Routing/module_RT.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - MODULE module_Routing #ifdef MPP_LAND use module_gw_baseflow, only: pix_ct_1 @@ -579,7 +559,7 @@ subroutine getChanDim(did) rt_domain(did)%GNLINKSL = 1 rt_domain(did)%NLINKSL = 1 endif - if(nlst(did)%UDMP_OPT .eq. 1) & + if(nlst(did)%UDMP_OPT .eq. 1 .or. nlst(did)%channel_option .eq. 1 .or. nlst(did)%channel_option .eq. 2) & call read_NSIMLAKES(rt_domain(did)%NLAKES,nlst(did)%route_lake_f) call rt_allocate(did,rt_domain(did)%ix,rt_domain(did)%jx,& @@ -587,7 +567,7 @@ subroutine getChanDim(did) return -endif + endif allocate(CH_NETLNK(ixrt,jxrt)) @@ -609,6 +589,11 @@ subroutine getChanDim(did) call get_NLINKSL(rt_domain(did)%NLINKSL, nlst(did)%channel_option, nlst(did)%route_link_f) #endif +if (nlst(did)%lake_option == 0) then + write(6,*) "Lakes have been disabled -- NLAKES will be set to zero." + rt_domain(did)%nlakes = 0 +end if + #ifdef HYDRO_D write(6,*) "before rt_allocate after READ_ROUTEDIM" #endif @@ -635,7 +620,7 @@ subroutine getChanDim(did) endif -if(nlst(did)%UDMP_OPT .eq. 1) then +if(nlst(did)%UDMP_OPT .eq. 1 .or. nlst(did)%channel_option .eq. 1 .or. nlst(did)%channel_option .eq. 2) then call read_NSIMLAKES(rt_domain(did)%NLAKES,nlst(did)%route_lake_f) endif @@ -853,7 +838,8 @@ subroutine LandRT_ini(did) rt_domain(did)%ORIFICEC(lake_index), & rt_domain(did)%ORIFICEA(lake_index), & rt_domain(did)%LAKEMAXH(lake_index), & - rt_domain(did)%LAKEIDM(lake_index) ) + rt_domain(did)%LAKEIDM(lake_index), & + nlst(did)%lake_option) type is (persistence_levelpool_hybrid) call reservoir%init( & diff --git a/hydro/Routing/module_UDMAP.F90 b/hydro/Routing/module_UDMAP.F90 index 0b72a8eb0c..ff621ea31b 100644 --- a/hydro/Routing/module_UDMAP.F90 +++ b/hydro/Routing/module_UDMAP.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - ! This subrouting includs the data structure and tools used for NHDPlus network mapping. module module_UDMAP @@ -335,8 +315,8 @@ subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag) allocate(LUDRSL(LNUMRSL)) allocate( basns_area(LNUMRSL) ) else -! When MPI is performed,for every subdomain in each process, all the links -! are listed and if there is no link in the subdomain then it is calling +! When MPI is performed,for every subdomain in each process, all the links +! are listed and if there is no link in the subdomain then it is calling ! cleanBuf (memory cleaning purposes), this used to print a warning ! that is not necessary for the user to see it, therefore it is been commented out here ! write(6,*) "Warning: no routing links found." @@ -465,7 +445,6 @@ subroutine get_dimension(fileName, ndata,npid) call mpp_land_bcast_int1(ndata) call mpp_land_bcast_int1(npid) #endif - return end subroutine get_dimension subroutine get1d_real8(fileName,var_name,out_buff) @@ -544,17 +523,17 @@ subroutine getUDMP_area(cell_area) do k = 1, LNUMRSL if(LUDRSL(k)%ngrids .gt. 0) then do m = 1, LUDRSL(k)%ngrids - LUDRSL(k)%nodeArea(m) = cell_area(LUDRSL(k)%grid_i(m),LUDRSL(k)%grid_j(m)) + LUDRSL(k)%nodeArea(m) = cell_area(LUDRSL(k)%grid_i(m),LUDRSL(k)%grid_j(m)) enddo endif do m = 1, LUDRSL(k)%ncell - LUDRSL(k)%cellArea(m) = cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) + LUDRSL(k)%cellArea(m) = cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) enddo basns_area(k) = 0 do m = 1, LUDRSL(k)%ncell basns_area(k) = basns_area(k) + & - cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) * LUDRSL(k)%cellWeight(m) + cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) * LUDRSL(k)%cellWeight(m) enddo end do diff --git a/hydro/Routing/module_channel_routing.F90 b/hydro/Routing/module_channel_routing.F90 index 37f65cbce8..c9d64962a6 100644 --- a/hydro/Routing/module_channel_routing.F90 +++ b/hydro/Routing/module_channel_routing.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - MODULE module_channel_routing #ifdef MPP_LAND use module_mpp_land @@ -566,13 +546,13 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & LAKE_MSKRT, DT, DTCT, DTRT_CH,MUSK, MUSX, QLINK, & QLateral, & HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, Tw, Tw_CC, n_CC, & - ChannK, RESHT, & + ChannK, RESHT, HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, ORIFICEE, & ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, & dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN, & - NLINKSL, LINKID, node_area & + NLINKSL, LINKID, node_area, lake_lookup & #ifdef MPP_LAND , lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks & - , LNLINKSL & + , LNLINKSL, LLINKID & , gtoNode,toNodeInd,nToNodeInd & #endif , CH_LNKRT_SL & @@ -639,6 +619,15 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & !-- lake params + REAL, INTENT(IN), DIMENSION(NLAKES) :: HRZAREA !-- horizontal area (km^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: LAKEMAXH !-- maximum lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRH !-- lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRC !-- weir coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRL !-- weir length (m) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEC !-- orrifice coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEA !-- orrifice area (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEE !-- orrifce elevation (m) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: RESHT !-- reservoir height (m) REAL*8, DIMENSION(NLAKES) :: QLAKEI8 !-- lake inflow (cms) REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEI !-- lake inflow (cms) @@ -652,8 +641,10 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme REAL*8, DIMENSION(NLAKES) :: QLLAKE8 !-- lateral inflow to lake in diffusion scheme + integer, intent(in), dimension(:) :: lake_lookup !-- inverse lake index for k->lake mapping + !-- Local Variables - INTEGER :: i,j,k,t,m,jj,kk,KRT,node + INTEGER :: i,j,k,t,m,jj,kk,KRT,node,l_idx, lakeid INTEGER :: DT_STEPS !-- number of timestep in routing REAL :: Qup,Quc !--Q upstream Previous, Q Upstream Current, downstream Previous REAL :: bo !--critical depth, bnd outflow just for testing @@ -671,19 +662,29 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & integer(kind=int64) link_location(ixrt,jxrt) real ywtmp(ixrt,jxrt) integer LNLINKSL - real*8, dimension(LNLINKSL) :: LQLateral -! real*4, dimension(LNLINKSL) :: LQLateral + integer(kind=int64), dimension(LNLINKSL) :: LLINKID + real(kind=8), dimension(LNLINKSL) :: LQLateral integer, dimension(:) :: toNodeInd integer(kind=int64), dimension(:,:) :: gtoNode integer :: nToNodeInd real, dimension(nToNodeInd,2) :: gQLINK + real, allocatable,dimension(:) :: tmpQLAKEO, tmpQLAKEI, tmpRESHT #else - real*8, dimension(NLINKS) :: LQLateral !--lateral flow + real(kind=8), dimension(NLINKS) :: LQLateral !--lateral flow #endif integer flag integer :: n, kk2, nt, nsteps ! tmp +#ifdef MPP_LAND + if(my_id == io_id) then +#endif + allocate(tmpQLAKEO(NLAKES)) + allocate(tmpQLAKEI(NLAKES)) + allocate(tmpRESHT(NLAKES)) +#ifdef MPP_LAND + endif +#endif QLAKEIP = 0 QLAKEI8 = 0 HLINKTMP = 0 @@ -791,6 +792,15 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & !---------- route other reaches, with upstream inflow tmpQlink = 0.0 +#ifdef MPP_LAND + if(my_id .eq. io_id) then +#endif + tmpQLAKEO = QLAKEO + tmpQLAKEI = QLAKEI + tmpRESHT = RESHT +#ifdef MPP_LAND + endif +#endif do k = 1,NLINKSL ! if (ORDER(k) .gt. 1 ) then !-- exclude first order stream Quc = 0.0 @@ -821,29 +831,39 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & end do ! do m #endif - if(TYPEL(k) .eq. 1) then !--link is a reservoir - - ! CALL LEVELPOOL(1,QLINK(k,1), Qup, QLINK(k,1), QLINK(k,2), & - ! QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & - ! WEIRC(k), WEIRL(k),ORIFICEE(k), ORIFICEC(k), ORIFICEA(k)) - - elseif (channel_option .eq. 1) then !muskingum routing + if(TYPEL(k) == 1) then !--link is a reservoir + l_idx = lake_lookup(k) + if (l_idx >= 0) then !-- -999 if not a reservoir in the lookup table (belt-and-suspenders check) + call rt_domain(did)%reservoirs(l_idx)%ptr%run(Qup, Quc, 0.0, & + RESHT(l_idx), QLINK(k,2), DTRT_CH, rt_domain(did)%final_reservoir_type(l_idx), & + rt_domain(did)%reservoir_assimilated_value(l_idx), rt_domain(did)%reservoir_assimilated_source_file(l_idx)) + + QLAKEO(l_idx) = QLINK(k,2) !save outflow to lake + QLAKEI(l_idx) = Quc !save inflow to lake + end if + elseif (channel_option .eq. 1) then !muskingum routing Km = MUSK(k) X = MUSX(k) - tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plust lateral inflow + tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plus lateral inflow elseif (channel_option .eq. 2) then ! muskingum cunge call SUBMUSKINGCUNGE(tmpQLINK(k,2), velocity(k), qloss(k), LINKID(k), & Qup,Quc, QLINK(k,1), QLateral(k), DTRT_CH, So(k), & CHANLEN(k), MannN(k), ChSSlp(k), Bw(k), Tw(k),Tw_CC(k), n_CC(k), HLINK(k), ChannK(k) ) - else + else print *, "FATAL ERROR: no channel option selected" call hydro_stop("In drive_CHANNEL() - no channel option selected") endif ! endif !!! order(1) .ne. 1 end do !--k links +#ifdef MPP_LAND + call updateLake_seq(RESHT,nlakes,tmpRESHT) + call updateLake_seq(QLAKEO,nlakes,tmpQLAKEO) + call updateLake_seq(QLAKEI,nlakes,tmpQLAKEI) +#endif + !yw check ! gQLINK = 0.0 ! call ReachLS_write_io(tmpQLINK(:,2), gQLINK(:,2)) @@ -856,7 +876,7 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & ! endif do k = 1, NLINKSL - if(TYPEL(k) .ne. 1) then + if(TYPEL(k) .ne. 2) then QLINK(k,2) = tmpQLINK(k,2) endif QLINK(k,1) = QLINK(k,2) !assing link flow of current to be previous for next time step @@ -1290,7 +1310,13 @@ Subroutine drive_CHANNEL(did, latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & if (KT .eq. 1) KT = KT + 1 - +#ifdef MPP_LAND + if (my_id == io_id) then + if(allocated(tmpRESHT)) deallocate(tmpRESHT) + if(allocated(tmpQLAKEO)) deallocate(tmpQLAKEO) + if(allocated(tmpQLAKEI)) deallocate(tmpQLAKEI) + endif +#endif end subroutine drive_CHANNEL ! ---------------------------------------------------------------- @@ -1524,7 +1550,6 @@ subroutine check_lake(unit,cd,lake_index,nlakes) #endif write(unit,*) cd call flush(unit) - return end subroutine check_lake subroutine check_channel(unit,cd,did,nlinks) @@ -1547,7 +1572,6 @@ subroutine check_channel(unit,cd,did,nlinks) #endif call flush(unit) close(unit) - return end subroutine check_channel subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) implicit none @@ -1581,7 +1605,6 @@ subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) endif end do var = vartmp - return end subroutine smoth121 ! SUBROUTINE drive_CHANNEL for NHDPLUS diff --git a/hydro/Routing/module_date_utilities_rt.F90 b/hydro/Routing/module_date_utilities_rt.F90 index d8bc691a29..9ac2cbc335 100644 --- a/hydro/Routing/module_date_utilities_rt.F90 +++ b/hydro/Routing/module_date_utilities_rt.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module Module_Date_utilities_rt use module_hydro_stop, only: HYDRO_stop contains diff --git a/hydro/Routing/module_gw_gw2d.F90 b/hydro/Routing/module_gw_gw2d.F90 index 7d663e7231..ae3ab1a8d6 100644 --- a/hydro/Routing/module_gw_gw2d.F90 +++ b/hydro/Routing/module_gw_gw2d.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - !------------------------------------------------------------------------------ ! Benjamin Fersch 2d groundwater model !------------------------------------------------------------------------------ @@ -103,7 +83,6 @@ subroutine gw2d_ini(did,dt,dx) end do - return end subroutine gw2d_ini subroutine gw2d_allocate(did, ix, jx, nsoil) @@ -822,12 +801,12 @@ subroutine gwstep(ix, jx, dx, & #ifdef MPP_LAND -call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, HYDRO_COMM_WORLD, ierr) -call MPI_COMM_SIZE( HYDRO_COMM_WORLD, mpiSize, ierr ) +call MPI_Reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, HYDRO_COMM_WORLD, ierr) +call MPI_Comm_size( HYDRO_COMM_WORLD, mpiSize, ierr ) if(my_id .eq. IO_id) delcur = mpiDelcur/mpiSize -call mpi_bcast(delcur, 1, mpi_real, 0, HYDRO_COMM_WORLD, ierr) +call MPI_Bcast(delcur, 1, MPI_REAL, 0, HYDRO_COMM_WORLD, ierr) #endif @@ -907,10 +886,10 @@ subroutine gwstep(ix, jx, dx, & #ifdef HYDRO_D #ifdef MPP_LAND - call MPI_REDUCE(dtot,gdtot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) - call MPI_REDUCE(dtoa,gdtoa,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) - call MPI_REDUCE(eocn,geocn,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) - call MPI_REDUCE(ebot,gebot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(dtot,gdtot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(dtoa,gdtoa,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(eocn,geocn,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) + call MPI_Reduce(ebot,gebot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr) if(my_id .eq. IO_id) then write (*,900) & @@ -931,7 +910,6 @@ subroutine gwstep(ix, jx, dx, & ! /3x,4f9.4,2(9x),e14.4) /3x,5(e14.4)) - return end subroutine gwstep @@ -950,7 +928,6 @@ SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) IB = IB + INCB 10 CONTINUE ! - RETURN END SUBROUTINE SCOPY @@ -1262,11 +1239,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (ZSPS,j)th equations. ! ! Receive (ZSPS+1,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1294,9 +1271,9 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & #endif ! ! Receive (0,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1328,11 +1305,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (ZSPS,j)th equations. ! ! Receive (ZSPS+1,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1362,8 +1339,8 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & call add_dt(ct,tf,ti,dt) #endif - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) do 60 j = 1, XSPS ! Backward elimination in (0,j)th equations. @@ -1375,7 +1352,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & 70 continue 60 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else if (z_pid .lt. ZDNS) then @@ -1385,9 +1362,9 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & #endif ! ! Receive (ZSPS+1,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1420,11 +1397,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (1,j)th equations. ! ! Receive (0,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1450,8 +1427,8 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & #endif ! ! Send (ZSPS,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, 1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) #ifdef TIMING tf = click() @@ -1468,7 +1445,7 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & 110 continue 100 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else @@ -1484,11 +1461,11 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & ! ! Send (1,j)th equations. ! ! Receive (0,j)th equations. - call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) - call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, rowshift, -1, source, dest, ierr) + call MPI_Isend(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1510,7 +1487,6 @@ subroutine parysolv1(c,b,r,ct,pid,z_pid, & endif - return end subroutine @@ -1574,11 +1550,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & ! ! Send (i,XSPS)th equations. ! ! Receive (i,(XSPS + 1))th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1609,9 +1585,9 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Receive (i,0)th equations. - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1642,11 +1618,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & ! ! Send (i,XSPS)th equations. ! ! Receive (i,(XSPS + 1))th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1675,8 +1651,8 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & tf = click() call add_dt(ct,tf,ti,dt) #endif - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) do 60 i = 1, ZSPS ! Backward elimination in (i,0)th equations. @@ -1690,7 +1666,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & r(i,j) = r(i,j) - b(i,j)*r(i,XSPS) - c(i,j)*r(i,1) 70 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else if (x_pid .lt. XDNS) then @@ -1700,9 +1676,9 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Receive (i,XSPS+1)th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1732,11 +1708,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Send (i,1)th equations. ! ! Receive (i,0)th equations. - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1762,8 +1738,8 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & #endif ! ! Send (i,XSPS)th equations. - call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Cart_shift(cartGridComm, colshift, 1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) #ifdef TIMING tf = click() call add_dt(ct,tf,ti,dt) @@ -1781,7 +1757,7 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & r(i,j) = r(i,j) - c(i,j)*r(i,1) - b(i,j)*r(i,XSPS) 110 continue - call mpi_wait(sendReq, mpp_status, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) else @@ -1798,11 +1774,11 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & ! ! Send (i,1)th equations. ! ! Receive (i,0)th equations. - call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr) - call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) - call MPI_IRECV( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) - call mpi_wait(sendReq, mpp_status, ierr) - call mpi_wait(recvReq, mpp_status, ierr) + call MPI_Cart_shift(cartGridComm, colshift, -1, source, dest, ierr) + call MPI_Isend(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr) + call MPI_Irecv( xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr) + call MPI_Wait(sendReq, mpp_status, ierr) + call MPI_Wait(recvReq, mpp_status, ierr) #ifdef TIMING tf = click() @@ -1825,7 +1801,6 @@ subroutine parxsolv1(c,b,r,ct,pid,x_pid, & endif - return end subroutine @@ -2056,7 +2031,6 @@ subroutine sub_n_form(n_xs,n_zs,c,a,b,r,c2,b2,r2,wk,xfac,zfac, & ! stop endif - return end subroutine #endif @@ -2150,7 +2124,6 @@ subroutine sub_tri_solv(n_xs,n_zs,c,a,b,r,x,wk,xfac,zfac,dir) ! stop endif - return end subroutine diff --git a/hydro/Routing/module_lsm_forcing.F90 b/hydro/Routing/module_lsm_forcing.F90 index 1006759629..0fbf9d0428 100644 --- a/hydro/Routing/module_lsm_forcing.F90 +++ b/hydro/Routing/module_lsm_forcing.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_lsm_forcing #ifdef MPP_LAND @@ -25,9 +5,9 @@ module module_lsm_forcing #endif use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int use module_hydro_stop, only:HYDRO_stop + use netcdf implicit none -#include integer :: i_forcing character(len=19) out_date @@ -62,8 +42,8 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) pcpc = 0 ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_WRF() - Problem opening netcdf file") endif @@ -83,7 +63,7 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) endif call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) !DJG Add the convective and non-convective rain components (note: conv. comp=0 !for cloud resolving runs...) @@ -103,63 +83,63 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) integer :: iret, ncid, dimid ! Open the NetCDF file. - iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + iret = nf90_open(geo_static_flnm, NF90_NOWRITE, ncid) if (iret /= 0) then write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(geo_static_flnm) call hydro_stop("In read_hrldas_hdrinfo() - Problem opening geo_static file") endif - iret = nf_inq_dimid(ncid, "west_east", dimid) + iret = nf90_inq_dimid(ncid, "west_east", dimid) if (iret /= 0) then -! print*, "nf_inq_dimid: west_east" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: west_east problem") +! print*, "nf90_inq_dimid: west_east" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: west_east problem") endif - iret = nf_inq_dimlen(ncid, dimid, ix) + iret = nf90_inquire_dimension(ncid, dimid, len=ix) if (iret /= 0) then -! print*, "nf_inq_dimlen: west_east" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: west_east problem") +! print*, "nf90_inq_dimlen: west_east" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: west_east problem") endif - iret = nf_inq_dimid(ncid, "south_north", dimid) + iret = nf90_inq_dimid(ncid, "south_north", dimid) if (iret /= 0) then -! print*, "nf_inq_dimid: south_north" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: south_north problem") +! print*, "nf90_inq_dimid: south_north" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: south_north problem") endif - iret = nf_inq_dimlen(ncid, dimid, jx) + iret = nf90_inquire_dimension(ncid, dimid, len=jx) if (iret /= 0) then - ! print*, "nf_inq_dimlen: south_north" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: south_north problem") + ! print*, "nf90_inq_dimlen: south_north" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: south_north problem") endif - iret = nf_inq_dimid(ncid, "land_cat", dimid) + iret = nf90_inq_dimid(ncid, "land_cat", dimid) if (iret /= 0) then - ! print*, "nf_inq_dimid: land_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: land_cat problem") + ! print*, "nf90_inq_dimid: land_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: land_cat problem") endif - iret = nf_inq_dimlen(ncid, dimid, land_cat) + iret = nf90_inquire_dimension(ncid, dimid, len=land_cat) if (iret /= 0) then - print*, "nf_inq_dimlen: land_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: land_cat problem") + print*, "nf90_inq_dimlen: land_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: land_cat problem") endif - iret = nf_inq_dimid(ncid, "soil_cat", dimid) + iret = nf90_inq_dimid(ncid, "soil_cat", dimid) if (iret /= 0) then - ! print*, "nf_inq_dimid: soil_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid: soil_cat problem") + ! print*, "nf90_inq_dimid: soil_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimid: soil_cat problem") endif - iret = nf_inq_dimlen(ncid, dimid, soil_cat) + iret = nf90_inquire_dimension(ncid, dimid, len=soil_cat) if (iret /= 0) then - ! print*, "nf_inq_dimlen: soil_cat" - call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen: soil_cat problem") + ! print*, "nf90_inq_dimlen: soil_cat" + call hydro_stop("In read_hrldas_hdrinfo() - nf90_inq_dimlen: soil_cat problem") endif - iret = nf_close(ncid) + iret = nf90_close(ncid) end subroutine read_hrldas_hdrinfo @@ -183,18 +163,18 @@ subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp integer :: islake, iswater, isoilwater ! Open the NetCDF file. - ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + ierr = nf90_open(geo_static_flnm, NF90_NOWRITE, ncid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm) call hydro_stop("In readland_hrldas() - Problem opening geo_static file") endif flag = -99 - ierr = nf_inq_varid(ncid,"XLAT", varid) + ierr = nf90_inq_varid(ncid,"XLAT", varid) flag = 1 if(ierr .ne. 0) then - ierr = nf_inq_varid(ncid,"XLAT_M", varid) + ierr = nf90_inq_varid(ncid,"XLAT_M", varid) if(ierr .ne. 0) then ! write(6,*) "XLAT not found from wrfstatic file. " call hydro_stop("In readland_hrldas() - XLAT not found from wrfstatic file") @@ -257,26 +237,26 @@ subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp endif - ierr = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'ISWATER', iswater) - if (ierr /= 0) then + ierr = nf90_get_att(ncid, NF90_GLOBAL, 'ISWATER', iswater) + if (ierr /= NF90_NOERR) then call hydro_stop("In readland_hrldas() - Attribute ISWATER unable to be read from geo_static_flnm") endif - ierr = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'ISOILWATER', isoilwater) - if (ierr /= 0) then + ierr = nf90_get_att(ncid, NF90_GLOBAL, 'ISOILWATER', isoilwater) + if (ierr /= NF90_NOERR) then call hydro_stop("In readland_hrldas() - Attribute ISOILWATER unable to be read from geo_static_flnm") endif - ierr = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'ISLAKE', islake) - if (ierr /= 0) then + ierr = nf90_get_att(ncid, NF90_GLOBAL, 'ISLAKE', islake) + if (ierr /= NF90_NOERR) then call hydro_stop("In readland_hrldas() - Attribute ISLAKE unable to be read from geo_static_flnm") endif ! Close the NetCDF file - ierr = nf_close(ncid) - if (ierr /= 0) then - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF_CLOSE" - call hydro_stop("In readland_hrldas() - NF_CLOSE problem") + ierr = nf90_close(ncid) + if (ierr /= NF90_NOERR) then + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF90_CLOSE" + call hydro_stop("In readland_hrldas() - NF90_CLOSE problem") endif write(6, *) "readland_hrldas: ISLAKE ISWATER ISOILWATER", islake, iswater, isoilwater @@ -309,21 +289,20 @@ subroutine get_2d_netcdf_ruc(var_name,ncid,var, & count(1) = ix count(2) = jx start(4) = tlevel - ierr = nf_inq_varid(ncid, var_name, varid) + ierr = nf90_inq_varid(ncid, var_name, varid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then if (fatal_IF_ERROR) then - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name) - call hydro_stop("In get_2d_netcdf_ruc() - nf_inq_varid problem") + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf90_inq_varid ", trim(var_name) + call hydro_stop("In get_2d_netcdf_ruc() - nf90_inq_varid problem") else return endif endif - ierr = nf_get_vara_real(ncid, varid, start,count,var) + ierr = nf90_get_var(ncid, varid, var, start, count) - return end subroutine get_2d_netcdf_ruc @@ -341,20 +320,19 @@ subroutine get_2d_netcdf_cows(var_name,ncid,var, & count(1) = ix count(2) = jx start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) + iret = nf90_inq_varid(ncid, var_name, varid) if (iret /= 0) then if (fatal_IF_ERROR) then - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" - call hydro_stop("In get_2d_netcdf_cows() - nf_inq_varid problem") + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf90_inq_varid" + call hydro_stop("In get_2d_netcdf_cows() - nf90_inq_varid problem") else ierr = iret return endif endif - iret = nf_get_vara_real(ncid, varid, start,count,var) + iret = nf90_get_var(ncid, varid, var, start,count) - return end subroutine get_2d_netcdf_cows @@ -387,8 +365,8 @@ subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois ! Open the NetCDF file. - ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(netcdf_flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') & trim(netcdf_flnm) call hydro_stop("In readinit_hrldas()- Problem opening netcdf file") @@ -437,19 +415,32 @@ subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & sh2o = smc - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine readinit_hrldas - subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) + subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + t,q,u,v,p,lw,sw,pcp,lai,snowbl,fpar) implicit none character(len=*), intent(in) :: flnm integer, intent(in) :: ix integer, intent(in) :: jx character(len=*), intent(in) :: target_date + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real, dimension(ix,jx), intent(out) :: t real, dimension(ix,jx), intent(out) :: q real, dimension(ix,jx), intent(out) :: u @@ -460,33 +451,46 @@ subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) real, dimension(ix,jx), intent(out) :: pcp real, dimension(ix,jx), intent(inout) :: lai real, dimension(ix,jx), intent(inout) :: fpar - + real, dimension(ix,jx), intent(inout) :: snowbl + real, dimension(:,:), allocatable :: liqfrac character(len=256) :: units integer :: ierr integer :: ncid ! Open the NetCDF file. - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(trim(flnm), NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_HRLDAS() - Problem opening netcdf file") endif - call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_T), ncid, t, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_Q), ncid, q, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_U), ncid, u, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_V), ncid, v, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_P), ncid, p, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_lw), ncid, lw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_sw), ncid, sw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_pr),ncid, pcp, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) if (ierr == 0) then if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 endif + call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) + call get_2d_netcdf(trim(forcing_name_SN), ncid, snowbl,units, ix, jx, .FALSE., ierr) + if (ierr /= NF90_NOERR) then + allocate(liqfrac(ix,jx)) + call get_2d_netcdf(trim(forcing_name_LF), ncid, liqfrac, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + snowbl = (1.0 - liqfrac) * pcp + else + snowbl = 0.0 ! since is liqfrac is not present it is equal to 1.0 + end if + deallocate(liqfrac) + end if - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_HRLDAS @@ -551,7 +555,7 @@ subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) !open NetCDF file... - ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) + ierr_flg = nf90_open(flnm, NF90_NOWRITE, ncid) if (ierr_flg /= 0) then #ifdef HYDRO_D write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') & @@ -560,13 +564,13 @@ subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) return end if - ierr = nf_inq_varid(ncid, "precip", varid) - if(ierr /= 0) ierr_flg = ierr - if (ierr /= 0) then - ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... - if (ierr /= 0) then - ierr = nf_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... - if (ierr /= 0) then + ierr = nf90_inq_varid(ncid, "precip", varid) + if(ierr /= NF90_NOERR) ierr_flg = ierr + if (ierr /= NF90_NOERR) then + ierr = nf90_inq_varid(ncid, "precip_rate", varid) !recheck variable name... + if (ierr /= NF90_NOERR) then + ierr = nf90_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... + if (ierr /= NF90_NOERR) then #ifdef HYDRO_D write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & trim(flnm) @@ -576,10 +580,10 @@ subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) ierr_flg = ierr mmflag = 1 end if - ierr = nf_get_var_real(ncid, varid, pcp) - ierr = nf_close(ncid) + ierr = nf90_get_var(ncid, varid, pcp) + ierr = nf90_close(ncid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then #ifdef HYDRO_D write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) #endif @@ -612,18 +616,18 @@ subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) !open NetCDF file... if (k.eq.1.) then - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') & trim(flnm) call hydro_stop("In READFORC_NAMPCP() - Problem opening netcdf file") end if - ierr = nf_inq_varid(ncid, trim(product), varid) - ierr = nf_get_var_real(ncid, varid, buf) - ierr = nf_close(ncid) + ierr = nf90_inq_varid(ncid, trim(product), varid) + ierr = nf90_get_var(ncid, varid, buf) + ierr = nf90_close(ncid) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') & trim(flnm) call hydro_stop("In READFORC_NAMPCP() - Problem reading netcdf file") @@ -670,8 +674,8 @@ subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) integer :: ncid ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_COWS() - Problem opening netcdf file") endif @@ -685,7 +689,7 @@ subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) call get_2d_netcdf_cows("RAIN", ncid, pcp, ix, jx,tlevel, .TRUE., ierr) !yw call get_2d_netcdf_cows("V2D", ncid, v, ix, jx,tlevel, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_COWS @@ -710,8 +714,8 @@ subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) tlevel = 1 ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_RUC() - Problem opening netcdf file") endif @@ -726,7 +730,7 @@ subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) !DJG Add the convective and non-convective rain components (note: conv. comp=0 @@ -757,14 +761,14 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READSNOW_FORC() - Problem opening netcdf file") endif call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) if (ierr == 0) then units = "mm" @@ -781,12 +785,12 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) endif endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then print *, "!!!!! NO WEASD present in input file...initialize to 0." endif call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. call get_2d_netcdf("SNOWH", ncid, tmp, units, ix, jx, .FALSE., ierr) if(ierr .eq. 0) then @@ -797,7 +801,7 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) snodep = tmp endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. !yw snodep = weasd * 10. where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... @@ -806,7 +810,7 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) !DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... where(snodep .lt. 0) snodep = 0 where(weasd .lt. 0) weasd = 0 - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READSNOW_FORC @@ -817,7 +821,7 @@ subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) real,dimension(ix,jx,nsoil):: smc,stc,sh2ox character(len=*), intent(in) :: inflnm character(len=256):: units - iret = nf_open(trim(inflnm), NF_NOWRITE, ncid) + iret = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) if(iret .ne. 0 )then write(6,*) "Error: failed to open file :",trim(inflnm) call hydro_stop("In get2d_hrldas() - failed to open file") @@ -855,8 +859,7 @@ subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) call get2d_hrldas_real("SOIL_W_7", ncid, SH2OX(:,:,7), ix, jx) call get2d_hrldas_real("SOIL_W_8", ncid, SH2OX(:,:,8), ix, jx) - iret = nf_close(ncid) - return + iret = nf90_close(ncid) end subroutine get2d_hrldas subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) @@ -864,9 +867,8 @@ subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) integer ::iret,varid,ncid,ix,jx real out_buff(ix,jx) character(len=*), intent(in) :: var_name - iret = nf_inq_varid(ncid,trim(var_name), varid) - iret = nf_get_var_real(ncid, varid, out_buff) - return + iret = nf90_inq_varid(ncid,trim(var_name), varid) + iret = nf90_get_var(ncid, varid, out_buff) end subroutine get2d_hrldas_real subroutine read_stage4(flnm,IX,JX,pcp) @@ -875,14 +877,14 @@ subroutine read_stage4(flnm,IX,JX,pcp) character(len=*), intent(in) :: flnm character(len=256) :: units - ierr = nf_open(flnm, NF_NOWRITE, ncid) + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) if(ierr .ne. 0) then call hydro_stop("In read_stage4() - failed to open stage4 file.") endif call get_2d_netcdf("RAINRATE",ncid, buf, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) do j = 1, jx do i = 1, ix if(buf(i,j) .lt. 0) then @@ -891,7 +893,6 @@ subroutine read_stage4(flnm,IX,JX,pcp) end do end do pcp = buf - return END subroutine read_stage4 @@ -900,28 +901,39 @@ END subroutine read_stage4 subroutine read_hydro_forcing_seq( & indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) + lai,snowbl,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. implicit none ! in variable character(len=*) :: olddate,hgrid,indir character(len=256) :: filename integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& prcpnew,weasd,snodep,prcp0,prcp2,prcp_old real :: dt, wrf_dt ! tmp variable character(len=256) :: inflnm, inflnm2, product integer :: i,j,mmflag,ierr_flg - real,dimension(ix,jx):: lai,fpar + real,dimension(ix,jx):: lai,snowbl,fpar character(len=4) nwxst_t logical :: fexist inflnm = trim(indir)//"/"//& olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& ".LDASIN_DOMAIN"//hgrid - !!!DJG... Call READFORC_(variable) Subroutine for forcing data... !!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) if(FORC_TYP.eq.1) then @@ -937,8 +949,11 @@ subroutine read_hydro_forcing_seq( & call hydro_stop("In read_hydro_forcing_seq") endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) end if @@ -956,8 +971,11 @@ subroutine read_hydro_forcing_seq( & print*, "no forcing data found", inflnm call hydro_stop("In read_hydro_forcing_seq() - no forcing data found") endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) end if @@ -1142,8 +1160,11 @@ subroutine read_hydro_forcing_seq( & print*, "reading forcing data at this time", inflnm #endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,& + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... endif @@ -1649,7 +1670,6 @@ subroutine mpp_readland_hrldas(geo_static_flnm,& call decompose_data_real(g_TERRAIN,TERRAIN) call decompose_data_real(g_LATITUDE,LATITUDE) call decompose_data_real(g_LONGITUDE,LONGITUDE) - return end subroutine mpp_readland_hrldas @@ -1675,7 +1695,6 @@ subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,& call decompose_data_real(g_WEASD,WEASD) call decompose_data_real(g_SNODEP,SNODEP) - return end subroutine MPP_READSNOW_FORC subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& @@ -1712,15 +1731,16 @@ subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) end do - return end subroutine MPP_DEEPGW_HRLDAS subroutine read_hydro_forcing_mpp( & indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) + lai,snowbl,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. @@ -1729,14 +1749,24 @@ subroutine read_hydro_forcing_mpp( & character(len=*) :: olddate,hgrid,indir character(len=256) :: filename integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& - prcpnew,lai,fpar,snodep,prcp_old + prcpnew,lai,snowbl,fpar,snodep,prcp_old real :: dt ! tmp variable character(len=256) :: inflnm, product integer :: i,j,mmflag real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & - g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar + g_SHORT,g_PRCP1,g_PRES,g_lai,g_snowbl,g_snodep,g_prcp_old, g_fpar integer flag @@ -1752,6 +1782,7 @@ subroutine read_hydro_forcing_mpp( & call write_io_real(prcp_old,g_PRCP_old) call write_io_real(lai,g_lai) + call write_io_real(snowbl,g_snowbl) call write_io_real(fpar,g_fpar) call write_io_real(snodep,g_snodep) @@ -1761,8 +1792,10 @@ subroutine read_hydro_forcing_mpp( & call read_hydro_forcing_seq( & indir,olddate,hgrid,& global_nx,global_ny,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,& - g_lai,g_fpar,g_snodep,dt,k,g_prcp_old) + g_lai,g_snowbl,g_fpar,g_snodep,dt,k,g_prcp_old) #ifdef HYDRO_D write(6,*) "finish read forcing,olddate ",olddate #endif @@ -1782,7 +1815,6 @@ subroutine read_hydro_forcing_mpp( & call decompose_data_real(g_fpar,fpar) call decompose_data_real(g_snodep,snodep) - return end subroutine read_hydro_forcing_mpp #endif @@ -2252,21 +2284,33 @@ end subroutine geth_newdate subroutine read_hydro_forcing_mpp1( & indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) + lai,snowbl,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. implicit none ! in variable character(len=*) :: olddate,hgrid,indir character(len=256) :: filename integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop +character(len=256), intent(in) :: forcing_name_T +character(len=256), intent(in) :: forcing_name_Q +character(len=256), intent(in) :: forcing_name_U +character(len=256), intent(in) :: forcing_name_V +character(len=256), intent(in) :: forcing_name_P +character(len=256), intent(in) :: forcing_name_LW +character(len=256), intent(in) :: forcing_name_SW +character(len=256), intent(in) :: forcing_name_PR +character(len=256), intent(in) :: forcing_name_SN +character(len=256), intent(in) :: forcing_name_LF real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& prcpnew,weasd,snodep,prcp0,prcp2,prcp_old real :: dt, wrf_dt ! tmp variable character(len=256) :: inflnm, inflnm2, product integer :: i,j,mmflag,ierr_flg -real,dimension(ix,jx):: lai,fpar +real,dimension(ix,jx):: lai,snowbl,fpar character(len=4) nwxst_t logical :: fexist @@ -2274,10 +2318,10 @@ subroutine read_hydro_forcing_mpp1( & olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& ".LDASIN_DOMAIN"//hgrid + !!!DJG... Call READFORC_(variable) Subroutine for forcing data... !!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) - !!! FORC_TYPE 1 ============================================================================ if(FORC_TYP.eq.1) then !!Create forcing data filename... @@ -2299,8 +2343,11 @@ subroutine read_hydro_forcing_mpp1( & #ifdef HYDRO_D print*, "read forcing data at ", OLDDATE, trim(inflnm) #endif - call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) where(PRCP1 .lt. 0) PRCP1= 0 ! set minimum to be 0 where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h @@ -2325,8 +2372,11 @@ subroutine read_hydro_forcing_mpp1( & print*, "no forcing data found", inflnm call hydro_stop("In read_hydro_forcing_mpp1() - no forcing data found") endif - call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,& + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) where(PRCP1 .lt. 0) PRCP1= 0 ! set minimum to be 0 where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h @@ -2539,8 +2589,11 @@ subroutine read_hydro_forcing_mpp1( & print*, "reading forcing data at this time", inflnm #endif - call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + call READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,& + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,snowbl,FPAR) PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... endif @@ -2729,13 +2782,26 @@ end subroutine read_hydro_forcing_mpp1 - subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) + subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, forcing_name_LF,& + t,q,u,v,p,lw,sw,pcp,lai,snowbl,fpar) implicit none character(len=*), intent(in) :: flnm integer, intent(in) :: ix integer, intent(in) :: jx character(len=*), intent(in) :: target_date + character(len=256), intent(in) :: forcing_name_T + character(len=256), intent(in) :: forcing_name_Q + character(len=256), intent(in) :: forcing_name_U + character(len=256), intent(in) :: forcing_name_V + character(len=256), intent(in) :: forcing_name_P + character(len=256), intent(in) :: forcing_name_LW + character(len=256), intent(in) :: forcing_name_SW + character(len=256), intent(in) :: forcing_name_PR + character(len=256), intent(in) :: forcing_name_SN + character(len=256), intent(in) :: forcing_name_LF real, dimension(ix,jx), intent(out) :: t real, dimension(ix,jx), intent(out) :: q real, dimension(ix,jx), intent(out) :: u @@ -2745,6 +2811,7 @@ subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,f real, dimension(ix,jx), intent(out) :: sw real, dimension(ix,jx), intent(out) :: pcp real, dimension(ix,jx), intent(inout) :: lai + real, dimension(ix,jx), intent(inout) :: snowbl real, dimension(ix,jx), intent(inout) :: fpar character(len=256) :: units @@ -2754,36 +2821,38 @@ subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,f ! Open the NetCDF file. #ifdef MPP_LAND real, allocatable, dimension(:,:):: buf2 + real, allocatable, dimension(:,:) :: liqfrac + if(my_id .eq. io_id) then allocate(buf2(global_nx,global_ny)) else allocate(buf2(1,1)) endif if(my_id .eq. io_id) then - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(flnm), NF90_NOWRITE, ncid) endif call mpp_land_bcast_int1(ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_HRLDAS_mpp() - Problem opening netcdf file") endif - if(my_id .eq. io_id ) call get_2d_netcdf("T2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_T), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,t) - if(my_id .eq. io_id ) call get_2d_netcdf("Q2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_Q), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,q) - if(my_id .eq. io_id ) call get_2d_netcdf("U2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_U), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,u) - if(my_id .eq. io_id ) call get_2d_netcdf("V2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_V), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,v) - if(my_id .eq. io_id ) call get_2d_netcdf("PSFC", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_P), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,p) - if(my_id .eq. io_id ) call get_2d_netcdf("LWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_LW), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,lw) - if(my_id .eq. io_id ) call get_2d_netcdf("SWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_SW), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,sw) - if(my_id .eq. io_id ) call get_2d_netcdf("RAINRATE", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_PR), ncid,buf2, units, global_nx, global_ny, .TRUE., ierr) call decompose_data_real (buf2,pcp) if(my_id .eq. io_id ) then call get_2d_netcdf("VEGFRA", ncid,buf2, units, global_nx, global_ny, .FALSE., ierr) @@ -2796,32 +2865,60 @@ subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,f if(my_id .eq. io_id ) call get_2d_netcdf("LAI", ncid, buf2, units, global_nx, global_ny, .FALSE., ierr) call mpp_land_bcast_int1(ierr) if(ierr == 0) call decompose_data_real (buf2,lai) + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_SN), ncid, buf2, units, global_nx, global_ny, .FALSE., ierr) + call mpp_land_bcast_int1(ierr) + if (ierr == 0) then + call decompose_data_real (buf2,snowbl) + else + if(my_id .eq. io_id ) call get_2d_netcdf(trim(forcing_name_LF), ncid, buf2, units, global_nx, global_ny, .FALSE., ierr) + call mpp_land_bcast_int1(ierr) + if(ierr == 0) then + allocate(liqfrac(ix,jx)) + call decompose_data_real (buf2,liqfrac) + snowbl = (1.0 - liqfrac) * pcp + deallocate(liqfrac) + else + snowbl = 0.0 ! since if liqfrac is not present it defaults to 1.0 + end if + end if deallocate(buf2) #else - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(trim(flnm), NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("READFORC_HRLDAS") endif - call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_T), ncid, t, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_Q), ncid, q, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_U), ncid, u, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_V), ncid, v, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_P), ncid, p, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_LW), ncid, lw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_SW), ncid, sw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf(trim(forcing_name_PR),ncid, pcp, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) if (ierr == 0) then if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 endif + call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) -#endif + call get_2d_netcdf(trim(forcing_name_SN), ncid, snowbl,units, ix, jx, .FALSE., ierr) + if (ierr /= NF90_NOERR) then + allocate(liqfrac(ix,jx)) + call get_2d_netcdf(trim(forcing_name_LF), ncid, liqfrac, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + snowbl = (1.0 - liqfrac) * pcp + else + snowbl = 0.0 ! since if liqfrac is not present it is set to 1.0 + end if + deallocate(liqfrac) + end if - ierr = nf_close(ncid) +#endif + ierr = nf90_close(ncid) end subroutine READFORC_HRLDAS_mpp subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) @@ -2854,9 +2951,9 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) ! Open the NetCDF file. - if(my_id .eq. io_id) ierr = nf_open(flnm, NF_NOWRITE, ncid) + if(my_id .eq. io_id) ierr = nf90_open(flnm, NF90_NOWRITE, ncid) call mpp_land_bcast_int1(ierr) - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file") endif @@ -2893,8 +2990,8 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) #else ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) + if (ierr /= NF90_NOERR) then write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file") endif @@ -2917,7 +3014,7 @@ subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_WRF_mpp @@ -2952,7 +3049,7 @@ subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) + ierr_flg = nf90_open(flnm, NF90_NOWRITE, ncid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr_flg) @@ -2969,31 +3066,31 @@ subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_inq_varid(ncid, "precip", varid) + ierr = nf90_inq_varid(ncid, "precip", varid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if(ierr /= 0) ierr_flg = ierr - if (ierr /= 0) then + if(ierr /= NF90_NOERR) ierr_flg = ierr + if (ierr /= NF90_NOERR) then #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... + ierr = nf90_inq_varid(ncid, "precip_rate", varid) !recheck variable name... #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... + ierr = nf90_inq_varid(ncid, "RAINRATE", varid) !recheck variable name... #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & trim(flnm) #ifdef MPP_LAND @@ -3007,18 +3104,18 @@ subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg) end if #ifdef MPP_LAND if(my_id .eq. io_id) then - ierr = nf_get_var_real(ncid, varid, buf2) + ierr = nf90_get_var(ncid, varid, buf2) endif call mpp_land_bcast_int1(ierr) if(ierr ==0) call decompose_data_real (buf2,pcp) deallocate(buf2) #else - ierr = nf_get_var_real(ncid, varid, pcp) + ierr = nf90_get_var(ncid, varid, pcp) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) end if - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READFORC_MDV_mpp @@ -3048,12 +3145,12 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) #ifdef MPP_LAND if(my_id .eq. io_id) then #endif - ierr = nf_open(flnm, NF_NOWRITE, ncid) + ierr = nf90_open(flnm, NF90_NOWRITE, ncid) #ifdef MPP_LAND endif call mpp_land_bcast_int1(ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) call hydro_stop("In READSNOW_FORC_mpp() - Problem opening netcdf file") endif @@ -3067,7 +3164,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) #else call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) if (ierr == 0) then units = "mm" @@ -3086,7 +3183,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) endif endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then print *, "!!!!! NO WEASD present in input file...initialize to 0." endif #ifdef MPP_LAND @@ -3098,7 +3195,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) #else call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) #endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. #ifdef MPP_LAND @@ -3120,7 +3217,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) snodep = tmp endif - if (ierr /= 0) then + if (ierr /= NF90_NOERR) then ! Quick assumption regarding snow depth. !yw snodep = weasd * 10. where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... @@ -3129,7 +3226,7 @@ subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep) !DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... where(snodep .lt. 0) snodep = 0 where(weasd .lt. 0) weasd = 0 - ierr = nf_close(ncid) + ierr = nf90_close(ncid) end subroutine READSNOW_FORC_mpp @@ -3189,7 +3286,7 @@ subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) ! read file1 #ifdef MPP_LAND if(my_id .eq. io_id) then - ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) endif call decompose_data_real (gArr,infxsrt) @@ -3198,18 +3295,18 @@ subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) endif call decompose_data_real (gArr,soldrain) if(my_id .eq. io_id) then - ierr = nf_close(ncid) + ierr = nf90_close(ncid) endif #else - ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) #endif ! read file2 #ifdef MPP_LAND if(my_id .eq. io_id) then - ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm2), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, gArr, units, global_nx, global_ny, .TRUE., ierr) endif call decompose_data_real (gArr,infxsrt2) @@ -3218,13 +3315,13 @@ subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) endif call decompose_data_real (gArr,soldrain2) if(my_id .eq. io_id) then - ierr = nf_close(ncid) + ierr = nf90_close(ncid) endif #else - ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm2), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt2, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain2, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) #endif infxsrt = infxsrt2 - infxsrt @@ -3284,15 +3381,15 @@ subroutine read_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain) call hydro_stop( "LDASOUT input Error") endif ! read file1 - ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) ! read file2 - ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid) + ierr = nf90_open(trim(inflnm2), NF90_NOWRITE, ncid) call get_2d_netcdf("SFCRNOFF", ncid, infxsrt2, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("UGDRNOFF", ncid, soldrain2, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) + ierr = nf90_close(ncid) infxsrt = infxsrt2 - infxsrt soldrain = soldrain2 - soldrain diff --git a/hydro/Routing/module_reservoir_routing.F90 b/hydro/Routing/module_reservoir_routing.F90 index b2b20b459e..bc157b2ba9 100644 --- a/hydro/Routing/module_reservoir_routing.F90 +++ b/hydro/Routing/module_reservoir_routing.F90 @@ -1,5 +1,5 @@ ! Intended purpose is to provide a module for all subroutines related to -! reservoir routing, including active management, level pool, and integrating live +! reservoir routing, including active management, level pool, and integrating live ! data feeds. As of NWMv2.0, this module stub can read in a timeslice file ! to incorporate data from external sources, should a data service become available. @@ -83,7 +83,7 @@ subroutine read_reservoir_obs(domainId) ! If not MPI, then default to 0, which is the I/O ID. if(mppFlag .eq. 1) then #ifdef MPP_LAND - call MPI_COMM_RANK( HYDRO_COMM_WORLD, myId, ierr ) + call MPI_Comm_rank( HYDRO_COMM_WORLD, myId, ierr ) call nwmCheck(diagFlag,ierr,'ERROR: Unable to determine MPI process ID.') #endif else @@ -92,7 +92,7 @@ subroutine read_reservoir_obs(domainId) ! Open up and read in the NetCDF file containing disharge data. if(myId .eq. 0) then - ! Initialize our missing flag to 0. If at any point we don't find a file, + ! Initialize our missing flag to 0. If at any point we don't find a file, ! the flag value will go to 1 to indicate no files were found. missingFlag = 0 diff --git a/hydro/nudging/module_date_utils_nudging.F90 b/hydro/nudging/module_date_utils_nudging.F90 index 45ad66738c..ce27082bfa 100644 --- a/hydro/nudging/module_date_utils_nudging.F90 +++ b/hydro/nudging/module_date_utils_nudging.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_date_utils_nudging use module_hydro_stop, only: HYDRO_stop contains diff --git a/hydro/nudging/module_nudging_io.F90 b/hydro/nudging/module_nudging_io.F90 index f29920ab8d..80f8780e1e 100644 --- a/hydro/nudging/module_nudging_io.F90 +++ b/hydro/nudging/module_nudging_io.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_nudging_io use netcdf diff --git a/hydro/nudging/module_nudging_utils.F90 b/hydro/nudging/module_nudging_utils.F90 index 3afe2108af..255840bf60 100644 --- a/hydro/nudging/module_nudging_utils.F90 +++ b/hydro/nudging/module_nudging_utils.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_nudging_utils real :: totalNudgeTime diff --git a/hydro/nudging/module_stream_nudging.F90 b/hydro/nudging/module_stream_nudging.F90 index c52dc7dee8..84b6a3910a 100644 --- a/hydro/nudging/module_stream_nudging.F90 +++ b/hydro/nudging/module_stream_nudging.F90 @@ -1,23 +1,3 @@ -! Program Name: -! Author(s)/Contact(s): -! Abstract: -! History Log: -! -! Usage: -! Parameters: -! Input Files: -! -! Output Files: -! -! -! Condition codes: -! -! If appropriate, descriptive troubleshooting instructions or -! likely causes for failures could be mentioned here with the -! appropriate error code -! -! User controllable options: - module module_stream_nudging use config_base, only: nlst diff --git a/hydro/template/HYDRO/hydro.namelist b/hydro/template/HYDRO/hydro.namelist index 54821f10fa..97683ae50c 100644 --- a/hydro/template/HYDRO/hydro.namelist +++ b/hydro/template/HYDRO/hydro.namelist @@ -154,10 +154,40 @@ compound_channel = .FALSE. ! Switch to activate channel-loss option (0=no, 1=yes) [Requires Kchan in RouteLink] ! channel_loss_option = 0 +! Lake / Reservoir options (0=lakes off, 1=level pool (typical default), +! 2=passthrough, 3=reservoir DA [see &reservoir_nlist below]) +lake_option = 1 + ! Specify the lake parameter file (e.g.: "LAKEPARM.nc"). ! Note REQUIRED if lakes are on. route_lake_f = "./DOMAIN/LAKEPARM.nc" +! Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through, +! 4=exp. bucket with area normalized parameters) +! Option 4 is currently only supported if using reach-based routing with UDMP=1. +GWBASESWCRT = 1 + +! Switch to activate bucket model loss (0=no, 1=yes) +! This option is currently only supported if using reach-based routing with UDMP=1. +bucket_loss = 0 + +! Groundwater/baseflow 2d mask specified on land surface model grid (e.g.: "GWBASINS.nc") +! Note: Only required if baseflow model is active (1 or 2) and UDMP_OPT=0. +gwbasmskfil = "./DOMAIN/GWBASINS.nc" + +! Groundwater bucket parameter file (e.g.: "GWBUCKPARM.nc") +GWBUCKPARM_file = "./DOMAIN/GWBUCKPARM.nc" + +! User defined mapping, such as NHDPlus: 0=no (default), 1=yes +UDMP_OPT = 0 + +! If on, specify the user-defined mapping file (e.g.: "spatialweights.nc") +!udmap_file = "./DOMAIN/spatialweights.nc" + +/ + +&reservoir_nlist + ! Specify the reservoir parameter file reservoir_parameter_file = "./DOMAIN/persistence_parm.nc" @@ -190,28 +220,6 @@ reservoir_rfc_forecasts_time_series_path = "./rfc_timeseries/" ! Specify lookback hours to read reservoir RFC forecasts reservoir_rfc_forecasts_lookback_hours = 28 -! Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through, -! 4=exp. bucket with area normalized parameters) -! Option 4 is currently only supported if using reach-based routing with UDMP=1. -GWBASESWCRT = 1 - -! Switch to activate bucket model loss (0=no, 1=yes) -! This option is currently only supported if using reach-based routing with UDMP=1. -bucket_loss = 0 - -! Groundwater/baseflow 2d mask specified on land surface model grid (e.g.: "GWBASINS.nc") -! Note: Only required if baseflow model is active (1 or 2) and UDMP_OPT=0. -gwbasmskfil = "./DOMAIN/GWBASINS.nc" - -! Groundwater bucket parameter file (e.g.: "GWBUCKPARM.nc") -GWBUCKPARM_file = "./DOMAIN/GWBUCKPARM.nc" - -! User defined mapping, such as NHDPlus: 0=no (default), 1=yes -UDMP_OPT = 0 - -! If on, specify the user-defined mapping file (e.g.: "spatialweights.nc") -!udmap_file = "./DOMAIN/spatialweights.nc" - / &NUDGING_nlist diff --git a/hydro/template/NoahMP/namelist.hrldas b/hydro/template/NoahMP/namelist.hrldas index c760fe65bb..a3a3da702c 100644 --- a/hydro/template/NoahMP/namelist.hrldas +++ b/hydro/template/NoahMP/namelist.hrldas @@ -64,6 +64,18 @@ rst_bi_in = 0 !0: use netcdf input restart file rst_bi_out = 0 !0: use netcdf output restart file !1: use parallel io for outputting multiple restart files (1 per core) +! Forcing input variable names +forcing_name_T = "T2D" +forcing_name_Q = "Q2D" +forcing_name_U = "U2D" +forcing_name_V = "V2D" +forcing_name_P = "PSFC" +forcing_name_LW = "LWDOWN" +forcing_name_SW = "SWDOWN" +forcing_name_PR = "RAINRATE" +forcing_name_SN = "" +forcing_name_LF = "LQFRAC" + / &WRF_HYDRO_OFFLINE diff --git a/hydro/utils/module_hydro_stop.F90 b/hydro/utils/module_hydro_stop.F90 index 724d61dcea..c4b25a21af 100644 --- a/hydro/utils/module_hydro_stop.F90 +++ b/hydro/utils/module_hydro_stop.F90 @@ -14,7 +14,7 @@ subroutine HYDRO_stop(msg) ierr = 1 #ifndef NCEP_WCOSS !#ifdef HYDRO_D !! PLEASE NEVER UNCOMMENT THIS IFDEF, it's just one incredibly useful string. - write(6,*) "The job is stopped due to the fatal error. ", trim(msg) + write(6,'(a)') "The job has stopped due to a fatal error: ", trim(msg) call flush(6) !#endif #else @@ -35,7 +35,7 @@ subroutine HYDRO_stop(msg) ! call flush(my_id+90) call mpp_land_abort() - call MPI_finalize(ierr) + call MPI_Finalize(ierr) #else stop "FATAL ERROR: Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." #endif