Skip to content

Commit

Permalink
Merge pull request #383 from zhangsp8/master
Browse files Browse the repository at this point in the history 
Fixed some bugs in special cases.
  • Loading branch information
@CoLM-SYSU
CoLM-SYSU authored Feb 26, 2025
2 parents 7d336cc + 5461a3c commit 2db476d
Show file tree
Hide file tree
Showing 11 changed files with 337 additions and 276 deletions.
161 changes: 102 additions & 59 deletions main/HYDRO/MOD_Catch_BasinNetwork.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,11 +15,11 @@ MODULE MOD_Catch_BasinNetwork
integer :: numbasin
integer, allocatable :: basinindex(:)

integer :: numrivmth
integer, allocatable :: rivermouth(:)

integer :: numbsnhru
type(subset_type) :: basin_hru

integer :: numrivmth
integer, allocatable :: rivermouth(:)

! -- communications --
type :: basin_pushdata_type
Expand All @@ -31,7 +31,6 @@ MODULE MOD_Catch_BasinNetwork
integer, allocatable :: paddr (:)
integer, allocatable :: ndata (:)
integer, allocatable :: ipush (:)
integer, allocatable :: isdrv (:)
CONTAINS
final :: basin_pushdata_free_mem
END type basin_pushdata_type
Expand Down Expand Up @@ -63,14 +62,19 @@ SUBROUTINE build_basin_network ()
! Local Variables
character(len=256) :: basin_file
integer, allocatable :: basindown(:), nhru_all(:), nhru_in_bsn(:)

integer, allocatable :: nups_nst(:), iups_nst(:), nups_all(:), b_up2down(:), orderbsn(:)

integer , allocatable :: nb_rs(:), iwrk_rs(:), nwrk_rs(:), nave_rs(:), nb_wrk(:)
real(r8), allocatable :: wtbsn(:), wt_rs (:), wt_wrk (:)

integer :: totalnumbasin, ibasin, nbasin
integer :: iworker, mesg(2), isrc, nrecv, idata, ndatall
integer :: ip, iloc, ielm, i, j, ithis, nave, nups
integer :: totalnumbasin, ibasin, nbasin, iriv
integer :: iworker, iwrkdsp, mesg(2), isrc, nrecv, idata, ndatall
integer :: ip, iloc, ielm, i, j, ithis
real(r8) :: sumwt

integer, allocatable :: eindex (:), bindex (:), addrelm (:), addrbasin(:), orderbsn(:)
integer, allocatable :: nups_nst(:), iups_nst(:), nups_all(:), b_up2down(:)
integer, allocatable :: nelm_wrk(:), paddr (:), icache (:)
integer, allocatable :: eindex(:), bindex(:), addrelm(:), addrbasin(:)
integer, allocatable :: paddr (:), icache(:)

integer, allocatable :: basin_sorted(:), element_sorted(:)
integer, allocatable :: basin_order (:), element_order (:)
Expand Down Expand Up @@ -133,6 +137,12 @@ SUBROUTINE build_basin_network ()

! 3-2: divide basins into groups and assign to workers
IF (p_is_master) THEN

IF (ncio_var_exist(basin_file, 'weightbasin')) THEN
CALL ncio_read_serial (basin_file, 'weightbasin', wtbsn)
ELSE
allocate (wtbsn (totalnumbasin)); wtbsn(:) = 1.
ENDIF

! sort basins from up to down, recorded by "b_up2down"

Expand Down Expand Up @@ -173,6 +183,46 @@ SUBROUTINE build_basin_network ()
deallocate (nups_nst)
deallocate (iups_nst)

allocate (rivermouth (totalnumbasin))
numrivmth = 0
DO i = totalnumbasin, 1, -1
j = basindown(b_up2down(i))
IF (j <= 0) THEN
numrivmth = numrivmth + 1
rivermouth(b_up2down(i)) = numrivmth
ELSE
rivermouth(b_up2down(i)) = rivermouth(j)
ENDIF
ENDDO

allocate (nb_rs (numrivmth)); nb_rs(:) = 0
allocate (wt_rs (numrivmth)); wt_rs(:) = 0
DO i = 1, totalnumbasin
nb_rs(rivermouth(i)) = nb_rs(rivermouth(i)) + 1
wt_rs(rivermouth(i)) = wt_rs(rivermouth(i)) + wtbsn(i)
ENDDO

sumwt = sum(wt_rs)

allocate (iwrk_rs (numrivmth))
allocate (nwrk_rs (numrivmth))
allocate (nave_rs (numrivmth))

