From 83743b55db6f996ef1ed72867618cf62fb31693a Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 29 Jun 2018 08:18:08 +0100 Subject: [PATCH] New error message for gather. --- base/comm/psb_cspgather.F90 | 48 ++++++++++++++++++++++++++++---- base/comm/psb_dspgather.F90 | 51 ++++++++++++++++++++++++++++++---- base/comm/psb_ispgather.F90 | 48 ++++++++++++++++++++++++++++---- base/comm/psb_lspgather.F90 | 48 ++++++++++++++++++++++++++++---- base/comm/psb_sspgather.F90 | 48 ++++++++++++++++++++++++++++---- base/comm/psb_zspgather.F90 | 48 ++++++++++++++++++++++++++++---- base/modules/psb_const_mod.F90 | 1 + base/modules/psb_error_mod.F90 | 8 +++++- 8 files changed, 263 insertions(+), 37 deletions(-) diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index d5e9fc81..817eebf1 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_cspgather.f90 subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -89,7 +92,7 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (keepnum_) then nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - + allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -113,6 +116,17 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) @@ -175,6 +189,9 @@ end subroutine psb_csp_allgather subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -254,6 +271,16 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 ! @@ -298,8 +325,6 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee goto 9999 end if - - call psb_erractionrestore(err_act) return @@ -312,6 +337,9 @@ subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_lcsp_allgather subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -391,11 +419,19 @@ subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 - ! - ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING - ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index 8836c1d6..f2ff6e98 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_dspgather.f90 subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -89,7 +92,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (keepnum_) then nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - + allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -113,6 +116,17 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) @@ -175,6 +189,9 @@ end subroutine psb_dsp_allgather subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -254,6 +271,16 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 ! @@ -298,8 +325,6 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee goto 9999 end if - - call psb_erractionrestore(err_act) return @@ -312,6 +337,9 @@ subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_ldsp_allgather subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -339,6 +367,7 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k integer(psb_mpk_) :: ictxt,np,me integer(psb_mpk_) :: icomm, minfo, ndx integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit @@ -390,12 +419,22 @@ subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k nzbr(:) = 0 nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 - ! - ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING - ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo diff --git a/base/comm/psb_ispgather.F90 b/base/comm/psb_ispgather.F90 index dba3f5ae..54481b1a 100644 --- a/base/comm/psb_ispgather.F90 +++ b/base/comm/psb_ispgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_ispgather.f90 subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -89,7 +92,7 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (keepnum_) then nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - + allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -113,6 +116,17 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) @@ -175,6 +189,9 @@ end subroutine psb_isp_allgather subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -254,6 +271,16 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 ! @@ -298,8 +325,6 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k goto 9999 end if - - call psb_erractionrestore(err_act) return @@ -312,6 +337,9 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k end subroutine psb_@LX@sp_allgather subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -391,11 +419,19 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 - ! - ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING - ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo diff --git a/base/comm/psb_lspgather.F90 b/base/comm/psb_lspgather.F90 index bb95b5ba..a66c9abe 100644 --- a/base/comm/psb_lspgather.F90 +++ b/base/comm/psb_lspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_lspgather.f90 subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -89,7 +92,7 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (keepnum_) then nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - + allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -113,6 +116,17 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) @@ -175,6 +189,9 @@ end subroutine psb_lsp_allgather subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -254,6 +271,16 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 ! @@ -298,8 +325,6 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k goto 9999 end if - - call psb_erractionrestore(err_act) return @@ -312,6 +337,9 @@ subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k end subroutine psb_@LX@sp_allgather subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -391,11 +419,19 @@ subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepn nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 - ! - ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING - ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index 6a20e732..3b8d30cf 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_sspgather.f90 subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -89,7 +92,7 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (keepnum_) then nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - + allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -113,6 +116,17 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) @@ -175,6 +189,9 @@ end subroutine psb_ssp_allgather subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -254,6 +271,16 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 ! @@ -298,8 +325,6 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee goto 9999 end if - - call psb_erractionrestore(err_act) return @@ -312,6 +337,9 @@ subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_lssp_allgather subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -391,11 +419,19 @@ subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 - ! - ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING - ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index bb7044ed..75d5e4b5 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_zspgather.f90 subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -89,7 +92,7 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep if (keepnum_) then nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - + allocate(nzbr(np), idisp(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ @@ -113,6 +116,17 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call psb_realloc(nzg,glbia,info) if (info == psb_success_) call psb_realloc(nzg,glbja,info) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) @@ -175,6 +189,9 @@ end subroutine psb_zsp_allgather subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -254,6 +271,16 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 ! @@ -298,8 +325,6 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee goto 9999 end if - - call psb_erractionrestore(err_act) return @@ -312,6 +337,9 @@ subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,kee end subroutine psb_lzsp_allgather subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -391,11 +419,19 @@ subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,k nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 - ! - ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING - ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 1b59aa62..8c01d68f 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -255,6 +255,7 @@ module psb_const_mod integer(psb_ipk_), parameter, public :: psb_err_wrong_ins_=298 integer(psb_ipk_), parameter, public :: psb_err_iarg_mbeeiarra_i_=300 integer(psb_ipk_), parameter, public :: psb_err_bad_int_cnv_=301 + integer(psb_ipk_), parameter, public :: psb_err_mpi_int_ovflw_=302 integer(psb_ipk_), parameter, public :: psb_err_mpi_error_=400 integer(psb_ipk_), parameter, public :: psb_err_parm_differs_among_procs_=550 integer(psb_ipk_), parameter, public :: psb_err_entry_out_of_bounds_=551 diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index 4233f309..a2e37e84 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -701,12 +701,18 @@ contains & trim(r_name) case(psb_err_bad_int_cnv_) - allocate(achmsg(3)) + allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Bad integer conversion from ",i0,"to ",i0)') & & e_e_d(1),e_e_d(2) + case(psb_err_mpi_int_ovflw_) + allocate(achmsg(2)) + achmsg(1) = tmpmsg + write(achmsg(2),& + & '("Size argument to MPI overflow.")') + case(psb_err_iarg_mbeeiarra_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg