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

Merge branch 'tempMixed' into MixedI8

Browse Source
ILmat
Salvatore Filippone 8 years ago
parent 9e5b76331a ee5af79c9b
commit a441938861
285 changed files with 14217 additions and 10153 deletions
Show Stats Download Patch File Download Diff File

4
Makefile
Unescape Escape View File

@ -1,9 +1,9 @@
include Make.inc include Make.inc
all: libd based precd kryld utild cbindd all: libd based precd kryld utild
@echo "=====================================" @echo "====================================="
@echo "PSBLAS libraries Compilation Successful." @echo "PSBLAS libraries Compilation Successful."
#cbindd
based: libd based: libd
precd utild: based precd utild: based
kryld: precd based kryld: precd based

8
base/comm/psb_cgather.f90
Unescape Escape View File

@ -58,8 +58,8 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_spk_), allocatable :: llocx(:) complex(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_cgather_multivect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_spk_), allocatable :: llocx(:,:) complex(psb_spk_), allocatable :: llocx(:,:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

11
base/comm/psb_cgather_a.f90
Unescape Escape View File

@ -58,9 +58,9 @@ subroutine psb_cgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & & maxk, k, jlx, ilx, i, j
& ilx, i, j, idx integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

16
base/comm/psb_chalo.f90
Unescape Escape View File

@ -66,9 +66,9 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -205,9 +205,9 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

11
base/comm/psb_chalo_a.f90
Unescape Escape View File

@ -66,8 +66,9 @@ subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx & err, liwork,data_, ldx
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:), xp(:,:) complex(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_chalov(x,desc_a,info,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, & integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_chalov(x,desc_a,info,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

16
base/comm/psb_covrl.f90
Unescape Escape View File

@ -75,9 +75,9 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -127,7 +127,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -200,9 +200,9 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -252,7 +252,7 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

13
base/comm/psb_covrl_a.f90
Unescape Escape View File

@ -77,8 +77,9 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:), xp(:,:) complex(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -137,7 +138,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -271,9 +272,9 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & k, update_, mode_, err, liwork, ldx
& mode_, err, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:) complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

20
base/comm/psb_cscatter_a.F90
Unescape Escape View File

@ -63,11 +63,13 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos & col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
complex(psb_spk_),allocatable :: scatterv(:) complex(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_scatterm' name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k do col=1, k
! prepare vector to scatter ! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
complex(psb_spk_), allocatable :: scatterv(:) complex(psb_spk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (iam == iroot) then if (iam == iroot) then

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

@ -51,6 +51,7 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_c_coo_sparse_mat) :: loc_coo, glob_coo type(psb_c_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
@ -101,14 +102,19 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
end if end if
nzl = loc_coo%get_nzeros() nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locia,info)
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locja,info)
call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I')
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = nzl nzbr(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr) nzg = sum(nzbr)
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -117,24 +123,33 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo) & psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,& & glbia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,& & glbja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info = minfo info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if
call loc_coo%free() call loc_coo%free()
deallocate(locia,locja, stat=info)
!
! Is the code below safe? For very large cases
! the indices in glob_coo will overflow. But then,
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg) call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl) if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo) call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_

8
base/comm/psb_dgather.f90
Unescape Escape View File

@ -58,8 +58,8 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_dpk_), allocatable :: llocx(:) real(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_dpk_), allocatable :: llocx(:,:) real(psb_dpk_), allocatable :: llocx(:,:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

11
base/comm/psb_dgather_a.f90
Unescape Escape View File

@ -58,9 +58,9 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & & maxk, k, jlx, ilx, i, j
& ilx, i, j, idx integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

16
base/comm/psb_dhalo.f90
Unescape Escape View File

@ -66,9 +66,9 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -205,9 +205,9 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

11
base/comm/psb_dhalo_a.f90
Unescape Escape View File

@ -66,8 +66,9 @@ subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx & err, liwork,data_, ldx
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:), xp(:,:) real(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, & integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

16
base/comm/psb_dovrl.f90
Unescape Escape View File

@ -75,9 +75,9 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -127,7 +127,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -200,9 +200,9 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -252,7 +252,7 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

13
base/comm/psb_dovrl_a.f90
Unescape Escape View File

@ -77,8 +77,9 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:), xp(:,:) real(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -137,7 +138,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -271,9 +272,9 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & k, update_, mode_, err, liwork, ldx
& mode_, err, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:) real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

20
base/comm/psb_dscatter_a.F90
Unescape Escape View File

@ -63,11 +63,13 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos & col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
real(psb_dpk_),allocatable :: scatterv(:) real(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_scatterm' name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k do col=1, k
! prepare vector to scatter ! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
real(psb_dpk_), allocatable :: scatterv(:) real(psb_dpk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (iam == iroot) then if (iam == iroot) then

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

@ -51,6 +51,7 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_d_coo_sparse_mat) :: loc_coo, glob_coo type(psb_d_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
@ -101,14 +102,19 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
end if end if
nzl = loc_coo%get_nzeros() nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locia,info)
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locja,info)
call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I')
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = nzl nzbr(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr) nzg = sum(nzbr)
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -117,24 +123,33 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo) & psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,& & glbia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,& & glbja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info = minfo info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if
call loc_coo%free() call loc_coo%free()
deallocate(locia,locja, stat=info)
!
! Is the code below safe? For very large cases
! the indices in glob_coo will overflow. But then,
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg) call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl) if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo) call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_

11
base/comm/psb_egather_a.f90
Unescape Escape View File

@ -58,9 +58,9 @@ subroutine psb_egatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & & maxk, k, jlx, ilx, i, j
& ilx, i, j, idx integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

11
base/comm/psb_ehalo_a.f90
Unescape Escape View File

@ -66,8 +66,9 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx & err, liwork,data_, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:), xp(:,:) integer(psb_epk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, & integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:) integer(psb_epk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

13
base/comm/psb_eovrl_a.f90
Unescape Escape View File

@ -77,8 +77,9 @@ subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:), xp(:,:) integer(psb_epk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -137,7 +138,7 @@ subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -271,9 +272,9 @@ subroutine psb_eovrlv(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & k, update_, mode_, err, liwork, ldx
& mode_, err, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:) integer(psb_epk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_eovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

20
base/comm/psb_escatter_a.F90
Unescape Escape View File

@ -63,11 +63,13 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos & col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
integer(psb_epk_),allocatable :: scatterv(:) integer(psb_epk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_scatterm' name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k do col=1, k
! prepare vector to scatter ! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
integer(psb_epk_), allocatable :: scatterv(:) integer(psb_epk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (iam == iroot) then if (iam == iroot) then

8
base/comm/psb_igather.f90
Unescape Escape View File

@ -58,8 +58,8 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_ipk_), allocatable :: llocx(:) integer(psb_ipk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_ipk_), allocatable :: llocx(:,:) integer(psb_ipk_), allocatable :: llocx(:,:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

16
base/comm/psb_ihalo.f90
Unescape Escape View File

@ -66,9 +66,9 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:) integer(psb_ipk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -205,9 +205,9 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:) integer(psb_ipk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

16
base/comm/psb_iovrl.f90
Unescape Escape View File

@ -75,9 +75,9 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:) integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -127,7 +127,7 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -200,9 +200,9 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:) integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -252,7 +252,7 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

35
base/comm/psb_ispgather.F90
Unescape Escape View File

@ -51,6 +51,7 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_i_coo_sparse_mat) :: loc_coo, glob_coo type(psb_i_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
@ -101,14 +102,19 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
end if end if
nzl = loc_coo%get_nzeros() nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locia,info)
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locja,info)
call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I')
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = nzl nzbr(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr) nzg = sum(nzbr)
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -117,24 +123,33 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,& & glbia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,& & glbja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info = minfo info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if
call loc_coo%free() call loc_coo%free()
deallocate(locia,locja, stat=info)
!
! Is the code below safe? For very large cases
! the indices in glob_coo will overflow. But then,
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg) call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl) if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo) call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_

8
base/comm/psb_lgather.f90
Unescape Escape View File

@ -58,8 +58,8 @@ subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_lpk_), allocatable :: llocx(:) integer(psb_lpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_lgather_multivect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_lpk_), allocatable :: llocx(:,:) integer(psb_lpk_), allocatable :: llocx(:,:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

16
base/comm/psb_lhalo.f90
Unescape Escape View File

@ -66,9 +66,9 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:) integer(psb_lpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -205,9 +205,9 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:) integer(psb_lpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

16
base/comm/psb_lovrl.f90
Unescape Escape View File

@ -75,9 +75,9 @@ subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:) integer(psb_lpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -127,7 +127,7 @@ subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -200,9 +200,9 @@ subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:) integer(psb_lpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -252,7 +252,7 @@ subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

35
base/comm/psb_lspgather.F90
Unescape Escape View File

@ -51,6 +51,7 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_l_coo_sparse_mat) :: loc_coo, glob_coo type(psb_l_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
@ -101,14 +102,19 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
end if end if
nzl = loc_coo%get_nzeros() nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locia,info)
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locja,info)
call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I')
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = nzl nzbr(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr) nzg = sum(nzbr)
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -117,24 +123,33 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,& & glbia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,& & glbja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info = minfo info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if
call loc_coo%free() call loc_coo%free()
deallocate(locia,locja, stat=info)
!
! Is the code below safe? For very large cases
! the indices in glob_coo will overflow. But then,
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg) call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl) if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo) call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_

11
base/comm/psb_mgather_a.f90
Unescape Escape View File

@ -58,9 +58,9 @@ subroutine psb_mgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & & maxk, k, jlx, ilx, i, j
& ilx, i, j, idx integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

11
base/comm/psb_mhalo_a.f90
Unescape Escape View File

@ -66,8 +66,9 @@ subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx & err, liwork,data_, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:), xp(:,:) integer(psb_mpk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, & integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:) integer(psb_mpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

13
base/comm/psb_movrl_a.f90
Unescape Escape View File

@ -77,8 +77,9 @@ subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:), xp(:,:) integer(psb_mpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -137,7 +138,7 @@ subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -271,9 +272,9 @@ subroutine psb_movrlv(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & k, update_, mode_, err, liwork, ldx
& mode_, err, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:) integer(psb_mpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_movrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

20
base/comm/psb_mscatter_a.F90
Unescape Escape View File

@ -63,11 +63,13 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos & col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
integer(psb_mpk_),allocatable :: scatterv(:) integer(psb_mpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_scatterm' name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k do col=1, k
! prepare vector to scatter ! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
integer(psb_mpk_), allocatable :: scatterv(:) integer(psb_mpk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (iam == iroot) then if (iam == iroot) then

8
base/comm/psb_sgather.f90
Unescape Escape View File

@ -58,8 +58,8 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_spk_), allocatable :: llocx(:) real(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_spk_), allocatable :: llocx(:,:) real(psb_spk_), allocatable :: llocx(:,:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

11
base/comm/psb_sgather_a.f90
Unescape Escape View File

@ -58,9 +58,9 @@ subroutine psb_sgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & & maxk, k, jlx, ilx, i, j
& ilx, i, j, idx integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

16
base/comm/psb_shalo.f90
Unescape Escape View File

@ -66,9 +66,9 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -205,9 +205,9 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

11
base/comm/psb_shalo_a.f90
Unescape Escape View File

@ -66,8 +66,9 @@ subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx & err, liwork,data_, ldx
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:), xp(:,:) real(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_shalov(x,desc_a,info,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, & integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_shalov(x,desc_a,info,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

16
base/comm/psb_sovrl.f90
Unescape Escape View File

@ -75,9 +75,9 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -127,7 +127,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -200,9 +200,9 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -252,7 +252,7 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

13
base/comm/psb_sovrl_a.f90
Unescape Escape View File

@ -77,8 +77,9 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:), xp(:,:) real(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -137,7 +138,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -271,9 +272,9 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & k, update_, mode_, err, liwork, ldx
& mode_, err, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:) real(psb_spk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

20
base/comm/psb_sscatter_a.F90
Unescape Escape View File

@ -63,11 +63,13 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos & col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
real(psb_spk_),allocatable :: scatterv(:) real(psb_spk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_scatterm' name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k do col=1, k
! prepare vector to scatter ! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
real(psb_spk_), allocatable :: scatterv(:) real(psb_spk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (iam == iroot) then if (iam == iroot) then

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

@ -51,6 +51,7 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_s_coo_sparse_mat) :: loc_coo, glob_coo type(psb_s_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
@ -101,14 +102,19 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
end if end if
nzl = loc_coo%get_nzeros() nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locia,info)
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locja,info)
call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I')
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = nzl nzbr(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr) nzg = sum(nzbr)
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -117,24 +123,33 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo) & psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,& & glbia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,& & glbja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info = minfo info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if
call loc_coo%free() call loc_coo%free()
deallocate(locia,locja, stat=info)
!
! Is the code below safe? For very large cases
! the indices in glob_coo will overflow. But then,
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg) call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl) if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo) call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_

8
base/comm/psb_zgather.f90
Unescape Escape View File

@ -58,8 +58,8 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_dpk_), allocatable :: llocx(:) complex(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_dpk_), allocatable :: llocx(:,:) complex(psb_dpk_), allocatable :: llocx(:,:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

11
base/comm/psb_zgather_a.f90
Unescape Escape View File

@ -58,9 +58,9 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & & maxk, k, jlx, ilx, i, j
& ilx, i, j, idx integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx & maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err character(len=20) :: name, ch_err

16
base/comm/psb_zhalo.f90
Unescape Escape View File

@ -66,9 +66,9 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -205,9 +205,9 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me,& integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& & nrow, imode, err, liwork,data_
& err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
endif endif
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

11
base/comm/psb_zhalo_a.f90
Unescape Escape View File

@ -66,8 +66,9 @@ subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,&
& err, liwork,data_, ldx & err, liwork,data_, ldx
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:) complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, & integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
character :: tran_ character :: tran_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data)
endif endif
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

16
base/comm/psb_zovrl.f90
Unescape Escape View File

@ -75,9 +75,9 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -127,7 +127,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -200,9 +200,9 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & nrow, imode, err, liwork,data_, update_, mode_, ncol
& mode_, err, liwork,ldx integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -252,7 +252,7 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

13
base/comm/psb_zovrl_a.f90
Unescape Escape View File

@ -77,8 +77,9 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,&
& mode_, err, liwork, ldx & mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:) complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -137,7 +138,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'
@ -271,9 +272,9 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
integer(psb_ipk_), intent(in), optional :: update,mode integer(psb_ipk_), intent(in), optional :: update,mode
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, & integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& & k, update_, mode_, err, liwork, ldx
& mode_, err, liwork, ldx integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:) complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap logical :: do_swap
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0) do_swap = (mode_ /= 0)
ldx = size(x,1) ldx = size(x,1)
! check vector correctness ! check vector correctness
call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_chkvect' ch_err='psb_chkvect'

20
base/comm/psb_zscatter_a.F90
Unescape Escape View File

@ -63,11 +63,13 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, &
& col,pos & col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
complex(psb_dpk_),allocatable :: scatterv(:) complex(psb_dpk_),allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_scatterm' name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k do col=1, k
! prepare vector to scatter ! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root)
! locals ! locals
integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& integer(psb_ipk_) :: ierr(5), err_act, idx, nrow,&
& ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
complex(psb_dpk_), allocatable :: scatterv(:) complex(psb_dpk_), allocatable :: scatterv(:)
integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) integer(psb_ipk_), allocatable :: displ(:), all_dim(:)
integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root)
end if end if
call mpi_gatherv(ltg,nrow,& call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,& & psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info) & displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter ! prepare vector to scatter
if (iam == iroot) then if (iam == iroot) then

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

@ -51,6 +51,7 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
logical, intent(in), optional :: keepnum,keeploc logical, intent(in), optional :: keepnum,keeploc
type(psb_z_coo_sparse_mat) :: loc_coo, glob_coo type(psb_z_coo_sparse_mat) :: loc_coo, glob_coo
integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:)
integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg
integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl
logical :: keepnum_, keeploc_ logical :: keepnum_, keeploc_
@ -101,14 +102,19 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
call loca%mv_to(loc_coo) call loca%mv_to(loc_coo)
end if end if
nzl = loc_coo%get_nzeros() nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locia,info)
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') call psb_realloc(nzl,locja,info)
call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I')
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = nzl nzbr(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzg = sum(nzbr) nzg = sum(nzbr)
if (info == psb_success_) call psb_realloc(nzg,glbia,info)
if (info == psb_success_) call psb_realloc(nzg,glbja,info)
if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -117,24 +123,33 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,& & glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo) & psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glob_coo%ia,nzbr,idisp,& & glbia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call & if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,& & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glob_coo%ja,nzbr,idisp,& & glbja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo) & psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info = minfo info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999 goto 9999
end if end if
call loc_coo%free() call loc_coo%free()
deallocate(locia,locja, stat=info)
!
! Is the code below safe? For very large cases
! the indices in glob_coo will overflow. But then,
! for very large cases it does not make sense to
! gather the matrix on a single procecss anyway...
!
glob_coo%ia(1:nzg) = glbia(1:nzg)
glob_coo%ja(1:nzg) = glbja(1:nzg)
call glob_coo%set_nzeros(nzg) call glob_coo%set_nzeros(nzg)
if (present(dupl)) call glob_coo%set_dupl(dupl) if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo) call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else else
write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_

2
base/internals/Makefile
Unescape Escape View File

@ -3,7 +3,7 @@ include ../../Make.inc
FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \
psi_crea_ovr_elem.o psi_bld_tmpovrl.o psi_dl_check.o \ psi_crea_ovr_elem.o psi_bld_tmpovrl.o psi_dl_check.o \
psi_bld_tmphalo.o psi_sort_dl.o \ psi_bld_tmphalo.o psi_sort_dl.o \
psi_desc_impl.o psi_exist_ovr_elem.o psi_list_search.o psi_srtlist.o psi_desc_impl.o psi_list_search.o psi_srtlist.o
MPFOBJS = psi_desc_index.o psi_extrct_dl.o \ MPFOBJS = psi_desc_index.o psi_extrct_dl.o \
psi_fnd_owner.o psb_indx_map_fnd_owner.o psi_fnd_owner.o psb_indx_map_fnd_owner.o

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

@ -60,19 +60,20 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
#ifdef MPI_H #ifdef MPI_H
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(in) :: idxmap class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), allocatable :: helem(:),hproc(:),& integer(psb_lpk_), allocatable :: answers(:,:), idxsrch(:,:), hproc(:)
& answers(:,:),idxsrch(:,:), hhidx(:) integer(psb_ipk_), allocatable :: helem(:), hhidx(:)
integer(psb_mpk_), allocatable :: hsz(:),hidx(:), & integer(psb_mpk_), allocatable :: hsz(:),hidx(:), &
& sdsz(:),sdidx(:), rvsz(:), rvidx(:) & sdsz(:),sdidx(:), rvsz(:), rvidx(:)
integer(psb_mpk_) :: icomm, minfo, iictxt integer(psb_mpk_) :: icomm, minfo, iictxt
integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,hsize,ip,isz,k,j,& integer(psb_ipk_) :: i,n_row,n_col,err_act,hsize,ip,isz,j, k,&
& last_ih, last_j, nv, mglob & last_ih, last_j, nv
integer(psb_lpk_) :: mglob, ih
integer(psb_ipk_) :: ictxt,np,me, nresp integer(psb_ipk_) :: ictxt,np,me, nresp
logical, parameter :: gettime=.false. logical, parameter :: gettime=.false.
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
@ -169,8 +170,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
t3 = psb_wtime() t3 = psb_wtime()
end if end if
call mpi_allgatherv(idx,hsz(me+1),psb_mpi_ipk_,& call mpi_allgatherv(idx,hsz(me+1),psb_mpi_lpk_,&
& hproc,hsz,hidx,psb_mpi_ipk_,& & hproc,hsz,hidx,psb_mpi_lpk_,&
& icomm,minfo) & icomm,minfo)
if (gettime) then if (gettime) then
tamx = psb_wtime() - t3 tamx = psb_wtime() - t3
@ -228,8 +229,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
rvidx(ip) = j rvidx(ip) = j
j = j + rvsz(ip) j = j + rvsz(ip)
end do end do
call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_,& call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_lpk_,&
& answers(:,1),rvsz,rvidx,psb_mpi_ipk_,& & answers(:,1),rvsz,rvidx,psb_mpi_lpk_,&
& icomm,minfo) & icomm,minfo)
if (gettime) then if (gettime) then
tamx = psb_wtime() - t3 + tamx tamx = psb_wtime() - t3 + tamx
@ -266,7 +267,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, & write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, &
& 'not found : ',size(answers,1),':',answers(:,1) & 'not found : ',size(answers,1),':',answers(:,1)
info = psb_err_internal_error_ info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') call psb_errpush(psb_err_internal_error_,&
& name,a_err='out bounds srch ih')
goto 9999 goto 9999
end if end if
end if end if

3
base/internals/psi_bld_tmphalo.f90
Unescape Escape View File

@ -56,7 +56,8 @@ subroutine psi_bld_tmphalo(desc,info)
type(psb_desc_type), intent(inout) :: desc type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),allocatable :: helem(:),hproc(:) integer(psb_lpk_),allocatable :: helem(:)
integer(psb_ipk_),allocatable :: hproc(:)
integer(psb_ipk_),allocatable :: tmphl(:) integer(psb_ipk_),allocatable :: tmphl(:)
integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,& integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,&

3
base/internals/psi_bld_tmpovrl.f90
Unescape Escape View File

@ -65,7 +65,8 @@ subroutine psi_i_bld_tmpovrl(iv,desc,info)
!locals !locals
integer(psb_ipk_) :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,& integer(psb_ipk_) :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,&
& l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, icomm & l_ov_ix,l_ov_el, err_act, itmpov, k, glx, icomm
integer(psb_ipk_) :: idx
integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:) integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:)
integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level

25
base/internals/psi_crea_bnd_elem.f90
Unescape Escape View File

@ -85,28 +85,19 @@ subroutine psi_i_crea_bnd_elem(bndel,desc_a,info)
call psb_msort_unique(work(1:i),j) call psb_msort_unique(work(1:i),j)
if (.true.) then
if (j>=0) then if (j>=0) then
call psb_realloc(j,bndel,info) call psb_realloc(j,bndel,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
bndel(1:j) = work(1:j)
else
if (allocated(bndel)) then
deallocate(bndel)
end if
end if
else
call psb_realloc(j+1,bndel,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
bndel(1:j) = work(1:j) bndel(1:j) = work(1:j)
bndel(j+1) = -1 else
endif if (allocated(bndel)) then
deallocate(bndel)
end if
end if
deallocate(work) deallocate(work)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

6
base/internals/psi_crea_index.f90
Unescape Escape View File

@ -52,8 +52,7 @@
! nrcv - integer Total receive buffer size on the calling process ! nrcv - integer Total receive buffer size on the calling process
! !
! !
subroutine psi_i_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info) subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
use psb_realloc_mod use psb_realloc_mod
use psb_desc_mod use psb_desc_mod
use psb_error_mod use psb_error_mod
@ -65,7 +64,6 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,in
integer(psb_ipk_), intent(out) :: info,nxch,nsnd,nrcv integer(psb_ipk_), intent(out) :: info,nxch,nsnd,nrcv
integer(psb_ipk_), intent(in) :: index_in(:) integer(psb_ipk_), intent(in) :: index_in(:)
integer(psb_ipk_), allocatable, intent(inout) :: index_out(:) integer(psb_ipk_), allocatable, intent(inout) :: index_out(:)
logical :: glob_idx
! ....local scalars... ! ....local scalars...
integer(psb_ipk_) :: ictxt, me, np, mode, err_act, dl_lda integer(psb_ipk_) :: ictxt, me, np, mode, err_act, dl_lda
@ -135,7 +133,7 @@ subroutine psi_i_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,in
& write(debug_unit,*) me,' ',trim(name),': calling psi_desc_index' & write(debug_unit,*) me,' ',trim(name),': calling psi_desc_index'
! Do the actual format conversion. ! Do the actual format conversion.
call psi_desc_index(desc_a,index_in,dep_list(1:,me),& call psi_desc_index(desc_a,index_in,dep_list(1:,me),&
& length_dl(me),nsnd,nrcv, index_out,glob_idx,info) & length_dl(me),nsnd,nrcv, index_out,info)
if(debug_level >= psb_debug_inner_) & if(debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': out of psi_desc_index',& & write(debug_unit,*) me,' ',trim(name),': out of psi_desc_index',&
& size(index_out) & size(index_out)

4
base/internals/psi_crea_ovr_elem.f90
Unescape Escape View File

@ -61,10 +61,6 @@ subroutine psi_i_crea_ovr_elem(me,desc_overlap,ovr_elem,info)
integer(psb_ipk_) :: dim_ovr_elem integer(psb_ipk_) :: dim_ovr_elem
integer(psb_ipk_) :: pairtree(2) integer(psb_ipk_) :: pairtree(2)
! ...external function...
integer(psb_ipk_) :: psi_exist_ovr_elem
external :: psi_exist_ovr_elem
integer(psb_ipk_) :: nel, ip, ix, iel, insize, err_act, iproc integer(psb_ipk_) :: nel, ip, ix, iel, insize, err_act, iproc
integer(psb_ipk_), allocatable :: telem(:,:) integer(psb_ipk_), allocatable :: telem(:,:)

12
base/internals/psi_desc_impl.f90
Unescape Escape View File

@ -67,9 +67,9 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
implicit none implicit none
! ....scalars parameters.... ! ....scalars parameters....
integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:)
type(psb_desc_type), intent(inout) :: cdesc type(psb_desc_type), intent(inout) :: cdesc
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), optional, intent(in) :: mold class(psb_i_base_vect_type), optional, intent(in) :: mold
! ....local scalars.... ! ....local scalars....
@ -102,7 +102,7 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
! first the halo index ! first the halo index
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',& if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',&
& size(halo_in) & size(halo_in)
call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) call psi_crea_index(cdesc,halo_in, idx_out,nxch,nsnd,nrcv,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index') call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999 goto 9999
@ -115,7 +115,7 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
! then ext index ! then ext index
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info) call psi_crea_index(cdesc,ext_in, idx_out,nxch,nsnd,nrcv,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index') call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999 goto 9999
@ -126,7 +126,7 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap'
! then the overlap index ! then the overlap index
call psi_crea_index(cdesc,ovrlap_in, idx_out,.true.,nxch,nsnd,nrcv,info) call psi_crea_index(cdesc,ovrlap_in, idx_out,nxch,nsnd,nrcv,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index') call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999 goto 9999
@ -150,7 +150,7 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
if (debug_level>0) write(debug_unit,*) me,'Calling bld_ovr_mst' if (debug_level>0) write(debug_unit,*) me,'Calling bld_ovr_mst'
call psi_bld_ovr_mst(me,cdesc%ovrlap_elem,tmp_mst_idx,info) call psi_bld_ovr_mst(me,cdesc%ovrlap_elem,tmp_mst_idx,info)
if (info == psb_success_) call psi_crea_index(cdesc,& if (info == psb_success_) call psi_crea_index(cdesc,&
& tmp_mst_idx,idx_out,.false.,nxch,nsnd,nrcv,info) & tmp_mst_idx,idx_out,nxch,nsnd,nrcv,info)
if (debug_level>0) write(debug_unit,*) me,'Done crea_indx' if (debug_level>0) write(debug_unit,*) me,'Done crea_indx'
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_bld_ovr_mst') call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_bld_ovr_mst')

46
base/internals/psi_desc_index.F90
Unescape Escape View File

@ -42,12 +42,9 @@
! mapping parts are used. ! mapping parts are used.
! index_in(:) - integer The index list, build format ! index_in(:) - integer The index list, build format
! index_out(:) - integer(psb_ipk_), allocatable The index list, assembled format ! index_out(:) - integer(psb_ipk_), allocatable The index list, assembled format
! glob_idx - logical Whether the input indices are in local or global ! nxch - integer The number of data exchanges on the calling process
! numbering; the global numbering is used when ! nsnd - integer Total send buffer size on the calling process
! converting the overlap exchange lists. ! nrcv - integer Total receive buffer size on the calling process
! nxch - integer The number of data exchanges on the calling process
! nsnd - integer Total send buffer size on the calling process
! nrcv - integer Total receive buffer size on the calling process
! !
! The format of the index lists. Copied from base/modules/psb_desc_type ! The format of the index lists. Copied from base/modules/psb_desc_type
! !
@ -99,7 +96,7 @@
! !
! !
subroutine psi_i_desc_index(desc,index_in,dep_list,& subroutine psi_i_desc_index(desc,index_in,dep_list,&
& length_dl,nsnd,nrcv,desc_index,isglob_in,info) & length_dl,nsnd,nrcv,desc_index,info)
use psb_desc_mod use psb_desc_mod
use psb_realloc_mod use psb_realloc_mod
use psb_error_mod use psb_error_mod
@ -116,17 +113,17 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
! ...array parameters..... ! ...array parameters.....
type(psb_desc_type) :: desc type(psb_desc_type) :: desc
integer(psb_ipk_) :: index_in(:),dep_list(:) integer(psb_ipk_) :: index_in(:)
integer(psb_ipk_) :: dep_list(:)
integer(psb_ipk_),allocatable :: desc_index(:) integer(psb_ipk_),allocatable :: desc_index(:)
integer(psb_ipk_) :: length_dl,nsnd,nrcv,info integer(psb_ipk_) :: length_dl,nsnd,nrcv,info
logical :: isglob_in
! ....local scalars... ! ....local scalars...
integer(psb_ipk_) :: j,me,np,i,proc integer(psb_ipk_) :: j,me,np,i,proc
! ...parameters... ! ...parameters...
integer(psb_ipk_) :: ictxt integer(psb_ipk_) :: ictxt
integer(psb_ipk_), parameter :: no_comm=-1 integer(psb_ipk_), parameter :: no_comm=-1
! ...local arrays.. ! ...local arrays..
integer(psb_ipk_),allocatable :: sndbuf(:), rcvbuf(:) integer(psb_lpk_),allocatable :: sndbuf(:), rcvbuf(:)
integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:),& integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:),&
& bsdindx(:),sdsz(:) & bsdindx(:),sdsz(:)
@ -255,22 +252,15 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
! !
! note that here bsdinx is zero-based, hence the following loop ! note that here bsdinx is zero-based, hence the following loop
! !
if (isglob_in) then call desc%indxmap%l2g(index_in(i+1:i+nerv),&
do j=1, nerv & sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),&
sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) & info)
end do
else if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g')
call desc%indxmap%l2g(index_in(i+1:i+nerv),& goto 9999
& sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& end if
& info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g')
goto 9999
end if
endif
bsdindx(proc+1) = bsdindx(proc+1) + nerv bsdindx(proc+1) = bsdindx(proc+1) + nerv
i = i + nerv + 1 i = i + nerv + 1
end do end do
@ -292,8 +282,8 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
idxr = idxr + rvsz(proc+1) idxr = idxr + rvsz(proc+1)
end do end do
call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_ipk_,& call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_lpk_,&
& rcvbuf,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) & rcvbuf,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv') call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv')
goto 9999 goto 9999

73
base/internals/psi_exist_ovr_elem.f90
Unescape Escape View File

@ -1,73 +0,0 @@
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006, 2010, 2015, 2017
! Salvatore Filippone
! Alfredo Buttari CNRS-IRIT, Toulouse
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
! 1. Redistributions of source code must retain the above copyright
! notice, this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions, and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
integer function psi_exist_ovr_elem(ovr_elem, dim_list,elem_searched)
use psb_const_mod
! PURPOSE:
! == = ====
!
! If ELEM_SEARCHED exist in the list OVR_ELEM returns its position in
! the list, else returns -1
!
!
! INPUT
! == = ===
! OVRLAP_ELEMENT_D.: Contains for all overlap points belonging to
! the current process:
! 1. overlap point index
! 2. Number of domains sharing that overlap point
! the end is marked by a -1...............................
!
! DIM_LIST..........: Dimension of list OVRLAP_ELEMENT_D
!
! ELEM_SEARCHED.....:point's Local index identifier to be searched.
implicit none
! ....Scalars parameters....
integer(psb_ipk_) :: dim_list,elem_searched
! ...array parameters....
integer(psb_ipk_) :: ovr_elem(dim_list,*)
! ...local scalars....
integer(psb_ipk_) :: i
i=1
do while ((i.le.dim_list).and.(ovr_elem(i,1).ne.elem_searched))
i=i+1
enddo
if ((i.le.dim_list).and.(ovr_elem(i,1).eq.elem_searched)) then
psi_exist_ovr_elem=i
else
psi_exist_ovr_elem=-1
endif
end function psi_exist_ovr_elem

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

@ -136,7 +136,8 @@ subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,&
integer(psb_ipk_) :: np,dl_lda,mode, info integer(psb_ipk_) :: np,dl_lda,mode, info
! ....array parameters.... ! ....array parameters....
integer(psb_ipk_) :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) integer(psb_ipk_) :: desc_str(*)
integer(psb_ipk_) :: dep_list(dl_lda,0:np),length_dl(0:np)
integer(psb_ipk_), allocatable :: itmp(:) integer(psb_ipk_), allocatable :: itmp(:)
! .....local arrays.... ! .....local arrays....
integer(psb_ipk_) :: int_err(5) integer(psb_ipk_) :: int_err(5)

2
base/internals/psi_fnd_owner.F90
Unescape Escape View File

