From ba51d74952fd791f0fb04e9b8949efbe794bdd61 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 27 Dec 2011 20:45:45 +0000 Subject: [PATCH] psblas3: 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. --- base/internals/psi_cswapdata.F90 | 43 ++++++++------ base/internals/psi_cswaptran.F90 | 88 +++++++++++++++------------- base/internals/psi_dswapdata.F90 | 66 +++++++++++---------- base/internals/psi_dswaptran.F90 | 91 ++++++++++++++++------------- base/internals/psi_iswapdata.F90 | 4 +- base/internals/psi_iswaptran.F90 | 4 +- base/internals/psi_sswapdata.F90 | 72 +++++++++++++---------- base/internals/psi_sswaptran.F90 | 98 ++++++++++++++++++-------------- base/internals/psi_zswapdata.F90 | 35 +++++++----- base/internals/psi_zswaptran.F90 | 36 ++++++++---- base/modules/psb_const_mod.F90 | 1 + base/modules/psb_desc_type.f90 | 5 +- base/tools/psb_csphalo.F90 | 13 ++--- base/tools/psb_dsphalo.F90 | 13 ++--- base/tools/psb_ssphalo.F90 | 13 ++--- base/tools/psb_zsphalo.F90 | 13 ++--- 16 files changed, 329 insertions(+), 266 deletions(-) diff --git a/base/internals/psi_cswapdata.F90 b/base/internals/psi_cswapdata.F90 index 03d7e3bc..0279815a 100644 --- a/base/internals/psi_cswapdata.F90 +++ b/base/internals/psi_cswapdata.F90 @@ -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) diff --git a/base/internals/psi_cswaptran.F90 b/base/internals/psi_cswaptran.F90 index 66f06a0b..1d7d2460 100644 --- a/base/internals/psi_cswaptran.F90 +++ b/base/internals/psi_cswaptran.F90 @@ -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 diff --git a/base/internals/psi_dswapdata.F90 b/base/internals/psi_dswapdata.F90 index 099316d8..e788451b 100644 --- a/base/internals/psi_dswapdata.F90 +++ b/base/internals/psi_dswapdata.F90 @@ -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) diff --git a/base/internals/psi_dswaptran.F90 b/base/internals/psi_dswaptran.F90 index b834f9e4..af013b38 100644 --- a/base/internals/psi_dswaptran.F90 +++ b/base/internals/psi_dswaptran.F90 @@ -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 diff --git a/base/internals/psi_iswapdata.F90 b/base/internals/psi_iswapdata.F90 index 8fc584bd..26ee63d5 100644 --- a/base/internals/psi_iswapdata.F90 +++ b/base/internals/psi_iswapdata.F90 @@ -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 diff --git a/base/internals/psi_iswaptran.F90 b/base/internals/psi_iswaptran.F90 index cd77e483..bea88a62 100644 --- a/base/internals/psi_iswaptran.F90 +++ b/base/internals/psi_iswaptran.F90 @@ -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 diff --git a/base/internals/psi_sswapdata.F90 b/base/internals/psi_sswapdata.F90 index b812294b..2cf82d44 100644 --- a/base/internals/psi_sswapdata.F90 +++ b/base/internals/psi_sswapdata.F90 @@ -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) diff --git a/base/internals/psi_sswaptran.F90 b/base/internals/psi_sswaptran.F90 index ff906900..c2cf03c5 100644 --- a/base/internals/psi_sswaptran.F90 +++ b/base/internals/psi_sswaptran.F90 @@ -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 diff --git a/base/internals/psi_zswapdata.F90 b/base/internals/psi_zswapdata.F90 index 27fda0f9..1e860e9e 100644 --- a/base/internals/psi_zswapdata.F90 +++ b/base/internals/psi_zswapdata.F90 @@ -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) diff --git a/base/internals/psi_zswaptran.F90 b/base/internals/psi_zswaptran.F90 index 0369e037..95e84145 100644 --- a/base/internals/psi_zswaptran.F90 +++ b/base/internals/psi_zswaptran.F90 @@ -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 diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 88739139..5c37bd89 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -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. diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 6bf42a17..0179000a 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -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. diff --git a/base/tools/psb_csphalo.F90 b/base/tools/psb_csphalo.F90 index 086b572e..998eacb7 100644 --- a/base/tools/psb_csphalo.F90 +++ b/base/tools/psb_csphalo.F90 @@ -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 diff --git a/base/tools/psb_dsphalo.F90 b/base/tools/psb_dsphalo.F90 index e397f4b3..1bb460ce 100644 --- a/base/tools/psb_dsphalo.F90 +++ b/base/tools/psb_dsphalo.F90 @@ -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 diff --git a/base/tools/psb_ssphalo.F90 b/base/tools/psb_ssphalo.F90 index e15e7704..f719e618 100644 --- a/base/tools/psb_ssphalo.F90 +++ b/base/tools/psb_ssphalo.F90 @@ -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 diff --git a/base/tools/psb_zsphalo.F90 b/base/tools/psb_zsphalo.F90 index 709d2354..2b2136df 100644 --- a/base/tools/psb_zsphalo.F90 +++ b/base/tools/psb_zsphalo.F90 @@ -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