From e1dfd279a536a32e2dcf9779af54ef4314cbf224 Mon Sep 17 00:00:00 2001 From: Naoki Mizukami Date: Fri, 21 Jun 2019 10:50:16 -0600 Subject: [PATCH] fixed problem in routing loop when mainstem does not exist in OMP decomposition --- route/build/src/domain_decomposition.f90 | 21 ++++++++++++--------- route/build/src/mpi_process.f90 | 6 ++++-- 2 files changed, 16 insertions(+), 11 deletions(-) diff --git a/route/build/src/domain_decomposition.f90 b/route/build/src/domain_decomposition.f90 index 9033ba9f..348365ec 100644 --- a/route/build/src/domain_decomposition.f90 +++ b/route/build/src/domain_decomposition.f90 @@ -733,15 +733,12 @@ subroutine basin_order(nSeg, structNTOPO_in, domains_omp, nDomain_omp, river_bas ! sorting reach processing order call indexx(segOrder,rankSegOrder) - allocate(river_basin_out(2), stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem allocating [river_basin_out]'; return; endif - allocate(nSubSeg(nDomain_omp),rankDomain(nDomain_omp),isAssigned(nDomain_omp),stat=ierr) if(ierr/=0)then; message=trim(message)//'problem allocating [nSubSeg,rankDomain,isAssigned]'; return; endif - ! rank domains based on number of reaches i.e., nSubSeg - rankDomain - ! count tributaries - + ! rank domains based on number of reaches i.e., rankDomain + ! count tributar and mainstem domains + ! nTrib > 0 and nMain = 0 or 1 nTrib = 0; nMain = 0 ! initialize number of tributaries and mainstems do ix = 1,nDomain_omp nSubSeg(ix) = size(domains_omp(ix)%segIndex) @@ -750,10 +747,16 @@ subroutine basin_order(nSeg, structNTOPO_in, domains_omp, nDomain_omp, river_bas end do call indexx(nSubSeg, rankDomain) - if (nTrib/=0) then - allocate(river_basin_out(tributary)%branch(nTrib), stat=ierr) - if(ierr/=0)then; message=trim(message)//'problem allocating [river_basin_out%branch]'; return; endif + ! allocate river_basin_out data strucuture + if (nMain==0) then + allocate(river_basin_out(1), stat=ierr) + else + allocate(river_basin_out(2), stat=ierr) endif + if(ierr/=0)then; message=trim(message)//'problem allocating [river_basin_out]'; return; endif + + allocate(river_basin_out(tributary)%branch(nTrib), stat=ierr) + if(ierr/=0)then; message=trim(message)//'problem allocating [river_basin_out%branch]'; return; endif if (nMain/=0) then allocate(river_basin_out(mainstem)%branch(nMain), stat=ierr) diff --git a/route/build/src/mpi_process.f90 b/route/build/src/mpi_process.f90 index d6e374c3..39b2703c 100644 --- a/route/build/src/mpi_process.f90 +++ b/route/build/src/mpi_process.f90 @@ -78,8 +78,10 @@ subroutine comm_ntopo_data(pid, & ! input: proc id USE alloc_data, ONLY: alloc_struct USE process_ntopo, ONLY: augment_ntopo ! compute all the additional network topology (only compute option = on) USE process_ntopo, ONLY: put_data_struct ! - USE domain_decomposition,ONLY: omp_domain_decomposition & ! domain decomposition for omp - => omp_domain_decomposition_stro + USE domain_decomposition,ONLY: omp_domain_decomposition ! domain decomposition for omp + !USE domain_decomposition,ONLY: omp_domain_decomposition & ! domain decomposition for omp + ! => omp_domain_decomposition_stro + implicit none ! Input variables integer(i4b), intent(in) :: pid ! process id (MPI)