Commit d64427ec authored by Anthony's avatar Anthony
Browse files

Truncate : anticipating loop errors and handling HTUs flowing out of the domain

parent 711419e1
...@@ -581,7 +581,7 @@ SUBROUTINE killbas(nbpt, nbxmax_in, nbasmax, nwbas,ops, tokill, totakeover, numo ...@@ -581,7 +581,7 @@ SUBROUTINE killbas(nbpt, nbxmax_in, nbasmax, nwbas,ops, tokill, totakeover, numo
INTEGER(i_std), DIMENSION(nbpt,nbxmax_in,nbxmax_in), INTENT(inout) :: inflow_grid !! INTEGER(i_std), DIMENSION(nbpt,nbxmax_in,nbxmax_in), INTENT(inout) :: inflow_grid !!
!! LOCAL !! LOCAL
INTEGER(i_std) :: ib, op, tok, totak INTEGER(i_std) :: ib, op, tok, totak, igrif, ibasf
DO ib=1,nbpt DO ib=1,nbpt
...@@ -591,6 +591,22 @@ SUBROUTINE killbas(nbpt, nbxmax_in, nbasmax, nwbas,ops, tokill, totakeover, numo ...@@ -591,6 +591,22 @@ SUBROUTINE killbas(nbpt, nbxmax_in, nbasmax, nwbas,ops, tokill, totakeover, numo
totak = totakeover(ib,op) totak = totakeover(ib,op)
IF (tok .GT. 0) THEN IF (tok .GT. 0) THEN
WRITE(numout,*) "nbpt", ib, "tokill", tok, "totakover", totak WRITE(numout,*) "nbpt", ib, "tokill", tok, "totakover", totak
! Test if tokill is downstream of totakeover (avoid loop)
igrif = outflow_grid(ib,totak)
ibasf = outflow_basin(ib,totak)
DO WHILE ( igrif >0 )
IF ((igrif .EQ. ib) .AND. (ibasf .EQ. tok)) THEN
!CALL ipslerr_p(3,'killbas','tokill is downstream totakeover','','')
igrif = 0
it = totak
totak = tok
tok = it
ELSE
it = outflow_grid(igrif,ibasf)
ibasf = outflow_basin(igrif,ibasf)
igrif = it
END IF
END DO
CALL routing_reg_killbas(nbpt, ib, tok, totak, nwbas, basin_count, basin_area, basin_cg, basin_topoind,& CALL routing_reg_killbas(nbpt, ib, tok, totak, nwbas, basin_count, basin_area, basin_cg, basin_topoind,&
& fetch_basin, basin_id, basin_coor, basin_type, basin_flowdir, outflow_grid, outflow_basin, inflow_number,& & fetch_basin, basin_id, basin_coor, basin_type, basin_flowdir, outflow_grid, outflow_basin, inflow_number,&
& inflow_grid, inflow_basin) & inflow_grid, inflow_basin)
......
...@@ -1059,7 +1059,7 @@ CONTAINS ...@@ -1059,7 +1059,7 @@ CONTAINS
! !
!! LOCAL VARIABLES !! LOCAL VARIABLES
REAL(r_std), PARAMETER :: flag=-9999. !! REAL(r_std), PARAMETER :: flag=-9999. !!
LOGICAL, PARAMETER :: debug=.TRUE. LOGICAL, PARAMETER :: debug=.FALSE.
LOGICAL, PARAMETER :: checkgrid=.FALSE. LOGICAL, PARAMETER :: checkgrid=.FALSE.
CHARACTER(LEN=7) :: fmt !! CHARACTER(LEN=7) :: fmt !!
CHARACTER(LEN=9) :: fmtr !! CHARACTER(LEN=9) :: fmtr !!
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment