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
all: libd based precd kryld utild cbindd
all: libd based precd kryld utild
@echo "====================================="
@echo "PSBLAS libraries Compilation Successful."
#cbindd
based: libd
precd utild: 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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_cgather_multivect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_spk_), allocatable :: llocx(:,:)
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, &
& ilx, i, j, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_cgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_chalov(x,desc_a,info,work,tran,mode,data)
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_chalov(x,desc_a,info,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& k, update_, mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_covrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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, &
& col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_cscatterm(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k
! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root)
! locals
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
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_cscatterv(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter
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
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_) :: ip,naggrm1,naggrp1, i, j, k, nzl
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)
end if
nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I')
call psb_realloc(nzl,locia,info)
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(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np))
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_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@ -117,24 +123,33 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
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)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_dpk_), allocatable :: llocx(:,:)
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, &
& ilx, i, j, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data)
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& k, update_, mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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, &
& col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k
! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root)
! locals
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
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter
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
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_) :: ip,naggrm1,naggrp1, i, j, k, nzl
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)
end if
nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I')
call psb_realloc(nzl,locia,info)
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(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np))
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_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@ -117,24 +123,33 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
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)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, &
& ilx, i, j, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_egatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
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
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
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data)
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& k, update_, mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_epk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_eovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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, &
& col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_escatterm(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k
! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root)
! locals
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
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_escatterv(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_ipk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_ipk_), allocatable :: llocx(:,:)
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
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_) :: ip,naggrm1,naggrp1, i, j, k, nzl
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)
end if
nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I')
call psb_realloc(nzl,locia,info)
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(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np))
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_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@ -117,24 +123,33 @@ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
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)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_lpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_lgather_multivect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
integer(psb_lpk_), allocatable :: llocx(:,:)
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
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_) :: ip,naggrm1,naggrp1, i, j, k, nzl
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)
end if
nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I')
call psb_realloc(nzl,locia,info)
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(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np))
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_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@ -117,24 +123,33 @@ subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
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)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, &
& ilx, i, j, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_mgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
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
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
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data)
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& k, update_, mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_mpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_movrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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, &
& col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_mscatterm(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k
! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root)
! locals
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
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_mscatterv(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_spk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
real(psb_spk_), allocatable :: llocx(:,:)
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, &
& ilx, i, j, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_sgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_shalov(x,desc_a,info,work,tran,mode,data)
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_shalov(x,desc_a,info,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& k, update_, mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_sovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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, &
& col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_sscatterm(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k
! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root)
! locals
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
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_sscatterv(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter
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
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_) :: ip,naggrm1,naggrp1, i, j, k, nzl
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)
end if
nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I')
call psb_realloc(nzl,locia,info)
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(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np))
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_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@ -117,24 +123,33 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,&
& psb_mpi_r_spk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
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)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_dpk_), allocatable :: llocx(:)
character(len=20) :: name, ch_err
@ -171,8 +171,8 @@ subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i
integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx
complex(psb_dpk_), allocatable :: llocx(:,:)
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
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, &
& ilx, i, j, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
character(len=20) :: name, ch_err
@ -230,8 +230,9 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot)
! locals
integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank
integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx
integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,&
& maxk, k, jlx, ilx, i, j
integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -119,7 +119,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me,&
& err_act, m, n, iix, jjx, ix, ijx, nrow, imode,&
& err, liwork,data_
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, &
& nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -258,7 +258,7 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
endif
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
character :: tran_
character(len=20) :: name, ch_err
@ -129,7 +130,7 @@ subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
ch_err='psb_chkvect'
@ -273,8 +274,8 @@ subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data)
! locals
integer(psb_mpk_) :: ictxt, np, me
integer(psb_ipk_) :: err_act, ldx, &
& m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_
integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
@ -319,7 +320,7 @@ subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data)
endif
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork,ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, &
& nrow, imode, err, liwork,data_, update_, mode_, ncol
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
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)
! 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
info=psb_err_from_subroutine_
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
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
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:), xp(:,:)
logical :: do_swap
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)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
! locals
integer(psb_ipk_) :: ictxt, np, me, &
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
& mode_, err, liwork, ldx
integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, &
& k, update_, mode_, err, liwork, ldx
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
@ -318,7 +319,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update,mode)
do_swap = (mode_ /= 0)
ldx = size(x,1)
! 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
info=psb_err_from_subroutine_
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
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, &
& col,pos
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
name='psb_scatterm'
@ -185,8 +187,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
do col=1, k
! prepare vector to scatter
@ -299,10 +301,12 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root)
! locals
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
integer(psb_lpk_) :: m, n, i, j, iglobx, jglobx
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
integer(psb_ipk_) :: debug_level, debug_unit
@ -417,8 +421,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, root)
end if
call mpi_gatherv(ltg,nrow,&
& psb_mpi_ipk_,l_t_g_all,all_dim,&
& displ,psb_mpi_ipk_,rootrank,icomm,info)
& psb_mpi_lpk_,l_t_g_all,all_dim,&
& displ,psb_mpi_lpk_,rootrank,icomm,info)
! prepare vector to scatter
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
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_) :: ip,naggrm1,naggrp1, i, j, k, nzl
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)
end if
nzl = loc_coo%get_nzeros()
call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I')
call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I')
call psb_realloc(nzl,locia,info)
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(me+1) = nzl
call psb_sum(ictxt,nzbr(1:np))
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_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
@ -117,24 +123,33 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep
& glob_coo%val,nzbr,idisp,&
& psb_mpi_c_dpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_,&
& glob_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locia,ndx,psb_mpi_lpk_,&
& glbia,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo == psb_success_) call &
& mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_,&
& glob_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_,icomm,minfo)
& mpi_allgatherv(locja,ndx,psb_mpi_lpk_,&
& glbja,nzbr,idisp,&
& psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
info = minfo
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
end if
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)
if (present(dupl)) call glob_coo%set_dupl(dupl)
call globa%mv_from(glob_coo)
deallocate(glbia,glbja, stat=info)
else
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 \
psi_crea_ovr_elem.o psi_bld_tmpovrl.o psi_dl_check.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 \
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
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), allocatable :: helem(:),hproc(:),&
& answers(:,:),idxsrch(:,:), hhidx(:)
integer(psb_lpk_), allocatable :: answers(:,:), idxsrch(:,:), hproc(:)
integer(psb_ipk_), allocatable :: helem(:), hhidx(:)
integer(psb_mpk_), allocatable :: hsz(:),hidx(:), &
& sdsz(:),sdidx(:), rvsz(:), rvidx(:)
integer(psb_mpk_) :: icomm, minfo, iictxt
integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,hsize,ip,isz,k,j,&
& last_ih, last_j, nv, mglob
integer(psb_ipk_) :: i,n_row,n_col,err_act,hsize,ip,isz,j, k,&
& last_ih, last_j, nv
integer(psb_lpk_) :: mglob, ih
integer(psb_ipk_) :: ictxt,np,me, nresp
logical, parameter :: gettime=.false.
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()
end if
call mpi_allgatherv(idx,hsz(me+1),psb_mpi_ipk_,&
& hproc,hsz,hidx,psb_mpi_ipk_,&
call mpi_allgatherv(idx,hsz(me+1),psb_mpi_lpk_,&
& hproc,hsz,hidx,psb_mpi_lpk_,&
& icomm,minfo)
if (gettime) then
tamx = psb_wtime() - t3
@ -228,8 +229,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
rvidx(ip) = j
j = j + rvsz(ip)
end do
call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_,&
& answers(:,1),rvsz,rvidx,psb_mpi_ipk_,&
call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_lpk_,&
& answers(:,1),rvsz,rvidx,psb_mpi_lpk_,&
& icomm,minfo)
if (gettime) then
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, &
& 'not found : ',size(answers,1),':',answers(:,1)
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
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
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_) :: 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
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_) :: 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)
if (.true.) then
if (j>=0) then
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 (j>=0) then
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)
bndel(j+1) = -1
endif
else
if (allocated(bndel)) then
deallocate(bndel)
end if
end if
deallocate(work)
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
!
!
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_desc_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(in) :: index_in(:)
integer(psb_ipk_), allocatable, intent(inout) :: index_out(:)
logical :: glob_idx
! ....local scalars...
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'
! Do the actual format conversion.
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_) &
& write(debug_unit,*) me,' ',trim(name),': out of psi_desc_index',&
& 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_) :: 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_), 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
! ....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
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), optional, intent(in) :: mold
! ....local scalars....
@ -102,7 +102,7 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
! first the halo index
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',&
& 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
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999
@ -115,7 +115,7 @@ subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
! then ext index
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
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
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'
! 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
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
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'
call psi_bld_ovr_mst(me,cdesc%ovrlap_elem,tmp_mst_idx,info)
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 (info /= psb_success_) then
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.
! index_in(:) - integer The index list, build format
! index_out(:) - integer(psb_ipk_), allocatable The index list, assembled format
! glob_idx - logical Whether the input indices are in local or global
! numbering; the global numbering is used when
! converting the overlap exchange lists.
! 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
! 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
!
@ -99,7 +96,7 @@
!
!
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_realloc_mod
use psb_error_mod
@ -116,17 +113,17 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
! ...array parameters.....
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_) :: length_dl,nsnd,nrcv,info
logical :: isglob_in
! ....local scalars...
integer(psb_ipk_) :: j,me,np,i,proc
! ...parameters...
integer(psb_ipk_) :: ictxt
integer(psb_ipk_), parameter :: no_comm=-1
! ...local arrays..
integer(psb_ipk_),allocatable :: sndbuf(:), rcvbuf(:)
integer(psb_lpk_),allocatable :: sndbuf(:), rcvbuf(:)
integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:),&
& 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
!
if (isglob_in) then
do j=1, nerv
sndbuf(bsdindx(proc+1)+j) = (index_in(i+j))
end do
else
call desc%indxmap%l2g(index_in(i+1:i+nerv),&
& sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),&
& info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g')
goto 9999
end if
endif
call desc%indxmap%l2g(index_in(i+1:i+nerv),&
& sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),&
& info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='l2g')
goto 9999
end if
bsdindx(proc+1) = bsdindx(proc+1) + nerv
i = i + nerv + 1
end do
@ -292,8 +282,8 @@ subroutine psi_i_desc_index(desc,index_in,dep_list,&
idxr = idxr + rvsz(proc+1)
end do
call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_ipk_,&
& rcvbuf,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo)
call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_lpk_,&
& rcvbuf,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo)
if (minfo /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv')
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
! ....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(:)
! .....local arrays....
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'
#endif
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(:)
type(psb_desc_type), intent(in) :: desc
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
$(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
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_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_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_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
@ -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_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_indx_map_mod.o desc/psb_desc_const_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)
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 $@
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
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
@INTE@
interface psb_msort_unique
subroutine psb_cmsort_u(x,nout,dir)
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
@INTE@
interface psb_msort_unique
subroutine psb_dmsort_u(x,nout,dir)
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
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
module procedure HashTransfer
end interface
@ -535,4 +539,44 @@ contains
end do
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

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 interface psb_isaperm
interface psb_msort_unique
subroutine psb_imsort_u(x,nout,dir)
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 interface psb_isaperm
interface psb_msort_unique
subroutine psb_lmsort_u(x,nout,dir)
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
@INTE@
interface psb_msort_unique
subroutine psb_smsort_u(x,nout,dir)
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
@INTE@
interface psb_msort_unique
subroutine psb_zmsort_u(x,nout,dir)
import

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

@ -35,7 +35,7 @@
! Auxiliary module for descriptor: constant values.
!
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
!
@ -121,8 +121,9 @@ module psb_desc_const_mod
interface
subroutine psb_parts(glob_index,nrow,np,pv,nv)
import :: psb_ipk_
integer(psb_ipk_), intent (in) :: glob_index,nrow, np
import :: psb_ipk_, psb_lpk_
integer(psb_lpk_), intent (in) :: glob_index,nrow
integer(psb_ipk_), intent (in) :: np
integer(psb_ipk_), intent (out) :: nv, pv(*)
end subroutine psb_parts
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.
!
! 8. When the descriptor is in the BLD state the INDEX vectors contains only
! the indices to be received, organized as a sequence
! of entries of the form (proc,N,(lx1,lx2,...,lxn)) with owning process,
! number of indices (most often but not necessarily N=1), list of local indices.
! the indices to be received, organized as a sequence of entries of
! the form (proc,N,(lx1,lx2,...,lxn)) with owning process, number of 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
! 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
@ -334,11 +334,13 @@ contains
val = cd_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
implicit none
integer(psb_ipk_), intent(in) :: ictxt,m
integer(psb_ipk_), intent(in) :: ictxt
integer(psb_lpk_), intent(in) :: m
logical :: val
!locals
integer(psb_ipk_) :: np,me
@ -348,8 +350,7 @@ contains
! it makes no sense to use them if you don't have at least
! 3 processes, no matter what the size of the process.
!
psb_cd_choose_large_state = &
& (m > psb_cd_get_large_threshold()) .and. &
val = (m > psb_cd_get_large_threshold()) .and. &
& (np > 2)
end function psb_cd_choose_large_state
@ -475,7 +476,7 @@ contains
function psb_cd_get_global_rows(desc) result(val)
implicit none
integer(psb_ipk_) :: val
integer(psb_lpk_) :: val
class(psb_desc_type), intent(in) :: desc
if (allocated(desc%indxmap)) then
@ -488,7 +489,7 @@ contains
function psb_cd_get_global_cols(desc) result(val)
implicit none
integer(psb_ipk_) :: val
integer(psb_lpk_) :: val
class(psb_desc_type), intent(in) :: desc
if (allocated(desc%indxmap)) then
@ -501,7 +502,7 @@ contains
function psb_cd_get_global_indices(desc,owned) result(val)
implicit none
integer(psb_ipk_), allocatable :: val(:)
integer(psb_lpk_), allocatable :: val(:)
class(psb_desc_type), intent(in) :: desc
logical, intent(in), optional :: owned
@ -1072,8 +1073,7 @@ contains
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_penv_mod
use psb_realloc_mod
@ -1082,12 +1082,11 @@ contains
integer(psb_ipk_), intent(in) :: data
Type(psb_desc_type), Intent(in), target :: desc
integer(psb_ipk_), intent(out) :: info
logical, intent(in) :: toglob
! .. Local Scalars ..
integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,&
& idx, gidx, proc, n_elem_send, n_elem_recv
integer(psb_ipk_), pointer :: idxlist(:)
& idx, proc, n_elem_send, n_elem_recv
integer(psb_ipk_), pointer :: idxlist(:)
integer(psb_ipk_) :: debug_level, debug_unit, err_act
character(len=20) :: name
@ -1135,29 +1134,16 @@ contains
Do j=0,n_elem_recv-1
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
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
if (toglob) then
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
else
tmp(outcnt) = proc
tmp(outcnt+1) = 1
tmp(outcnt+2) = idx
tmp(outcnt+3) = -1
end if
tmp(outcnt) = proc
tmp(outcnt+1) = 1
tmp(outcnt+2) = idx
tmp(outcnt+3) = -1
outcnt = outcnt+3
end Do
incnt = incnt+n_elem_recv+n_elem_send+3
@ -1171,6 +1157,100 @@ contains
return
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)
class(psb_desc_type), intent(inout), target :: desc
@ -1188,7 +1268,7 @@ contains
use psb_error_mod
implicit none
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
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
@ -1199,7 +1279,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1223,7 +1303,7 @@ contains
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
@ -1236,7 +1316,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1259,7 +1339,7 @@ contains
use psb_error_mod
implicit none
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
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@ -1271,7 +1351,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1294,7 +1374,7 @@ contains
implicit none
class(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@ -1306,7 +1386,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1329,7 +1409,7 @@ contains
use psb_error_mod
implicit none
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
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
@ -1341,7 +1421,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1363,7 +1443,7 @@ contains
use psb_error_mod
implicit none
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) :: info
logical, intent(in), optional :: mask
@ -1377,7 +1457,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1400,7 +1480,7 @@ contains
use psb_error_mod
implicit none
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
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@ -1412,7 +1492,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1434,7 +1514,7 @@ contains
use psb_error_mod
implicit none
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) :: info
logical, intent(in), optional :: mask(:)
@ -1449,7 +1529,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1473,7 +1553,7 @@ contains
use psb_error_mod
implicit none
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
logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx
@ -1485,7 +1565,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1507,7 +1587,7 @@ contains
use psb_error_mod
implicit none
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) :: info
logical, intent(in), optional :: mask
@ -1522,7 +1602,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1545,7 +1625,7 @@ contains
use psb_error_mod
implicit none
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
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
@ -1559,7 +1639,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1581,7 +1661,7 @@ contains
use psb_error_mod
implicit none
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) :: info
logical, intent(in), optional :: mask(:)
@ -1596,7 +1676,7 @@ contains
call psb_erractionsave(err_act)
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
info = psb_err_invalid_cd_state_
end if
@ -1618,7 +1698,7 @@ contains
subroutine cd_fnd_owner(idx,iprc,desc,info)
use psb_error_mod
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_desc_type), intent(in) :: desc
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_sort_mod
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_glist_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: ictxt, iam, np
integer(psb_ipk_) :: nv, i, ngp
integer(psb_lpk_) :: nv, i, ngp
ictxt = idxmap%get_ctxt()
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
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
contains
@ -78,20 +79,20 @@ module psb_hash_map_mod
procedure, nopass :: row_extendable => hash_row_extendable
procedure, pass(idxmap) :: l2gs1 => hash_l2gs1
procedure, pass(idxmap) :: l2gs2 => hash_l2gs2
procedure, pass(idxmap) :: l2gv1 => hash_l2gv1
procedure, pass(idxmap) :: l2gv2 => hash_l2gv2
procedure, pass(idxmap) :: ll2gs1 => hash_l2gs1
procedure, pass(idxmap) :: ll2gs2 => hash_l2gs2
procedure, pass(idxmap) :: ll2gv1 => hash_l2gv1
procedure, pass(idxmap) :: ll2gv2 => hash_l2gv2
procedure, pass(idxmap) :: g2ls1 => hash_g2ls1
procedure, pass(idxmap) :: g2ls2 => hash_g2ls2
procedure, pass(idxmap) :: g2lv1 => hash_g2lv1
procedure, pass(idxmap) :: g2lv2 => hash_g2lv2
procedure, pass(idxmap) :: lg2ls1 => hash_g2ls1
procedure, pass(idxmap) :: lg2ls2 => hash_g2ls2
procedure, pass(idxmap) :: lg2lv1 => hash_g2lv1
procedure, pass(idxmap) :: lg2lv2 => hash_g2lv2
procedure, pass(idxmap) :: g2ls1_ins => hash_g2ls1_ins
procedure, pass(idxmap) :: g2ls2_ins => hash_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => hash_g2lv1_ins
procedure, pass(idxmap) :: g2lv2_ins => hash_g2lv2_ins
procedure, pass(idxmap) :: lg2ls1_ins => hash_g2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => hash_g2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => hash_g2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => hash_g2lv2_ins
procedure, pass(idxmap) :: hash_cpy
generic, public :: assignment(=) => hash_cpy
@ -159,11 +160,11 @@ contains
subroutine hash_l2gs1(idx,idxmap,info,mask,owned)
implicit none
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
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
@ -179,13 +180,21 @@ contains
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%l2gip(idxout,info,mask,owned)
integer(psb_lpk_) :: idxv(1)
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
@ -193,7 +202,7 @@ contains
subroutine hash_l2gv1(idx,idxmap,info,mask,owned)
implicit none
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
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@ -249,7 +258,7 @@ contains
implicit none
class(psb_hash_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
@ -270,11 +279,11 @@ contains
subroutine hash_g2ls1(idx,idxmap,info,mask,owned)
implicit none
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
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
@ -290,14 +299,21 @@ contains
subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none
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) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_lpk_) :: idxv(1)
info = 0
idxout = idxin
call idxmap%g2lip(idxout,info,mask,owned)
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 hash_g2ls2
@ -307,11 +323,12 @@ contains
use psb_sort_mod
implicit none
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
logical, intent(in), optional :: mask(:)
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
logical :: owned_
@ -358,8 +375,10 @@ contains
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm)
if (lip < 0) &
& call psb_hash_searchkey(ip,lip,idxmap%hash,info)
if (lip < 0) then
call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then
if (lip<=nrow) then
idx(i) = lip
@ -394,8 +413,10 @@ contains
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm)
if (lip < 0) &
& call psb_hash_searchkey(ip,lip,idxmap%hash,info)
if (lip < 0) then
call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then
if (lip<=nrow) then
idx(i) = lip
@ -419,20 +440,23 @@ contains
end subroutine hash_g2lv1
subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned)
use psb_realloc_mod
implicit none
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) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
integer(psb_lpk_), allocatable :: tidx(:)
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
call psb_realloc(im,tidx,info)
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
write(0,*) 'g2lv2 err -3'
info = -3
@ -447,12 +471,13 @@ contains
use psb_sort_mod
implicit none
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
logical, intent(in), optional :: mask
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
if (present(mask)) then
@ -473,15 +498,28 @@ contains
subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
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) :: info
logical, intent(in), optional :: mask
integer(psb_ipk_), intent(in), optional :: lidx
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
idxout = idxin
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 hash_g2ls2_ins
@ -493,13 +531,14 @@ contains
use psb_penv_mod
implicit none
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
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, is, mglob, ip, lip, nrow, ncol, &
& nxt, err_act
integer(psb_ipk_) :: i, is, lip, nrow, ncol, &
& err_act
integer(psb_lpk_) :: mglob, ip, nxt, tlip
integer(psb_ipk_) :: ictxt, me, np
character(len=20) :: name,ch_err
@ -540,18 +579,20 @@ contains
idx(i) = -1
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) then
tlip = lip
nxt = lidx(i)
if (nxt <= nrow) then
idx(i) = -1
cycle
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 (nxt == lip) then
if (nxt == tlip) then
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
info=1
ch_err='psb_ensure_size'
@ -593,12 +634,13 @@ contains
idx(i) = -1
cycle
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 (nxt == lip) then
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
info=1
ch_err='psb_ensure_size'
@ -636,13 +678,15 @@ contains
endif
nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) &
& call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
if (lip < 0) then
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
end if
if (info >=0) then
if (nxt == lip) then
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
info=1
ch_err='psb_ensure_size'
@ -678,13 +722,15 @@ contains
endif
nxt = ncol + 1
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol)
if (lip < 0) &
& call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
if (lip < 0) then
call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info)
lip = tlip
end if
if (info >=0) then
if (nxt == lip) then
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
info=1
ch_err='psb_ensure_size'
@ -724,20 +770,23 @@ contains
end subroutine hash_g2lv1_ins
subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
use psb_realloc_mod
implicit none
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) :: info
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_lpk_), allocatable :: tidx(:)
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)
call psb_realloc(im,tidx,info)
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
write(0,*) 'g2lv2_ins err -3'
info = -3
@ -756,12 +805,14 @@ contains
implicit none
class(psb_hash_map), intent(inout) :: idxmap
integer(psb_mpk_), intent(in) :: ictxt
integer(psb_ipk_), intent(in) :: vl(:)
integer(psb_lpk_), intent(in) :: vl(:)
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: i, nlu, nl, m, nrt,int_err(5)
integer(psb_ipk_), allocatable :: vlu(:), ix(:)
integer(psb_ipk_) :: i, nlu, nl, nrt,int_err(5)
integer(psb_lpk_) :: m
integer(psb_lpk_), allocatable :: vlu(:)
integer(psb_lpk_), allocatable :: ix(:)
character(len=20), parameter :: name='hash_map_init_vl'
info = 0
@ -831,8 +882,9 @@ contains
integer(psb_ipk_), intent(out) :: info
! To be implemented
integer(psb_mpk_) :: iam, np
integer(psb_ipk_) :: i, j, nl, n, int_err(5)
integer(psb_ipk_), allocatable :: vlu(:)
integer(psb_ipk_) :: i, j, nl, int_err(5)
integer(psb_lpk_) :: n
integer(psb_lpk_), allocatable :: vlu(:)
info = 0
call psb_info(ictxt,iam,np)
@ -886,7 +938,8 @@ contains
implicit none
class(psb_hash_map), intent(inout) :: idxmap
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
! To be implemented
integer(psb_mpk_) :: iam, np
@ -1127,8 +1180,8 @@ contains
end subroutine hash_inner_cnvs1
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) :: x
integer(psb_ipk_), intent(in) :: hashmask,hashv(0:)
integer(psb_lpk_), intent(in) :: x, glb_lc(:,:)
integer(psb_ipk_), intent(out) :: y
integer(psb_ipk_), intent(in) :: nrm
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)
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(:)
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
!
@ -1460,9 +1514,11 @@ contains
implicit none
class(psb_hash_map), intent(inout) :: idxmap
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_ipk_), allocatable :: idx(:),lidx(:)
integer(psb_ipk_), allocatable :: lidx(:)
integer(psb_lpk_), allocatable :: idx(:)
character(len=20) :: name='hash_reinit'
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) :: reinit => base_reinit
procedure, pass(idxmap) :: l2gs1 => base_l2gs1
procedure, pass(idxmap) :: l2gs2 => base_l2gs2
procedure, pass(idxmap) :: l2gv1 => base_l2gv1
procedure, pass(idxmap) :: l2gv2 => base_l2gv2
!!$ procedure, pass(idxmap) :: l2gs1 => base_l2gs1
!!$ procedure, pass(idxmap) :: l2gs2 => base_l2gs2
!!$ procedure, pass(idxmap) :: l2gv1 => base_l2gv1
!!$ procedure, pass(idxmap) :: l2gv2 => base_l2gv2
procedure, pass(idxmap) :: ll2gs1 => base_ll2gs1
procedure, pass(idxmap) :: ll2gs2 => base_ll2gs2
procedure, pass(idxmap) :: ll2gv1 => base_ll2gv1
procedure, pass(idxmap) :: ll2gv2 => base_ll2gv2
generic, public :: l2g => l2gs2, l2gv2, ll2gs2, ll2gv2
generic, public :: l2gip => l2gs1, l2gv1, ll2gs1, ll2gv1
procedure, pass(idxmap) :: g2ls1 => base_g2ls1
procedure, pass(idxmap) :: g2ls2 => base_g2ls2
procedure, pass(idxmap) :: g2lv1 => base_g2lv1
procedure, pass(idxmap) :: g2lv2 => base_g2lv2
!!$ generic, public :: l2g => l2gs2, l2gv2
!!$ generic, public :: l2gip => l2gs1, l2gv1
generic, public :: l2g => ll2gs2, ll2gv2
generic, public :: l2gip => ll2gs1, ll2gv1
!!$ procedure, pass(idxmap) :: g2ls1 => base_g2ls1
!!$ 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) :: lg2ls2 => base_lg2ls2
procedure, pass(idxmap) :: lg2lv1 => base_lg2lv1
procedure, pass(idxmap) :: lg2lv2 => base_lg2lv2
generic, public :: g2l => g2ls2, g2lv2, lg2ls2, lg2lv2
generic, public :: g2lip => g2ls1, g2lv1, lg2ls1, lg2lv1
procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_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
!!$ generic, public :: g2l => g2ls2, g2lv2
!!$ generic, public :: g2lip => g2ls1, g2lv1
generic, public :: g2l => lg2ls2, lg2lv2
generic, public :: g2lip => lg2ls1, lg2lv1
!!$ procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_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) :: lg2ls2_ins => base_lg2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => base_lg2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => base_lg2lv2_ins
generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins, lg2ls2_ins, lg2lv2_ins
generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins, lg2ls1_ins, lg2lv1_ins
!!$ generic, public :: g2l_ins => g2ls2_ins, g2lv2_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) :: init_vl => base_init_vl
@ -242,9 +248,9 @@ module psb_indx_map_mod
interface
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
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_indx_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
@ -1150,7 +1156,7 @@ contains
implicit none
class(psb_indx_map), intent(inout) :: idxmap
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_) :: err_act
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_ipk_), allocatable :: glob_to_loc(:)
contains
procedure, pass(idxmap) :: init_vl => list_initvl
procedure, pass(idxmap) :: init_lvl => list_initlvl
procedure, pass(idxmap) :: init_vl => list_initlvl
procedure, pass(idxmap) :: sizeof => list_sizeof
procedure, pass(idxmap) :: asb => list_asb
@ -61,30 +59,30 @@ module psb_list_map_mod
procedure, nopass :: get_fmt => list_get_fmt
procedure, nopass :: row_extendable => list_row_extendable
procedure, pass(idxmap) :: l2gs1 => list_l2gs1
procedure, pass(idxmap) :: l2gs2 => list_l2gs2
procedure, pass(idxmap) :: l2gv1 => list_l2gv1
procedure, pass(idxmap) :: l2gv2 => list_l2gv2
!!$ procedure, pass(idxmap) :: l2gs1 => list_l2gs1
!!$ procedure, pass(idxmap) :: l2gs2 => list_l2gs2
!!$ procedure, pass(idxmap) :: l2gv1 => list_l2gv1
!!$ procedure, pass(idxmap) :: l2gv2 => list_l2gv2
procedure, pass(idxmap) :: ll2gs1 => list_ll2gs1
procedure, pass(idxmap) :: ll2gs2 => list_ll2gs2
procedure, pass(idxmap) :: ll2gv1 => list_ll2gv1
procedure, pass(idxmap) :: ll2gv2 => list_ll2gv2
procedure, pass(idxmap) :: g2ls1 => list_g2ls1
procedure, pass(idxmap) :: g2ls2 => list_g2ls2
procedure, pass(idxmap) :: g2lv1 => list_g2lv1
procedure, pass(idxmap) :: g2lv2 => list_g2lv2
!!$ procedure, pass(idxmap) :: g2ls1 => list_g2ls1
!!$ procedure, pass(idxmap) :: g2ls2 => list_g2ls2
!!$ procedure, pass(idxmap) :: g2lv1 => list_g2lv1
!!$ procedure, pass(idxmap) :: g2lv2 => list_g2lv2
procedure, pass(idxmap) :: lg2ls1 => list_lg2ls1
procedure, pass(idxmap) :: lg2ls2 => list_lg2ls2
procedure, pass(idxmap) :: lg2lv1 => list_lg2lv1
procedure, pass(idxmap) :: lg2lv2 => list_lg2lv2
procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins
procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins
procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins
!!$ procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins
!!$ procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins
!!$ procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins
!!$ procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins
procedure, pass(idxmap) :: lg2ls1_ins => list_lg2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => list_lg2ls2_ins
@ -138,113 +136,113 @@ contains
end subroutine list_free
subroutine list_l2gs1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idx
call idxmap%l2gip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine list_l2gs1
subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%l2gip(idxout,info,mask,owned)
end subroutine list_l2gs2
subroutine list_l2gv1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i
logical :: owned_
info = 0
if (present(mask)) then
if (size(mask) < size(idx)) then
info = -1
return
end if
end if
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
if (present(mask)) then
do i=1, size(idx)
if (mask(i)) then
if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
idx(i) = idxmap%loc_to_glob(idx(i))
else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
& .and.(.not.owned_)) then
idx(i) = idxmap%loc_to_glob(idx(i))
else
idx(i) = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, size(idx)
if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
idx(i) = idxmap%loc_to_glob(idx(i))
else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
& .and.(.not.owned_)) then
idx(i) = idxmap%loc_to_glob(idx(i))
else
idx(i) = -1
end if
end do
end if
end subroutine list_l2gv1
subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine list_l2gv2
!!$ subroutine list_l2gs1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: idxv(1)
!!$ info = 0
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$
!!$ idxv(1) = idx
!!$ call idxmap%l2gip(idxv,info,owned=owned)
!!$ idx = idxv(1)
!!$
!!$ end subroutine list_l2gs1
!!$
!!$ subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$
!!$ idxout = idxin
!!$ call idxmap%l2gip(idxout,info,mask,owned)
!!$
!!$ end subroutine list_l2gs2
!!$
!!$
!!$ subroutine list_l2gv1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: i
!!$ logical :: owned_
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$ if (present(owned)) then
!!$ owned_ = owned
!!$ else
!!$ owned_ = .false.
!!$ end if
!!$
!!$ if (present(mask)) then
!!$
!!$ do i=1, size(idx)
!!$ if (mask(i)) then
!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
!!$ & .and.(.not.owned_)) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, size(idx)
!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
!!$ & .and.(.not.owned_)) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$
!!$ end if
!!$
!!$ end subroutine list_l2gv1
!!$
!!$ subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: is, im
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$ idxout(1:im) = idxin(1:im)
!!$ call idxmap%l2gip(idxout(1:im),info,mask,owned)
!!$ if (is > im) info = -3
!!$
!!$ end subroutine list_l2gv2
!!$
subroutine list_ll2gs1(idx,idxmap,info,mask,owned)
implicit none
@ -353,126 +351,126 @@ contains
end subroutine list_ll2gv2
subroutine list_g2ls1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idx
call idxmap%g2lip(idxv,info,owned=owned)
idx = idxv(1)
end subroutine list_g2ls1
subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%g2lip(idxout,info,mask,owned)
end subroutine list_g2ls2
subroutine list_g2lv1(idx,idxmap,info,mask,owned)
use psb_sort_mod
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is, ix
logical :: owned_
info = 0
if (present(mask)) then
if (size(mask) < size(idx)) then
info = -1
return
end if
end if
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
is = size(idx)
if (present(mask)) then
if (idxmap%is_valid()) 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 > idxmap%get_lr()).and.(owned_)) ix = -1
idx(i) = ix
else
idx(i) = -1
end if
end if
end do
else
idx(1:is) = -1
info = -1
end if
else if (.not.present(mask)) then
if (idxmap%is_valid()) 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 > idxmap%get_lr()).and.(owned_)) ix = -1
idx(i) = ix
else
idx(i) = -1
end if
end do
else
idx(1:is) = -1
info = -1
end if
end if
end subroutine list_g2lv1
subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
if (is > im) info = -3
end subroutine list_g2lv2
!!$
!!$ subroutine list_g2ls1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: idxv(1)
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$
!!$ idxv(1) = idx
!!$ call idxmap%g2lip(idxv,info,owned=owned)
!!$ idx = idxv(1)
!!$
!!$ end subroutine list_g2ls1
!!$
!!$ subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$
!!$ idxout = idxin
!!$ call idxmap%g2lip(idxout,info,mask,owned)
!!$
!!$ end subroutine list_g2ls2
!!$
!!$
!!$ subroutine list_g2lv1(idx,idxmap,info,mask,owned)
!!$ use psb_sort_mod
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: i, is, ix
!!$ logical :: owned_
!!$
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$ if (present(owned)) then
!!$ owned_ = owned
!!$ else
!!$ owned_ = .false.
!!$ end if
!!$
!!$ is = size(idx)
!!$
!!$ if (present(mask)) then
!!$ if (idxmap%is_valid()) 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 > idxmap%get_lr()).and.(owned_)) ix = -1
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$ else
!!$ idx(1:is) = -1
!!$ info = -1
!!$ end if
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ if (idxmap%is_valid()) 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 > idxmap%get_lr()).and.(owned_)) ix = -1
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$ else
!!$ idx(1:is) = -1
!!$ info = -1
!!$ end if
!!$
!!$ end if
!!$
!!$ end subroutine list_g2lv1
!!$
!!$ subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$
!!$ integer(psb_ipk_) :: is, im
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$ idxout(1:im) = idxin(1:im)
!!$ call idxmap%g2lip(idxout(1:im),info,mask,owned)
!!$ if (is > im) info = -3
!!$
!!$ end subroutine list_g2lv2
@ -610,18 +608,221 @@ contains
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_sort_mod
implicit none
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
logical, intent(in), optional :: mask
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
if (present(mask)) then
@ -637,193 +838,17 @@ contains
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
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) :: 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_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_ipk_) :: lidxv(1)
@ -831,7 +856,7 @@ contains
if (present(mask)) then
if (.not.mask) return
end if
idxv(1) = idx
idxv(1) = idxin
if (present(lidx)) then
lidxv(1) = lidx
call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
@ -839,21 +864,7 @@ contains
call idxmap%g2lip_ins(idxv,info)
end if
idx = 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)
idxout = idxv(1)
end subroutine list_lg2ls2_ins
@ -1057,7 +1068,7 @@ contains
end if
lvl(1:nl) = vl(1:nl)
call idxmap%init_lvl(ictxt,lvl,info)
call idxmap%init_vl(ictxt,lvl,info)
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, nopass :: get_fmt => repl_get_fmt
procedure, pass(idxmap) :: l2gs1 => repl_l2gs1
procedure, pass(idxmap) :: l2gs2 => repl_l2gs2
procedure, pass(idxmap) :: l2gv1 => repl_l2gv1
procedure, pass(idxmap) :: l2gv2 => repl_l2gv2
procedure, pass(idxmap) :: ll2gs1 => repl_l2gs1
procedure, pass(idxmap) :: ll2gs2 => repl_l2gs2
procedure, pass(idxmap) :: ll2gv1 => repl_l2gv1
procedure, pass(idxmap) :: ll2gv2 => repl_l2gv2
procedure, pass(idxmap) :: g2ls1 => repl_g2ls1
procedure, pass(idxmap) :: g2ls2 => repl_g2ls2
procedure, pass(idxmap) :: g2lv1 => repl_g2lv1
procedure, pass(idxmap) :: g2lv2 => repl_g2lv2
procedure, pass(idxmap) :: lg2ls1 => repl_g2ls1
procedure, pass(idxmap) :: lg2ls2 => repl_g2ls2
procedure, pass(idxmap) :: lg2lv1 => repl_g2lv1
procedure, pass(idxmap) :: lg2lv2 => repl_g2lv2
procedure, pass(idxmap) :: g2ls1_ins => repl_g2ls1_ins
procedure, pass(idxmap) :: g2ls2_ins => repl_g2ls2_ins
procedure, pass(idxmap) :: g2lv1_ins => repl_g2lv1_ins
procedure, pass(idxmap) :: g2lv2_ins => repl_g2lv2_ins
procedure, pass(idxmap) :: lg2ls1_ins => repl_g2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => repl_g2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => repl_g2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => repl_g2lv2_ins
procedure, pass(idxmap) :: fnd_owner => repl_fnd_owner
@ -107,11 +107,11 @@ contains
subroutine repl_l2gs1(idx,idxmap,info,mask,owned)
implicit none
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
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
if (.not.mask) return
@ -127,13 +127,20 @@ contains
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin
integer(psb_ipk_), intent(out) :: idxout
integer(psb_lpk_), intent(out) :: idxout
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%l2gip(idxout,info,mask,owned)
integer(psb_lpk_) :: idxv(1)
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
@ -141,11 +148,11 @@ contains
subroutine repl_l2gv1(idx,idxmap,info,mask,owned)
implicit none
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
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i
integer(psb_lpk_) :: i
logical :: owned_
info = 0
@ -191,12 +198,12 @@ contains
implicit none
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
integer(psb_ipk_), intent(out) :: idxout(:)
integer(psb_lpk_), intent(out) :: idxout(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
integer(psb_ipk_) :: i
integer(psb_lpk_) :: is, im
integer(psb_lpk_) :: i
logical :: owned_
info = 0
@ -247,11 +254,11 @@ contains
subroutine repl_g2ls1(idx,idxmap,info,mask,owned)
implicit none
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
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
integer(psb_ipk_) :: idxv(1)
integer(psb_lpk_) :: idxv(1)
info = 0
if (present(mask)) then
@ -267,26 +274,35 @@ contains
subroutine repl_g2ls2(idxin,idxout,idxmap,info,mask,owned)
implicit none
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) :: info
logical, intent(in), optional :: mask
logical, intent(in), optional :: owned
idxout = idxin
call idxmap%g2lip(idxout,info,mask,owned)
integer(psb_lpk_) :: idxv(1)
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)
implicit none
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
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: i, is
integer(psb_lpk_) :: i, is
logical :: owned_
info = 0
@ -363,13 +379,13 @@ contains
subroutine repl_g2lv2(idxin,idxout,idxmap,info,mask,owned)
implicit none
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) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im,i
integer(psb_lpk_) :: is, im,i
logical :: owned_
info = 0
@ -453,12 +469,13 @@ contains
use psb_sort_mod
implicit none
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
logical, intent(in), optional :: mask
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
if (present(mask)) then
@ -478,14 +495,27 @@ contains
subroutine repl_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
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) :: 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)
integer(psb_lpk_) :: idxv(1)
integer(psb_ipk_) :: lidxv(1)
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
@ -495,12 +525,12 @@ contains
use psb_sort_mod
implicit none
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
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: i, is
integer(psb_lpk_) :: i, is
info = 0
is = size(idx)
@ -579,13 +609,13 @@ contains
subroutine repl_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
implicit none
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) :: info
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: is, im, i
integer(psb_lpk_) :: is, im, i
info = 0
@ -669,7 +699,7 @@ contains
subroutine repl_fnd_owner(idx,iprc,idxmap,info)
use psb_penv_mod
implicit none
integer(psb_ipk_), intent(in) :: idx(:)
integer(psb_lpk_), intent(in) :: idx(:)
integer(psb_ipk_), allocatable, intent(out) :: iprc(:)
class(psb_repl_map), intent(in) :: idxmap
integer(psb_ipk_), intent(out) :: info
@ -695,7 +725,7 @@ contains
use psb_error_mod
implicit none
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_ipk_), intent(out) :: info
! 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 psb_const_mod
use psb_error_mod
use psb_mat_mod
use psb_vect_mod
! !$ use psb_rsb_mod
#ifdef MPI_MOD
use mpi
@ -294,13 +296,13 @@ contains
integer(psb_mpk_), intent(out) :: ictxt
integer(psb_mpk_), intent(in), optional :: np, basectxt, ids(:)
integer(psb_mpk_) :: i, isnullcomm
integer(psb_mpk_), allocatable :: iids(:)
logical :: initialized
integer(psb_mpk_) :: np_, npavail, iam, info, basecomm, basegroup, newgroup
character(len=20), parameter :: name='psb_init'
integer(psb_ipk_) :: iinfo
!
call psb_set_debug_unit(psb_err_unit)
#if defined(SERIAL_MPI)
@ -390,19 +392,20 @@ contains
call psi_get_sizes()
if (ictxt == mpi_comm_null) return
#endif
! !$ call psb_rsb_init(info)
! !$ if (info.ne.psb_rsb_const_success) then
! !$ if (info.eq.psb_rsb_const_not_available) then
! !$ info=psb_success_ ! rsb is not present
! !$ else
! !$ ! rsb failed to initialize, and we issue an internal error.
! !$ ! or shall we tolerate this ?
! !$ info=psb_err_internal_error_
! !$ call psb_errpush(info,name)
! !$ call psb_error(ictxt)
! !$ endif
! !$ endif
call psb_init_vect_defaults()
call psb_init_mat_defaults()
! !$ call psb_rsb_init(info)
! !$ if (info.ne.psb_rsb_const_success) then
! !$ if (info.eq.psb_rsb_const_not_available) then
! !$ info=psb_success_ ! rsb is not present
! !$ else
! !$ ! rsb failed to initialize, and we issue an internal error.
! !$ ! or shall we tolerate this ?
! !$ info=psb_err_internal_error_
! !$ call psb_errpush(info,name)
! !$ call psb_error(ictxt)
! !$ endif
! !$ endif
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
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
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: iix, jjx
@ -193,7 +194,8 @@ contains
use psb_error_mod
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
integer(psb_ipk_), intent(out) :: info
@ -311,7 +313,7 @@ contains
use psb_error_mod
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
integer(psb_ipk_), intent(out) :: info
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_lpk_ = psb_epk_
#elif defined(INT_I8_L8)
integer, parameter :: psb_ipk_ = psb_mpk_
integer, parameter :: psb_ipk_ = psb_epk_
integer, parameter :: psb_lpk_ = psb_epk_
#else
! Unsupported combination, compilation will stop later on
@ -101,13 +101,13 @@ module psb_const_mod
integer, parameter :: psb_lpk_ = -1
#endif
integer(psb_ipk_), save :: psb_sizeof_sp
integer(psb_ipk_), save :: psb_sizeof_dp
integer(psb_ipk_), save :: psb_sizeof_i2p
integer(psb_ipk_), save :: psb_sizeof_mp
integer(psb_ipk_), save :: psb_sizeof_ep
integer(psb_ipk_), save :: psb_sizeof_ip
integer(psb_ipk_), save :: psb_sizeof_lp
integer(psb_ipk_), save :: psb_sizeof_sp
integer(psb_ipk_), save :: psb_sizeof_dp
integer(psb_ipk_), save :: psb_sizeof_i2p
integer(psb_ipk_), save :: psb_sizeof_mp
integer(psb_ipk_), save :: psb_sizeof_ep
integer(psb_ipk_), save :: psb_sizeof_ip
integer(psb_ipk_), save :: psb_sizeof_lp
!
! 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
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type
use psi_c_comm_a_mod
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 psi_c_comm_v_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
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
use psi_d_comm_a_mod
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 psi_d_comm_v_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
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_
use psi_m_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_multivect_mod, only : psb_i_base_multivect_type
use psi_i_comm_v_mod
interface psi_compute_size
subroutine psi_i_compute_size(desc_data,&
@ -58,13 +58,12 @@ module psi_i_mod
end interface
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
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: nxch,nsnd,nrcv
integer(psb_ipk_), intent(in) :: index_in(:)
integer(psb_ipk_), allocatable, intent(inout) :: index_out(:)
logical :: glob_idx
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_crea_index
end interface
@ -80,13 +79,12 @@ module psi_i_mod
interface psi_desc_index
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
type(psb_desc_type) :: desc
integer(psb_ipk_) :: index_in(:),dep_list(:)
integer(psb_ipk_),allocatable :: desc_index(:)
integer(psb_ipk_) :: length_dl,nsnd,nrcv
logical :: isglob_in
integer(psb_ipk_) :: info
end subroutine psi_i_desc_index
end interface
@ -204,5 +202,6 @@ module psi_i_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i_bld_ovr_mst
end interface
end module psi_i_mod

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

@ -30,13 +30,13 @@
!
!
module psi_l_mod
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_
use psi_m_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_multivect_mod, only : psb_l_base_multivect_type
use psi_l_comm_v_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
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type
use psi_s_comm_a_mod
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 psi_s_comm_v_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
use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type
use psi_z_comm_a_mod
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 psi_z_comm_v_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) :: csgetrow => psb_c_csgetrow
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) :: triu => psb_c_triu
procedure, pass(a) :: m_csclip => psb_c_csclip
@ -1292,5 +1297,63 @@ contains
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

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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_c_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function c_vect_get_fmt
subroutine c_vect_all(n, x, info, mold)
implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_c_base_vect_type :: x%v,stat=info)
endif
@ -512,21 +482,22 @@ contains
class(psb_c_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(in), optional :: mold
class(psb_c_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info,mold=psb_c_get_base_vect_default())
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
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info
class(psb_c_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_c_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_c_base_multivect_type :: x%v,stat=info)
endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info, mold=psb_c_get_base_multivect_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 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) :: csgetrow => psb_d_csgetrow
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) :: triu => psb_d_triu
procedure, pass(a) :: m_csclip => psb_d_csclip
@ -1292,5 +1297,63 @@ contains
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

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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_d_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function d_vect_get_fmt
subroutine d_vect_all(n, x, info, mold)
implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_d_base_vect_type :: x%v,stat=info)
endif
@ -512,21 +482,22 @@ contains
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in), optional :: mold
class(psb_d_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info,mold=psb_d_get_base_vect_default())
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
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info
class(psb_d_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_d_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_d_base_multivect_type :: x%v,stat=info)
endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info, mold=psb_d_get_base_multivect_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 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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(invect)
@ -198,23 +189,14 @@ contains
integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_i_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(n)
@ -325,6 +298,7 @@ contains
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function i_vect_get_fmt
subroutine i_vect_all(n, x, info, mold)
implicit none
@ -337,11 +311,7 @@ contains
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_i_base_vect_type :: x%v,stat=info)
endif
@ -485,21 +455,22 @@ contains
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
class(psb_i_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info,mold=psb_i_get_base_vect_default())
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
@ -697,19 +668,11 @@ contains
integer(psb_ipk_) :: info
class(psb_i_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_i_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(m,n)
@ -833,11 +787,7 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_i_base_multivect_type :: x%v,stat=info)
endif
@ -996,18 +946,16 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info, mold=psb_i_get_base_multivect_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 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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(invect)
@ -199,23 +190,14 @@ contains
integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_l_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(n)
@ -326,6 +299,7 @@ contains
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function l_vect_get_fmt
subroutine l_vect_all(n, x, info, mold)
implicit none
@ -338,11 +312,7 @@ contains
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_l_base_vect_type :: x%v,stat=info)
endif
@ -486,21 +456,22 @@ contains
class(psb_l_vect_type), intent(inout) :: x
class(psb_l_base_vect_type), intent(in), optional :: mold
class(psb_l_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info,mold=psb_l_get_base_vect_default())
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
@ -698,19 +669,11 @@ contains
integer(psb_ipk_) :: info
class(psb_l_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_l_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(m,n)
@ -834,11 +788,7 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_l_base_multivect_type :: x%v,stat=info)
endif
@ -997,18 +947,16 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info, mold=psb_l_get_base_multivect_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 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_c_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

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) :: csgetrow => psb_s_csgetrow
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) :: triu => psb_s_triu
procedure, pass(a) :: m_csclip => psb_s_csclip
@ -1292,5 +1297,63 @@ contains
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

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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_s_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function s_vect_get_fmt
subroutine s_vect_all(n, x, info, mold)
implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_s_base_vect_type :: x%v,stat=info)
endif
@ -512,21 +482,22 @@ contains
class(psb_s_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(in), optional :: mold
class(psb_s_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info,mold=psb_s_get_base_vect_default())
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
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info
class(psb_s_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_s_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_s_base_multivect_type :: x%v,stat=info)
endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info, mold=psb_s_get_base_multivect_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 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 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

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_c_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

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) :: csgetrow => psb_z_csgetrow
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) :: triu => psb_z_triu
procedure, pass(a) :: m_csclip => psb_z_csclip
@ -1292,5 +1297,63 @@ contains
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

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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(invect)
@ -225,23 +216,14 @@ contains
integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_z_base_vect_type), pointer :: mld
info = psb_success_
if (allocated(x%v)) &
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(n)
@ -352,6 +325,7 @@ contains
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function z_vect_get_fmt
subroutine z_vect_all(n, x, info, mold)
implicit none
@ -364,11 +338,7 @@ contains
& call x%free(info)
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_z_base_vect_type :: x%v,stat=info)
endif
@ -512,21 +482,22 @@ contains
class(psb_z_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(in), optional :: mold
class(psb_z_base_vect_type), allocatable :: tmp
integer(psb_ipk_) :: info
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info,mold=psb_z_get_base_vect_default())
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
@ -968,19 +939,11 @@ contains
integer(psb_ipk_) :: info
class(psb_z_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
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_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_z_base_multivect_type), pointer :: mld
info = psb_success_
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
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
if (info == psb_success_) call x%v%bld(m,n)
@ -1104,11 +1058,7 @@ contains
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_z_base_multivect_type :: x%v,stat=info)
endif
@ -1267,18 +1217,16 @@ contains
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#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)
else
allocate(tmp,stat=info, mold=psb_z_get_base_multivect_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 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