@ -63,7 +63,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
include 'mpif.h' include 'mpif.h'
#endif #endif
integer(psb_ipk_), intent(in) :: nv integer(psb_ipk_), intent(in) :: nv
integer(psb_ipk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
type(psb_desc_type), intent(in) :: desc type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info

8
base/modules/Makefile
Unescape Escape View File

@ -125,7 +125,7 @@ psb_realloc_mod.o \
auxil/psb_z_realloc_mod.o: psb_error_mod.o auxil/psb_z_realloc_mod.o: psb_error_mod.o
$(UTIL_MODS): $(BASIC_MODS) $(UTIL_MODS): $(BASIC_MODS)
penv/psi_penv_mod.o: penv/psi_comm_buffers_mod.o penv/psi_penv_mod.o: penv/psi_comm_buffers_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o
penv/psi_collective_mod.o penv/psi_p2p_mod.o: penv/psi_penv_mod.o penv/psi_collective_mod.o penv/psi_p2p_mod.o: penv/psi_penv_mod.o
psb_realloc_mod.o: auxil/psb_m_realloc_mod.o \ psb_realloc_mod.o: auxil/psb_m_realloc_mod.o \
@ -213,7 +213,7 @@ serial/psb_z_csc_mat_mod.o serial/psb_z_csr_mat_mod.o: serial/psb_z_base_mat_mod
serial/psb_mat_mod.o: serial/psb_vect_mod.o serial/psb_s_mat_mod.o serial/psb_d_mat_mod.o serial/psb_c_mat_mod.o serial/psb_z_mat_mod.o serial/psb_mat_mod.o: serial/psb_vect_mod.o serial/psb_s_mat_mod.o serial/psb_d_mat_mod.o serial/psb_c_mat_mod.o serial/psb_z_mat_mod.o
serial/psb_serial_mod.o: serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o serial/psb_serial_mod.o: serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o
serial/psb_i_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_i_vect_mod.o: serial/psb_i_base_vect_mod.o
serial/psb_l_vect_mod.o: serial/psb_l_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_l_vect_mod.o: serial/psb_l_base_vect_mod.o serial/psb_i_vect_mod.o
serial/psb_s_vect_mod.o: serial/psb_s_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_s_vect_mod.o: serial/psb_s_base_vect_mod.o serial/psb_i_vect_mod.o
serial/psb_d_vect_mod.o: serial/psb_d_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_d_vect_mod.o: serial/psb_d_base_vect_mod.o serial/psb_i_vect_mod.o
serial/psb_c_vect_mod.o: serial/psb_c_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_c_vect_mod.o: serial/psb_c_base_vect_mod.o serial/psb_i_vect_mod.o
@ -245,7 +245,7 @@ psi_z_mod.o: desc/psb_desc_mod.o serial/psb_z_vect_mod.o comm/psi_z_comm_a_mod.o
psi_mod.o: psb_penv_mod.o desc/psb_desc_mod.o auxil/psi_serial_mod.o serial/psb_serial_mod.o\ psi_mod.o: psb_penv_mod.o desc/psb_desc_mod.o auxil/psi_serial_mod.o serial/psb_serial_mod.o\
psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o
desc/psb_indx_map_mod.o: desc/psb_desc_const_mod.o psb_error_mod.o psb_penv_mod.o desc/psb_indx_map_mod.o: desc/psb_desc_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o
desc/psb_hash_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o desc/psb_gen_block_map_mod.o:\ desc/psb_hash_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o desc/psb_gen_block_map_mod.o:\
desc/psb_indx_map_mod.o desc/psb_desc_const_mod.o \ desc/psb_indx_map_mod.o desc/psb_desc_const_mod.o \
auxil/psb_sort_mod.o psb_penv_mod.o auxil/psb_sort_mod.o psb_penv_mod.o
@ -326,7 +326,7 @@ psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o psblas/psb_d_psblas_mod.o ps
psb_base_mod.o: $(MODULES) psb_base_mod.o: $(MODULES)
penv/psi_penv_mod.o: penv/psi_penv_mod.F90 $(BASIC_MODS) penv/psi_penv_mod.o: penv/psi_penv_mod.F90 $(BASIC_MODS) serial/psb_vect_mod.o serial/psb_mat_mod.o
$(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@
psb_penv_mod.o: psb_penv_mod.F90 $(COMMINT) $(BASIC_MODS) psb_penv_mod.o: psb_penv_mod.F90 $(COMMINT) $(BASIC_MODS)

78
base/modules/README.F2003
Unescape Escape View File

@ -98,6 +98,82 @@ Design principles for this directory.
AND IT'S DONE! Nothing else in the library requires the explicit AND IT'S DONE! Nothing else in the library requires the explicit
knowledge of type of MOLD. knowledge of type of MOLD.
3. Data precisoin (aka KIND / aka byte size)
Data precision is a bit of a thorny issue here, because it is used
by the Fortran language to disambiguate generic interfaces. This
means that we must be careful when choosing precision for data
structures. On the other hand, we want to have some freedom of
choice. The sticky point here is how to deal with integers, because
real and complex are already standardized on S/D/C/Z.
Integers are tricky because we do not want to use large integer
sizes (read: 8 bytes) unless they are really necessary; moreover,
the GPU code currently use 4 byte integers (and with good
reason). However if we want to tackle large index spaces, we will
need at some point 8-byte integers.
So, here is the plan.
A. We have two basic integer kinds, 4-byte PSB_MPK_ which takes its
name from being the kind that is going to be passed to MPI for
all arguments other than data buffers, and 8-byte PSB_EPK_, to
be used as necessary; the PSB_SIZEOF functions which return
data structure sizes (sometimes summed over all processes) are
always 8-byte.
B. At all levels where a function/subroutine is supposed to be
interfaced with an array of integers, there should be two
versions, distinguished by an M or an E in the specific name,
all adding to a generic set. This applies to the internal
utilities, such as sorting and reallocation.
C. For computation we have I and L, as in psb_ipk_ and
psb_lpk_. The idea is that I<=L, and I is used for almost
everything, e.g. for the integer parts of the sparse matrix data
structures. L is only used for a very small subset of data, and
specifically for the indices in *GLOBAL* numbering mode, hence
the I<=L constraint.
D. The values for I and L can be remapped independently at
configure time over M and E; thus, if a sparse matrix routine is
reallocating integer data through the generic names of the
utilities, the PSB_IPK_ is remapped at compile time onto
PSB_MPK_ or PSB_EPK_ as needed.
E. Because we must have I<=L, this means that supported
configurations are (I=4,L=4), (I=4,L=8), (I=8,L=8). Default
is (I=4,L=8), because it allows us to go to multi-billion linear
systems while still keeping all local data structures on 4-byte
integers.
F. Thus, care must be taken in defining specific interfaces: to
reiterate, if we are dealing with an interface which accepts an
integer array, it should be defined with M and E (which are
always distinct) and not I/L (which might be
indistinguishable). Example in case:
interface psb_realloc
Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb)
integer(psb_mpk_),Intent(in) :: len
integer(psb_mpk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info
integer(psb_mpk_), optional, intent(in) :: pad
integer(psb_mpk_), optional, intent(in) :: lb
G. The INFO argument and others related to error handling should
always be PSB_IPK_;
H. Arguments related to MPI interfacing should always be PSB_MPK_
I. Encapsulated types such as psb_i_base_vect_mod can still be I
and L, because if the name of the type is different, the types
are interpreted as distinguishable even when the contents are
identical.
L. This means that most user-level interfaces will deal in I and L,
not M and E, which are going to be used mostly in the
internals.
M. Actually, the user will probably never see M, but will (for
sizeof & friends) see E.

2
base/modules/auxil/psb_c_sort_mod.f90
Unescape Escape View File

@ -44,6 +44,8 @@ module psb_c_sort_mod
use psb_const_mod use psb_const_mod
@INTE@
interface psb_msort_unique interface psb_msort_unique
subroutine psb_cmsort_u(x,nout,dir) subroutine psb_cmsort_u(x,nout,dir)
import import

2
base/modules/auxil/psb_d_sort_mod.f90
Unescape Escape View File

@ -44,6 +44,8 @@ module psb_d_sort_mod
use psb_const_mod use psb_const_mod
@INTE@
interface psb_msort_unique interface psb_msort_unique
subroutine psb_dmsort_u(x,nout,dir) subroutine psb_dmsort_u(x,nout,dir)
import import

44
base/modules/auxil/psb_hash_mod.f90
Unescape Escape View File

@ -83,6 +83,10 @@ module psb_hash_mod
module procedure psb_hash_searchinskey, psb_hash_lsearchinskey module procedure psb_hash_searchinskey, psb_hash_lsearchinskey
end interface psb_hash_searchinskey end interface psb_hash_searchinskey
interface psb_hash_searchkey
module procedure psb_hash_searchkey, psb_hash_lsearchkey
end interface psb_hash_searchkey
interface psb_move_alloc interface psb_move_alloc
module procedure HashTransfer module procedure HashTransfer
end interface end interface
@ -535,4 +539,44 @@ contains
end do end do
end subroutine psb_hash_searchkey end subroutine psb_hash_searchkey
subroutine psb_hash_lsearchkey(key,val,hash,info)
integer(psb_lpk_), intent(in) :: key
type(psb_hash_type) :: hash
integer(psb_lpk_), intent(out) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: hsize,hmask, hk, hd
info = HashOK
if (.not.allocated(hash%table) ) then
val = HashFreeEntry
return
end if
hsize = hash%hsize
hmask = hash%hmask
hk = iand(hashval(key),hmask)
if (hk == 0) then
hd = 1
else
hd = hsize - hk
hd = ior(hd,1)
end if
hash%nsrch = hash%nsrch + 1
do
hash%nacc = hash%nacc + 1
if (hash%table(hk,1) == key) then
val = hash%table(hk,2)
return
end if
if (hash%table(hk,1) == HashFreeEntry) then
val = HashFreeEntry
! !$ info = HashNotFound
return
end if
hk = hk - hd
if (hk < 0) hk = hk + hsize
end do
end subroutine psb_hash_lsearchkey
end module psb_hash_mod end module psb_hash_mod

1
base/modules/auxil/psb_i_sort_mod.f90
Unescape Escape View File

@ -51,6 +51,7 @@ module psb_i_sort_mod
end function psb_iisaperm end function psb_iisaperm
end interface psb_isaperm end interface psb_isaperm
interface psb_msort_unique interface psb_msort_unique
subroutine psb_imsort_u(x,nout,dir) subroutine psb_imsort_u(x,nout,dir)
import import

1
base/modules/auxil/psb_l_sort_mod.f90
Unescape Escape View File

@ -51,6 +51,7 @@ module psb_l_sort_mod
end function psb_lisaperm end function psb_lisaperm
end interface psb_isaperm end interface psb_isaperm
interface psb_msort_unique interface psb_msort_unique
subroutine psb_lmsort_u(x,nout,dir) subroutine psb_lmsort_u(x,nout,dir)
import import

2
base/modules/auxil/psb_s_sort_mod.f90
Unescape Escape View File

@ -44,6 +44,8 @@ module psb_s_sort_mod
use psb_const_mod use psb_const_mod
@INTE@
interface psb_msort_unique interface psb_msort_unique
subroutine psb_smsort_u(x,nout,dir) subroutine psb_smsort_u(x,nout,dir)
import import

2
base/modules/auxil/psb_z_sort_mod.f90
Unescape Escape View File

@ -44,6 +44,8 @@ module psb_z_sort_mod
use psb_const_mod use psb_const_mod
@INTE@
interface psb_msort_unique interface psb_msort_unique
subroutine psb_zmsort_u(x,nout,dir) subroutine psb_zmsort_u(x,nout,dir)
import import

7
base/modules/desc/psb_desc_const_mod.f90
Unescape Escape View File

@ -35,7 +35,7 @@
! Auxiliary module for descriptor: constant values. ! Auxiliary module for descriptor: constant values.
! !
module psb_desc_const_mod module psb_desc_const_mod
use psb_const_mod, only : psb_ipk_, psb_mpk_ use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_
! !
! Communication, prolongation & restriction ! Communication, prolongation & restriction
! !
@ -121,8 +121,9 @@ module psb_desc_const_mod
interface interface
subroutine psb_parts(glob_index,nrow,np,pv,nv) subroutine psb_parts(glob_index,nrow,np,pv,nv)
import :: psb_ipk_ import :: psb_ipk_, psb_lpk_
integer(psb_ipk_), intent (in) :: glob_index,nrow, np integer(psb_lpk_), intent (in) :: glob_index,nrow
integer(psb_ipk_), intent (in) :: np
integer(psb_ipk_), intent (out) :: nv, pv(*) integer(psb_ipk_), intent (out) :: nv, pv(*)
end subroutine psb_parts end subroutine psb_parts
end interface end interface

196
base/modules/desc/psb_desc_mod.F90
Unescape Escape View File

@ -142,9 +142,9 @@ module psb_desc_mod
! psb_ovrl subroutine. ! psb_ovrl subroutine.
! !
! 8. When the descriptor is in the BLD state the INDEX vectors contains only ! 8. When the descriptor is in the BLD state the INDEX vectors contains only
! the indices to be received, organized as a sequence ! the indices to be received, organized as a sequence of entries of
! of entries of the form (proc,N,(lx1,lx2,...,lxn)) with owning process, ! the form (proc,N,(lx1,lx2,...,lxn)) with owning process, number of indices
! number of indices (most often but not necessarily N=1), list of local indices. ! (most often but not necessarily N=1), list of local indices.
! This is because we only know the list of halo indices to be received ! This is because we only know the list of halo indices to be received
! as we go about building the sparse matrix pattern, and we want the build ! as we go about building the sparse matrix pattern, and we want the build
! phase to be loosely synchronized. Thus we record the indices we have to ask ! phase to be loosely synchronized. Thus we record the indices we have to ask
@ -334,11 +334,13 @@ contains
val = cd_large_threshold val = cd_large_threshold
end function psb_cd_get_large_threshold end function psb_cd_get_large_threshold
logical function psb_cd_choose_large_state(ictxt,m) function psb_cd_choose_large_state(ictxt,m) result(val)
use psb_penv_mod use psb_penv_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: ictxt,m integer(psb_ipk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: m
logical :: val
!locals !locals
integer(psb_ipk_) :: np,me integer(psb_ipk_) :: np,me
@ -348,8 +350,7 @@ contains
! it makes no sense to use them if you don't have at least ! it makes no sense to use them if you don't have at least
! 3 processes, no matter what the size of the process. ! 3 processes, no matter what the size of the process.
! !
psb_cd_choose_large_state = & val = (m > psb_cd_get_large_threshold()) .and. &
& (m > psb_cd_get_large_threshold()) .and. &
& (np > 2) & (np > 2)
end function psb_cd_choose_large_state end function psb_cd_choose_large_state
@ -475,7 +476,7 @@ contains
function psb_cd_get_global_rows(desc) result(val) function psb_cd_get_global_rows(desc) result(val)
implicit none implicit none
integer(psb_ipk_) :: val integer(psb_lpk_) :: val
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
@ -488,7 +489,7 @@ contains
function psb_cd_get_global_cols(desc) result(val) function psb_cd_get_global_cols(desc) result(val)
implicit none implicit none
integer(psb_ipk_) :: val integer(psb_lpk_) :: val
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
@ -501,7 +502,7 @@ contains
function psb_cd_get_global_indices(desc,owned) result(val) function psb_cd_get_global_indices(desc,owned) result(val)
implicit none implicit none
integer(psb_ipk_), allocatable :: val(:) integer(psb_lpk_), allocatable :: val(:)
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -1072,8 +1073,7 @@ contains
end subroutine psb_cd_clone end subroutine psb_cd_clone
Subroutine psb_cd_get_recv_idx(tmp,desc,data,info,toglob) Subroutine psb_cd_get_recv_idx(tmp,desc,data,info)
use psb_error_mod use psb_error_mod
use psb_penv_mod use psb_penv_mod
use psb_realloc_mod use psb_realloc_mod
@ -1082,12 +1082,11 @@ contains
integer(psb_ipk_), intent(in) :: data integer(psb_ipk_), intent(in) :: data
Type(psb_desc_type), Intent(in), target :: desc Type(psb_desc_type), Intent(in), target :: desc
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in) :: toglob
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,& integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,&
& idx, gidx, proc, n_elem_send, n_elem_recv & idx, proc, n_elem_send, n_elem_recv
integer(psb_ipk_), pointer :: idxlist(:) integer(psb_ipk_), pointer :: idxlist(:)
integer(psb_ipk_) :: debug_level, debug_unit, err_act integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name character(len=20) :: name
@ -1135,29 +1134,16 @@ contains
Do j=0,n_elem_recv-1 Do j=0,n_elem_recv-1
idx = idxlist(incnt+psb_elem_recv_+j) idx = idxlist(incnt+psb_elem_recv_+j)
call psb_ensure_size((outcnt+3),tmp,info,pad=-ione) call psb_ensure_size((outcnt+3),tmp,info,pad=-1_psb_ipk_)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size') call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999 goto 9999
end if end if
if (toglob) then tmp(outcnt) = proc
call desc%indxmap%l2g(idx,gidx,info) tmp(outcnt+1) = 1
If (gidx < 0) then tmp(outcnt+2) = idx
info=-3 tmp(outcnt+3) = -1
call psb_errpush(info,name)
goto 9999
endif
tmp(outcnt) = proc
tmp(outcnt+1) = 1
tmp(outcnt+2) = gidx
tmp(outcnt+3) = -1
else
tmp(outcnt) = proc
tmp(outcnt+1) = 1
tmp(outcnt+2) = idx
tmp(outcnt+3) = -1
end if
outcnt = outcnt+3 outcnt = outcnt+3
end Do end Do
incnt = incnt+n_elem_recv+n_elem_send+3 incnt = incnt+n_elem_recv+n_elem_send+3
@ -1171,6 +1157,100 @@ contains
return return
end Subroutine psb_cd_get_recv_idx end Subroutine psb_cd_get_recv_idx
Subroutine psb_cd_get_recv_idx_glob(tmp,desc,data,info)
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
Implicit None
integer(psb_lpk_), allocatable, intent(out) :: tmp(:)
integer(psb_ipk_), intent(in) :: data
Type(psb_desc_type), Intent(in), target :: desc
integer(psb_ipk_), intent(out) :: info
! .. Local Scalars ..
integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,&
& idx, proc, n_elem_send, n_elem_recv
integer(psb_ipk_), pointer :: idxlist(:)
integer(psb_lpk_) :: gidx
integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name
name = 'psb_cd_get_recv_idx'
info = psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc)
call psb_info(ictxt, me, np)
select case(data)
case(psb_comm_halo_)
idxlist => desc%halo_index
case(psb_comm_ovr_)
idxlist => desc%ovrlap_index
case(psb_comm_ext_)
idxlist => desc%ext_index
case(psb_comm_mov_)
idxlist => desc%ovr_mst_idx
write(psb_err_unit,*) 'Warning: unusual request getidx on ovr_mst_idx'
case default
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='wrong Data selector')
goto 9999
end select
l_tmp = 3*size(idxlist)
allocate(tmp(l_tmp),stat=info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
incnt = 1
outcnt = 1
tmp(:) = -1
Do While (idxlist(incnt) /= -1)
proc = idxlist(incnt+psb_proc_id_)
n_elem_recv = idxlist(incnt+psb_n_elem_recv_)
n_elem_send = idxlist(incnt+n_elem_recv+psb_n_elem_send_)
Do j=0,n_elem_recv-1
idx = idxlist(incnt+psb_elem_recv_+j)
call psb_ensure_size((outcnt+3),tmp,info,pad=-1_psb_lpk_)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
call desc%indxmap%l2g(idx,gidx,info)
If (gidx < 0) then
info=-3
call psb_errpush(info,name)
goto 9999
endif
tmp(outcnt) = proc
tmp(outcnt+1) = 1
tmp(outcnt+2) = gidx
tmp(outcnt+3) = -1
outcnt = outcnt+3
end Do
incnt = incnt+n_elem_recv+n_elem_send+3
end Do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end Subroutine psb_cd_get_recv_idx_glob
subroutine psb_cd_cnv(desc, mold) subroutine psb_cd_cnv(desc, mold)
class(psb_desc_type), intent(inout), target :: desc class(psb_desc_type), intent(inout), target :: desc
@ -1188,7 +1268,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -1199,7 +1279,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%l2gs1(idx,info,mask=mask,owned=owned) call desc%indxmap%l2gip(idx,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1223,7 +1303,7 @@ contains
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -1236,7 +1316,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%l2gs2(idxin,idxout,info,mask=mask,owned=owned) call desc%indxmap%l2g(idxin,idxout,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1259,7 +1339,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -1271,7 +1351,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%l2gv1(idx,info,mask=mask,owned=owned) call desc%indxmap%l2gip(idx,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1294,7 +1374,7 @@ contains
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -1306,7 +1386,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%l2gv2(idxin,idxout,info,mask=mask,owned=owned) call desc%indxmap%l2g(idxin,idxout,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1329,7 +1409,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -1341,7 +1421,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls1(idx,info,mask=mask,owned=owned) call desc%indxmap%g2lip(idx,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1363,7 +1443,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
@ -1377,7 +1457,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls2(idxin,idxout,info,mask=mask,owned=owned) call desc%indxmap%g2l(idxin,idxout,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1400,7 +1480,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -1412,7 +1492,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv1(idx,info,mask=mask,owned=owned) call desc%indxmap%g2lip(idx,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1434,7 +1514,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
@ -1449,7 +1529,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv2(idxin,idxout,info,mask=mask,owned=owned) call desc%indxmap%g2l(idxin,idxout,info,mask=mask,owned=owned)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1473,7 +1553,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(inout) :: desc class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_), intent(in), optional :: lidx
@ -1485,7 +1565,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls1_ins(idx,info,mask=mask,lidx=lidx) call desc%indxmap%g2lip_ins(idx,info,mask=mask,lidx=lidx)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1507,7 +1587,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(inout) :: desc class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
@ -1522,7 +1602,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2ls2_ins(idxin,idxout,info,mask=mask,lidx=lidx) call desc%indxmap%g2l_ins(idxin,idxout,info,mask=mask,lidx=lidx)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1545,7 +1625,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(inout) :: desc class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_), intent(in), optional :: lidx(:)
@ -1559,7 +1639,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv1_ins(idx,info,mask=mask,lidx=lidx) call desc%indxmap%g2lip_ins(idx,info,mask=mask,lidx=lidx)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1581,7 +1661,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_desc_type), intent(inout) :: desc class(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
@ -1596,7 +1676,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(desc%indxmap)) then if (allocated(desc%indxmap)) then
call desc%indxmap%g2lv2_ins(idxin,idxout,info,mask=mask,lidx=lidx) call desc%indxmap%g2l_ins(idxin,idxout,info,mask=mask,lidx=lidx)
else else
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
end if end if
@ -1618,7 +1698,7 @@ contains
subroutine cd_fnd_owner(idx,iprc,desc,info) subroutine cd_fnd_owner(idx,iprc,desc,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_desc_type), intent(in) :: desc class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info

1973
base/modules/desc/psb_gen_block_map_mod.f90
View File

File diff suppressed because it is too large Load Diff

4
base/modules/desc/psb_glist_map_mod.f90
Unescape Escape View File

@ -153,12 +153,12 @@ contains
use psb_penv_mod use psb_penv_mod
use psb_sort_mod use psb_sort_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_glist_map), intent(in) :: idxmap class(psb_glist_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: ictxt, iam, np integer(psb_mpk_) :: ictxt, iam, np
integer(psb_ipk_) :: nv, i, ngp integer(psb_lpk_) :: nv, i, ngp
ictxt = idxmap%get_ctxt() ictxt = idxmap%get_ctxt()
call psb_info(ictxt,iam,np) call psb_info(ictxt,iam,np)

202
base/modules/desc/psb_hash_map_mod.f90
Unescape Escape View File

@ -61,7 +61,8 @@ module psb_hash_map_mod
type, extends(psb_indx_map) :: psb_hash_map type, extends(psb_indx_map) :: psb_hash_map
integer(psb_ipk_) :: hashvsize, hashvmask integer(psb_ipk_) :: hashvsize, hashvmask
integer(psb_ipk_), allocatable :: hashv(:), glb_lc(:,:), loc_to_glob(:) integer(psb_ipk_), allocatable :: hashv(:)
integer(psb_lpk_), allocatable :: glb_lc(:,:), loc_to_glob(:)
type(psb_hash_type) :: hash type(psb_hash_type) :: hash
contains contains
@ -78,20 +79,20 @@ module psb_hash_map_mod
procedure, nopass :: row_extendable => hash_row_extendable procedure, nopass :: row_extendable => hash_row_extendable
procedure, pass(idxmap) :: l2gs1 => hash_l2gs1 procedure, pass(idxmap) :: ll2gs1 => hash_l2gs1
procedure, pass(idxmap) :: l2gs2 => hash_l2gs2 procedure, pass(idxmap) :: ll2gs2 => hash_l2gs2
procedure, pass(idxmap) :: l2gv1 => hash_l2gv1 procedure, pass(idxmap) :: ll2gv1 => hash_l2gv1
procedure, pass(idxmap) :: l2gv2 => hash_l2gv2 procedure, pass(idxmap) :: ll2gv2 => hash_l2gv2
procedure, pass(idxmap) :: g2ls1 => hash_g2ls1 procedure, pass(idxmap) :: lg2ls1 => hash_g2ls1
procedure, pass(idxmap) :: g2ls2 => hash_g2ls2 procedure, pass(idxmap) :: lg2ls2 => hash_g2ls2
procedure, pass(idxmap) :: g2lv1 => hash_g2lv1 procedure, pass(idxmap) :: lg2lv1 => hash_g2lv1
procedure, pass(idxmap) :: g2lv2 => hash_g2lv2 procedure, pass(idxmap) :: lg2lv2 => hash_g2lv2
procedure, pass(idxmap) :: g2ls1_ins => hash_g2ls1_ins procedure, pass(idxmap) :: lg2ls1_ins => hash_g2ls1_ins
procedure, pass(idxmap) :: g2ls2_ins => hash_g2ls2_ins procedure, pass(idxmap) :: lg2ls2_ins => hash_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => hash_g2lv1_ins procedure, pass(idxmap) :: lg2lv1_ins => hash_g2lv1_ins
procedure, pass(idxmap) :: g2lv2_ins => hash_g2lv2_ins procedure, pass(idxmap) :: lg2lv2_ins => hash_g2lv2_ins
procedure, pass(idxmap) :: hash_cpy procedure, pass(idxmap) :: hash_cpy
generic, public :: assignment(=) => hash_cpy generic, public :: assignment(=) => hash_cpy
@ -159,11 +160,11 @@ contains
subroutine hash_l2gs1(idx,idxmap,info,mask,owned) subroutine hash_l2gs1(idx,idxmap,info,mask,owned)
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1) integer(psb_lpk_) :: idxv(1)
info = 0 info = 0
if (present(mask)) then if (present(mask)) then
if (.not.mask) return if (.not.mask) return
@ -179,13 +180,21 @@ contains
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
idxout = idxin integer(psb_lpk_) :: idxv(1)
call idxmap%l2gip(idxout,info,mask,owned) info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
call idxmap%l2gip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine hash_l2gs2 end subroutine hash_l2gs2
@ -193,7 +202,7 @@ contains
subroutine hash_l2gv1(idx,idxmap,info,mask,owned) subroutine hash_l2gv1(idx,idxmap,info,mask,owned)
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -249,7 +258,7 @@ contains
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
@ -270,11 +279,11 @@ contains
subroutine hash_g2ls1(idx,idxmap,info,mask,owned) subroutine hash_g2ls1(idx,idxmap,info,mask,owned)
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1) integer(psb_lpk_) :: idxv(1)
info = 0 info = 0
if (present(mask)) then if (present(mask)) then
@ -290,14 +299,21 @@ contains
subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned) subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_lpk_) :: idxv(1)
info = 0
idxout = idxin if (present(mask)) then
call idxmap%g2lip(idxout,info,mask,owned) if (.not.mask) return
end if
idxv(1) = idxin
call idxmap%g2lip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine hash_g2ls2 end subroutine hash_g2ls2
@ -307,11 +323,12 @@ contains
use psb_sort_mod use psb_sort_mod
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is, mglob, ip, lip, nrow, ncol, nrm integer(psb_ipk_) :: i, is, mglob, lip, nrow, nrm
integer(psb_lpk_) :: ncol, ip, tlip
integer(psb_mpk_) :: ictxt, iam, np integer(psb_mpk_) :: ictxt, iam, np
logical :: owned_ logical :: owned_
@ -358,8 +375,10 @@ contains
cycle cycle
endif endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm)
if (lip < 0) & if (lip < 0) then
& call psb_hash_searchkey(ip,lip,idxmap%hash,info) call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then if (owned_) then
if (lip<=nrow) then if (lip<=nrow) then
idx(i) = lip idx(i) = lip
@ -394,8 +413,10 @@ contains
cycle cycle
endif endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm)
if (lip < 0) & if (lip < 0) then
& call psb_hash_searchkey(ip,lip,idxmap%hash,info) call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then if (owned_) then
if (lip<=nrow) then if (lip<=nrow) then
idx(i) = lip idx(i) = lip
@ -419,20 +440,23 @@ contains
end subroutine hash_g2lv1 end subroutine hash_g2lv1
subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned)
use psb_realloc_mod
implicit none implicit none
class(psb_hash_map), intent(in) :: idxmap class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im integer(psb_ipk_) :: is, im
integer(psb_lpk_), allocatable :: tidx(:)
is = size(idxin) is = size(idxin)
im = min(is,size(idxout)) im = min(is,size(idxout))
idxout(1:im) = idxin(1:im) call psb_realloc(im,tidx,info)
call idxmap%g2lip(idxout(1:im),info,mask,owned) tidx(1:im) = idxin(1:im)
call idxmap%g2lip(tidx(1:im),info,mask,owned)
idxout(1:im) = tidx(1:im)
if (is > im) then if (is > im) then
write(0,*) 'g2lv2 err -3' write(0,*) 'g2lv2 err -3'
info = -3 info = -3
@ -447,12 +471,13 @@ contains
use psb_sort_mod use psb_sort_mod
implicit none implicit none
class(psb_hash_map), intent(inout) :: idxmap class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_), intent(in), optional :: lidx
integer(psb_ipk_) :: idxv(1), lidxv(1) integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0 info = 0
if (present(mask)) then if (present(mask)) then
@ -473,15 +498,28 @@ contains
subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none implicit none
class(psb_hash_map), intent(inout) :: idxmap class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_), intent(in), optional :: lidx
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
idxout = idxin info = 0
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2lip_ins(idxv,info)
end if
idxout = idxv(1)
end subroutine hash_g2ls2_ins end subroutine hash_g2ls2_ins
@ -493,13 +531,14 @@ contains
use psb_penv_mod use psb_penv_mod
implicit none implicit none
class(psb_hash_map), intent(inout) :: idxmap class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, is, mglob, ip, lip, nrow, ncol, & integer(psb_ipk_) :: i, is, lip, nrow, ncol, &
& nxt, err_act & err_act
integer(psb_lpk_) :: mglob, ip, nxt, tlip
integer(psb_ipk_) :: ictxt, me, np integer(psb_ipk_) :: ictxt, me, np
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -540,18 +579,20 @@ contains
idx(i) = -1 idx(i) = -1
cycle cycle
endif endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
if (lip < 0) then & idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then
tlip = lip
nxt = lidx(i) nxt = lidx(i)
if (nxt <= nrow) then if (nxt <= nrow) then
idx(i) = -1 idx(i) = -1
cycle cycle
endif endif
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
if (info >=0) then if (info >=0) then
if (nxt == lip) then if (nxt == tlip) then
ncol = max(ncol,nxt) ncol = max(ncol,nxt)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz) call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then if (info /= psb_success_) then
info=1 info=1
ch_err='psb_ensure_size' ch_err='psb_ensure_size'
@ -593,12 +634,13 @@ contains
idx(i) = -1 idx(i) = -1
cycle cycle
endif endif
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
if (info >=0) then if (info >=0) then
if (nxt == lip) then if (nxt == lip) then
ncol = max(nxt,ncol) ncol = max(nxt,ncol)
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz) call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then if (info /= psb_success_) then
info=1 info=1
ch_err='psb_ensure_size' ch_err='psb_ensure_size'
@ -636,13 +678,15 @@ contains
endif endif
nxt = ncol + 1 nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) & if (lip < 0) then
& call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
end if
if (info >=0) then if (info >=0) then
if (nxt == lip) then if (nxt == lip) then
ncol = nxt ncol = nxt
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz) call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then if (info /= psb_success_) then
info=1 info=1
ch_err='psb_ensure_size' ch_err='psb_ensure_size'
@ -678,13 +722,15 @@ contains
endif endif
nxt = ncol + 1 nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) & if (lip < 0) then
& call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
end if
if (info >=0) then if (info >=0) then
if (nxt == lip) then if (nxt == lip) then
ncol = nxt ncol = nxt
call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz) call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz)
if (info /= psb_success_) then if (info /= psb_success_) then
info=1 info=1
ch_err='psb_ensure_size' ch_err='psb_ensure_size'
@ -724,20 +770,23 @@ contains
end subroutine hash_g2lv1_ins end subroutine hash_g2lv1_ins
subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
use psb_realloc_mod
implicit none implicit none
class(psb_hash_map), intent(inout) :: idxmap class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_lpk_), allocatable :: tidx(:)
integer(psb_ipk_) :: is, im integer(psb_ipk_) :: is, im
is = size(idxin) is = size(idxin)
im = min(is,size(idxout)) im = min(is,size(idxout))
idxout(1:im) = idxin(1:im) call psb_realloc(im,tidx,info)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx) tidx(1:im) = idxin(1:im)
call idxmap%g2lip_ins(tidx(1:im),info,mask=mask,lidx=lidx)
idxout(1:im) = tidx(1:im)
if (is > im) then if (is > im) then
write(0,*) 'g2lv2_ins err -3' write(0,*) 'g2lv2_ins err -3'
info = -3 info = -3
@ -756,12 +805,14 @@ contains
implicit none implicit none
class(psb_hash_map), intent(inout) :: idxmap class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vl(:) integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! To be implemented ! To be implemented
integer(psb_mpk_) :: iam, np integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: i, nlu, nl, m, nrt,int_err(5) integer(psb_ipk_) :: i, nlu, nl, nrt,int_err(5)
integer(psb_ipk_), allocatable :: vlu(:), ix(:) integer(psb_lpk_) :: m
integer(psb_lpk_), allocatable :: vlu(:)
integer(psb_lpk_), allocatable :: ix(:)
character(len=20), parameter :: name='hash_map_init_vl' character(len=20), parameter :: name='hash_map_init_vl'
info = 0 info = 0
@ -831,8 +882,9 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! To be implemented ! To be implemented
integer(psb_mpk_) :: iam, np integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: i, j, nl, n, int_err(5) integer(psb_ipk_) :: i, j, nl, int_err(5)
integer(psb_ipk_), allocatable :: vlu(:) integer(psb_lpk_) :: n
integer(psb_lpk_), allocatable :: vlu(:)
info = 0 info = 0
call psb_info(ictxt,iam,np) call psb_info(ictxt,iam,np)
@ -886,7 +938,8 @@ contains
implicit none implicit none
class(psb_hash_map), intent(inout) :: idxmap class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vlu(:), nl, ntot integer(psb_lpk_), intent(in) :: vlu(:), ntot
integer(psb_ipk_), intent(in) :: nl
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! To be implemented ! To be implemented
integer(psb_mpk_) :: iam, np integer(psb_mpk_) :: iam, np
@ -1127,8 +1180,8 @@ contains
end subroutine hash_inner_cnvs1 end subroutine hash_inner_cnvs1
subroutine hash_inner_cnvs2(x,y,hashmask,hashv,glb_lc,nrm) subroutine hash_inner_cnvs2(x,y,hashmask,hashv,glb_lc,nrm)
integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) integer(psb_ipk_), intent(in) :: hashmask,hashv(0:)
integer(psb_ipk_), intent(in) :: x integer(psb_lpk_), intent(in) :: x, glb_lc(:,:)
integer(psb_ipk_), intent(out) :: y integer(psb_ipk_), intent(out) :: y
integer(psb_ipk_), intent(in) :: nrm integer(psb_ipk_), intent(in) :: nrm
integer(psb_ipk_) :: ih, key, idx,nh,tmp,lb,ub,lm integer(psb_ipk_) :: ih, key, idx,nh,tmp,lb,ub,lm
@ -1175,10 +1228,11 @@ contains
subroutine hash_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask,nrm) subroutine hash_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask,nrm)
integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:)
integer(psb_lpk_), intent(in) :: glb_lc(:,:)
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: nrm integer(psb_ipk_), intent(in), optional :: nrm
integer(psb_ipk_), intent(inout) :: x(:) integer(psb_lpk_), intent(inout) :: x(:)
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm
! !
@ -1460,9 +1514,11 @@ contains
implicit none implicit none
class(psb_hash_map), intent(inout) :: idxmap class(psb_hash_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nr,nc,k, nl, ntot integer(psb_ipk_) :: err_act, nr,nc,k, nl
integer(psb_lpk_) :: ntot
integer(psb_mpk_) :: ictxt, me, np integer(psb_mpk_) :: ictxt, me, np
integer(psb_ipk_), allocatable :: idx(:),lidx(:) integer(psb_ipk_), allocatable :: lidx(:)
integer(psb_lpk_), allocatable :: idx(:)
character(len=20) :: name='hash_reinit' character(len=20) :: name='hash_reinit'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.

52
base/modules/desc/psb_indx_map_mod.f90
Unescape Escape View File

@ -167,38 +167,44 @@ module psb_indx_map_mod
procedure, pass(idxmap) :: clone => base_clone procedure, pass(idxmap) :: clone => base_clone
procedure, pass(idxmap) :: reinit => base_reinit procedure, pass(idxmap) :: reinit => base_reinit
procedure, pass(idxmap) :: l2gs1 => base_l2gs1 !!$ procedure, pass(idxmap) :: l2gs1 => base_l2gs1
procedure, pass(idxmap) :: l2gs2 => base_l2gs2 !!$ procedure, pass(idxmap) :: l2gs2 => base_l2gs2
procedure, pass(idxmap) :: l2gv1 => base_l2gv1 !!$ procedure, pass(idxmap) :: l2gv1 => base_l2gv1
procedure, pass(idxmap) :: l2gv2 => base_l2gv2 !!$ procedure, pass(idxmap) :: l2gv2 => base_l2gv2
procedure, pass(idxmap) :: ll2gs1 => base_ll2gs1 procedure, pass(idxmap) :: ll2gs1 => base_ll2gs1
procedure, pass(idxmap) :: ll2gs2 => base_ll2gs2 procedure, pass(idxmap) :: ll2gs2 => base_ll2gs2
procedure, pass(idxmap) :: ll2gv1 => base_ll2gv1 procedure, pass(idxmap) :: ll2gv1 => base_ll2gv1
procedure, pass(idxmap) :: ll2gv2 => base_ll2gv2 procedure, pass(idxmap) :: ll2gv2 => base_ll2gv2
generic, public :: l2g => l2gs2, l2gv2, ll2gs2, ll2gv2 !!$ generic, public :: l2g => l2gs2, l2gv2
generic, public :: l2gip => l2gs1, l2gv1, ll2gs1, ll2gv1 !!$ generic, public :: l2gip => l2gs1, l2gv1
generic, public :: l2g => ll2gs2, ll2gv2
procedure, pass(idxmap) :: g2ls1 => base_g2ls1 generic, public :: l2gip => ll2gs1, ll2gv1
procedure, pass(idxmap) :: g2ls2 => base_g2ls2
procedure, pass(idxmap) :: g2lv1 => base_g2lv1 !!$ procedure, pass(idxmap) :: g2ls1 => base_g2ls1
procedure, pass(idxmap) :: g2lv2 => base_g2lv2 !!$ procedure, pass(idxmap) :: g2ls2 => base_g2ls2
!!$ procedure, pass(idxmap) :: g2lv1 => base_g2lv1
!!$ procedure, pass(idxmap) :: g2lv2 => base_g2lv2
procedure, pass(idxmap) :: lg2ls1 => base_lg2ls1 procedure, pass(idxmap) :: lg2ls1 => base_lg2ls1
procedure, pass(idxmap) :: lg2ls2 => base_lg2ls2 procedure, pass(idxmap) :: lg2ls2 => base_lg2ls2
procedure, pass(idxmap) :: lg2lv1 => base_lg2lv1 procedure, pass(idxmap) :: lg2lv1 => base_lg2lv1
procedure, pass(idxmap) :: lg2lv2 => base_lg2lv2 procedure, pass(idxmap) :: lg2lv2 => base_lg2lv2
generic, public :: g2l => g2ls2, g2lv2, lg2ls2, lg2lv2 !!$ generic, public :: g2l => g2ls2, g2lv2
generic, public :: g2lip => g2ls1, g2lv1, lg2ls1, lg2lv1 !!$ generic, public :: g2lip => g2ls1, g2lv1
generic, public :: g2l => lg2ls2, lg2lv2
procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_ins generic, public :: g2lip => lg2ls1, lg2lv1
procedure, pass(idxmap) :: g2ls2_ins => base_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => base_g2lv1_ins !!$ procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_ins
procedure, pass(idxmap) :: g2lv2_ins => base_g2lv2_ins !!$ procedure, pass(idxmap) :: g2ls2_ins => base_g2ls2_ins
!!$ procedure, pass(idxmap) :: g2lv1_ins => base_g2lv1_ins
!!$ procedure, pass(idxmap) :: g2lv2_ins => base_g2lv2_ins
procedure, pass(idxmap) :: lg2ls1_ins => base_lg2ls1_ins procedure, pass(idxmap) :: lg2ls1_ins => base_lg2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => base_lg2ls2_ins procedure, pass(idxmap) :: lg2ls2_ins => base_lg2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => base_lg2lv1_ins procedure, pass(idxmap) :: lg2lv1_ins => base_lg2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => base_lg2lv2_ins procedure, pass(idxmap) :: lg2lv2_ins => base_lg2lv2_ins
generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins, lg2ls2_ins, lg2lv2_ins !!$ generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins
generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins, lg2ls1_ins, lg2lv1_ins !!$ generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins
generic, public :: g2l_ins => lg2ls2_ins, lg2lv2_ins
generic, public :: g2lip_ins => lg2ls1_ins, lg2lv1_ins
procedure, pass(idxmap) :: fnd_owner => psb_indx_map_fnd_owner procedure, pass(idxmap) :: fnd_owner => psb_indx_map_fnd_owner
procedure, pass(idxmap) :: init_vl => base_init_vl procedure, pass(idxmap) :: init_vl => base_init_vl
@ -242,9 +248,9 @@ module psb_indx_map_mod
interface interface
subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
import :: psb_indx_map, psb_ipk_ import :: psb_indx_map, psb_ipk_, psb_lpk_
implicit none implicit none
integer(psb_ipk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(in) :: idxmap class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -1150,7 +1156,7 @@ contains
implicit none implicit none
class(psb_indx_map), intent(inout) :: idxmap class(psb_indx_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vl(:) integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='base_init_vl' character(len=20) :: name='base_init_vl'

893
base/modules/desc/psb_list_map_mod.f90
Unescape Escape View File

@ -49,9 +49,7 @@ module psb_list_map_mod
integer(psb_lpk_), allocatable :: loc_to_glob(:) integer(psb_lpk_), allocatable :: loc_to_glob(:)
integer(psb_ipk_), allocatable :: glob_to_loc(:) integer(psb_ipk_), allocatable :: glob_to_loc(:)
contains contains
procedure, pass(idxmap) :: init_vl => list_initvl procedure, pass(idxmap) :: init_vl => list_initlvl
procedure, pass(idxmap) :: init_lvl => list_initlvl
procedure, pass(idxmap) :: sizeof => list_sizeof procedure, pass(idxmap) :: sizeof => list_sizeof
procedure, pass(idxmap) :: asb => list_asb procedure, pass(idxmap) :: asb => list_asb
@ -61,30 +59,30 @@ module psb_list_map_mod
procedure, nopass :: get_fmt => list_get_fmt procedure, nopass :: get_fmt => list_get_fmt
procedure, nopass :: row_extendable => list_row_extendable procedure, nopass :: row_extendable => list_row_extendable
procedure, pass(idxmap) :: l2gs1 => list_l2gs1 !!$ procedure, pass(idxmap) :: l2gs1 => list_l2gs1
procedure, pass(idxmap) :: l2gs2 => list_l2gs2 !!$ procedure, pass(idxmap) :: l2gs2 => list_l2gs2
procedure, pass(idxmap) :: l2gv1 => list_l2gv1 !!$ procedure, pass(idxmap) :: l2gv1 => list_l2gv1
procedure, pass(idxmap) :: l2gv2 => list_l2gv2 !!$ procedure, pass(idxmap) :: l2gv2 => list_l2gv2
procedure, pass(idxmap) :: ll2gs1 => list_ll2gs1 procedure, pass(idxmap) :: ll2gs1 => list_ll2gs1
procedure, pass(idxmap) :: ll2gs2 => list_ll2gs2 procedure, pass(idxmap) :: ll2gs2 => list_ll2gs2
procedure, pass(idxmap) :: ll2gv1 => list_ll2gv1 procedure, pass(idxmap) :: ll2gv1 => list_ll2gv1
procedure, pass(idxmap) :: ll2gv2 => list_ll2gv2 procedure, pass(idxmap) :: ll2gv2 => list_ll2gv2
procedure, pass(idxmap) :: g2ls1 => list_g2ls1 !!$ procedure, pass(idxmap) :: g2ls1 => list_g2ls1
procedure, pass(idxmap) :: g2ls2 => list_g2ls2 !!$ procedure, pass(idxmap) :: g2ls2 => list_g2ls2
procedure, pass(idxmap) :: g2lv1 => list_g2lv1 !!$ procedure, pass(idxmap) :: g2lv1 => list_g2lv1
procedure, pass(idxmap) :: g2lv2 => list_g2lv2 !!$ procedure, pass(idxmap) :: g2lv2 => list_g2lv2
procedure, pass(idxmap) :: lg2ls1 => list_lg2ls1 procedure, pass(idxmap) :: lg2ls1 => list_lg2ls1
procedure, pass(idxmap) :: lg2ls2 => list_lg2ls2 procedure, pass(idxmap) :: lg2ls2 => list_lg2ls2
procedure, pass(idxmap) :: lg2lv1 => list_lg2lv1 procedure, pass(idxmap) :: lg2lv1 => list_lg2lv1
procedure, pass(idxmap) :: lg2lv2 => list_lg2lv2 procedure, pass(idxmap) :: lg2lv2 => list_lg2lv2
procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins !!$ procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins
procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins !!$ procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins !!$ procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins
procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins !!$ procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins
procedure, pass(idxmap) :: lg2ls1_ins => list_lg2ls1_ins procedure, pass(idxmap) :: lg2ls1_ins => list_lg2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => list_lg2ls2_ins procedure, pass(idxmap) :: lg2ls2_ins => list_lg2ls2_ins
@ -138,113 +136,113 @@ contains
end subroutine list_free end subroutine list_free
subroutine list_l2gs1(idx,idxmap,info,mask,owned) !!$ subroutine list_l2gs1(idx,idxmap,info,mask,owned)
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx !!$ integer(psb_ipk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask !!$ logical, intent(in), optional :: mask
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1) !!$ integer(psb_ipk_) :: idxv(1)
info = 0 !!$ info = 0
if (present(mask)) then !!$ if (present(mask)) then
if (.not.mask) return !!$ if (.not.mask) return
end if !!$ end if
!!$
idxv(1) = idx !!$ idxv(1) = idx
call idxmap%l2gip(idxv,info,owned=owned) !!$ call idxmap%l2gip(idxv,info,owned=owned)
idx = idxv(1) !!$ idx = idxv(1)
!!$
end subroutine list_l2gs1 !!$ end subroutine list_l2gs1
!!$
subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned) !!$ subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned)
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin !!$ integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout !!$ integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask !!$ logical, intent(in), optional :: mask
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
!!$
idxout = idxin !!$ idxout = idxin
call idxmap%l2gip(idxout,info,mask,owned) !!$ call idxmap%l2gip(idxout,info,mask,owned)
!!$
end subroutine list_l2gs2 !!$ end subroutine list_l2gs2
!!$
!!$
subroutine list_l2gv1(idx,idxmap,info,mask,owned) !!$ subroutine list_l2gv1(idx,idxmap,info,mask,owned)
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) !!$ integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) !!$ logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
integer(psb_ipk_) :: i !!$ integer(psb_ipk_) :: i
logical :: owned_ !!$ logical :: owned_
info = 0 !!$ info = 0
!!$
if (present(mask)) then !!$ if (present(mask)) then
if (size(mask) < size(idx)) then !!$ if (size(mask) < size(idx)) then
info = -1 !!$ info = -1
return !!$ return
end if !!$ end if
end if !!$ end if
if (present(owned)) then !!$ if (present(owned)) then
owned_ = owned !!$ owned_ = owned
else !!$ else
owned_ = .false. !!$ owned_ = .false.
end if !!$ end if
!!$
if (present(mask)) then !!$ if (present(mask)) then
!!$
do i=1, size(idx) !!$ do i=1, size(idx)
if (mask(i)) then !!$ if (mask(i)) then
if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then !!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
idx(i) = idxmap%loc_to_glob(idx(i)) !!$ idx(i) = idxmap%loc_to_glob(idx(i))
else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& !!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
& .and.(.not.owned_)) then !!$ & .and.(.not.owned_)) then
idx(i) = idxmap%loc_to_glob(idx(i)) !!$ idx(i) = idxmap%loc_to_glob(idx(i))
else !!$ else
idx(i) = -1 !!$ idx(i) = -1
end if !!$ end if
end if !!$ end if
end do !!$ end do
!!$
else if (.not.present(mask)) then !!$ else if (.not.present(mask)) then
!!$
do i=1, size(idx) !!$ do i=1, size(idx)
if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then !!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
idx(i) = idxmap%loc_to_glob(idx(i)) !!$ idx(i) = idxmap%loc_to_glob(idx(i))
else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& !!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
& .and.(.not.owned_)) then !!$ & .and.(.not.owned_)) then
idx(i) = idxmap%loc_to_glob(idx(i)) !!$ idx(i) = idxmap%loc_to_glob(idx(i))
else !!$ else
idx(i) = -1 !!$ idx(i) = -1
end if !!$ end if
end do !!$ end do
!!$
end if !!$ end if
!!$
end subroutine list_l2gv1 !!$ end subroutine list_l2gv1
!!$
subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned) !!$ subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned)
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) !!$ integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) !!$ integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) !!$ logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im !!$ integer(psb_ipk_) :: is, im
!!$
is = size(idxin) !!$ is = size(idxin)
im = min(is,size(idxout)) !!$ im = min(is,size(idxout))
idxout(1:im) = idxin(1:im) !!$ idxout(1:im) = idxin(1:im)
call idxmap%l2gip(idxout(1:im),info,mask,owned) !!$ call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (is > im) info = -3 !!$ if (is > im) info = -3
!!$
end subroutine list_l2gv2 !!$ end subroutine list_l2gv2
!!$
subroutine list_ll2gs1(idx,idxmap,info,mask,owned) subroutine list_ll2gs1(idx,idxmap,info,mask,owned)
implicit none implicit none
@ -353,126 +351,126 @@ contains
end subroutine list_ll2gv2 end subroutine list_ll2gv2
!!$
subroutine list_g2ls1(idx,idxmap,info,mask,owned) !!$ subroutine list_g2ls1(idx,idxmap,info,mask,owned)
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx !!$ integer(psb_ipk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask !!$ logical, intent(in), optional :: mask
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1) !!$ integer(psb_ipk_) :: idxv(1)
info = 0 !!$ info = 0
!!$
if (present(mask)) then !!$ if (present(mask)) then
if (.not.mask) return !!$ if (.not.mask) return
end if !!$ end if
!!$
idxv(1) = idx !!$ idxv(1) = idx
call idxmap%g2lip(idxv,info,owned=owned) !!$ call idxmap%g2lip(idxv,info,owned=owned)
idx = idxv(1) !!$ idx = idxv(1)
!!$
end subroutine list_g2ls1 !!$ end subroutine list_g2ls1
!!$
subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned) !!$ subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin !!$ integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout !!$ integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask !!$ logical, intent(in), optional :: mask
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
!!$
idxout = idxin !!$ idxout = idxin
call idxmap%g2lip(idxout,info,mask,owned) !!$ call idxmap%g2lip(idxout,info,mask,owned)
!!$
end subroutine list_g2ls2 !!$ end subroutine list_g2ls2
!!$
!!$
subroutine list_g2lv1(idx,idxmap,info,mask,owned) !!$ subroutine list_g2lv1(idx,idxmap,info,mask,owned)
use psb_sort_mod !!$ use psb_sort_mod
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) !!$ integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) !!$ logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is, ix !!$ integer(psb_ipk_) :: i, is, ix
logical :: owned_ !!$ logical :: owned_
!!$
info = 0 !!$ info = 0
!!$
if (present(mask)) then !!$ if (present(mask)) then
if (size(mask) < size(idx)) then !!$ if (size(mask) < size(idx)) then
info = -1 !!$ info = -1
return !!$ return
end if !!$ end if
end if !!$ end if
if (present(owned)) then !!$ if (present(owned)) then
owned_ = owned !!$ owned_ = owned
else !!$ else
owned_ = .false. !!$ owned_ = .false.
end if !!$ end if
!!$
is = size(idx) !!$ is = size(idx)
!!$
if (present(mask)) then !!$ if (present(mask)) then
if (idxmap%is_valid()) then !!$ if (idxmap%is_valid()) then
do i=1,is !!$ do i=1,is
if (mask(i)) then !!$ if (mask(i)) then
if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then !!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idx(i)) !!$ ix = idxmap%glob_to_loc(idx(i))
if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 !!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1
idx(i) = ix !!$ idx(i) = ix
else !!$ else
idx(i) = -1 !!$ idx(i) = -1
end if !!$ end if
end if !!$ end if
end do !!$ end do
else !!$ else
idx(1:is) = -1 !!$ idx(1:is) = -1
info = -1 !!$ info = -1
end if !!$ end if
!!$
else if (.not.present(mask)) then !!$ else if (.not.present(mask)) then
!!$
if (idxmap%is_valid()) then !!$ if (idxmap%is_valid()) then
do i=1, is !!$ do i=1, is
if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then !!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idx(i)) !!$ ix = idxmap%glob_to_loc(idx(i))
if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 !!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1
idx(i) = ix !!$ idx(i) = ix
else !!$ else
idx(i) = -1 !!$ idx(i) = -1
end if !!$ end if
end do !!$ end do
else !!$ else
idx(1:is) = -1 !!$ idx(1:is) = -1
info = -1 !!$ info = -1
end if !!$ end if
!!$
end if !!$ end if
!!$
end subroutine list_g2lv1 !!$ end subroutine list_g2lv1
!!$
subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned) !!$ subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned)
implicit none !!$ implicit none
class(psb_list_map), intent(in) :: idxmap !!$ class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) !!$ integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) !!$ integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) !!$ logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned !!$ logical, intent(in), optional :: owned
!!$
integer(psb_ipk_) :: is, im !!$ integer(psb_ipk_) :: is, im
!!$
is = size(idxin) !!$ is = size(idxin)
im = min(is,size(idxout)) !!$ im = min(is,size(idxout))
idxout(1:im) = idxin(1:im) !!$ idxout(1:im) = idxin(1:im)
call idxmap%g2lip(idxout(1:im),info,mask,owned) !!$ call idxmap%g2lip(idxout(1:im),info,mask,owned)
if (is > im) info = -3 !!$ if (is > im) info = -3
!!$
end subroutine list_g2lv2 !!$ end subroutine list_g2lv2
@ -610,18 +608,221 @@ contains
end subroutine list_lg2lv2 end subroutine list_lg2lv2
!!$ subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx)
!!$ use psb_realloc_mod
!!$ use psb_sort_mod
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ integer(psb_ipk_), intent(in), optional :: lidx
!!$
!!$ integer(psb_ipk_) :: idxv(1), lidxv(1)
!!$
!!$ info = 0
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$ idxv(1) = idx
!!$ if (present(lidx)) then
!!$ lidxv(1) = lidx
!!$ call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
!!$ else
!!$ call idxmap%g2lip_ins(idxv,info)
!!$ end if
!!$
!!$ idx = idxv(1)
!!$
!!$ end subroutine list_g2ls1_ins
!!$
!!$ subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ integer(psb_ipk_), intent(in), optional :: lidx
!!$
!!$ idxout = idxin
!!$ call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
!!$
!!$ end subroutine list_g2ls2_ins
!!$
!!$
!!$ subroutine list_g2lv1_ins(idx,idxmap,info,mask,lidx)
!!$ use psb_realloc_mod
!!$ use psb_sort_mod
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ integer(psb_ipk_), intent(in), optional :: lidx(:)
!!$
!!$ integer(psb_ipk_) :: i, is, ix, lix
!!$
!!$ info = 0
!!$ is = size(idx)
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$ if (present(lidx)) then
!!$ if (size(lidx) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$
!!$
!!$ if (idxmap%is_asb()) then
!!$ ! State is wrong for this one !
!!$ idx = -1
!!$ info = -1
!!$
!!$ else if (idxmap%is_valid()) then
!!$
!!$ if (present(lidx)) then
!!$ if (present(mask)) then
!!$ do i=1, is
!!$ if (mask(i)) then
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = lidx(i)
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = max(ix,idxmap%local_cols)
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, is
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = lidx(i)
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = max(ix,idxmap%local_cols)
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$ end if
!!$
!!$ else if (.not.present(lidx)) then
!!$
!!$ if (present(mask)) then
!!$ do i=1, is
!!$ if (mask(i)) then
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = idxmap%local_cols + 1
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if (info /= 0) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = ix
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, is
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = idxmap%local_cols + 1
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if (info /= 0) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = ix
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$ end if
!!$ end if
!!$
!!$ else
!!$ idx = -1
!!$ info = -1
!!$ end if
!!$
!!$ end subroutine list_g2lv1_ins
!!$
!!$ subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ integer(psb_ipk_), intent(in), optional :: lidx(:)
!!$
!!$ integer(psb_ipk_) :: is, im
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$ idxout(1:im) = idxin(1:im)
!!$ call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
!!$ if (is > im) info = -3
!!$
!!$ end subroutine list_g2lv2_ins
!!$
subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx) subroutine list_lg2ls1_ins(idx,idxmap,info,mask,lidx)
use psb_realloc_mod use psb_realloc_mod
use psb_sort_mod use psb_sort_mod
implicit none implicit none
class(psb_list_map), intent(inout) :: idxmap class(psb_list_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_), intent(in), optional :: lidx
integer(psb_ipk_) :: idxv(1), lidxv(1) integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0 info = 0
if (present(mask)) then if (present(mask)) then
@ -637,193 +838,17 @@ contains
idx = idxv(1) idx = idxv(1)
end subroutine list_g2ls1_ins end subroutine list_lg2ls1_ins
subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) subroutine list_lg2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none implicit none
class(psb_list_map), intent(inout) :: idxmap class(psb_list_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_), intent(in), optional :: lidx
idxout = idxin
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
end subroutine list_g2ls2_ins
subroutine list_g2lv1_ins(idx,idxmap,info,mask,lidx)
use psb_realloc_mod
use psb_sort_mod
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, is, ix, lix
info = 0
is = size(idx)
if (present(mask)) then
if (size(mask) < size(idx)) then
info = -1
return
end if
end if
if (present(lidx)) then
if (size(lidx) < size(idx)) then
info = -1
return
end if
end if
if (idxmap%is_asb()) then
! State is wrong for this one !
idx = -1
info = -1
else if (idxmap%is_valid()) then
if (present(lidx)) then
if (present(mask)) then
do i=1, is
if (mask(i)) then
if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idx(i))
if (ix < 0) then
ix = lidx(i)
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if ((ix <= idxmap%local_rows).or.(info /= 0)) then
info = -4
return
end if
idxmap%local_cols = max(ix,idxmap%local_cols)
idxmap%loc_to_glob(ix) = idx(i)
idxmap%glob_to_loc(idx(i)) = ix
end if
idx(i) = ix
else
idx(i) = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, is
if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idx(i))
if (ix < 0) then
ix = lidx(i)
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if ((ix <= idxmap%local_rows).or.(info /= 0)) then
info = -4
return
end if
idxmap%local_cols = max(ix,idxmap%local_cols)
idxmap%loc_to_glob(ix) = idx(i)
idxmap%glob_to_loc(idx(i)) = ix
end if
idx(i) = ix
else
idx(i) = -1
end if
end do
end if
else if (.not.present(lidx)) then
if (present(mask)) then
do i=1, is
if (mask(i)) then
if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idx(i))
if (ix < 0) then
ix = idxmap%local_cols + 1
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = ix
idxmap%loc_to_glob(ix) = idx(i)
idxmap%glob_to_loc(idx(i)) = ix
end if
idx(i) = ix
else
idx(i) = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, is
if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idx(i))
if (ix < 0) then
ix = idxmap%local_cols + 1
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = ix
idxmap%loc_to_glob(ix) = idx(i)
idxmap%glob_to_loc(idx(i)) = ix
end if
idx(i) = ix
else
idx(i) = -1
end if
end do
end if
end if
else
idx = -1
info = -1
end if
end subroutine list_g2lv1_ins
subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: is, im
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
if (is > im) info = -3
end subroutine list_g2lv2_ins
subroutine list_lg2ls1_ins(idx,idxmap,info,mask,lidx)
use psb_realloc_mod
use psb_sort_mod
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx
integer(psb_lpk_) :: idxv(1) integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1) integer(psb_ipk_) :: lidxv(1)
@ -831,7 +856,7 @@ contains
if (present(mask)) then if (present(mask)) then
if (.not.mask) return if (.not.mask) return
end if end if
idxv(1) = idx idxv(1) = idxin
if (present(lidx)) then if (present(lidx)) then
lidxv(1) = lidx lidxv(1) = lidx
call idxmap%g2lip_ins(idxv,info,lidx=lidxv) call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
@ -839,21 +864,7 @@ contains
call idxmap%g2lip_ins(idxv,info) call idxmap%g2lip_ins(idxv,info)
end if end if
idx = idxv(1) idxout = idxv(1)
end subroutine list_lg2ls1_ins
subroutine list_lg2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx
idxout = idxin
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
end subroutine list_lg2ls2_ins end subroutine list_lg2ls2_ins
@ -1057,7 +1068,7 @@ contains
end if end if
lvl(1:nl) = vl(1:nl) lvl(1:nl) = vl(1:nl)
call idxmap%init_lvl(ictxt,lvl,info) call idxmap%init_vl(ictxt,lvl,info)
end subroutine list_initvl end subroutine list_initvl

