diff --git a/base/modules/psb_desc_mod.f90 b/base/modules/psb_desc_mod.f90 index da5fadf7..a5a62978 100644 --- a/base/modules/psb_desc_mod.f90 +++ b/base/modules/psb_desc_mod.f90 @@ -233,6 +233,16 @@ module psb_desc_mod end type psb_desc_type + + interface + subroutine psb_cd_clone(desc, desc_out, info) + import psb_desc_type, psb_ipk_ + class(psb_desc_type), intent(inout), target :: desc + class(psb_desc_type), intent(inout) :: desc_out + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cd_clone + end interface + interface psb_sizeof module procedure psb_cd_sizeof end interface psb_sizeof @@ -899,89 +909,6 @@ contains end Subroutine psb_cd_get_recv_idx - subroutine psb_cd_clone(desc, desc_out, info) - - use psb_error_mod - use psb_penv_mod - use psb_realloc_mod - - implicit none - !....parameters... - - class(psb_desc_type), intent(inout), target :: desc - class(psb_desc_type), intent(inout) :: desc_out - integer(psb_ipk_), intent(out) :: info - !locals - 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() - - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - name = 'psb_cdcpy' - - if (desc%is_valid()) then - ictxt = desc%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Entered' - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - desc_out%base_desc => desc%base_desc - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%halo_index,desc_out%halo_index,info) - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%ext_index,desc_out%ext_index,info) - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%ovrlap_index,& - & desc_out%ovrlap_index,info) - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%bnd_elem,desc_out%bnd_elem,info) - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%ovrlap_elem,desc_out%ovrlap_elem,info) - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%ovr_mst_idx,desc_out%ovr_mst_idx,info) - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%lprm,desc_out%lprm,info) - if (info == psb_success_)& - & call psb_safe_ab_cpy(desc%idx_space,desc_out%idx_space,info) - if ((info == psb_success_).and.(allocated(desc%indxmap))) & - & call desc%indxmap%clone(desc_out%indxmap,info) - else - call desc_out%free(info) - end if - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name) - goto 9999 - endif - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Done' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - - end subroutine psb_cd_clone end module psb_desc_mod diff --git a/base/modules/psb_gen_block_map_mod.f90 b/base/modules/psb_gen_block_map_mod.f90 index 1a5d4f1d..55376b3b 100644 --- a/base/modules/psb_gen_block_map_mod.f90 +++ b/base/modules/psb_gen_block_map_mod.f90 @@ -64,6 +64,7 @@ module psb_gen_block_map_mod procedure, pass(idxmap) :: asb => block_asb procedure, pass(idxmap) :: free => block_free procedure, pass(idxmap) :: clone => block_clone + procedure, pass(idxmap) :: reinit => block_reinit procedure, nopass :: get_fmt => block_get_fmt procedure, pass(idxmap) :: l2gs1 => block_l2gs1 @@ -89,7 +90,7 @@ module psb_gen_block_map_mod & block_get_fmt, block_l2gs1, block_l2gs2, block_l2gv1,& & block_l2gv2, block_g2ls1, block_g2ls2, block_g2lv1,& & block_g2lv2, block_g2ls1_ins, block_g2ls2_ins,& - & block_g2lv1_ins, block_g2lv2_ins, block_clone + & block_g2lv1_ins, block_g2lv2_ins, block_clone, block_reinit integer(psb_ipk_), private :: laddsz=500 @@ -696,6 +697,7 @@ contains subroutine block_init(idxmap,ictxt,nl,info) use psb_penv_mod + use psb_realloc_mod use psb_error_mod implicit none class(psb_gen_block_map), intent(inout) :: idxmap @@ -743,7 +745,7 @@ contains idxmap%min_glob_row = vnl(iam)+1 idxmap%max_glob_row = vnl(iam+1) call move_alloc(vnl,idxmap%vnl) - allocate(idxmap%loc_to_glob(nl),stat=info) + call psb_realloc(nl,idxmap%loc_to_glob,info) if (info /= 0) then info = -2 return @@ -854,4 +856,106 @@ contains return end subroutine block_clone + + subroutine block_reinit(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, nr,nc,k, nl, ictxt + integer(psb_ipk_), allocatable :: idx(:),lidx(:) + character(len=20) :: name='block_reinit' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + + nr = idxmap%get_lr() + nc = idxmap%get_lc() + if (nc>nr) then + lidx = (/(k,k=nr+1,nc)/) + idx = (/(k,k=nr+1,nc)/) + call idxmap%l2gip(idx,info) + end if + if (info /= 0) & + & write(0,*) 'From l2gip',info + + + call psb_hash_init(nr,idxmap%hash,info) + if (info /= 0) & + & write(0,*) 'From hash_init',info + call idxmap%set_state(psb_desc_bld_) + if (nc>nr) then + call idxmap%g2lip_ins(idx,info,lidx=lidx) + end if + + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + end subroutine block_reinit + +!!$ +!!$ subroutine block_reinit(idxmap,info) +!!$ use psb_penv_mod +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ implicit none +!!$ class(psb_gen_block_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_) :: err_act, nr,nc,k, nl, ictxt +!!$ integer(psb_ipk_), allocatable :: idx(:),lidx(:) +!!$ character(len=20) :: name='block_reinit' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ info = psb_success_ +!!$ call psb_get_erraction(err_act) +!!$ ictxt = idxmap%get_ctxt() +!!$ nr = idxmap%get_lr() +!!$ nc = idxmap%get_lc() +!!$ if (nc>nr) then +!!$ lidx = (/(k,k=nr+1,nc)/) +!!$ idx = (/(k,k=nr+1,nc)/) +!!$ call idxmap%l2gip(idx,info) +!!$ end if +!!$ if (info /= 0) & +!!$ & write(0,*) 'From l2gip',info +!!$ +!!$ call idxmap%init(ictxt,nr,info) +!!$ if (nc>nr) then +!!$ call idxmap%g2lip_ins(idx,info,lidx=lidx) +!!$ end if +!!$ +!!$ +!!$ if (info /= psb_success_) then +!!$ info = psb_err_from_subroutine_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ end subroutine block_reinit +!!$ + + end module psb_gen_block_map_mod diff --git a/base/modules/psb_indx_map_mod.f90 b/base/modules/psb_indx_map_mod.f90 index 3cdffc0c..ebebba42 100644 --- a/base/modules/psb_indx_map_mod.f90 +++ b/base/modules/psb_indx_map_mod.f90 @@ -1,3 +1,4 @@ + !!$ !!$ Parallel Sparse BLAS version 3.1 !!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013 @@ -158,6 +159,7 @@ module psb_indx_map_mod procedure, pass(idxmap) :: asb => base_asb procedure, pass(idxmap) :: free => base_free procedure, pass(idxmap) :: clone => base_clone + procedure, pass(idxmap) :: reinit => base_reinit procedure, pass(idxmap) :: l2gs1 => base_l2gs1 procedure, pass(idxmap) :: l2gs2 => base_l2gs2 @@ -196,7 +198,7 @@ module psb_indx_map_mod & base_g2ls1, base_g2ls2, base_g2lv1, base_g2lv2,& & base_g2ls1_ins, base_g2ls2_ins, base_g2lv1_ins,& & base_g2lv2_ins, base_init_vl, base_is_null,& - & base_row_extendable, base_clone + & base_row_extendable, base_clone, base_reinit !> Function: psb_indx_map_fnd_owner !! \memberof psb_indx_map @@ -879,4 +881,30 @@ contains return end subroutine base_clone + + subroutine base_reinit(idxmap,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_reinit' + logical, parameter :: debug=.false. + + info = psb_success_ + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + end subroutine base_reinit + end module psb_indx_map_mod diff --git a/base/modules/psb_list_map_mod.f90 b/base/modules/psb_list_map_mod.f90 index 4a92f38e..14326d97 100644 --- a/base/modules/psb_list_map_mod.f90 +++ b/base/modules/psb_list_map_mod.f90 @@ -54,6 +54,7 @@ module psb_list_map_mod procedure, pass(idxmap) :: asb => list_asb procedure, pass(idxmap) :: free => list_free procedure, pass(idxmap) :: clone => list_clone + procedure, pass(idxmap) :: reinit => list_reinit procedure, nopass :: get_fmt => list_get_fmt procedure, nopass :: row_extendable => list_row_extendable @@ -705,4 +706,26 @@ contains return end subroutine list_clone + + subroutine list_reinit(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, nr,nc,k, nl + integer(psb_ipk_), allocatable :: idx(:),lidx(:) + character(len=20) :: name='list_reinit' + logical, parameter :: debug=.false. + + info = psb_success_ + + call idxmap%set_state(psb_desc_bld_) + + return + + end subroutine list_reinit + + end module psb_list_map_mod diff --git a/base/modules/psb_repl_map_mod.f90 b/base/modules/psb_repl_map_mod.f90 index 71aec5ce..20ad603c 100644 --- a/base/modules/psb_repl_map_mod.f90 +++ b/base/modules/psb_repl_map_mod.f90 @@ -55,6 +55,7 @@ module psb_repl_map_mod procedure, pass(idxmap) :: asb => repl_asb procedure, pass(idxmap) :: free => repl_free procedure, pass(idxmap) :: clone => repl_clone + procedure, pass(idxmap) :: reinit => repl_reinit procedure, nopass :: get_fmt => repl_get_fmt procedure, pass(idxmap) :: l2gs1 => repl_l2gs1 @@ -592,6 +593,7 @@ contains logical, parameter :: debug=.false. info = psb_success_ + write(0,*)name,' Start' call psb_get_erraction(err_act) if (allocated(outmap)) then write(0,*) 'Error: should not be allocated on input' @@ -629,4 +631,25 @@ contains end if return end subroutine repl_clone + + subroutine repl_reinit(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_repl_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, nr,nc,k, nl + integer(psb_ipk_), allocatable :: idx(:),lidx(:) + character(len=20) :: name='repl_reinit' + logical, parameter :: debug=.false. + + info = psb_success_ + + call idxmap%set_state(psb_desc_bld_) + + return + + end subroutine repl_reinit + end module psb_repl_map_mod diff --git a/base/tools/Makefile b/base/tools/Makefile index 8ac704f7..f9d03099 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -6,7 +6,7 @@ FOBJS = psb_sallc.o psb_sasb.o \ psb_dfree.o psb_dins.o \ psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \ psb_cdren.o psb_cdrep.o psb_get_overlap.o psb_cd_lstext.o\ - psb_cdcpy.o psb_cd_reinit.o psb_cd_switch_ovl_indxmap.o\ + psb_cdcpy.o psb_cd_reinit.o psb_cd_switch_ovl_indxmap.o psb_cd_clone.o\ psb_dspalloc.o psb_dspasb.o \ psb_dspfree.o psb_dspins.o psb_dsprn.o \ psb_sspalloc.o psb_sspasb.o \ diff --git a/base/tools/psb_cd_clone.f90 b/base/tools/psb_cd_clone.f90 new file mode 100644 index 00000000..4b1a98e7 --- /dev/null +++ b/base/tools/psb_cd_clone.f90 @@ -0,0 +1,90 @@ + subroutine psb_cd_clone(desc, desc_out, info) + + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + use psb_desc_mod, psb_protect_name => psb_cd_clone + implicit none + !....parameters... + + class(psb_desc_type), intent(inout), target :: desc + class(psb_desc_type), intent(inout) :: desc_out + integer(psb_ipk_), intent(out) :: info + !locals + 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() + + if (psb_get_errstatus() /= 0) return + info = psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cdcpy' + + if (desc%is_valid()) then + ictxt = desc%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Entered' + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + desc_out%base_desc => desc%base_desc + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%halo_index,desc_out%halo_index,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%ext_index,desc_out%ext_index,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%ovrlap_index,& + & desc_out%ovrlap_index,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%bnd_elem,desc_out%bnd_elem,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%ovrlap_elem,desc_out%ovrlap_elem,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%ovr_mst_idx,desc_out%ovr_mst_idx,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%lprm,desc_out%lprm,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(desc%idx_space,desc_out%idx_space,info) +!!$ if ((info == psb_success_).and.(allocated(desc%indxmap))) & +!!$ & call desc%indxmap%clone(desc_out%indxmap,info) +!!$ associate(indxin => desc%indxmap) +!!$ if ((info == psb_success_).and.(allocated(desc%indxmap))) & +!!$ & call indxin%clone(desc_out%indxmap,info) +!!$ end associate + if ((info == psb_success_).and.(allocated(desc%indxmap))) & + & allocate(desc_out%indxmap,source=desc%indxmap,stat=info) + + else + call desc_out%free(info) + end if + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name) + goto 9999 + endif + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Done' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + + end subroutine psb_cd_clone diff --git a/base/tools/psb_cd_reinit.f90 b/base/tools/psb_cd_reinit.f90 index 0b5f0927..d3285ae2 100644 --- a/base/tools/psb_cd_reinit.f90 +++ b/base/tools/psb_cd_reinit.f90 @@ -68,6 +68,7 @@ Subroutine psb_cd_reinit(desc,info) call psb_move_alloc(tmp_ovr,desc%ovrlap_index,info) call psb_move_alloc(tmp_halo,desc%halo_index,info) call psb_move_alloc(tmp_ext,desc%ext_index,info) + call desc%indxmap%reinit(info) call psb_cd_set_bld(desc,info) if (debug_level >= psb_debug_outer_) &