From 04d97d04bb6535e2f82212e171b51c7fe17c5289 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 6 Feb 2012 17:34:42 +0000 Subject: [PATCH] psblas3-integer8: base/comm/psb_cspgather.F90 base/comm/psb_dspgather.F90 base/comm/psb_sspgather.F90 base/comm/psb_zspgather.F90 base/internals/psb_indx_map_fnd_owner.F90 base/internals/psi_extrct_dl.F90 base/modules/psb_realloc_mod.F90 base/modules/psi_reduce_mod.F90 Partial updates for reduce operations to support mixed I8/I4. To be finished yet. --- base/comm/psb_cspgather.F90 | 2 +- base/comm/psb_dspgather.F90 | 2 +- base/comm/psb_sspgather.F90 | 2 +- base/comm/psb_zspgather.F90 | 2 +- base/internals/psb_indx_map_fnd_owner.F90 | 19 +- base/internals/psi_extrct_dl.F90 | 10 +- base/modules/psb_realloc_mod.F90 | 1024 +++++++++++++-------- base/modules/psi_reduce_mod.F90 | 133 +++ 8 files changed, 782 insertions(+), 412 deletions(-) diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index f30d8086..ee207f0c 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -22,7 +22,7 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index 546b174f..063ed78c 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -22,7 +22,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index a77d406a..349dccc5 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -22,7 +22,7 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index fec9f1df..7913be9a 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -22,7 +22,7 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit diff --git a/base/internals/psb_indx_map_fnd_owner.F90 b/base/internals/psb_indx_map_fnd_owner.F90 index 75a99447..48988349 100644 --- a/base/internals/psb_indx_map_fnd_owner.F90 +++ b/base/internals/psb_indx_map_fnd_owner.F90 @@ -66,12 +66,14 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), allocatable :: hsz(:),hidx(:),helem(:),hproc(:),& - & sdsz(:),sdidx(:), rvsz(:), rvidx(:),answers(:,:),idxsrch(:,:) - - integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,& + integer(psb_ipk_), allocatable :: helem(:),hproc(:),& + & answers(:,:),idxsrch(:,:) + integer(psb_mpik_), allocatable :: hsz(:),hidx(:), & + & sdsz(:),sdidx(:), rvsz(:), rvidx(:) + integer(psb_mpik_) :: icomm, minfo + integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,hsize,ip,isz,k,j,& & last_ih, last_j, nv - integer(psb_ipk_) :: ictxt,np,me + integer(psb_mpik_) :: ictxt,np,me logical, parameter :: gettime=.false. real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx character(len=20) :: name @@ -136,7 +138,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) call mpi_allgatherv(idx,hsz(me+1),psb_mpi_ipk_integer,& & hproc,hsz,hidx,psb_mpi_ipk_integer,& - & icomm,info) + & icomm,minfo) if (gettime) then tamx = psb_wtime() - t3 end if @@ -178,7 +180,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) end if ! Collect all the answers with alltoallv (need sizes) - call mpi_alltoall(sdsz,1,psb_mpi_ipk_integer,rvsz,1,psb_mpi_def_integer,icomm,info) + call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& + & rvsz,1,psb_mpi_def_integer,icomm,minfo) isz = sum(rvsz) @@ -194,7 +197,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) end do call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_integer,& & answers(:,1),rvsz,rvidx,psb_mpi_ipk_integer,& - & icomm,info) + & icomm,minfo) if (gettime) then tamx = psb_wtime() - t3 + tamx end if diff --git a/base/internals/psi_extrct_dl.F90 b/base/internals/psi_extrct_dl.F90 index 9977533e..97943f05 100644 --- a/base/internals/psi_extrct_dl.F90 +++ b/base/internals/psi_extrct_dl.F90 @@ -145,7 +145,7 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& integer(psb_ipk_) :: i,pointer_dep_list,proc,j,err_act integer(psb_ipk_) :: err integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpik_) :: icomm, me, npr + integer(psb_mpik_) :: icomm, me, npr, dl_mpi, minfo character name*20 name='psi_extrct_dl' @@ -271,9 +271,11 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& goto 9999 endif itmp(1:dl_lda) = dep_list(1:dl_lda,me) - call mpi_allgather(itmp,dl_lda,psb_mpi_ipk_integer,& - & dep_list,dl_lda,psb_mpi_ipk_integer,icomm,info) - deallocate(itmp,stat=info) + dl_mpi = dl_lda + call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_integer,& + & dep_list,dl_mpi,psb_mpi_ipk_integer,icomm,minfo) + info = minfo + if (info == 0) deallocate(itmp,stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ goto 9999 diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index 90653812..ee6c5396 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -58,6 +58,8 @@ module psb_realloc_mod module procedure psb_reallocatez2 module procedure psb_reallocatec2 #if defined(LONG_INTEGERS) + module procedure psb_reallocate1i4 + module procedure psb_reallocatei4_2 module procedure psb_rp1i1 module procedure psb_rp1i2i2 module procedure psb_ri1p2i2 @@ -96,6 +98,9 @@ module psb_realloc_mod #if !defined(LONG_INTEGERS) module procedure psb_i8move_alloc1d module procedure psb_i8move_alloc2d +#else + module procedure psb_i4move_alloc1d + module procedure psb_i4move_alloc2d #endif module procedure psb_cmove_alloc1d module procedure psb_cmove_alloc2d @@ -1761,93 +1766,6 @@ Contains End Subroutine psb_reallocate1i - Subroutine psb_reallocate1i8(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Integer(psb_long_int_k_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_long_int_k_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_long_int_k_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim, err_act, err,lb_, lbi, ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error() - end if - return - - - End Subroutine psb_reallocate1i8 - - Subroutine psb_reallocate1s(len,rrax,info,pad,lb) use psb_error_mod @@ -2637,6 +2555,93 @@ Contains End Subroutine psb_reallocatei2 #if !defined(LONG_INTEGERS) + + Subroutine psb_reallocate1i8(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_ipk_),Intent(in) :: len + Integer(psb_long_int_k_),allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_long_int_k_), optional, intent(in) :: pad + integer(psb_ipk_), optional, intent(in) :: lb + ! ...Local Variables + Integer(psb_long_int_k_),allocatable :: tmp(:) + integer(psb_ipk_) :: dim, err_act, err,lb_, lbi, ub_ + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_reallocate1i' + call psb_erractionsave(err_act) + info=psb_success_ + + if (debug) write(psb_err_unit,*) 'reallocate I',len + if (psb_get_errstatus() /= 0) then + if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer') + goto 9999 + end if + ub_ = lb_+len-1 + if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' + call psb_move_alloc(tmp,rrax,info) + if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info + end if + else + dim = 0 + allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + if (debug) write(psb_err_unit,*) 'end reallocate : ',info + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + + End Subroutine psb_reallocate1i8 + Subroutine psb_reallocatei8_2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod ! ...Subroutine Arguments @@ -3261,330 +3266,557 @@ Contains deallocate(vin,stat=info) #endif end Subroutine psb_i8move_alloc2d -#endif - -#if defined(LONG_INTEGERS) - Subroutine psb_rp1i1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1i1 +#else - subroutine psb_rp1i2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2i2 - - subroutine psb_ri1p2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2i2 - - subroutine psb_rp1p2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2i2 - - Subroutine psb_rp1s1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - real(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb + Subroutine psb_i4move_alloc1d(vin,vout,info) + use psb_error_mod + integer(psb_mpik_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_mpik_), intent(out) :: info + ! + ! + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1s1 - - subroutine psb_rp1i2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2s2 - - subroutine psb_ri1p2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2s2 - - subroutine psb_rp1p2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2s2 + call move_alloc(vin,vout) +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + allocate(vout(lbound(vin,1):ubound(vin,1)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_i4move_alloc1d + Subroutine psb_i4move_alloc2d(vin,vout,info) + use psb_error_mod + integer(psb_mpik_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_mpik_), intent(out) :: info + ! + ! + info=psb_success_ +#ifdef HAVE_MOVE_ALLOC - Subroutine psb_rp1d1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - Real(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb + call move_alloc(vin,vout) - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1d1 +#else + if (allocated(vout)) then + deallocate(vout,stat=info) + end if + if (.not.allocated(vin) ) return + + allocate(vout(lbound(vin,1):ubound(vin,1),& + & lbound(vin,2):ubound(vin,2)),stat=info) + if (info /= psb_success_) return + vout = vin + deallocate(vin,stat=info) +#endif + end Subroutine psb_i4move_alloc2d +#endif - subroutine psb_rp1i2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2d2 - - subroutine psb_ri1p2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2d2 - - subroutine psb_rp1p2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2d2 +#if defined(LONG_INTEGERS) + Subroutine psb_reallocate1i4(len,rrax,info,pad,lb) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len + Integer(psb_mpik_),allocatable, intent(inout) :: rrax(:) + integer(psb_mpik_) :: info + integer(psb_mpik_), optional, intent(in) :: pad + integer(psb_mpik_), optional, intent(in) :: lb + ! ...Local Variables + Integer(psb_mpik_),allocatable :: tmp(:) + integer(psb_mpik_) :: dim, lb_, lbi, ub_ + integer(psb_ipk_) :: err, err_act, ierr(5) + character(len=20) :: name + logical, parameter :: debug=.false. + name='psb_reallocate1i4' + call psb_erractionsave(err_act) + info=psb_success_ - Subroutine psb_rp1c1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - complex(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb + if (debug) write(psb_err_unit,*) 'reallocate I',len + if (psb_get_errstatus() /= 0) then + if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' + info=psb_err_from_subroutine_ + goto 9999 + end if - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1c1 - - subroutine psb_rp1i2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2c2 - - subroutine psb_ri1p2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2c2 - - subroutine psb_rp1p2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2c2 - - - Subroutine psb_rp1z1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - Complex(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025; ierr(1) = len + call psb_errpush(err,name,i_err=ierr,a_err='integer') + goto 9999 + end if + ub_ = lb_+len-1 + if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025; ierr(1) = len + call psb_errpush(err,name,i_err=ierr,a_err='integer') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' + call psb_move_alloc(tmp,rrax,info) + if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info + end if + else + dim = 0 + allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025; ierr(1) = len + call psb_errpush(err,name,i_err=ierr,a_err='integer') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + if (debug) write(psb_err_unit,*) 'end reallocate : ',info + call psb_erractionrestore(err_act) + return - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + + End Subroutine psb_reallocate1i4 + + Subroutine psb_reallocatei4_2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1,len2 + integer(psb_mpik_),allocatable :: rrax(:,:) + integer(psb_mpik_) :: info + integer(psb_mpik_), optional, intent(in) :: pad + integer(psb_mpik_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + integer(psb_mpik_),allocatable :: tmp(:,:) + integer(psb_mpik_) :: dim, dim2,lb1_, lb2_, ub1_, ub2_,& + & lbi1, lbi2 + integer(psb_ipk_) :: err,err_act, ierr(5) + character(len=20) :: name + + name='psb_reallocatei2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025; ierr(1) = len1 + call psb_errpush(err,name,i_err=ierr,a_err='integer') + goto 9999 + end if + if (len2 < 0) then + err=4025; ierr(1) = len2 + call psb_errpush(err,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025; ierr(1) = len1*len2 + call psb_errpush(err,name,i_err=ierr,a_err='integer') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025; ierr(1) = len1*len2 + call psb_errpush(err,name,i_err=ierr,a_err='integer') + goto 9999 end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1z1 - - subroutine psb_rp1i2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2z2 - - subroutine psb_ri1p2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2z2 - - subroutine psb_rp1p2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2z2 + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error() + end if + return + + End Subroutine psb_reallocatei4_2 + + + Subroutine psb_rp1i1(len,rrax,info,pad,lb) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len + integer(psb_ipk_),allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional, intent(in) :: pad + integer(psb_mpik_), optional, intent(in) :: lb + + integer(psb_ipk_) :: ilen, ilb + + ilen=len + if (present(lb)) then + ilb=lb + else + ilb = 1 + end if + call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) + + end Subroutine psb_rp1i1 + + + subroutine psb_rp1i2i2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_ipk_),Intent(in) :: len2 + integer(psb_ipk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1i2i2 + + subroutine psb_ri1p2i2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len2 + integer(psb_ipk_),Intent(in) :: len1 + integer(psb_ipk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len2_ = len2 + call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_ri1p2i2 + + subroutine psb_rp1p2i2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_mpik_),Intent(in) :: len2 + integer(psb_ipk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + len2_ = len2 + call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1p2i2 + + Subroutine psb_rp1s1(len,rrax,info,pad,lb) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpik_), optional, intent(in) :: lb + + integer(psb_ipk_) :: ilen, ilb + + ilen=len + if (present(lb)) then + ilb=lb + else + ilb = 1 + end if + call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) + + end Subroutine psb_rp1s1 + + subroutine psb_rp1i2s2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_ipk_),Intent(in) :: len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1i2s2 + + subroutine psb_ri1p2s2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len2 + integer(psb_ipk_),Intent(in) :: len1 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len2_ = len2 + call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_ri1p2s2 + + subroutine psb_rp1p2s2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_mpik_),Intent(in) :: len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + len2_ = len2 + call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1p2s2 + + + + Subroutine psb_rp1d1(len,rrax,info,pad,lb) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len + Real(psb_dpk_),allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpik_), optional, intent(in) :: lb + + integer(psb_ipk_) :: ilen, ilb + + ilen=len + if (present(lb)) then + ilb=lb + else + ilb = 1 + end if + call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) + + end Subroutine psb_rp1d1 + + + subroutine psb_rp1i2d2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_ipk_),Intent(in) :: len2 + Real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1i2d2 + + subroutine psb_ri1p2d2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len2 + integer(psb_ipk_),Intent(in) :: len1 + Real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len2_ = len2 + call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_ri1p2d2 + + subroutine psb_rp1p2d2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_mpik_),Intent(in) :: len2 + Real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + len2_ = len2 + call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1p2d2 + + + + Subroutine psb_rp1c1(len,rrax,info,pad,lb) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpik_), optional, intent(in) :: lb + + integer(psb_ipk_) :: ilen, ilb + + ilen=len + if (present(lb)) then + ilb=lb + else + ilb = 1 + end if + call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) + + end Subroutine psb_rp1c1 + + subroutine psb_rp1i2c2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_ipk_),Intent(in) :: len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1i2c2 + + subroutine psb_ri1p2c2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len2 + integer(psb_ipk_),Intent(in) :: len1 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len2_ = len2 + call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_ri1p2c2 + + subroutine psb_rp1p2c2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_mpik_),Intent(in) :: len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + len2_ = len2 + call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1p2c2 + + + Subroutine psb_rp1z1(len,rrax,info,pad,lb) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len + Complex(psb_dpk_),allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpik_), optional, intent(in) :: lb + + integer(psb_ipk_) :: ilen, ilb + + ilen=len + if (present(lb)) then + ilb=lb + else + ilb = 1 + end if + call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) + + end Subroutine psb_rp1z1 + + subroutine psb_rp1i2z2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_ipk_),Intent(in) :: len2 + Complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1i2z2 + + subroutine psb_ri1p2z2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len2 + integer(psb_ipk_),Intent(in) :: len1 + Complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len2_ = len2 + call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_ri1p2z2 + + subroutine psb_rp1p2z2(len1,len2,rrax,info,pad,lb1,lb2) + ! ...Subroutine Arguments + integer(psb_mpik_),Intent(in) :: len1 + integer(psb_mpik_),Intent(in) :: len2 + Complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_ipk_),Intent(in), optional :: lb1,lb2 + + integer(psb_ipk_) :: len1_, len2_ + len1_ = len1 + len2_ = len2 + call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) + end subroutine psb_rp1p2z2 #endif diff --git a/base/modules/psi_reduce_mod.F90 b/base/modules/psi_reduce_mod.F90 index 169dbb7d..410eff86 100644 --- a/base/modules/psi_reduce_mod.F90 +++ b/base/modules/psi_reduce_mod.F90 @@ -62,6 +62,11 @@ module psi_reduce_mod module procedure psb_i2sums, psb_i2sumv, psb_i2summ end interface psb_sum #endif +#if defined(LONG_INTEGERS) + interface psb_sum + module procedure psb_i4sums, psb_i4sumv, psb_i4summ + end interface +#endif #if !defined(LONG_INTEGERS) interface psb_sum module procedure psb_i8sums, psb_i8sumv, psb_i8summ @@ -2924,6 +2929,134 @@ contains #endif +#if defined(LONG_INTEGERS) + subroutine psb_i4sums(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpik_), intent(inout) :: dat + integer(psb_mpik_), intent(in), optional :: root + integer(psb_mpik_) :: root_ + integer(psb_mpik_) :: dat_ + integer(psb_mpik_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_lng_integer,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_i4sums + + subroutine psb_i4sumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpik_), intent(inout) :: dat(:) + integer(psb_mpik_), intent(in), optional :: root + integer(psb_mpik_) :: root_ + integer(psb_mpik_), allocatable :: dat_(:) + integer(psb_mpik_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_lng_integer,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i4sumv + + subroutine psb_i4summ(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpik_), intent(inout) :: dat(:,:) + integer(psb_mpik_), intent(in), optional :: root + integer(psb_mpik_) :: root_ + integer(psb_mpik_), allocatable :: dat_(:,:) + integer(psb_mpik_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_lng_integer,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,info) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i4summ + +#endif + #if !defined(LONG_INTEGERS) subroutine psb_i8sums(ictxt,dat,root)