diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 0470e5de..78568524 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -152,34 +152,12 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if + idxr = idxr * n idxs = idxs * n @@ -634,35 +612,11 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index 3e5a3ee6..9fb1a525 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -155,34 +155,11 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n @@ -632,42 +609,17 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) do_send = swap_mpi .or. swap_sync .or. swap_send do_recv = swap_mpi .or. swap_sync .or. swap_recv - if(present(data)) then - write(0,*) 'External data present: ',data + if (present(data)) then data_ = data else data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - write(0,*) 'Really wrong?? ',data_, psb_comm_halo_, psb_comm_ovr_, psb_comm_ext_ - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n @@ -718,7 +670,6 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) end if - idxr = max(idxr,1) idxs = max(idxs,1) if((idxr+idxs) < size(work)) then diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index 25be48d6..20f1a8d5 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -151,34 +151,12 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if + idxr = idxr * n idxs = idxs * n @@ -634,35 +612,11 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index e690f0d4..de37f02a 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -154,34 +154,11 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n @@ -636,34 +613,11 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index 4248fdf3..d442ab18 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -151,34 +151,12 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if + idxr = idxr * n idxs = idxs * n @@ -634,35 +612,11 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index d427f845..7a892608 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -155,34 +155,11 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n @@ -638,34 +615,11 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) data_ = psb_comm_halo_ end if - select case(data_) - case(psb_comm_halo_) - d_idx => desc_a%halo_index - totxch = desc_a%matrix_data(psb_thal_xch_) - idxr = desc_a%matrix_data(psb_thal_rcv_) - idxs = desc_a%matrix_data(psb_thal_snd_) - - case(psb_comm_ovr_) - d_idx => desc_a%ovrlap_index - totxch = desc_a%matrix_data(psb_tovr_xch_) - idxr = desc_a%matrix_data(psb_tovr_rcv_) - idxs = desc_a%matrix_data(psb_tovr_snd_) - - case(psb_comm_ext_) - d_idx => desc_a%ext_index - totxch = desc_a%matrix_data(psb_text_xch_) - idxr = desc_a%matrix_data(psb_text_rcv_) - idxs = desc_a%matrix_data(psb_text_snd_) - - case(psb_comm_mov_) - d_idx => desc_a%ovr_mst_idx - totxch = desc_a%matrix_data(psb_tmov_xch_) - idxr = desc_a%matrix_data(psb_tmov_rcv_) - idxs = desc_a%matrix_data(psb_tmov_snd_) - case default - call psb_errpush(4010,name,a_err='wrong Data selector') + call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info) + if (info /= 0) then + call psb_errpush(4001,name,a_err='psb_cd_get_list') goto 9999 - end select + end if idxr = idxr * n idxs = idxs * n diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 9890ecd9..f4e3fdfd 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -297,7 +297,8 @@ module psb_descriptor_type interface psb_sizeof module procedure psb_cd_sizeof end interface - + + integer, private, save :: cd_large_threshold=psb_default_large_threshold @@ -571,5 +572,74 @@ contains end if return end subroutine psb_cd_set_bld - + + + subroutine psb_cd_get_list(data,desc,ipnt,totxch,idxr,idxs,info) + use psb_const_mod + use psb_error_mod + use psb_penv_mod + + implicit none + integer, intent(in) :: data + integer, pointer :: ipnt(:) + type(psb_desc_type), target :: desc + integer, intent(out) :: totxch,idxr,idxs,info + + !locals + integer :: np,me,ictxt,err_act + logical, parameter :: debug=.false.,debugprt=.false. + character(len=20), parameter :: name='psb_cd_get_list' + + info = 0 + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc) + + call psb_info(ictxt, me, np) + + select case(data) + case(psb_comm_halo_) + ipnt => desc%halo_index + totxch = desc%matrix_data(psb_thal_xch_) + idxr = desc%matrix_data(psb_thal_rcv_) + idxs = desc%matrix_data(psb_thal_snd_) + + case(psb_comm_ovr_) + ipnt => desc%ovrlap_index + totxch = desc%matrix_data(psb_tovr_xch_) + idxr = desc%matrix_data(psb_tovr_rcv_) + idxs = desc%matrix_data(psb_tovr_snd_) + + case(psb_comm_ext_) + ipnt => desc%ext_index + totxch = desc%matrix_data(psb_text_xch_) + idxr = desc%matrix_data(psb_text_rcv_) + idxs = desc%matrix_data(psb_text_snd_) + + case(psb_comm_mov_) + ipnt => desc%ovr_mst_idx + totxch = desc%matrix_data(psb_tmov_xch_) + idxr = desc%matrix_data(psb_tmov_rcv_) + idxs = desc%matrix_data(psb_tmov_snd_) + + case default + info=4010 + call psb_errpush(info,name,a_err='wrong Data selector') + goto 9999 + end select + 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_get_list + + end module psb_descriptor_type