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

psblas3-submodules:

Browse Source 
base/internals/psi_dswapdata.F90
 base/internals/psi_dswaptran.F90
 base/modules/psb_d_csr_mat_mod.f90
 base/modules/psb_d_mat_mod.f90
 base/modules/psb_d_sort_mod.f90
 base/modules/psb_error_impl.F90
 base/modules/psi_d_mod.f90
 base/serial/psb_drwextd.f90
 base/serial/sort/psb_d_isort_impl.f90
 base/serial/sort/psb_d_qsort_impl.f90
 test/kernel/Makefile

Various fixes. Currently fails to link properly due to psb_error_impl;
to be investigated further.
psblas3-submodules
Salvatore Filippone 10 years ago
parent f63f52e21b
commit ad6d800411
11 changed files with 233 additions and 228 deletions
Show Stats Download Patch File Download Diff File

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

@ -154,7 +154,7 @@ contains
return
end subroutine psi_dswapdatam
subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod
@ -168,14 +168,14 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -196,9 +196,9 @@ contains
info=psb_success_
name='psi_swap_data'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -239,7 +239,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = n*nerv
@ -301,7 +301,7 @@ contains
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_r_dpk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_r_dpk_,icomm,iret)
& brvidx,psb_mpi_r_dpk_,iicomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -321,14 +321,14 @@ contains
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
@ -357,12 +357,12 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_double_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -371,7 +371,7 @@ contains
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
@ -387,11 +387,11 @@ contains
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
if(iret /= mpi_success) then
@ -447,7 +447,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
@ -466,7 +466,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -517,7 +517,7 @@ contains
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_dswapidxm
@ -655,7 +655,7 @@ contains
!
!
!
subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, &
subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod
@ -669,14 +669,14 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -697,9 +697,9 @@ contains
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
iictxt = ictxt
iicomm = icomm
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -740,7 +740,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
@ -802,7 +802,7 @@ contains
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_r_dpk_,rcvbuf,rvsz,&
& brvidx,psb_mpi_r_dpk_,icomm,iret)
& brvidx,psb_mpi_r_dpk_,iicomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -821,14 +821,14 @@ contains
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
@ -855,12 +855,12 @@ contains
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_double_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
& p2ptag, iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -869,7 +869,7 @@ contains
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -885,11 +885,11 @@ contains
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
if(iret /= mpi_success) then
@ -942,7 +942,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
if (nesd>0) call psb_snd(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -958,7 +958,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,&
if (nerv>0) call psb_rcv(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1005,7 +1005,7 @@ contains
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_dswapidxv
@ -1103,7 +1103,7 @@ contains
!
!
!
subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, &
subroutine psi_dswap_vidx_vect(ictxt,icomm,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
use psb_error_mod
@ -1120,7 +1120,7 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
@ -1129,7 +1129,7 @@ contains
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1144,10 +1144,10 @@ contains
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -1190,13 +1190,13 @@ contains
nesd = idx%v(pnti+nerv+psb_n_elem_send_)
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
p2ptag = psb_double_swap_tag
call mpi_irecv(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1239,7 +1239,7 @@ contains
if ((nesd>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
if(iret /= mpi_success) then
@ -1344,7 +1344,7 @@ contains
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_dswap_vidx_vect

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

@ -159,7 +159,7 @@ contains
return
end subroutine psi_dswaptranm
subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod
use psb_desc_mod
@ -172,14 +172,14 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag,n
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -200,10 +200,10 @@ contains
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -244,7 +244,7 @@ contains
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
@ -312,7 +312,7 @@ contains
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_r_dpk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret)
& sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,iicomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -331,14 +331,14 @@ contains
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
@ -365,12 +365,12 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_double_swap_tag
call mpi_irecv(sndbuf(snd_pt),n*nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -379,7 +379,7 @@ contains
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -394,11 +394,11 @@ contains
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),n*nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,iret)
& p2ptag,iicomm,iret)
end if
if(iret /= mpi_success) then
@ -452,7 +452,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -469,7 +469,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm)
rcv_pt = rcv_pt + n*nerv
snd_pt = snd_pt + n*nesd
@ -517,7 +517,7 @@ contains
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_dtranidxm
@ -659,7 +659,7 @@ contains
!
subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod
@ -673,14 +673,14 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
@ -707,10 +707,10 @@ contains
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -751,7 +751,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
call psb_get_rank(prcid(proc_to_comm),iictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
@ -818,7 +818,7 @@ contains
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_r_dpk_,&
& sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret)
& sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,iicomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
@ -837,14 +837,14 @@ contains
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
@ -871,12 +871,12 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_double_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
& p2ptag,iicomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -885,7 +885,7 @@ contains
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
if (usersend) call mpi_barrier(iicomm,iret)
pnti = 1
snd_pt = 1
@ -900,11 +900,11 @@ contains
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,iret)
& p2ptag, iicomm,iret)
end if
if(iret /= mpi_success) then
@ -957,7 +957,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,&
if (nerv>0) call psb_snd(iictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -974,7 +974,7 @@ contains
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,&
if (nesd>0) call psb_rcv(iictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
@ -1024,7 +1024,7 @@ contains
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return
end subroutine psi_dtranidxv
@ -1125,7 +1125,7 @@ contains
!
!
!
subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
subroutine psi_dtran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_serial_mod
use psb_error_mod
@ -1140,7 +1140,7 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
@ -1149,7 +1149,7 @@ contains
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
integer(psb_mpik_) :: iictxt, iicomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable :: prcid(:)
integer(psb_ipk_) :: nesd, nerv,&
@ -1164,10 +1164,10 @@ contains
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
iictxt = ictxt
iicomm = icomm
call psb_info(ictxt,me,np)
call psb_info(iictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
@ -1212,12 +1212,12 @@ contains
snd_pt = 1+pnti+nerv+psb_n_elem_send_
rcv_pt = 1+pnti+psb_n_elem_recv_
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
call psb_get_rank(prcid(i),iictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt
call mpi_irecv(y%combuf(snd_pt),nesd,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag, icomm,y%comid(i,2),iret)
& p2ptag, iicomm,y%comid(i,2),iret)
end if
pnti = pnti + nerv + nesd + 3
end do
@ -1265,7 +1265,7 @@ contains
if ((nerv>0).and.(proc_to_comm /= me)) then
call mpi_isend(y%combuf(rcv_pt),nerv,&
& psb_mpi_r_dpk_,prcid(i),&
& p2ptag,icomm,y%comid(i,1),iret)
& p2ptag,iicomm,y%comid(i,1),iret)
end if
if(iret /= mpi_success) then
@ -1370,7 +1370,7 @@ contains
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
9999 call psb_error_handler(iictxt,err_act)
return

2
base/modules/psb_d_csr_mat_mod.f90
Unescape Escape View File

@ -52,7 +52,7 @@ module psb_d_csr_mat_mod
!! This is a very common storage type, and is the default for assembled
!! matrices in our library
type, extends(psb_d_base_sparse_mat) :: psb_d_csr_sparse_mat
private
!private
!> Pointers to beginning of rows in JA and VAL.
integer(psb_ipk_), allocatable :: irp(:)
!> Column indices.

4
base/modules/psb_d_mat_mod.f90
Unescape Escape View File

@ -611,10 +611,10 @@ module psb_d_mat_mod
interface
module subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl)
module subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: iinfo
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_d_base_sparse_mat), intent(in), optional :: mold

