Reuse GEN_BLOCK_MAP if already on input.

base/tools/psb_cd_renum_block.F90

@@ -56,7 +56,7 @@ subroutine psb_cd_renum_block(desc_in, desc_out, info)
   integer(psb_ipk_) :: np,me,ictxt, err_act
   integer(psb_ipk_) :: debug_level, debug_unit
   character(len=20)   :: name
-  
+
   debug_unit  = psb_get_debug_unit()
   debug_level = psb_get_debug_level()
 
@@ -81,72 +81,79 @@ subroutine psb_cd_renum_block(desc_in, desc_out, info)
   if (desc_in%is_ovl()) then
     write(0,*) 'Warning: descriptor with overlap, not going to clone into BLOCK'
   else
-    !
+    select type (desc_in%indxmap)
-    ! Ok, convert into a GEN BLOCK. 
+      class is (psb_gen_block_map)
-    !
+        call psb_erractionrestore(err_act)
-    allocate(psb_gen_block_map :: blck_map, stat=info) 
+        return
-    if (info == 0) allocate(vnl(0:np),stat=info)
+
-    if (info /= 0) then
+      class default
-      info = psb_err_alloc_dealloc_
+        !
-      call psb_errpush(info,name)
+        ! Ok, convert into a GEN BLOCK. 
-      goto 9999
+        !
-    endif
+      allocate(psb_gen_block_map :: blck_map, stat=info) 
-    n_row = desc_in%get_local_rows()
+      if (info == 0) allocate(vnl(0:np),stat=info)
-    n_col = desc_in%get_local_cols()
+      if (info /= 0) then
-    n_glob_row = desc_in%get_global_rows()
+        info = psb_err_alloc_dealloc_
-    n_glob_col = desc_in%get_global_cols()
+        call psb_errpush(info,name)
-    vnl = 0
+        goto 9999
-    vnl(me) = n_row
+      endif
-    call psb_sum(ictxt,vnl)
+      n_row = desc_in%get_local_rows()
-    vnl(1:np) = vnl(0:np-1)
+      n_col = desc_in%get_local_cols()
-    vnl(0) = 0
+      n_glob_row = desc_in%get_global_rows()
-    do i=1,np
+      n_glob_col = desc_in%get_global_cols()
-      vnl(i) = vnl(i-1)+vnl(i)
+      vnl = 0
-    end do
+      vnl(me) = n_row
-    allocate(lidx(n_col),reflidx(n_col),gidx(n_col),stat=info)
+      call psb_sum(ictxt,vnl)
-    if (info /= 0) then
+      vnl(1:np) = vnl(0:np-1)
-      info = psb_err_alloc_dealloc_
+      vnl(0) = 0
-      call psb_errpush(info,name)
+      do i=1,np
-      goto 9999
+        vnl(i) = vnl(i-1)+vnl(i)
-    endif
+      end do
-    !
+      allocate(lidx(n_col),reflidx(n_col),gidx(n_col),stat=info)
-    ! A GEN_BLOCK distribution would just assign indices 1:N_R0
+      if (info /= 0) then
-    ! to process 0, N_R0+1:N_R0+N_R1 to process 1 and so on;
+        info = psb_err_alloc_dealloc_
-    ! once these are set you can get the others by invoking
+        call psb_errpush(info,name)
-    ! HALO on the old descriptor, then put the map into the new
+        goto 9999
-    ! one. Halo lists are stored in local indices, so they will
+      endif
-    ! continue to work since local indices stay the same, it's
+      !
-    ! only the global indices that were reshuffled.
+      ! A GEN_BLOCK distribution would just assign indices 1:N_R0
-    !
+      ! to process 0, N_R0+1:N_R0+N_R1 to process 1 and so on;
-    reflidx(1:n_col) = [(i,i=1,n_col)]
+      ! once these are set you can get the others by invoking
-    gidx(1:n_row) = reflidx(1:n_row) + vnl(me)
+      ! HALO on the old descriptor, then put the map into the new
-    call psb_halo(gidx,desc_in,info)
+      ! one. Halo lists are stored in local indices, so they will
-    if (debug_level >= psb_debug_ext_) &
+      ! continue to work since local indices stay the same, it's
-         & write(debug_unit,*) me,' ',trim(name),': Done halo on gidx ',info
+      ! only the global indices that were reshuffled.
-  
+      !
-    if (info == 0) call blck_map%gen_block_map_init(ictxt,n_row,info)
+      reflidx(1:n_col) = [(i,i=1,n_col)]
-    if (debug_level >= psb_debug_ext_) &
+      gidx(1:n_row) = reflidx(1:n_row) + vnl(me)
-         & write(debug_unit,*) me,' ',trim(name),': Done gen_block_map_init ',info,&
+      call psb_halo(gidx,desc_in,info)
-         & blck_map%get_lr(),blck_map%get_lc(),vnl(me)
+      if (debug_level >= psb_debug_ext_) &
-    
+           & write(debug_unit,*) me,' ',trim(name),': Done halo on gidx ',info
-    if (info == 0) call blck_map%g2l_ins(gidx,lidx,info,lidx=reflidx)
+
-    if (debug_level >= psb_debug_ext_) then 
+      if (info == 0) call blck_map%gen_block_map_init(ictxt,n_row,info)
-      write(debug_unit,*) me,' ',trim(name),': Done g2l_ins ',info,size(gidx),size(lidx),size(reflidx)
+      if (debug_level >= psb_debug_ext_) &
-      write(debug_unit,*) me,' ',trim(name),': Done g2l_ins ',gidx(:),':',lidx(:),' :',reflidx(:)
+           & write(debug_unit,*) me,' ',trim(name),': Done gen_block_map_init ',info,&
-    end if
+           & blck_map%get_lr(),blck_map%get_lc(),vnl(me)
-      
+
-    if (info == 0) call blck_map%asb(info)
+      if (info == 0) call blck_map%g2l_ins(gidx,lidx,info,lidx=reflidx)
-    if (debug_level >= psb_debug_ext_) &
+      if (debug_level >= psb_debug_ext_) then 
-         & write(debug_unit,*) me,' ',trim(name),': Done asb ',info
+        write(debug_unit,*) me,' ',trim(name),': Done g2l_ins ',info,size(gidx),size(lidx),size(reflidx)
-  
+        write(debug_unit,*) me,' ',trim(name),': Done g2l_ins ',gidx(:),':',lidx(:),' :',reflidx(:)
-    if (info /= psb_success_) then
+      end if
-      info = psb_err_from_subroutine_
+
-      call psb_errpush(info,name)
+      if (info == 0) call blck_map%asb(info)
-      goto 9999
+      if (debug_level >= psb_debug_ext_) &
-    endif
+           & write(debug_unit,*) me,' ',trim(name),': Done asb ',info
-    call move_alloc(blck_map,desc_out%indxmap)
+
+      if (info /= psb_success_) then
+        info = psb_err_from_subroutine_
+        call psb_errpush(info,name)
+        goto 9999
+      endif
+      call move_alloc(blck_map,desc_out%indxmap)
+    end select
   end if
-  
+
   if (info /= psb_success_) then
     info = psb_err_from_subroutine_
     call psb_errpush(info,name)