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

psblas3:

Browse Source 
base/internals/psi_cswapdata.F90
 base/internals/psi_cswaptran.F90
 base/internals/psi_dswapdata.F90
 base/internals/psi_dswaptran.F90
 base/internals/psi_iswapdata.F90
 base/internals/psi_iswaptran.F90
 base/internals/psi_sswapdata.F90
 base/internals/psi_sswaptran.F90
 base/internals/psi_zswapdata.F90
 base/internals/psi_zswaptran.F90
 base/modules/psb_const_mod.F90
 base/modules/psb_desc_type.f90
 base/tools/psb_csphalo.F90
 base/tools/psb_dsphalo.F90
 base/tools/psb_ssphalo.F90
 base/tools/psb_zsphalo.F90

Transform get_list in a method of desc; side effect of preparing for
storing lists on the GPU side.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent caaced3ad1
commit ba51d74952
16 changed files with 329 additions and 266 deletions
Show Stats Download Patch File Download Diff File

43
base/internals/psi_cswapdata.F90
Unescape Escape View File

@ -38,8 +38,8 @@
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -132,7 +132,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -330,7 +330,8 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
@ -379,7 +380,7 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
@ -424,7 +425,9 @@ subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*)&
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
@ -529,8 +532,8 @@ end subroutine psi_cswapidxm
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -624,7 +627,7 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -822,7 +825,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
@ -867,7 +872,7 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag= psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -911,7 +916,9 @@ subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
@ -1054,7 +1061,7 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1254,7 +1261,8 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
@ -1300,7 +1308,7 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -1332,7 +1340,7 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag =psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
@ -1344,7 +1352,8 @@ subroutine psi_cswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)

88
base/internals/psi_cswaptran.F90
Unescape Escape View File

@ -30,9 +30,9 @@
!!$
!!$
!
! File: psi_cswaptran.F90
! File: psi_zswaptran.F90
!
! Subroutine: psi_cswaptranm
! Subroutine: psi_zswaptranm
! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -42,8 +42,8 @@
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -85,9 +85,9 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswaptranm
use psi_mod, psb_protect_name => psi_zswaptranm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -138,7 +138,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -157,11 +157,11 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_cswaptranm
end subroutine psi_zswaptranm
subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidxm
use psi_mod, psb_protect_name => psi_ztranidxm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -340,7 +340,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -386,7 +388,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag= psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& mpi_complex,prcid(i),&
@ -417,7 +419,7 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
@ -429,7 +431,9 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -518,10 +522,10 @@ subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
return
end if
return
end subroutine psi_ctranidxm
end subroutine psi_ztranidxm
!
!
! Subroutine: psi_cswaptranv
! Subroutine: psi_zswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -531,8 +535,8 @@ end subroutine psi_ctranidxm
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -574,9 +578,9 @@ end subroutine psi_ctranidxm
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswaptranv
use psi_mod, psb_protect_name => psi_zswaptranv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -626,7 +630,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -645,13 +649,13 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_cswaptranv
end subroutine psi_zswaptranv
subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidxv
use psi_mod, psb_protect_name => psi_ztranidxv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -829,7 +833,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -875,7 +881,7 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag= psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_complex,prcid(i),&
@ -917,7 +923,9 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1008,12 +1016,12 @@ subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
return
end if
return
end subroutine psi_ctranidxv
end subroutine psi_ztranidxv
subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_cswaptran_vect
use psi_mod, psb_protect_name => psi_zswaptran_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -1065,7 +1073,7 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1084,14 +1092,14 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_cswaptran_vect
end subroutine psi_zswaptran_vect
subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_ctranidx_vect
use psi_mod, psb_protect_name => psi_ztranidx_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -1271,7 +1279,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1317,7 +1327,7 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=psb_complex_swap_tag
p2ptag = psb_complex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_complex,prcid(i),&
@ -1359,7 +1369,9 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1450,7 +1462,7 @@ subroutine psi_ctranidx_vect(ictxt,icomm,flag,beta,y,idx,&
return
end if
return
end subroutine psi_ctranidx_vect
end subroutine psi_ztranidx_vect

66
base/internals/psi_dswapdata.F90
Unescape Escape View File

@ -81,7 +81,6 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
!
subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswapdatam
@ -100,7 +99,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
@ -133,7 +132,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -331,7 +330,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
@ -380,7 +380,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=psb_double_swap_tag
p2ptag = psb_double_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
@ -389,7 +389,7 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& mpi_double_precision,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
@ -425,7 +425,8 @@ subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*)&
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
@ -573,6 +574,7 @@ end subroutine psi_dswapidxm
! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswapdatav
@ -591,7 +593,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
integer, intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
@ -625,7 +627,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -823,7 +825,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
@ -869,7 +872,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=psb_double_swap_tag
p2ptag = psb_double_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -901,7 +904,7 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag =psb_double_swap_tag
p2ptag = psb_double_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
@ -913,7 +916,8 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
@ -1003,8 +1007,6 @@ subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
return
end subroutine psi_dswapidxv
subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswapdata_vect
@ -1020,13 +1022,13 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
include 'mpif.h'
#endif
integer, intent(in) :: flag
integer, intent(out) :: info
integer, intent(in) :: flag
integer, intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
integer :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
@ -1059,7 +1061,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1096,12 +1098,12 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h'
#endif
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd, totrcv
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer :: np, me, nesd, nerv,&
@ -1259,7 +1261,8 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
@ -1305,7 +1308,7 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=psb_double_swap_tag
p2ptag = psb_double_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -1337,7 +1340,7 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag =psb_double_swap_tag
p2ptag = psb_double_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
@ -1349,7 +1352,8 @@ subroutine psi_dswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)

