diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index 829504fa..1a40274b 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -441,3 +441,115 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) return end subroutine psb_cgather_vect + + +subroutine psb_cgather_multivect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_cgather_multivect + implicit none + + type(psb_c_multivect_type), intent(inout) :: locx + complex(psb_spk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + complex(psb_spk_), allocatable :: llocx(:,:) + character(len=20) :: name, ch_err + + name='psb_cgatherv' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + k = locx%get_ncols() + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:) = czero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,:) = llocx(i,:) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,:) = czero + end if + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cgather_multivect diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index 062334ff..d135eeac 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -441,3 +441,115 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) return end subroutine psb_dgather_vect + + +subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_dgather_multivect + implicit none + + type(psb_d_multivect_type), intent(inout) :: locx + real(psb_dpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + real(psb_dpk_), allocatable :: llocx(:,:) + character(len=20) :: name, ch_err + + name='psb_cgatherv' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + k = locx%get_ncols() + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:) = dzero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,:) = llocx(i,:) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,:) = dzero + end if + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dgather_multivect diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index 3249d417..b7157eaa 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -441,3 +441,115 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) return end subroutine psb_igather_vect + + +subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_igather_multivect + implicit none + + type(psb_i_multivect_type), intent(inout) :: locx + integer(psb_ipk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_ipk_), allocatable :: llocx(:,:) + character(len=20) :: name, ch_err + + name='psb_cgatherv' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + k = locx%get_ncols() + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:) = izero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,:) = llocx(i,:) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,:) = izero + end if + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_igather_multivect diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 5e913aa3..7a8bf1b5 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -441,3 +441,115 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) return end subroutine psb_sgather_vect + + +subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_sgather_multivect + implicit none + + type(psb_s_multivect_type), intent(inout) :: locx + real(psb_spk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + real(psb_spk_), allocatable :: llocx(:,:) + character(len=20) :: name, ch_err + + name='psb_cgatherv' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + k = locx%get_ncols() + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:) = szero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,:) = llocx(i,:) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,:) = szero + end if + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sgather_multivect diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index a04e4425..bd201803 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -441,3 +441,115 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) return end subroutine psb_zgather_vect + + +subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_zgather_multivect + implicit none + + type(psb_z_multivect_type), intent(inout) :: locx + complex(psb_dpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& + & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + complex(psb_dpk_), allocatable :: llocx(:,:) + character(len=20) :: name, ch_err + + name='psb_cgatherv' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + k = locx%get_ncols() + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:) = zzero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,:) = llocx(i,:) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,:) = zzero + end if + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zgather_multivect diff --git a/base/modules/psb_c_comm_mod.f90 b/base/modules/psb_c_comm_mod.f90 index 2f3cfcaf..859d819f 100644 --- a/base/modules/psb_c_comm_mod.f90 +++ b/base/modules/psb_c_comm_mod.f90 @@ -178,6 +178,15 @@ module psb_c_comm_mod integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root end subroutine psb_cgather_vect + subroutine psb_cgather_multivect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_c_multivect_type), intent(inout) :: locx + complex(psb_spk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_cgather_multivect end interface psb_gather end module psb_c_comm_mod diff --git a/base/modules/psb_d_comm_mod.f90 b/base/modules/psb_d_comm_mod.f90 index e6af2e48..cf974360 100644 --- a/base/modules/psb_d_comm_mod.f90 +++ b/base/modules/psb_d_comm_mod.f90 @@ -178,6 +178,15 @@ module psb_d_comm_mod integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root end subroutine psb_dgather_vect + subroutine psb_dgather_multivect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_d_multivect_type), intent(inout) :: locx + real(psb_dpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_dgather_multivect end interface psb_gather end module psb_d_comm_mod diff --git a/base/modules/psb_i_comm_mod.f90 b/base/modules/psb_i_comm_mod.f90 index fbf2c1cc..ca2f9a70 100644 --- a/base/modules/psb_i_comm_mod.f90 +++ b/base/modules/psb_i_comm_mod.f90 @@ -167,6 +167,15 @@ module psb_i_comm_mod integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root end subroutine psb_igather_vect + subroutine psb_igather_multivect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_i_multivect_type), intent(inout) :: locx + integer(psb_ipk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_igather_multivect end interface psb_gather end module psb_i_comm_mod diff --git a/base/modules/psb_s_comm_mod.f90 b/base/modules/psb_s_comm_mod.f90 index 0e0026fc..a39fa696 100644 --- a/base/modules/psb_s_comm_mod.f90 +++ b/base/modules/psb_s_comm_mod.f90 @@ -178,6 +178,15 @@ module psb_s_comm_mod integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root end subroutine psb_sgather_vect + subroutine psb_sgather_multivect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_s_multivect_type), intent(inout) :: locx + real(psb_spk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_sgather_multivect end interface psb_gather end module psb_s_comm_mod diff --git a/base/modules/psb_z_comm_mod.f90 b/base/modules/psb_z_comm_mod.f90 index 9f8150c7..aeca8334 100644 --- a/base/modules/psb_z_comm_mod.f90 +++ b/base/modules/psb_z_comm_mod.f90 @@ -178,6 +178,15 @@ module psb_z_comm_mod integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: root end subroutine psb_zgather_vect + subroutine psb_zgather_multivect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_z_multivect_type), intent(inout) :: locx + complex(psb_dpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_zgather_multivect end interface psb_gather end module psb_z_comm_mod diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 index 9181729d..a9cce205 100644 --- a/base/tools/psb_cfree.f90 +++ b/base/tools/psb_cfree.f90 @@ -265,3 +265,58 @@ subroutine psb_cfree_vect_r2(x, desc_a, info) return end subroutine psb_cfree_vect_r2 + + +subroutine psb_cfree_multivect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_cfree_multivect + implicit none + !....parameters... + type(psb_c_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_cfree' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cfree_multivect diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index d094668e..73a18fcc 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -713,3 +713,119 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) end subroutine psb_cinsi + +subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_cins_multivect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + type(psb_c_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_cinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cins_multivect + + diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 7d4571e4..06518421 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -265,3 +265,58 @@ subroutine psb_dfree_vect_r2(x, desc_a, info) return end subroutine psb_dfree_vect_r2 + + +subroutine psb_dfree_multivect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_dfree_multivect + implicit none + !....parameters... + type(psb_d_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_dfree' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dfree_multivect diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 5f636c1f..09255fd8 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -713,3 +713,119 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) end subroutine psb_dinsi + +subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_dins_multivect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:,:) + type(psb_d_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_dinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dins_multivect + + diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index 3f2bd69c..803f8f0f 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -265,3 +265,58 @@ subroutine psb_ifree_vect_r2(x, desc_a, info) return end subroutine psb_ifree_vect_r2 + + +subroutine psb_ifree_multivect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_ifree_multivect + implicit none + !....parameters... + type(psb_i_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_ifree' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ifree_multivect diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index 23d1dc56..d0c90eb3 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -713,3 +713,119 @@ subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local) end subroutine psb_iinsi + +subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_iins_multivect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_ipk_), intent(in) :: val(:,:) + type(psb_i_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_iinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_iins_multivect + + diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 index eeb906bd..fd56aa06 100644 --- a/base/tools/psb_sfree.f90 +++ b/base/tools/psb_sfree.f90 @@ -265,3 +265,58 @@ subroutine psb_sfree_vect_r2(x, desc_a, info) return end subroutine psb_sfree_vect_r2 + + +subroutine psb_sfree_multivect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_sfree_multivect + implicit none + !....parameters... + type(psb_s_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_sfree' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sfree_multivect diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index ffe1873e..700125e8 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -713,3 +713,119 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) end subroutine psb_sinsi + +subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_sins_multivect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + type(psb_s_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_sinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sins_multivect + + diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index cc6000a2..4ede0841 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -265,3 +265,58 @@ subroutine psb_zfree_vect_r2(x, desc_a, info) return end subroutine psb_zfree_vect_r2 + + +subroutine psb_zfree_multivect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_zfree_multivect + implicit none + !....parameters... + type(psb_z_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_zfree' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zfree_multivect diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index 8e834f69..fd6bc391 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -713,3 +713,119 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) end subroutine psb_zinsi + +subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_zins_multivect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:,:) + type(psb_z_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: ictxt,i,& + & loc_rows,loc_cols,mglob,err_act, int_err(5) + integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_zinsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + int_err(1) = 1 + int_err(2) = m + call psb_errpush(info,name,int_err) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + int_err(1) = 5 + int_err(2) = 4 + call psb_errpush(info,name,int_err) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zins_multivect + +