fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3-integer8:

Browse Source 
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.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent 1e78b3b695
commit 04d97d04bb
8 changed files with 782 additions and 412 deletions
Show Stats Download Patch File Download Diff File

2
base/comm/psb_cspgather.F90
Unescape Escape View File

@ -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_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

2
base/comm/psb_dspgather.F90
Unescape Escape View File

@ -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_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

2
base/comm/psb_sspgather.F90
Unescape Escape View File

@ -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_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

2
base/comm/psb_zspgather.F90
Unescape Escape View File

@ -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_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k integer(psb_ipk_) :: ip, ndx,naggrm1,naggrp1, i, j, k
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit

19
base/internals/psb_indx_map_fnd_owner.F90
Unescape Escape View File

@ -66,12 +66,14 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), allocatable :: hsz(:),hidx(:),helem(:),hproc(:),& integer(psb_ipk_), allocatable :: helem(:),hproc(:),&
& sdsz(:),sdidx(:), rvsz(:), rvidx(:),answers(:,:),idxsrch(:,:) & answers(:,:),idxsrch(:,:)
integer(psb_mpik_), allocatable :: hsz(:),hidx(:), &
integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,& & 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 & last_ih, last_j, nv
integer(psb_ipk_) :: ictxt,np,me integer(psb_mpik_) :: ictxt,np,me
logical, parameter :: gettime=.false. logical, parameter :: gettime=.false.
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
character(len=20) :: name 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,& call mpi_allgatherv(idx,hsz(me+1),psb_mpi_ipk_integer,&
& hproc,hsz,hidx,psb_mpi_ipk_integer,& & hproc,hsz,hidx,psb_mpi_ipk_integer,&
& icomm,info) & icomm,minfo)
if (gettime) then if (gettime) then
tamx = psb_wtime() - t3 tamx = psb_wtime() - t3
end if end if
@ -178,7 +180,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
end if end if
! Collect all the answers with alltoallv (need sizes) ! 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) isz = sum(rvsz)
@ -194,7 +197,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
end do end do
call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_integer,& call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_integer,&
& answers(:,1),rvsz,rvidx,psb_mpi_ipk_integer,& & answers(:,1),rvsz,rvidx,psb_mpi_ipk_integer,&
& icomm,info) & icomm,minfo)
if (gettime) then if (gettime) then
tamx = psb_wtime() - t3 + tamx tamx = psb_wtime() - t3 + tamx
end if end if

10
base/internals/psi_extrct_dl.F90
Unescape Escape View File

@ -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_) :: i,pointer_dep_list,proc,j,err_act
integer(psb_ipk_) :: err integer(psb_ipk_) :: err
integer(psb_ipk_) :: debug_level, debug_unit 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 character name*20
name='psi_extrct_dl' name='psi_extrct_dl'
@ -271,9 +271,11 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,&
goto 9999 goto 9999
endif endif
itmp(1:dl_lda) = dep_list(1:dl_lda,me) itmp(1:dl_lda) = dep_list(1:dl_lda,me)
call mpi_allgather(itmp,dl_lda,psb_mpi_ipk_integer,& dl_mpi = dl_lda
& dep_list,dl_lda,psb_mpi_ipk_integer,icomm,info) call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_integer,&
deallocate(itmp,stat=info) & dep_list,dl_mpi,psb_mpi_ipk_integer,icomm,minfo)
info = minfo
if (info == 0) deallocate(itmp,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_dealloc_ info=psb_err_alloc_dealloc_
goto 9999 goto 9999

406
base/modules/psb_realloc_mod.F90
Unescape Escape View File

@ -58,6 +58,8 @@ module psb_realloc_mod
module procedure psb_reallocatez2 module procedure psb_reallocatez2
module procedure psb_reallocatec2 module procedure psb_reallocatec2
#if defined(LONG_INTEGERS) #if defined(LONG_INTEGERS)
module procedure psb_reallocate1i4
module procedure psb_reallocatei4_2
module procedure psb_rp1i1 module procedure psb_rp1i1
module procedure psb_rp1i2i2 module procedure psb_rp1i2i2
module procedure psb_ri1p2i2 module procedure psb_ri1p2i2
@ -96,6 +98,9 @@ module psb_realloc_mod
#if !defined(LONG_INTEGERS) #if !defined(LONG_INTEGERS)
module procedure psb_i8move_alloc1d module procedure psb_i8move_alloc1d
module procedure psb_i8move_alloc2d module procedure psb_i8move_alloc2d
#else
module procedure psb_i4move_alloc1d
module procedure psb_i4move_alloc2d
#endif #endif
module procedure psb_cmove_alloc1d module procedure psb_cmove_alloc1d
module procedure psb_cmove_alloc2d module procedure psb_cmove_alloc2d
@ -1761,93 +1766,6 @@ Contains
End Subroutine psb_reallocate1i 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) Subroutine psb_reallocate1s(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
@ -2637,6 +2555,93 @@ Contains
End Subroutine psb_reallocatei2 End Subroutine psb_reallocatei2
#if !defined(LONG_INTEGERS) #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) Subroutine psb_reallocatei8_2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
@ -3261,9 +3266,236 @@ Contains
deallocate(vin,stat=info) deallocate(vin,stat=info)
#endif #endif
end Subroutine psb_i8move_alloc2d end Subroutine psb_i8move_alloc2d
#else
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
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
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),&
& 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 #endif
#if defined(LONG_INTEGERS) #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_
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; 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
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
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 psb_rp1i1(len,rrax,info,pad,lb)
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpik_),Intent(in) :: len integer(psb_mpik_),Intent(in) :: len

133
base/modules/psi_reduce_mod.F90
Unescape Escape View File

@ -62,6 +62,11 @@ module psi_reduce_mod
module procedure psb_i2sums, psb_i2sumv, psb_i2summ module procedure psb_i2sums, psb_i2sumv, psb_i2summ
end interface psb_sum end interface psb_sum
#endif #endif
#if defined(LONG_INTEGERS)
interface psb_sum
module procedure psb_i4sums, psb_i4sumv, psb_i4summ
end interface
#endif
#if !defined(LONG_INTEGERS) #if !defined(LONG_INTEGERS)
interface psb_sum interface psb_sum
module procedure psb_i8sums, psb_i8sumv, psb_i8summ module procedure psb_i8sums, psb_i8sumv, psb_i8summ
@ -2924,6 +2929,134 @@ contains
#endif #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) #if !defined(LONG_INTEGERS)
subroutine psb_i8sums(ictxt,dat,root) subroutine psb_i8sums(ictxt,dat,root)

Write Preview
Loading…
Cancel
Save