91
base/internals/psi_dswaptran.F90
Unescape Escape View File

@ -30,9 +30,9 @@
!!$
!!$
!
! File: psi_dswaptran.F90
! File: psi_zswaptran.F90
!
! Subroutine: psi_dswaptranm
! Subroutine: psi_zswaptranm
! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -85,9 +85,9 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswaptranm
use psi_mod, psb_protect_name => psi_zswaptranm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -103,8 +103,8 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer, intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
integer :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
@ -138,7 +138,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -157,11 +157,11 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_dswaptranm
end subroutine psi_zswaptranm
subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dtranidxm
use psi_mod, psb_protect_name => psi_ztranidxm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -340,7 +340,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -386,7 +388,7 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=psb_double_swap_tag
p2ptag = psb_double_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& mpi_double_precision,prcid(i),&
@ -429,7 +431,9 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -518,10 +522,10 @@ subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
return
end if
return
end subroutine psi_dtranidxm
end subroutine psi_ztranidxm
!
!
! Subroutine: psi_dswaptranv
! Subroutine: psi_zswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -574,9 +578,9 @@ end subroutine psi_dtranidxm
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswaptranv
use psi_mod, psb_protect_name => psi_zswaptranv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -626,7 +630,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -645,13 +649,13 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_dswaptranv
end subroutine psi_zswaptranv
subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dtranidxv
use psi_mod, psb_protect_name => psi_ztranidxv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -829,7 +833,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -875,7 +881,7 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=psb_double_swap_tag
p2ptag = psb_double_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_double_precision,prcid(i),&
@ -917,7 +923,9 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1008,11 +1016,12 @@ subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
return
end if
return
end subroutine psi_dtranidxv
end subroutine psi_ztranidxv
subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_dswaptran_vect
subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_zswaptran_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -1025,11 +1034,11 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
include 'mpif.h'
#endif
integer, intent(in) :: flag
integer, intent(out) :: info
integer, intent(in) :: flag
integer, intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
@ -1064,7 +1073,7 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1083,14 +1092,14 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_dswaptran_vect
end subroutine psi_zswaptran_vect
subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_dtranidx_vect
use psi_mod, psb_protect_name => psi_ztranidx_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -1270,7 +1279,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1316,7 +1327,7 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=psb_double_swap_tag
p2ptag = psb_double_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_double_precision,prcid(i),&
@ -1358,7 +1369,9 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1449,7 +1462,7 @@ subroutine psi_dtranidx_vect(ictxt,icomm,flag,beta,y,idx,&
return
end if
return
end subroutine psi_dtranidx_vect
end subroutine psi_ztranidx_vect

4
base/internals/psi_iswapdata.F90
Unescape Escape View File

@ -132,7 +132,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -623,7 +623,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999

4
base/internals/psi_iswaptran.F90
Unescape Escape View File

@ -138,7 +138,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -626,7 +626,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999

72
base/internals/psi_sswapdata.F90
Unescape Escape View File

@ -38,8 +38,8 @@
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -99,7 +99,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, intent(out) :: info
real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
@ -132,7 +132,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -330,7 +330,8 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
@ -379,7 +380,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag= psb_real_swap_tag
p2ptag = psb_real_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
@ -388,7 +389,7 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& mpi_real,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
@ -424,7 +425,9 @@ subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*)&
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
@ -529,8 +532,8 @@ end subroutine psi_sswapidxm
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -571,6 +574,7 @@ end subroutine psi_sswapidxm
! psb_comm_ovrl_ use ovrl_index
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswapdatav
@ -589,7 +593,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
integer, intent(out) :: info
real(psb_spk_) :: y(:), beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
@ -623,7 +627,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -821,7 +825,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
@ -866,7 +872,7 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag= psb_real_swap_tag
p2ptag = psb_real_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -910,7 +916,9 @@ subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
@ -1014,13 +1022,13 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
include 'mpif.h'
#endif
integer, intent(in) :: flag
integer, intent(out) :: info
integer, intent(in) :: flag
integer, intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
integer :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
@ -1053,7 +1061,7 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1090,12 +1098,12 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
include 'mpif.h'
#endif
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd, totrcv
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer :: np, me, nesd, nerv,&
@ -1253,7 +1261,8 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
@ -1299,7 +1308,7 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=psb_real_swap_tag
p2ptag = psb_real_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -1331,7 +1340,7 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag =psb_real_swap_tag
p2ptag = psb_real_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
@ -1343,7 +1352,8 @@ subroutine psi_sswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)