iwrkdsp = -1
DO i = 1, numrivmth
nwrk_rs(i) = floor(wt_rs(i)/sumwt * p_np_worker)
IF (nwrk_rs(i) > 1) THEN

nave_rs(i) = nb_rs(i) / nwrk_rs(i)
IF (mod(nb_rs(i), nwrk_rs(i)) /= 0) THEN
nave_rs(i) = nave_rs(i) + 1
ENDIF

iwrk_rs(i) = iwrkdsp + 1
iwrkdsp = iwrkdsp + nwrk_rs(i)
ENDIF
ENDDO

allocate (nups_all (totalnumbasin)); nups_all(:) = 1

DO i = 1, totalnumbasin
Expand All @@ -182,21 +232,15 @@ SUBROUTINE build_basin_network ()
ENDIF
ENDDO

nave = totalnumbasin / p_np_worker
IF (mod(totalnumbasin, p_np_worker) /= 0) THEN
nave = nave + 1
ENDIF
allocate (addrbasin (totalnumbasin)); addrbasin(:) = -1
allocate (wt_wrk (0:p_np_worker-1)); wt_wrk(:) = 0
allocate (nb_wrk (0:p_np_worker-1)); nb_wrk(:) = 0

allocate (orderbsn(totalnumbasin))
orderbsn(b_up2down) = (/(i, i = 1, totalnumbasin)/)

allocate (nelm_wrk (0:p_np_worker-1)); nelm_wrk(:) = 0

allocate (addrbasin (totalnumbasin))
addrbasin(:) = -1

ithis = totalnumbasin
iworker = p_np_worker-1
ithis = totalnumbasin
DO WHILE (ithis > 0)

i = b_up2down(ithis)
Expand All @@ -215,48 +259,56 @@ SUBROUTINE build_basin_network ()
ENDIF
ENDIF

IF (nups_all(i) <= nave-nelm_wrk(iworker)) THEN
addrbasin(i) = p_address_worker(iworker)
nelm_wrk(iworker) = nelm_wrk(iworker) + nups_all(i)
iriv = rivermouth(i)
IF (nwrk_rs(iriv) > 1) THEN
iworker = iwrk_rs(iriv)
IF (nups_all(i) <= nave_rs(iriv)-nb_wrk(iworker)) THEN

IF (nelm_wrk(iworker) == nave) THEN
iworker = iworker - 1
ENDIF
addrbasin(i) = p_address_worker(iworker)

j = basindown(i)
DO WHILE (j > 0)
nups_all(j) = nups_all(j) - nups_all(i)
ithis = orderbsn(j)
j = basindown(j)
ENDDO
nb_wrk(iworker) = nb_wrk(iworker) + nups_all(i)
IF (nb_wrk(iworker) == nave_rs(iriv)) THEN
iwrk_rs(iriv) = iwrk_rs(iriv) + 1
ENDIF

j = basindown(i)
IF (j > 0) THEN
DO WHILE (j > 0)
nups_all(j) = nups_all(j) - nups_all(i)
ithis = orderbsn(j)
j = basindown(j)
ENDDO
ELSE
ithis = ithis - 1
ENDIF
ELSE
ithis = ithis - 1
ENDIF
ELSE
ithis = ithis - 1
ENDIF
ENDDO
iworker = minloc(wt_wrk(iwrkdsp+1:p_np_worker-1), dim=1) + iwrkdsp

allocate (rivermouth (totalnumbasin))
ithis = 0
DO i = totalnumbasin, 1, -1
j = basindown(b_up2down(i))
IF (j <= 0) THEN
ithis = ithis + 1
rivermouth(b_up2down(i)) = ithis
ELSE
rivermouth(b_up2down(i)) = rivermouth(j)
addrbasin(i) = p_address_worker(iworker)

wt_wrk(iworker) = wt_wrk(iworker) + wt_rs(iriv)
ithis = ithis - 1
ENDIF
ENDDO

numrivmth = ithis
ENDDO

deallocate (wtbsn )
deallocate (b_up2down)
deallocate (nups_all )
deallocate (orderbsn )
deallocate (nelm_wrk )
deallocate (nb_rs )
deallocate (wt_rs )
deallocate (iwrk_rs )
deallocate (nwrk_rs )
deallocate (nave_rs )
deallocate (wt_wrk )
deallocate (nb_wrk )

ENDIF

CALL mpi_bcast (numrivmth, 1, MPI_INTEGER, p_address_master, p_comm_glb, p_err)

