fixed problem in routing loop when mainstem does not exist in OMP dec…

…omposition
nmizukami · Jun 21, 2019 · e1dfd27 · e1dfd27
1 parent 9b00d3a
commit e1dfd27
Show file tree

Hide file tree

Showing 2 changed files with 16 additions and 11 deletions.
diff --git 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
@@ -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)