98
base/internals/psi_sswaptran.F90
Unescape Escape View File

@ -30,9 +30,9 @@
!!$
!!$
!
! File: psi_sswaptran.F90
! File: psi_zswaptran.F90
!
! Subroutine: psi_sswaptranm
! Subroutine: psi_zswaptranm
! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -42,8 +42,8 @@
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -85,9 +85,9 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswaptranm
use psi_mod, psb_protect_name => psi_zswaptranm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -103,8 +103,8 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer, intent(out) :: info
real(psb_spk_) :: y(:,:), beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
type(psb_desc_type),target :: desc_a
integer, optional :: data
! locals
integer :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
@ -138,7 +138,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -157,11 +157,11 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_sswaptranm
end subroutine psi_zswaptranm
subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidxm
use psi_mod, psb_protect_name => psi_ztranidxm
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -340,7 +340,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -386,7 +388,7 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag= psb_real_swap_tag
p2ptag = psb_real_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& mpi_real,prcid(i),&
@ -429,7 +431,9 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -518,10 +522,10 @@ subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
return
end if
return
end subroutine psi_stranidxm
end subroutine psi_ztranidxm
!
!
! Subroutine: psi_sswaptranv
! Subroutine: psi_zswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -531,8 +535,8 @@ end subroutine psi_stranidxm
! it is capable of pruning empty exchanges, which are very likely in out
! application environment. All the variants have the same structure
! In all these subroutines X may be: I Integer
! D real(psb_spk_)
! Z complex(psb_spk_)
! D real(psb_dpk_)
! Z complex(psb_dpk_)
! Basically the operation is as follows: on each process, we identify
! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y)));
! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y
@ -574,9 +578,9 @@ end subroutine psi_stranidxm
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswaptranv
use psi_mod, psb_protect_name => psi_zswaptranv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -626,7 +630,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -645,13 +649,13 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_sswaptranv
end subroutine psi_zswaptranv
subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidxv
use psi_mod, psb_protect_name => psi_ztranidxv
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -829,7 +833,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -875,7 +881,7 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag= psb_real_swap_tag
p2ptag = psb_real_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_real,prcid(i),&
@ -917,7 +923,9 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1008,12 +1016,12 @@ subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
return
end if
return
end subroutine psi_stranidxv
end subroutine psi_ztranidxv
subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_sswaptran_vect
use psi_mod, psb_protect_name => psi_zswaptran_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -1026,11 +1034,11 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
include 'mpif.h'
#endif
integer, intent(in) :: flag
integer, intent(out) :: info
integer, intent(in) :: flag
integer, intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
real(psb_spk_) :: beta
real(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer, optional :: data
@ -1065,7 +1073,7 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1084,14 +1092,14 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
return
end if
return
end subroutine psi_sswaptran_vect
end subroutine psi_zswaptran_vect
subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_stranidx_vect
use psi_mod, psb_protect_name => psi_ztranidx_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
@ -1271,7 +1279,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1317,7 +1327,7 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=psb_real_swap_tag
p2ptag = psb_real_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_real,prcid(i),&
@ -1359,7 +1369,9 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1450,7 +1462,7 @@ subroutine psi_stranidx_vect(ictxt,icomm,flag,beta,y,idx,&
return
end if
return
end subroutine psi_stranidx_vect
end subroutine psi_ztranidx_vect

35
base/internals/psi_zswapdata.F90
Unescape Escape View File

@ -132,7 +132,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -330,7 +330,8 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
@ -379,7 +380,7 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag= psb_dcomplex_swap_tag
p2ptag = psb_dcomplex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
@ -424,7 +425,9 @@ subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*)&
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1)
end if
@ -624,7 +627,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -822,7 +825,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
@ -867,7 +872,7 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag= psb_dcomplex_swap_tag
p2ptag = psb_dcomplex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -911,7 +916,9 @@ subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send', &
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
@ -1054,7 +1061,7 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1254,7 +1261,8 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
@ -1300,7 +1308,7 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag=psb_dcomplex_swap_tag
p2ptag = psb_dcomplex_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
@ -1332,7 +1340,7 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag =psb_dcomplex_swap_tag
p2ptag = psb_dcomplex_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
@ -1344,7 +1352,8 @@ subroutine psi_zswapidx_vect(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,wo
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swapdata: mismatch on self sendf',&
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)

