From 7b086688a01c20e377eb29fe556f7140c85b29c7 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 2 Jan 2011 10:44:03 +0000 Subject: [PATCH] psblsa3-dev: base/modules/psb_gen_block_map_mod.f03 base/modules/psb_glist_map_mod.f03 base/modules/psb_hash_map_mod.f03 base/modules/psb_indx_map_mod.f03 base/modules/psb_list_map_mod.f03 base/modules/psb_repl_map_mod.f03 base/tools/psb_cdcpy.f90 Defined CLONE method in indx_map. Use it to work around GNU PR 47085. TBD: move under IFDEF --- base/modules/psb_gen_block_map_mod.f03 | 65 ++++++++++++++++++++++++- base/modules/psb_glist_map_mod.f03 | 63 ++++++++++++++++++++++++ base/modules/psb_hash_map_mod.f03 | 66 ++++++++++++++++++++++++++ base/modules/psb_indx_map_mod.f03 | 28 ++++++++++- base/modules/psb_list_map_mod.f03 | 59 +++++++++++++++++++++++ base/modules/psb_repl_map_mod.f03 | 52 ++++++++++++++++++++ base/tools/psb_cdcpy.f90 | 18 ++++--- 7 files changed, 343 insertions(+), 8 deletions(-) diff --git a/base/modules/psb_gen_block_map_mod.f03 b/base/modules/psb_gen_block_map_mod.f03 index 988836ee..359d113b 100644 --- a/base/modules/psb_gen_block_map_mod.f03 +++ b/base/modules/psb_gen_block_map_mod.f03 @@ -61,6 +61,7 @@ module psb_gen_block_map_mod procedure, pass(idxmap) :: sizeof => block_sizeof procedure, pass(idxmap) :: asb => block_asb procedure, pass(idxmap) :: free => block_free + procedure, pass(idxmap) :: clone => block_clone procedure, pass(idxmap) :: get_fmt => block_get_fmt procedure, pass(idxmap) :: l2gs1 => block_l2gs1 @@ -86,7 +87,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_g2lv1_ins, block_g2lv2_ins, block_clone contains @@ -669,4 +670,66 @@ contains res = 'BLOCK' end function block_get_fmt + + subroutine block_clone(idxmap,outmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + class(psb_indx_map), allocatable, intent(out) :: outmap + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='block_clone' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (allocated(outmap)) then + write(0,*) 'Error: should not be allocated on input' + info = -87 + goto 9999 + end if + + allocate(psb_gen_block_map :: outmap, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + select type (outmap) + type is (psb_gen_block_map) + if (info == psb_success_) then + outmap%psb_indx_map = idxmap%psb_indx_map + outmap%min_glob_row = idxmap%min_glob_row + outmap%max_glob_row = idxmap%max_glob_row + end if + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%vnl,outmap%vnl,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%srt_l2g,outmap%srt_l2g,info) + class default + ! This should be impossible + info = -1 + end select + + 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_clone + end module psb_gen_block_map_mod diff --git a/base/modules/psb_glist_map_mod.f03 b/base/modules/psb_glist_map_mod.f03 index cd87138a..f5414400 100644 --- a/base/modules/psb_glist_map_mod.f03 +++ b/base/modules/psb_glist_map_mod.f03 @@ -52,6 +52,7 @@ module psb_glist_map_mod procedure, pass(idxmap) :: glist_map_init => glist_initvg procedure, pass(idxmap) :: sizeof => glist_sizeof procedure, pass(idxmap) :: free => glist_free + procedure, pass(idxmap) :: clone => glist_clone procedure, pass(idxmap) :: get_fmt => glist_get_fmt procedure, pass(idxmap) :: fnd_owner => glist_fnd_owner @@ -184,4 +185,66 @@ contains end function glist_get_fmt + + subroutine glist_clone(idxmap,outmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_glist_map), intent(in) :: idxmap + class(psb_indx_map), allocatable, intent(out) :: outmap + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='glist_clone' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (allocated(outmap)) then + write(0,*) 'Error: should not be allocated on input' + info = -87 + goto 9999 + end if + + allocate(psb_glist_map :: outmap, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + select type (outmap) + type is (psb_glist_map) + + if (info == psb_success_) then + outmap%psb_indx_map = idxmap%psb_indx_map + outmap%pnt_h = idxmap%pnt_h + end if + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%glob_to_loc,outmap%glob_to_loc,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%vgp,outmap%vgp,info) + class default + ! This should be impossible + info = -1 + end select + + 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 glist_clone + end module psb_glist_map_mod diff --git a/base/modules/psb_hash_map_mod.f03 b/base/modules/psb_hash_map_mod.f03 index 303899ad..91f3e3d0 100644 --- a/base/modules/psb_hash_map_mod.f03 +++ b/base/modules/psb_hash_map_mod.f03 @@ -72,6 +72,7 @@ contains procedure, pass(idxmap) :: sizeof => hash_sizeof procedure, pass(idxmap) :: asb => hash_asb procedure, pass(idxmap) :: free => hash_free + procedure, pass(idxmap) :: clone => hash_clone procedure, pass(idxmap) :: get_fmt => hash_get_fmt procedure, pass(idxmap) :: row_extendable => hash_row_extendable @@ -1241,4 +1242,69 @@ subroutine hash_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask,nrm) end subroutine hash_inner_cnv2 + subroutine hash_clone(idxmap,outmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_hash_map), intent(in) :: idxmap + class(psb_indx_map), allocatable, intent(out) :: outmap + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='hash_clone' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (allocated(outmap)) then + write(0,*) 'Error: should not be allocated on input' + info = -87 + goto 9999 + end if + + allocate(psb_hash_map :: outmap, stat=info ) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + select type (outmap) + type is (psb_hash_map) + if (info == psb_success_) then + outmap%psb_indx_map = idxmap%psb_indx_map + outmap%hashvsize = idxmap%hashvsize + outmap%hashvmask = idxmap%hashvmask + allocate(outmap%hash, stat=info) + end if + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%hashv,outmap%hashv,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%glb_lc,outmap%glb_lc,info) + if (info == psb_success_)& + & call psb_hash_copy(idxmap%hash,outmap%hash,info) + class default + ! This should be impossible + info = -1 + end select + + 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 hash_clone + + end module psb_hash_map_mod diff --git a/base/modules/psb_indx_map_mod.f03 b/base/modules/psb_indx_map_mod.f03 index 0720d64a..ab7c3318 100644 --- a/base/modules/psb_indx_map_mod.f03 +++ b/base/modules/psb_indx_map_mod.f03 @@ -119,6 +119,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) :: l2gs1 => base_l2gs1 procedure, pass(idxmap) :: l2gs2 => base_l2gs2 @@ -154,7 +155,8 @@ module psb_indx_map_mod & base_l2gs1, base_l2gs2, base_l2gv1, base_l2gv2,& & 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_g2lv2_ins, base_init_vl, base_is_null,& + & base_row_extendable, base_clone interface subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) @@ -788,6 +790,30 @@ contains return end subroutine base_init_vl + subroutine base_clone(idxmap,outmap,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + class(psb_indx_map), allocatable, intent(out) :: outmap + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='base_clone' + 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_clone end module psb_indx_map_mod diff --git a/base/modules/psb_list_map_mod.f03 b/base/modules/psb_list_map_mod.f03 index 5b956d84..27bd5e0f 100644 --- a/base/modules/psb_list_map_mod.f03 +++ b/base/modules/psb_list_map_mod.f03 @@ -53,6 +53,7 @@ module psb_list_map_mod procedure, pass(idxmap) :: sizeof => list_sizeof procedure, pass(idxmap) :: asb => list_asb procedure, pass(idxmap) :: free => list_free + procedure, pass(idxmap) :: clone => list_clone procedure, pass(idxmap) :: get_fmt => list_get_fmt procedure, pass(idxmap) :: row_extendable => list_row_extendable @@ -631,4 +632,62 @@ contains end function list_get_fmt + subroutine list_clone(idxmap,outmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_list_map), intent(in) :: idxmap + class(psb_indx_map), allocatable, intent(out) :: outmap + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='list_clone' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (allocated(outmap)) then + write(0,*) 'Error: should not be allocated on input' + info = -87 + goto 9999 + end if + + allocate(psb_list_map :: outmap, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + select type (outmap) + type is (psb_list_map) + if (info == psb_success_) then + outmap%psb_indx_map = idxmap%psb_indx_map + outmap%pnt_h = idxmap%pnt_h + end if + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info) + if (info == psb_success_)& + & call psb_safe_ab_cpy(idxmap%glob_to_loc,outmap%glob_to_loc,info) + class default + ! This should be impossible + info = -1 + end select + + 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 list_clone + end module psb_list_map_mod diff --git a/base/modules/psb_repl_map_mod.f03 b/base/modules/psb_repl_map_mod.f03 index 7077317f..2c6c5571 100644 --- a/base/modules/psb_repl_map_mod.f03 +++ b/base/modules/psb_repl_map_mod.f03 @@ -54,6 +54,7 @@ module psb_repl_map_mod procedure, pass(idxmap) :: is_repl => repl_is_repl procedure, pass(idxmap) :: asb => repl_asb procedure, pass(idxmap) :: free => repl_free + procedure, pass(idxmap) :: clone => repl_clone procedure, pass(idxmap) :: get_fmt => repl_get_fmt procedure, pass(idxmap) :: l2gs1 => repl_l2gs1 @@ -540,4 +541,55 @@ contains res = 'REPL' end function repl_get_fmt + + subroutine repl_clone(idxmap,outmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_repl_map), intent(in) :: idxmap + class(psb_indx_map), allocatable, intent(out) :: outmap + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='repl_clone' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (allocated(outmap)) then + write(0,*) 'Error: should not be allocated on input' + info = -87 + goto 9999 + end if + + allocate(psb_repl_map :: outmap, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + select type (outmap) + type is (psb_repl_map) + outmap%psb_indx_map = idxmap%psb_indx_map + class default + ! This should be impossible + info = -1 + end select + + 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 repl_clone end module psb_repl_map_mod diff --git a/base/tools/psb_cdcpy.f90 b/base/tools/psb_cdcpy.f90 index 772e678d..9baaeb63 100644 --- a/base/tools/psb_cdcpy.f90 +++ b/base/tools/psb_cdcpy.f90 @@ -85,12 +85,18 @@ subroutine psb_cdcpy(desc_in, desc_out, info) if (info == psb_success_) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info) if (allocated(desc_in%indxmap)) then - if (allocated(desc_out%indxmap)) then - call desc_out%indxmap%free() - deallocate(desc_out%indxmap) - end if - if (info == psb_success_)& - & allocate(desc_out%indxmap, source=desc_in%indxmap, stat=info) +!!$ if (allocated(desc_out%indxmap)) then +!!$ ! This should never happen +!!$ call desc_out%indxmap%free() +!!$ deallocate(desc_out%indxmap) +!!$ end if +!!$ write(debug_unit,*) me,' ',trim(name),': Calling allocate(SOURCE = )' +!!$ if (info == psb_success_)& +!!$ & allocate(desc_out%indxmap, source=desc_in%indxmap, stat=info) + + call desc_in%indxmap%clone(desc_out%indxmap,info) + + end if if (info /= psb_success_) then