118
base/modules/desc/psb_repl_map_mod.f90
Unescape Escape View File

@ -58,20 +58,20 @@ module psb_repl_map_mod
procedure, pass(idxmap) :: reinit => repl_reinit procedure, pass(idxmap) :: reinit => repl_reinit
procedure, nopass :: get_fmt => repl_get_fmt procedure, nopass :: get_fmt => repl_get_fmt
procedure, pass(idxmap) :: l2gs1 => repl_l2gs1 procedure, pass(idxmap) :: ll2gs1 => repl_l2gs1
procedure, pass(idxmap) :: l2gs2 => repl_l2gs2 procedure, pass(idxmap) :: ll2gs2 => repl_l2gs2
procedure, pass(idxmap) :: l2gv1 => repl_l2gv1 procedure, pass(idxmap) :: ll2gv1 => repl_l2gv1
procedure, pass(idxmap) :: l2gv2 => repl_l2gv2 procedure, pass(idxmap) :: ll2gv2 => repl_l2gv2
procedure, pass(idxmap) :: g2ls1 => repl_g2ls1 procedure, pass(idxmap) :: lg2ls1 => repl_g2ls1
procedure, pass(idxmap) :: g2ls2 => repl_g2ls2 procedure, pass(idxmap) :: lg2ls2 => repl_g2ls2
procedure, pass(idxmap) :: g2lv1 => repl_g2lv1 procedure, pass(idxmap) :: lg2lv1 => repl_g2lv1
procedure, pass(idxmap) :: g2lv2 => repl_g2lv2 procedure, pass(idxmap) :: lg2lv2 => repl_g2lv2
procedure, pass(idxmap) :: g2ls1_ins => repl_g2ls1_ins procedure, pass(idxmap) :: lg2ls1_ins => repl_g2ls1_ins
procedure, pass(idxmap) :: g2ls2_ins => repl_g2ls2_ins procedure, pass(idxmap) :: lg2ls2_ins => repl_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => repl_g2lv1_ins procedure, pass(idxmap) :: lg2lv1_ins => repl_g2lv1_ins
procedure, pass(idxmap) :: g2lv2_ins => repl_g2lv2_ins procedure, pass(idxmap) :: lg2lv2_ins => repl_g2lv2_ins
procedure, pass(idxmap) :: fnd_owner => repl_fnd_owner procedure, pass(idxmap) :: fnd_owner => repl_fnd_owner
@ -107,11 +107,11 @@ contains
subroutine repl_l2gs1(idx,idxmap,info,mask,owned) subroutine repl_l2gs1(idx,idxmap,info,mask,owned)
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1) integer(psb_lpk_) :: idxv(1)
info = 0 info = 0
if (present(mask)) then if (present(mask)) then
if (.not.mask) return if (.not.mask) return
@ -127,13 +127,20 @@ contains
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
idxout = idxin integer(psb_lpk_) :: idxv(1)
call idxmap%l2gip(idxout,info,mask,owned) info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
call idxmap%l2gip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine repl_l2gs2 end subroutine repl_l2gs2
@ -141,11 +148,11 @@ contains
subroutine repl_l2gv1(idx,idxmap,info,mask,owned) subroutine repl_l2gv1(idx,idxmap,info,mask,owned)
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: i integer(psb_lpk_) :: i
logical :: owned_ logical :: owned_
info = 0 info = 0
@ -191,12 +198,12 @@ contains
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im integer(psb_lpk_) :: is, im
integer(psb_ipk_) :: i integer(psb_lpk_) :: i
logical :: owned_ logical :: owned_
info = 0 info = 0
@ -247,11 +254,11 @@ contains
subroutine repl_g2ls1(idx,idxmap,info,mask,owned) subroutine repl_g2ls1(idx,idxmap,info,mask,owned)
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1) integer(psb_lpk_) :: idxv(1)
info = 0 info = 0
if (present(mask)) then if (present(mask)) then
@ -267,26 +274,35 @@ contains
subroutine repl_g2ls2(idxin,idxout,idxmap,info,mask,owned) subroutine repl_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
idxout = idxin integer(psb_lpk_) :: idxv(1)
call idxmap%g2lip(idxout,info,mask,owned) info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
call idxmap%g2lip(idxv,info,owned=owned)
idxout = idxv(1)
end subroutine repl_g2ls2 end subroutine repl_g2ls2
subroutine repl_g2lv1(idx,idxmap,info,mask,owned) subroutine repl_g2lv1(idx,idxmap,info,mask,owned)
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is integer(psb_lpk_) :: i, is
logical :: owned_ logical :: owned_
info = 0 info = 0
@ -363,13 +379,13 @@ contains
subroutine repl_g2lv2(idxin,idxout,idxmap,info,mask,owned) subroutine repl_g2lv2(idxin,idxout,idxmap,info,mask,owned)
implicit none implicit none
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im,i integer(psb_lpk_) :: is, im,i
logical :: owned_ logical :: owned_
info = 0 info = 0
@ -453,12 +469,13 @@ contains
use psb_sort_mod use psb_sort_mod
implicit none implicit none
class(psb_repl_map), intent(inout) :: idxmap class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx integer(psb_lpk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_), intent(in), optional :: lidx
integer(psb_ipk_) :: idxv(1),lidxv(1) integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
info = 0 info = 0
if (present(mask)) then if (present(mask)) then
@ -478,14 +495,27 @@ contains
subroutine repl_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) subroutine repl_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none implicit none
class(psb_repl_map), intent(inout) :: idxmap class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin integer(psb_lpk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx integer(psb_ipk_), intent(in), optional :: lidx
integer(psb_lpk_) :: idxv(1)
idxout = idxin integer(psb_ipk_) :: lidxv(1)
call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idxin
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
else
call idxmap%g2lip_ins(idxv,info)
end if
idxout = idxv(1)
end subroutine repl_g2ls2_ins end subroutine repl_g2ls2_ins
@ -495,12 +525,12 @@ contains
use psb_sort_mod use psb_sort_mod
implicit none implicit none
class(psb_repl_map), intent(inout) :: idxmap class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:) integer(psb_lpk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, is integer(psb_lpk_) :: i, is
info = 0 info = 0
is = size(idx) is = size(idx)
@ -579,13 +609,13 @@ contains
subroutine repl_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) subroutine repl_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none implicit none
class(psb_repl_map), intent(inout) :: idxmap class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:) integer(psb_lpk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:) logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: is, im, i integer(psb_lpk_) :: is, im, i
info = 0 info = 0
@ -669,7 +699,7 @@ contains
subroutine repl_fnd_owner(idx,iprc,idxmap,info) subroutine repl_fnd_owner(idx,iprc,idxmap,info)
use psb_penv_mod use psb_penv_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: idx(:) integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_repl_map), intent(in) :: idxmap class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -695,7 +725,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_repl_map), intent(inout) :: idxmap class(psb_repl_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: nl integer(psb_lpk_), intent(in) :: nl
integer(psb_mpk_), intent(in) :: ictxt integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! To be implemented ! To be implemented

31
base/modules/penv/psi_penv_mod.F90
Unescape Escape View File

@ -283,6 +283,8 @@ contains
use psi_comm_buffers_mod use psi_comm_buffers_mod
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_mat_mod
use psb_vect_mod
! !$ use psb_rsb_mod ! !$ use psb_rsb_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -294,13 +296,13 @@ contains
integer(psb_mpk_), intent(out) :: ictxt integer(psb_mpk_), intent(out) :: ictxt
integer(psb_mpk_), intent(in), optional :: np, basectxt, ids(:) integer(psb_mpk_), intent(in), optional :: np, basectxt, ids(:)
integer(psb_mpk_) :: i, isnullcomm integer(psb_mpk_) :: i, isnullcomm
integer(psb_mpk_), allocatable :: iids(:) integer(psb_mpk_), allocatable :: iids(:)
logical :: initialized logical :: initialized
integer(psb_mpk_) :: np_, npavail, iam, info, basecomm, basegroup, newgroup integer(psb_mpk_) :: np_, npavail, iam, info, basecomm, basegroup, newgroup
character(len=20), parameter :: name='psb_init' character(len=20), parameter :: name='psb_init'
integer(psb_ipk_) :: iinfo integer(psb_ipk_) :: iinfo
!
call psb_set_debug_unit(psb_err_unit) call psb_set_debug_unit(psb_err_unit)
#if defined(SERIAL_MPI) #if defined(SERIAL_MPI)
@ -390,19 +392,20 @@ contains
call psi_get_sizes() call psi_get_sizes()
if (ictxt == mpi_comm_null) return if (ictxt == mpi_comm_null) return
#endif #endif
call psb_init_vect_defaults()
! !$ call psb_rsb_init(info) call psb_init_mat_defaults()
! !$ if (info.ne.psb_rsb_const_success) then ! !$ call psb_rsb_init(info)
! !$ if (info.eq.psb_rsb_const_not_available) then ! !$ if (info.ne.psb_rsb_const_success) then
! !$ info=psb_success_ ! rsb is not present ! !$ if (info.eq.psb_rsb_const_not_available) then
! !$ else ! !$ info=psb_success_ ! rsb is not present
! !$ ! rsb failed to initialize, and we issue an internal error. ! !$ else
! !$ ! or shall we tolerate this ? ! !$ ! rsb failed to initialize, and we issue an internal error.
! !$ info=psb_err_internal_error_ ! !$ ! or shall we tolerate this ?
! !$ call psb_errpush(info,name) ! !$ info=psb_err_internal_error_
! !$ call psb_error(ictxt) ! !$ call psb_errpush(info,name)
! !$ endif ! !$ call psb_error(ictxt)
! !$ endif ! !$ endif
! !$ endif
end subroutine psb_init_mpik end subroutine psb_init_mpik

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

@ -72,7 +72,8 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: m,n,ix,jx,lldx integer(psb_lpk_), intent(in) :: m,n,ix,jx
integer(psb_ipk_), intent(in) :: lldx
type(psb_desc_type), intent(in) :: desc_dec type(psb_desc_type), intent(in) :: desc_dec
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: iix, jjx integer(psb_ipk_), optional :: iix, jjx
@ -193,7 +194,8 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: m,n,ix,jx,lldx integer(psb_lpk_), intent(in) :: m,n,ix,jx
integer(psb_ipk_), intent(in) :: lldx
type(psb_desc_type), intent(in) :: desc_dec type(psb_desc_type), intent(in) :: desc_dec
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -311,7 +313,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: m,n,ia,ja integer(psb_lpk_), intent(in) :: m,n,ia,ja
type(psb_desc_type), intent(in) :: desc_dec type(psb_desc_type), intent(in) :: desc_dec
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: iia, jja integer(psb_ipk_), optional :: iia, jja

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

@ -93,7 +93,7 @@ module psb_const_mod
integer, parameter :: psb_ipk_ = psb_mpk_ integer, parameter :: psb_ipk_ = psb_mpk_
integer, parameter :: psb_lpk_ = psb_epk_ integer, parameter :: psb_lpk_ = psb_epk_
#elif defined(INT_I8_L8) #elif defined(INT_I8_L8)
integer, parameter :: psb_ipk_ = psb_mpk_ integer, parameter :: psb_ipk_ = psb_epk_
integer, parameter :: psb_lpk_ = psb_epk_ integer, parameter :: psb_lpk_ = psb_epk_
#else #else
! Unsupported combination, compilation will stop later on ! Unsupported combination, compilation will stop later on
@ -101,13 +101,13 @@ module psb_const_mod
integer, parameter :: psb_lpk_ = -1 integer, parameter :: psb_lpk_ = -1
#endif #endif
integer(psb_ipk_), save :: psb_sizeof_sp integer(psb_ipk_), save :: psb_sizeof_sp
integer(psb_ipk_), save :: psb_sizeof_dp integer(psb_ipk_), save :: psb_sizeof_dp
integer(psb_ipk_), save :: psb_sizeof_i2p integer(psb_ipk_), save :: psb_sizeof_i2p
integer(psb_ipk_), save :: psb_sizeof_mp integer(psb_ipk_), save :: psb_sizeof_mp
integer(psb_ipk_), save :: psb_sizeof_ep integer(psb_ipk_), save :: psb_sizeof_ep
integer(psb_ipk_), save :: psb_sizeof_ip integer(psb_ipk_), save :: psb_sizeof_ip
integer(psb_ipk_), save :: psb_sizeof_lp integer(psb_ipk_), save :: psb_sizeof_lp
! !
! Integer type identifiers for MPI operations. ! Integer type identifiers for MPI operations.
! !

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

@ -30,12 +30,12 @@
! !
! !
module psi_c_mod module psi_c_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type
use psi_c_comm_a_mod use psi_c_comm_a_mod
use psb_c_base_vect_mod, only : psb_c_base_vect_type use psb_c_base_vect_mod, only : psb_c_base_vect_type
use psb_c_base_multivect_mod, only : psb_c_base_multivect_type use psb_c_base_multivect_mod, only : psb_c_base_multivect_type
use psi_c_comm_v_mod use psi_c_comm_v_mod
end module psi_c_mod end module psi_c_mod

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

@ -30,12 +30,12 @@
! !
! !
module psi_d_mod module psi_d_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
use psi_d_comm_a_mod use psi_d_comm_a_mod
use psb_d_base_vect_mod, only : psb_d_base_vect_type use psb_d_base_vect_mod, only : psb_d_base_vect_type
use psb_d_base_multivect_mod, only : psb_d_base_multivect_type use psb_d_base_multivect_mod, only : psb_d_base_multivect_type
use psi_d_comm_v_mod use psi_d_comm_v_mod
end module psi_d_mod end module psi_d_mod

9
base/modules/psi_i_mod.F90
Unescape Escape View File

@ -30,13 +30,13 @@
! !
! !
module psi_i_mod module psi_i_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_ use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_
use psi_m_comm_a_mod use psi_m_comm_a_mod
use psi_e_comm_a_mod use psi_e_comm_a_mod
use psb_i_base_vect_mod, only : psb_i_base_vect_type use psb_i_base_vect_mod, only : psb_i_base_vect_type
use psb_i_base_multivect_mod, only : psb_i_base_multivect_type use psb_i_base_multivect_mod, only : psb_i_base_multivect_type
use psi_i_comm_v_mod use psi_i_comm_v_mod
interface psi_compute_size interface psi_compute_size
subroutine psi_i_compute_size(desc_data,& subroutine psi_i_compute_size(desc_data,&
@ -58,13 +58,12 @@ module psi_i_mod
end interface end interface
interface psi_crea_index interface psi_crea_index
subroutine psi_i_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info) subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info)
import import
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: nxch,nsnd,nrcv integer(psb_ipk_), intent(out) :: nxch,nsnd,nrcv
integer(psb_ipk_), intent(in) :: index_in(:) integer(psb_ipk_), intent(in) :: index_in(:)
integer(psb_ipk_), allocatable, intent(inout) :: index_out(:) integer(psb_ipk_), allocatable, intent(inout) :: index_out(:)
logical :: glob_idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_crea_index end subroutine psi_i_crea_index
end interface end interface
@ -80,13 +79,12 @@ module psi_i_mod
interface psi_desc_index interface psi_desc_index
subroutine psi_i_desc_index(desc,index_in,dep_list,& subroutine psi_i_desc_index(desc,index_in,dep_list,&
& length_dl,nsnd,nrcv,desc_index,isglob_in,info) & length_dl,nsnd,nrcv,desc_index,info)
import import
type(psb_desc_type) :: desc type(psb_desc_type) :: desc
integer(psb_ipk_) :: index_in(:),dep_list(:) integer(psb_ipk_) :: index_in(:),dep_list(:)
integer(psb_ipk_),allocatable :: desc_index(:) integer(psb_ipk_),allocatable :: desc_index(:)
integer(psb_ipk_) :: length_dl,nsnd,nrcv integer(psb_ipk_) :: length_dl,nsnd,nrcv
logical :: isglob_in
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
end subroutine psi_i_desc_index end subroutine psi_i_desc_index
end interface end interface
@ -204,5 +202,6 @@ module psi_i_mod
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_bld_ovr_mst end subroutine psi_i_bld_ovr_mst
end interface end interface
end module psi_i_mod end module psi_i_mod

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

@ -30,13 +30,13 @@
! !
! !
module psi_l_mod module psi_l_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_ use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_
use psi_m_comm_a_mod use psi_m_comm_a_mod
use psi_e_comm_a_mod use psi_e_comm_a_mod
use psb_l_base_vect_mod, only : psb_l_base_vect_type use psb_l_base_vect_mod, only : psb_l_base_vect_type
use psb_l_base_multivect_mod, only : psb_l_base_multivect_type use psb_l_base_multivect_mod, only : psb_l_base_multivect_type
use psi_l_comm_v_mod use psi_l_comm_v_mod
end module psi_l_mod end module psi_l_mod

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

@ -30,12 +30,12 @@
! !
! !
module psi_s_mod module psi_s_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type
use psi_s_comm_a_mod use psi_s_comm_a_mod
use psb_s_base_vect_mod, only : psb_s_base_vect_type use psb_s_base_vect_mod, only : psb_s_base_vect_type
use psb_s_base_multivect_mod, only : psb_s_base_multivect_type use psb_s_base_multivect_mod, only : psb_s_base_multivect_type
use psi_s_comm_v_mod use psi_s_comm_v_mod
end module psi_s_mod end module psi_s_mod

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

@ -30,12 +30,12 @@
! !
! !
module psi_z_mod module psi_z_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
use psi_z_comm_a_mod use psi_z_comm_a_mod
use psb_z_base_vect_mod, only : psb_z_base_vect_type use psb_z_base_vect_mod, only : psb_z_base_vect_type
use psb_z_base_multivect_mod, only : psb_z_base_multivect_type use psb_z_base_multivect_mod, only : psb_z_base_multivect_type
use psi_z_comm_v_mod use psi_z_comm_v_mod
end module psi_z_mod end module psi_z_mod

67
base/modules/serial/psb_c_mat_mod.f90 → base/modules/serial/psb_c_mat_mod.F90
Unescape Escape View File

@ -127,7 +127,12 @@ module psb_c_mat_mod
procedure, pass(a) :: csgetptn => psb_c_csgetptn procedure, pass(a) :: csgetptn => psb_c_csgetptn
procedure, pass(a) :: csgetrow => psb_c_csgetrow procedure, pass(a) :: csgetrow => psb_c_csgetrow
procedure, pass(a) :: csgetblk => psb_c_csgetblk procedure, pass(a) :: csgetblk => psb_c_csgetblk
generic, public :: csget => csgetptn, csgetrow, csgetblk generic, public :: csget => csgetptn, csgetrow, csgetblk
#if defined(INT_I4_L8)
procedure, pass(a) :: lcsgetptn => psb_c_lcsgetptn
procedure, pass(a) :: lcsgetrow => psb_c_lcsgetrow
generic, public :: csget => lcsgetptn, lcsgetrow
#endif
procedure, pass(a) :: tril => psb_c_tril procedure, pass(a) :: tril => psb_c_tril
procedure, pass(a) :: triu => psb_c_triu procedure, pass(a) :: triu => psb_c_triu
procedure, pass(a) :: m_csclip => psb_c_csclip procedure, pass(a) :: m_csclip => psb_c_csclip
@ -1292,5 +1297,63 @@ contains
end subroutine psb_c_clean_zeros end subroutine psb_c_clean_zeros
#if defined(INT_I4_L8)
subroutine psb_c_lcsgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_c_lcsgetptn
subroutine psb_c_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_cspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
complex(psb_spk_), allocatable, intent(inout) :: val(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_c_lcsgetrow
#endif
end module psb_c_mat_mod end module psb_c_mat_mod

102
base/modules/serial/psb_c_vect_mod.F90
Unescape Escape View File

@ -193,24 +193,15 @@ contains
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
#else
mld = psb_c_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld class(psb_c_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
#else
mld = psb_c_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -253,25 +235,16 @@ contains
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_vect_default())
#else
mld = psb_c_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL' res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function c_vect_get_fmt end function c_vect_get_fmt
subroutine c_vect_all(n, x, info, mold) subroutine c_vect_all(n, x, info, mold)
implicit none implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_c_base_vect_type :: x%v,stat=info) allocate(psb_c_base_vect_type :: x%v,stat=info)
endif endif
@ -512,21 +482,22 @@ contains
class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold class(psb_c_base_vect_type), intent(in), optional :: mold
class(psb_c_base_vect_type), allocatable :: tmp class(psb_c_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info,mold=psb_c_get_base_vect_default())
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end subroutine c_vect_cnv end subroutine c_vect_cnv
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_c_base_multivect_type), pointer :: mld class(psb_c_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default())
#else
mld = psb_c_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -993,21 +956,12 @@ contains
class(psb_c_multivect_type), intent(out) :: x class(psb_c_multivect_type), intent(out) :: x
class(psb_c_base_multivect_type), intent(in), optional :: mold class(psb_c_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_c_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default())
#else
mld = psb_c_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_c_base_multivect_type :: x%v,stat=info) allocate(psb_c_base_multivect_type :: x%v,stat=info)
endif endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info, mold=psb_c_get_base_multivect_default())
#endif endif
if (allocated(x%v)) then if (allocated(x%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info) call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
call move_alloc(tmp,x%v)
end subroutine c_vect_cnv end subroutine c_vect_cnv

67
base/modules/serial/psb_d_mat_mod.f90 → base/modules/serial/psb_d_mat_mod.F90
Unescape Escape View File

@ -127,7 +127,12 @@ module psb_d_mat_mod
procedure, pass(a) :: csgetptn => psb_d_csgetptn procedure, pass(a) :: csgetptn => psb_d_csgetptn
procedure, pass(a) :: csgetrow => psb_d_csgetrow procedure, pass(a) :: csgetrow => psb_d_csgetrow
procedure, pass(a) :: csgetblk => psb_d_csgetblk procedure, pass(a) :: csgetblk => psb_d_csgetblk
generic, public :: csget => csgetptn, csgetrow, csgetblk generic, public :: csget => csgetptn, csgetrow, csgetblk
#if defined(INT_I4_L8)
procedure, pass(a) :: lcsgetptn => psb_d_lcsgetptn
procedure, pass(a) :: lcsgetrow => psb_d_lcsgetrow
generic, public :: csget => lcsgetptn, lcsgetrow
#endif
procedure, pass(a) :: tril => psb_d_tril procedure, pass(a) :: tril => psb_d_tril
procedure, pass(a) :: triu => psb_d_triu procedure, pass(a) :: triu => psb_d_triu
procedure, pass(a) :: m_csclip => psb_d_csclip procedure, pass(a) :: m_csclip => psb_d_csclip
@ -1292,5 +1297,63 @@ contains
end subroutine psb_d_clean_zeros end subroutine psb_d_clean_zeros
#if defined(INT_I4_L8)
subroutine psb_d_lcsgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_d_lcsgetptn
subroutine psb_d_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_dspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
real(psb_dpk_), allocatable, intent(inout) :: val(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_d_lcsgetrow
#endif
end module psb_d_mat_mod end module psb_d_mat_mod

102
base/modules/serial/psb_d_vect_mod.F90
Unescape Escape View File

@ -193,24 +193,15 @@ contains
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
#else
mld = psb_d_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld class(psb_d_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
#else
mld = psb_d_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -253,25 +235,16 @@ contains
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_vect_default())
#else
mld = psb_d_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL' res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function d_vect_get_fmt end function d_vect_get_fmt
subroutine d_vect_all(n, x, info, mold) subroutine d_vect_all(n, x, info, mold)
implicit none implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_d_base_vect_type :: x%v,stat=info) allocate(psb_d_base_vect_type :: x%v,stat=info)
endif endif
@ -512,21 +482,22 @@ contains
class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold class(psb_d_base_vect_type), intent(in), optional :: mold
class(psb_d_base_vect_type), allocatable :: tmp class(psb_d_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info,mold=psb_d_get_base_vect_default())
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end subroutine d_vect_cnv end subroutine d_vect_cnv
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_d_base_multivect_type), pointer :: mld class(psb_d_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default())
#else
mld = psb_d_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -993,21 +956,12 @@ contains
class(psb_d_multivect_type), intent(out) :: x class(psb_d_multivect_type), intent(out) :: x
class(psb_d_base_multivect_type), intent(in), optional :: mold class(psb_d_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_d_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default())
#else
mld = psb_d_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_d_base_multivect_type :: x%v,stat=info) allocate(psb_d_base_multivect_type :: x%v,stat=info)
endif endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info, mold=psb_d_get_base_multivect_default())
#endif endif
if (allocated(x%v)) then if (allocated(x%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info) call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
call move_alloc(tmp,x%v)
end subroutine d_vect_cnv end subroutine d_vect_cnv

102
base/modules/serial/psb_i_vect_mod.F90
Unescape Escape View File

@ -166,24 +166,15 @@ contains
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
#else
mld = psb_i_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -198,23 +189,14 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld class(psb_i_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
#else
mld = psb_i_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -226,25 +208,16 @@ contains
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_vect_default())
#else
mld = psb_i_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -325,6 +298,7 @@ contains
res = 'NULL' res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function i_vect_get_fmt end function i_vect_get_fmt
subroutine i_vect_all(n, x, info, mold) subroutine i_vect_all(n, x, info, mold)
implicit none implicit none
@ -337,11 +311,7 @@ contains
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_i_base_vect_type :: x%v,stat=info) allocate(psb_i_base_vect_type :: x%v,stat=info)
endif endif
@ -485,21 +455,22 @@ contains
class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold class(psb_i_base_vect_type), intent(in), optional :: mold
class(psb_i_base_vect_type), allocatable :: tmp class(psb_i_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info,mold=psb_i_get_base_vect_default())
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end subroutine i_vect_cnv end subroutine i_vect_cnv
@ -697,19 +668,11 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_i_base_multivect_type), pointer :: mld class(psb_i_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default())
#else
mld = psb_i_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -722,21 +685,12 @@ contains
class(psb_i_multivect_type), intent(out) :: x class(psb_i_multivect_type), intent(out) :: x
class(psb_i_base_multivect_type), intent(in), optional :: mold class(psb_i_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_i_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default())
#else
mld = psb_i_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n)
@ -833,11 +787,7 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_i_base_multivect_type :: x%v,stat=info) allocate(psb_i_base_multivect_type :: x%v,stat=info)
endif endif
@ -996,18 +946,16 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info, mold=psb_i_get_base_multivect_default())
#endif endif
if (allocated(x%v)) then if (allocated(x%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info) call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
call move_alloc(tmp,x%v)
end subroutine i_vect_cnv end subroutine i_vect_cnv

102
base/modules/serial/psb_l_vect_mod.F90
Unescape Escape View File

@ -167,24 +167,15 @@ contains
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
#else
mld = psb_l_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -199,23 +190,14 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld class(psb_l_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
#else
mld = psb_l_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -227,25 +209,16 @@ contains
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_vect_default())
#else
mld = psb_l_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -326,6 +299,7 @@ contains
res = 'NULL' res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function l_vect_get_fmt end function l_vect_get_fmt
subroutine l_vect_all(n, x, info, mold) subroutine l_vect_all(n, x, info, mold)
implicit none implicit none
@ -338,11 +312,7 @@ contains
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_l_base_vect_type :: x%v,stat=info) allocate(psb_l_base_vect_type :: x%v,stat=info)
endif endif
@ -486,21 +456,22 @@ contains
class(psb_l_vect_type), intent(inout) :: x class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold class(psb_l_base_vect_type), intent(in), optional :: mold
class(psb_l_base_vect_type), allocatable :: tmp class(psb_l_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info,mold=psb_l_get_base_vect_default())
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end subroutine l_vect_cnv end subroutine l_vect_cnv
@ -698,19 +669,11 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_l_base_multivect_type), pointer :: mld class(psb_l_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default())
#else
mld = psb_l_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -723,21 +686,12 @@ contains
class(psb_l_multivect_type), intent(out) :: x class(psb_l_multivect_type), intent(out) :: x
class(psb_l_base_multivect_type), intent(in), optional :: mold class(psb_l_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_l_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default())
#else
mld = psb_l_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n)
@ -834,11 +788,7 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_l_base_multivect_type :: x%v,stat=info) allocate(psb_l_base_multivect_type :: x%v,stat=info)
endif endif
@ -997,18 +947,16 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info, mold=psb_l_get_base_multivect_default())
#endif endif
if (allocated(x%v)) then if (allocated(x%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info) call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
call move_alloc(tmp,x%v)
end subroutine l_vect_cnv end subroutine l_vect_cnv

20
base/modules/serial/psb_mat_mod.f90
Unescape Escape View File

@ -3,4 +3,24 @@ module psb_mat_mod
use psb_d_mat_mod use psb_d_mat_mod
use psb_c_mat_mod use psb_c_mat_mod
use psb_z_mat_mod use psb_z_mat_mod
contains
subroutine psb_init_mat_defaults()
implicit none
!
! Defaults for matrices
!
type(psb_s_csr_sparse_mat) :: smatdef
type(psb_d_csr_sparse_mat) :: dmatdef
type(psb_c_csr_sparse_mat) :: cmatdef
type(psb_z_csr_sparse_mat) :: zmatdef
call psb_set_mat_default(smatdef)
call psb_set_mat_default(dmatdef)
call psb_set_mat_default(cmatdef)
call psb_set_mat_default(zmatdef)
end subroutine psb_init_mat_defaults
end module psb_mat_mod end module psb_mat_mod

67
base/modules/serial/psb_s_mat_mod.f90 → base/modules/serial/psb_s_mat_mod.F90
Unescape Escape View File

@ -127,7 +127,12 @@ module psb_s_mat_mod
procedure, pass(a) :: csgetptn => psb_s_csgetptn procedure, pass(a) :: csgetptn => psb_s_csgetptn
procedure, pass(a) :: csgetrow => psb_s_csgetrow procedure, pass(a) :: csgetrow => psb_s_csgetrow
procedure, pass(a) :: csgetblk => psb_s_csgetblk procedure, pass(a) :: csgetblk => psb_s_csgetblk
generic, public :: csget => csgetptn, csgetrow, csgetblk generic, public :: csget => csgetptn, csgetrow, csgetblk
#if defined(INT_I4_L8)
procedure, pass(a) :: lcsgetptn => psb_s_lcsgetptn
procedure, pass(a) :: lcsgetrow => psb_s_lcsgetrow
generic, public :: csget => lcsgetptn, lcsgetrow
#endif
procedure, pass(a) :: tril => psb_s_tril procedure, pass(a) :: tril => psb_s_tril
procedure, pass(a) :: triu => psb_s_triu procedure, pass(a) :: triu => psb_s_triu
procedure, pass(a) :: m_csclip => psb_s_csclip procedure, pass(a) :: m_csclip => psb_s_csclip
@ -1292,5 +1297,63 @@ contains
end subroutine psb_s_clean_zeros end subroutine psb_s_clean_zeros
#if defined(INT_I4_L8)
subroutine psb_s_lcsgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_s_lcsgetptn
subroutine psb_s_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_sspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
real(psb_spk_), allocatable, intent(inout) :: val(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_s_lcsgetrow
#endif
end module psb_s_mat_mod end module psb_s_mat_mod

102
base/modules/serial/psb_s_vect_mod.F90
Unescape Escape View File

@ -193,24 +193,15 @@ contains
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
#else
mld = psb_s_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld class(psb_s_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
#else
mld = psb_s_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -253,25 +235,16 @@ contains
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_vect_default())
#else
mld = psb_s_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL' res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function s_vect_get_fmt end function s_vect_get_fmt
subroutine s_vect_all(n, x, info, mold) subroutine s_vect_all(n, x, info, mold)
implicit none implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_s_base_vect_type :: x%v,stat=info) allocate(psb_s_base_vect_type :: x%v,stat=info)
endif endif
@ -512,21 +482,22 @@ contains
class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold class(psb_s_base_vect_type), intent(in), optional :: mold
class(psb_s_base_vect_type), allocatable :: tmp class(psb_s_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info,mold=psb_s_get_base_vect_default())
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end subroutine s_vect_cnv end subroutine s_vect_cnv
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_s_base_multivect_type), pointer :: mld class(psb_s_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default())
#else
mld = psb_s_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -993,21 +956,12 @@ contains
class(psb_s_multivect_type), intent(out) :: x class(psb_s_multivect_type), intent(out) :: x
class(psb_s_base_multivect_type), intent(in), optional :: mold class(psb_s_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_s_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default())
#else
mld = psb_s_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_s_base_multivect_type :: x%v,stat=info) allocate(psb_s_base_multivect_type :: x%v,stat=info)
endif endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info, mold=psb_s_get_base_multivect_default())
#endif endif
if (allocated(x%v)) then if (allocated(x%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info) call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
call move_alloc(tmp,x%v)
end subroutine s_vect_cnv end subroutine s_vect_cnv

10
base/modules/serial/psb_serial_mod.f90
Unescape Escape View File

@ -68,6 +68,16 @@ module psb_serial_mod
end subroutine psb_d_nspaxpby end subroutine psb_d_nspaxpby
end interface psb_nspaxpby end interface psb_nspaxpby
interface symbmm
subroutine symbmm (n, m, l, ia, ja, diaga, &
& ib, jb, diagb, ic, jc, diagc, index)
import :: psb_ipk_
integer(psb_ipk_) :: n,m,l, ia(*), ja(*), diaga, ib(*), jb(*), diagb,&
& diagc, index(*)
integer(psb_ipk_), allocatable :: ic(:),jc(:)
end subroutine symbmm
end interface
contains contains

25
base/modules/serial/psb_vect_mod.f90
Unescape Escape View File

@ -11,4 +11,29 @@ module psb_vect_mod
use psb_d_multivect_mod use psb_d_multivect_mod
use psb_c_multivect_mod use psb_c_multivect_mod
use psb_z_multivect_mod use psb_z_multivect_mod
contains
subroutine psb_init_vect_defaults()
implicit none
!
! Defaults for vectors
!
type(psb_i_base_vect_type) :: ivetdef
type(psb_l_base_vect_type) :: lvetdef
type(psb_s_base_vect_type) :: svetdef
type(psb_d_base_vect_type) :: dvetdef
type(psb_c_base_vect_type) :: cvetdef
type(psb_z_base_vect_type) :: zvetdef
call psb_set_vect_default(ivetdef)
call psb_set_vect_default(lvetdef)
call psb_set_vect_default(svetdef)
call psb_set_vect_default(dvetdef)
call psb_set_vect_default(cvetdef)
call psb_set_vect_default(zvetdef)
end subroutine psb_init_vect_defaults
end module psb_vect_mod end module psb_vect_mod

67
base/modules/serial/psb_z_mat_mod.f90 → base/modules/serial/psb_z_mat_mod.F90
Unescape Escape View File

@ -127,7 +127,12 @@ module psb_z_mat_mod
procedure, pass(a) :: csgetptn => psb_z_csgetptn procedure, pass(a) :: csgetptn => psb_z_csgetptn
procedure, pass(a) :: csgetrow => psb_z_csgetrow procedure, pass(a) :: csgetrow => psb_z_csgetrow
procedure, pass(a) :: csgetblk => psb_z_csgetblk procedure, pass(a) :: csgetblk => psb_z_csgetblk
generic, public :: csget => csgetptn, csgetrow, csgetblk generic, public :: csget => csgetptn, csgetrow, csgetblk
#if defined(INT_I4_L8)
procedure, pass(a) :: lcsgetptn => psb_z_lcsgetptn
procedure, pass(a) :: lcsgetrow => psb_z_lcsgetrow
generic, public :: csget => lcsgetptn, lcsgetrow
#endif
procedure, pass(a) :: tril => psb_z_tril procedure, pass(a) :: tril => psb_z_tril
procedure, pass(a) :: triu => psb_z_triu procedure, pass(a) :: triu => psb_z_triu
procedure, pass(a) :: m_csclip => psb_z_csclip procedure, pass(a) :: m_csclip => psb_z_csclip
@ -1292,5 +1297,63 @@ contains
end subroutine psb_z_clean_zeros end subroutine psb_z_clean_zeros
#if defined(INT_I4_L8)
subroutine psb_z_lcsgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_z_lcsgetptn
subroutine psb_z_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
implicit none
class(psb_zspmat_type), intent(in) :: a
integer(psb_ipk_), intent(in) :: imin,imax
integer(psb_ipk_), intent(out) :: nz
integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:)
complex(psb_dpk_), allocatable, intent(inout) :: val(:)
integer(psb_ipk_),intent(out) :: info
logical, intent(in), optional :: append
integer(psb_ipk_), intent(in), optional :: iren(:)
integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
! Local
integer(psb_ipk_), allocatable :: lia(:), lja(:)
if (allocated(ia)) then
lia = ia
end if
if (allocated(ja)) then
lja = ja
end if
call a%csget(imin,imax,nz,lia,lja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
ia = lia
ja = lja
end subroutine psb_z_lcsgetrow
#endif
end module psb_z_mat_mod end module psb_z_mat_mod

102
base/modules/serial/psb_z_vect_mod.F90
Unescape Escape View File

@ -193,24 +193,15 @@ contains
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
#else
mld = psb_z_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld class(psb_z_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
#else
mld = psb_z_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -253,25 +235,16 @@ contains
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) & if (allocated(x%v)) &
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_vect_default())
#else
mld = psb_z_get_base_vect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(n) if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL' res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt() if (allocated(x%v)) res = x%v%get_fmt()
end function z_vect_get_fmt end function z_vect_get_fmt
subroutine z_vect_all(n, x, info, mold) subroutine z_vect_all(n, x, info, mold)
implicit none implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info) & call x%free(info)
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_z_base_vect_type :: x%v,stat=info) allocate(psb_z_base_vect_type :: x%v,stat=info)
endif endif
@ -512,21 +482,22 @@ contains
class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold class(psb_z_base_vect_type), intent(in), optional :: mold
class(psb_z_base_vect_type), allocatable :: tmp class(psb_z_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info,mold=psb_z_get_base_vect_default())
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end subroutine z_vect_cnv end subroutine z_vect_cnv
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_z_base_multivect_type), pointer :: mld class(psb_z_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default())
#else
mld = psb_z_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(invect) if (info == psb_success_) call x%v%bld(invect)
@ -993,21 +956,12 @@ contains
class(psb_z_multivect_type), intent(out) :: x class(psb_z_multivect_type), intent(out) :: x
class(psb_z_base_multivect_type), intent(in), optional :: mold class(psb_z_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
class(psb_z_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default()) allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default())
#else
mld = psb_z_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif endif
if (info == psb_success_) call x%v%bld(m,n) if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold) allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else else
allocate(psb_z_base_multivect_type :: x%v,stat=info) allocate(psb_z_base_multivect_type :: x%v,stat=info)
endif endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
if (present(mold)) then if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold) allocate(tmp,stat=info,mold=mold)
#else else
call mold%mold(tmp,info) allocate(tmp,stat=info, mold=psb_z_get_base_multivect_default())
#endif endif
if (allocated(x%v)) then if (allocated(x%v)) then
call x%v%sync() call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v) if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info) call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if end if
call move_alloc(tmp,x%v)
end subroutine z_vect_cnv end subroutine z_vect_cnv

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save