36
base/internals/psi_zswaptran.F90
Unescape Escape View File

@ -138,7 +138,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -340,7 +340,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -386,7 +388,7 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag= psb_dcomplex_swap_tag
p2ptag = psb_dcomplex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& mpi_double_complex,prcid(i),&
@ -429,7 +431,9 @@ subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1)
end if
@ -626,7 +630,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -829,7 +833,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -875,7 +881,7 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag= psb_dcomplex_swap_tag
p2ptag = psb_dcomplex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_double_complex,prcid(i),&
@ -917,7 +923,9 @@ subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,i
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1065,7 +1073,7 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_
end if
call psb_cd_get_list(data_,desc_a,d_idx,totxch,idxr,idxs,info)
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
@ -1271,7 +1279,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
@ -1317,7 +1327,7 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag=psb_dcomplex_swap_tag
p2ptag = psb_dcomplex_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& mpi_double_complex,prcid(i),&
@ -1359,7 +1369,9 @@ subroutine psi_ztranidx_vect(ictxt,icomm,flag,beta,y,idx,&
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) 'Fatal error in swaptran: mismatch on self sendf',nerv,nesd
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if

1
base/modules/psb_const_mod.F90
Unescape Escape View File

@ -75,6 +75,7 @@ module psb_const_mod
real(psb_dpk_), parameter :: d_epstol=1.1d-16 ! Unit roundoff.
real(psb_spk_), parameter :: s_epstol=5.e-8 ! Is this right?
character, parameter :: psb_all_='A', psb_topdef_=' '
logical, parameter :: psb_i_is_complex_ = .false.
logical, parameter :: psb_s_is_complex_ = .false.
logical, parameter :: psb_d_is_complex_ = .false.
logical, parameter :: psb_c_is_complex_ = .true.

5
base/modules/psb_desc_type.f90
Unescape Escape View File

@ -224,6 +224,7 @@ module psb_descriptor_type
procedure, pass(desc) :: get_local_cols => psb_cd_get_local_cols
procedure, pass(desc) :: get_global_rows => psb_cd_get_global_rows
procedure, pass(desc) :: get_global_cols => psb_cd_get_global_cols
procedure, pass(desc) :: get_list => psb_cd_get_list
procedure, pass(desc) :: sizeof => psb_cd_sizeof
procedure, pass(desc) :: free => psb_cdfree
procedure, pass(desc) :: nullify => nullify_desc
@ -525,9 +526,9 @@ contains
implicit none
integer, intent(in) :: data
integer, pointer :: ipnt(:)
type(psb_desc_type), target :: desc
class(psb_desc_type), target :: desc
integer, intent(out) :: totxch,idxr,idxs,info
!locals
integer :: np,me,ictxt,err_act, debug_level,debug_unit
logical, parameter :: debug=.false.,debugprt=.false.