! 3-3: send basin index to workers
IF (p_is_master) THEN
Expand Down Expand Up @@ -286,10 +338,6 @@ SUBROUTINE build_basin_network ()
CALL mpi_send (icache, nbasin, MPI_INTEGER, p_address_worker(iworker), &
mpi_tag_data, p_comm_glb, p_err)

icache = rivermouth(bindex)
CALL mpi_send (icache, nbasin, MPI_INTEGER, p_address_worker(iworker), &
mpi_tag_data, p_comm_glb, p_err)

nhru_in_bsn = nhru_all(bindex)
CALL mpi_send (nhru_in_bsn, nbasin, MPI_INTEGER, p_address_worker(iworker), &
mpi_tag_data, p_comm_glb, p_err)
Expand Down Expand Up @@ -321,10 +369,6 @@ SUBROUTINE build_basin_network ()
CALL mpi_recv (basindown, numbasin, MPI_INTEGER, p_address_master, &
mpi_tag_data, p_comm_glb, p_stat, p_err)

allocate (rivermouth (numbasin))
CALL mpi_recv (rivermouth, numbasin, MPI_INTEGER, p_address_master, &
mpi_tag_data, p_comm_glb, p_stat, p_err)

allocate (nhru_in_bsn (numbasin))
CALL mpi_recv (nhru_in_bsn, numbasin, MPI_INTEGER, p_address_master, &
mpi_tag_data, p_comm_glb, p_stat, p_err)
Expand Down Expand Up @@ -1017,7 +1061,6 @@ SUBROUTINE basin_pushdata_free_mem (this)
IF (allocated(this%paddr)) deallocate(this%paddr)
IF (allocated(this%ndata)) deallocate(this%ndata)
IF (allocated(this%ipush)) deallocate(this%ipush)
IF (allocated(this%isdrv)) deallocate(this%isdrv)

END SUBROUTINE basin_pushdata_free_mem

Expand Down
14 changes: 14 additions & 0 deletions main/HYDRO/MOD_Catch_Hist.F90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,8 @@ MODULE MOD_Catch_Hist

real(r8), allocatable :: a_xsubs_elm (:)
real(r8), allocatable :: a_xsubs_hru (:)

real(r8), allocatable :: ntacc_elm (:)

! -- PUBLIC SUBROUTINEs --
PUBLIC :: hist_basin_init
Expand Down Expand Up @@ -154,6 +156,7 @@ SUBROUTINE hist_basin_out (file_hist, idate)
allocate (a_wdsrf_elm (numelm))
allocate (a_veloc_elm (numelm))
allocate (a_dschg_elm (numelm))
allocate (ntacc_elm (numelm))
ENDIF
ENDIF

Expand Down Expand Up @@ -196,6 +199,13 @@ SUBROUTINE hist_basin_out (file_hist, idate)
file_hist_basin, a_dschg_elm, numelm, totalnumelm, 'discharge', 'basin', elm_data_address, &
DEF_hist_vars%discharge, itime_in_file, 'River Discharge', 'm^3/s')

! ----- number of time steps for each basin -----
CALL worker_push_data (iam_bsn, iam_elm, ntacc_bsn, ntacc_elm)

CALL vector_write_basin (&
file_hist_basin, ntacc_elm, numelm, totalnumelm, 'timesteps', 'basin', elm_data_address, &
.true., itime_in_file, 'Number of accumulated timesteps for each basin', '-')

! ----- water depth in hydro unit -----
IF ((p_is_worker) .and. allocated(a_wdsrf_bsnhru)) THEN
WHERE(a_wdsrf_bsnhru /= spval)
Expand Down Expand Up @@ -253,6 +263,8 @@ SUBROUTINE hist_basin_out (file_hist, idate)
IF (allocated(a_wdsrf_elm)) deallocate(a_wdsrf_elm)
IF (allocated(a_veloc_elm)) deallocate(a_veloc_elm)
IF (allocated(a_dschg_elm)) deallocate(a_dschg_elm)
IF (allocated(ntacc_elm )) deallocate(ntacc_elm )


END SUBROUTINE hist_basin_out

Expand Down Expand Up @@ -283,6 +295,8 @@ SUBROUTINE FLUSH_acc_fluxes_basin ()
ENDIF

IF (numhru > 0) a_xsubs_hru(:) = spval

IF (numbasin > 0) ntacc_bsn(:) = 0.

ENDIF

Expand Down
Loading

0 comments on commit 2db476d

Please sign in to comment.