4
base/modules/psb_d_sort_mod.f90
Unescape Escape View File

@ -200,9 +200,9 @@ module psb_d_sort_mod
interface
module subroutine psi_d_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
import
real(psb_dpk_), intent(inout) :: key
real(psb_dpk_), intent(out) :: key
integer(psb_ipk_), intent(out) :: index
real(psb_dpk_), intent(inout) :: heap(:)
real(psb_dpk_), intent(inout) :: heap(:)
integer(psb_ipk_), intent(in) :: dir
integer(psb_ipk_), intent(inout) :: last
integer(psb_ipk_), intent(inout) :: idxs(:)

2
base/modules/psb_error_impl.F90
Unescape Escape View File

@ -61,7 +61,6 @@ contains
! handles the occurence of an error in a serial routine
subroutine psb_serror()
use psb_const_mod
use psb_error_mod
implicit none
integer(psb_ipk_) :: err_c
character(len=20) :: r_name
@ -98,7 +97,6 @@ contains
! handles the occurence of an error in a parallel routine
subroutine psb_perror(ictxt,abrt)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
integer(psb_mpik_), intent(in) :: ictxt

8
base/modules/psi_d_mod.f90
Unescape Escape View File

@ -81,10 +81,10 @@ module psi_d_mod
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxv
module subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
module subroutine psi_dswap_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
@ -142,10 +142,10 @@ module psi_d_mod
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxv
module subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
module subroutine psi_dtran_vidx_vect(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(in) :: ictxt,icomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta

14
base/serial/psb_drwextd.f90
Unescape Escape View File

@ -104,12 +104,14 @@ subroutine psb_dbase_rwextd(nr,a,info,b,rowscale)
! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes)
integer(psb_ipk_), intent(in) :: nr
class(psb_d_base_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(inout), target :: a
integer(psb_ipk_),intent(out) :: info
class(psb_d_base_sparse_mat), intent(in), optional :: b
logical,intent(in), optional :: rowscale
integer(psb_ipk_) :: i,j,ja,jb,err_act,nza,nzb, ma, mb, na, nb
integer(psb_ipk_), pointer :: irpp(:), jap(:)
real(psb_dpk_), pointer :: valp(:)
character(len=20) :: name, ch_err
logical rowscale_
@ -123,13 +125,17 @@ subroutine psb_dbase_rwextd(nr,a,info,b,rowscale)
rowscale_ = .true.
end if
ma = a%get_nrows()
na = a%get_ncols()
ma = a%get_nrows()
na = a%get_ncols()
nza = a%get_nzeros()
select type(a)
type is (psb_d_csr_sparse_mat)
call a%set_nrows(nr)
call psb_ensure_size(nr+1,a%irp,info)
if (present(b)) then
@ -167,8 +173,6 @@ subroutine psb_dbase_rwextd(nr,a,info,b,rowscale)
end if
call a%set_nrows(nr)
type is (psb_d_coo_sparse_mat)
nza = a%get_nzeros()

48
base/serial/sort/psb_d_isort_impl.f90
Unescape Escape View File

@ -130,56 +130,56 @@ contains
return
end subroutine psb_disort
subroutine psi_disrx_up(n,x,idx)
subroutine psi_disrx_up(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: i,j,lx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = idx(j)
lx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = lx
endif
enddo
end subroutine psi_disrx_up
subroutine psi_disrx_dw(n,x,idx)
subroutine psi_disrx_dw(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: i,j,lx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = idx(j)
lx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = lx
endif
enddo
end subroutine psi_disrx_dw
@ -231,56 +231,56 @@ contains
enddo
end subroutine psi_disr_dw
subroutine psi_daisrx_up(n,x,idx)
subroutine psi_daisrx_up(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: i,j,lx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = idx(j)
lx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = lx
endif
enddo
end subroutine psi_daisrx_up
subroutine psi_daisrx_dw(n,x,idx)
subroutine psi_daisrx_dw(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: i,j,ix
integer(psb_ipk_) :: i,j,lx
real(psb_dpk_) :: xx
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = idx(j)
lx = ix(j)
i=j+1
do
x(i-1) = x(i)
idx(i-1) = idx(i)
ix(i-1) = ix(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= abs(xx)) exit
end do
x(i-1) = xx
idx(i-1) = ix
ix(i-1) = lx
endif
enddo
end subroutine psi_daisrx_dw

176
base/serial/sort/psb_d_qsort_impl.f90
Unescape Escape View File

@ -130,12 +130,12 @@ contains
return
end subroutine psb_dqsort
subroutine psi_dqsrx_up(n,x,idx)
subroutine psi_dqsrx_up(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
! .. Local Scalars ..
real(psb_dpk_) :: piv, xk, xt
@ -168,39 +168,39 @@ contains
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
ixt = idx(j)
ixt = ix(j)
x(j) = x(lpiv)
idx(j) = idx(lpiv)
ix(j) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
@ -226,11 +226,11 @@ contains
if (j > i) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(j)
idx(i) = idx(j)
ix(i) = ix(j)
x(j) = xt
idx(j) = ixt
ix(j) = ixt
else
exit outer_up
end if
@ -252,14 +252,14 @@ contains
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_disrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_disrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_disrx_up(n2,x(i:iux),idx(i:iux))
call psi_disrx_up(n2,x(i:iux),ix(i:iux))
endif
else
if (n2 > ithrs) then
@ -267,28 +267,28 @@ contains
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_disrx_up(n2,x(i:iux),idx(i:iux))
call psi_disrx_up(n2,x(i:iux),ix(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_disrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_disrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif
endif
enddo
else
call psi_disrx_up(n,x,idx)
call psi_disrx_up(n,x,ix)
endif
end subroutine psi_dqsrx_up
subroutine psi_dqsrx_dw(n,x,idx)
subroutine psi_dqsrx_dw(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
! .. Local Scalars ..
real(psb_dpk_) :: piv, xk, xt
@ -321,39 +321,39 @@ contains
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
ixt = idx(j)
ixt = ix(j)
x(j) = x(lpiv)
idx(j) = idx(lpiv)
ix(j) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = x(lpiv)
i = ilx - 1
@ -379,11 +379,11 @@ contains
if (j > i) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(j)
idx(i) = idx(j)
ix(i) = ix(j)
x(j) = xt
idx(j) = ixt
ix(j) = ixt
else
exit outer_dw
end if
@ -405,14 +405,14 @@ contains
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_disrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_disrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_disrx_dw(n2,x(i:iux),idx(i:iux))
call psi_disrx_dw(n2,x(i:iux),ix(i:iux))
endif
else
if (n2 > ithrs) then
@ -420,19 +420,19 @@ contains
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_disrx_dw(n2,x(i:iux),idx(i:iux))
call psi_disrx_dw(n2,x(i:iux),ix(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_disrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_disrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif
endif
enddo
else
call psi_disrx_dw(n,x,idx)
call psi_disrx_dw(n,x,ix)
endif
end subroutine psi_dqsrx_dw
@ -717,12 +717,12 @@ contains
end subroutine psi_dqsr_dw
subroutine psi_daqsrx_up(n,x,idx)
subroutine psi_daqsrx_up(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
! .. Local Scalars ..
real(psb_dpk_) :: piv, xk
@ -756,39 +756,39 @@ contains
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
ixt = idx(j)
ixt = ix(j)
x(j) = x(lpiv)
idx(j) = idx(lpiv)
ix(j) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
i = ilx - 1
j = iux + 1
@ -813,11 +813,11 @@ contains
if (j > i) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(j)
idx(i) = idx(j)
ix(i) = ix(j)
x(j) = xt
idx(j) = ixt
ix(j) = ixt
else
exit outer_up
end if
@ -839,14 +839,14 @@ contains
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_daisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_daisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_daisrx_up(n2,x(i:iux),idx(i:iux))
call psi_daisrx_up(n2,x(i:iux),ix(i:iux))
endif
else
if (n2 > ithrs) then
@ -854,30 +854,30 @@ contains
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_daisrx_up(n2,x(i:iux),idx(i:iux))
call psi_daisrx_up(n2,x(i:iux),ix(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_daisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_daisrx_up(n1,x(ilx:i-1),ix(ilx:i-1))
endif
endif
enddo
else
call psi_daisrx_up(n,x,idx)
call psi_daisrx_up(n,x,ix)
endif
end subroutine psi_daqsrx_up
subroutine psi_daqsrx_dw(n,x,idx)
subroutine psi_daqsrx_dw(n,x,ix)
use psb_error_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(inout) :: ix(:)
integer(psb_ipk_), intent(in) :: n
! .. Local Scalars ..
real(psb_dpk_) :: piv, xk
@ -910,39 +910,39 @@ contains
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
ixt = idx(j)
ixt = ix(j)
x(j) = x(lpiv)
idx(j) = idx(lpiv)
ix(j) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(lpiv)
idx(i) = idx(lpiv)
ix(i) = ix(lpiv)
x(lpiv) = xt
idx(lpiv) = ixt
ix(lpiv) = ixt
i = ilx - 1
j = iux + 1
@ -967,11 +967,11 @@ contains
if (j > i) then
xt = x(i)
ixt = idx(i)
ixt = ix(i)
x(i) = x(j)
idx(i) = idx(j)
ix(i) = ix(j)
x(j) = xt
idx(j) = ixt
ix(j) = ixt
else
exit outer_dw
end if
@ -993,14 +993,14 @@ contains
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_daisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_daisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_daisrx_dw(n2,x(i:iux),idx(i:iux))
call psi_daisrx_dw(n2,x(i:iux),ix(i:iux))
endif
else
if (n2 > ithrs) then
@ -1008,19 +1008,19 @@ contains
istack(1,istp) = i
istack(2,istp) = iux
else
call psi_daisrx_dw(n2,x(i:iux),idx(i:iux))
call psi_daisrx_dw(n2,x(i:iux),ix(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call psi_daisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
call psi_daisrx_dw(n1,x(ilx:i-1),ix(ilx:i-1))
endif
endif
enddo
else
call psi_daisrx_dw(n,x,idx)
call psi_daisrx_dw(n,x,ix)
endif
end subroutine psi_daqsrx_dw

3
test/kernel/Makefile
Unescape Escape View File

@ -27,6 +27,9 @@ pdgenspmv: $(DPGOBJS)
$(F90LINK) $(LOPT) $(DPGOBJS) -o pdgenspmv $(PSBLAS_LIB) $(LDLIBS)
/bin/mv pdgenspmv $(EXEDIR)
tt: tt.o
$(F90LINK) $(LOPT) tt.o -o tt $(PSBLAS_LIB) $(LDLIBS)
/bin/mv tt $(EXEDIR)
s_file_spmv: $(STOBJS)
$(F90LINK) $(LOPT) $(STOBJS) -o s_file_spmv $(PSBLAS_LIB) $(LDLIBS)

Write Preview
Loading…
Cancel
Save