13
base/tools/psb_csphalo.F90
Unescape Escape View File

@ -78,7 +78,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Integer :: np,me,counter,proc,i, &
& n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,&
& n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,&
& irmin,icmin,irmax,icmax,data_,ngtz
& irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr
Integer :: l1, icomm, err_act
Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), &
& rvsz(:), bsdindx(:),sdsz(:), iasnd(:), jasnd(:)
@ -149,20 +149,15 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
If (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Data selector',data_
select case(data_)
case(psb_comm_halo_)
idxv => desc_a%halo_index
case(psb_comm_ext_)
idxv => desc_a%ext_index
! !$ case(psb_comm_ovr_)
! !$ idxv => desc_a%ovrlap_index
case(psb_comm_halo_,psb_comm_ext_ )
! Do not accept OVRLAP_INDEX any longer.
case default
call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector')
goto 9999
end select
call desc_a%get_list(data_,idxv,totxch,nxs,nxr,info)
l1 = 0
sdsz(:)=0

13
base/tools/psb_dsphalo.F90
Unescape Escape View File

@ -78,7 +78,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Integer :: np,me,counter,proc,i, &
& n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,&
& n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,&
& irmin,icmin,irmax,icmax,data_,ngtz
& irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr
Integer :: l1, icomm, err_act
Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), &
& rvsz(:), bsdindx(:),sdsz(:), iasnd(:), jasnd(:)
@ -149,20 +149,15 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
If (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Data selector',data_
select case(data_)
case(psb_comm_halo_)
idxv => desc_a%halo_index
case(psb_comm_ext_)
idxv => desc_a%ext_index
! !$ case(psb_comm_ovr_)
! !$ idxv => desc_a%ovrlap_index
case(psb_comm_halo_,psb_comm_ext_ )
! Do not accept OVRLAP_INDEX any longer.
case default
call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector')
goto 9999
end select
call desc_a%get_list(data_,idxv,totxch,nxs,nxr,info)
l1 = 0
sdsz(:)=0

13
base/tools/psb_ssphalo.F90
Unescape Escape View File

@ -78,7 +78,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Integer :: np,me,counter,proc,i, &
& n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,&
& n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,&
& irmin,icmin,irmax,icmax,data_,ngtz
& irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr
Integer :: l1, icomm, err_act
Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), &
& rvsz(:), bsdindx(:),sdsz(:), iasnd(:), jasnd(:)
@ -149,20 +149,15 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
If (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Data selector',data_
select case(data_)
case(psb_comm_halo_)
idxv => desc_a%halo_index
case(psb_comm_ext_)
idxv => desc_a%ext_index
! !$ case(psb_comm_ovr_)
! !$ idxv => desc_a%ovrlap_index
case(psb_comm_halo_,psb_comm_ext_ )
! Do not accept OVRLAP_INDEX any longer.
case default
call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector')
goto 9999
end select
call desc_a%get_list(data_,idxv,totxch,nxs,nxr,info)
l1 = 0
sdsz(:)=0

13
base/tools/psb_zsphalo.F90
Unescape Escape View File

@ -78,7 +78,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Integer :: np,me,counter,proc,i, &
& n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,&
& n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,&
& irmin,icmin,irmax,icmax,data_,ngtz
& irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr
Integer :: l1, icomm, err_act
Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), &
& rvsz(:), bsdindx(:),sdsz(:), iasnd(:), jasnd(:)
@ -149,20 +149,15 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
If (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Data selector',data_
select case(data_)
case(psb_comm_halo_)
idxv => desc_a%halo_index
case(psb_comm_ext_)
idxv => desc_a%ext_index
! !$ case(psb_comm_ovr_)
! !$ idxv => desc_a%ovrlap_index
case(psb_comm_halo_,psb_comm_ext_ )
! Do not accept OVRLAP_INDEX any longer.
case default
call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector')
goto 9999
end select
call desc_a%get_list(data_,idxv,totxch,nxs,nxr,info)
l1 = 0
sdsz(:)=0

Write Preview
Loading…
Cancel
Save