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

psblas-submodules:

Browse Source 
base/internals/psi_desc_impl.f90

New submodules for psi_mod
psblas3-submodules
Salvatore Filippone 11 years ago
parent e173841a60
commit 28bd5e9a6a
1 changed files with 387 additions and 391 deletions
Show Stats Download Patch File Download Diff File

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

@ -29,273 +29,302 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
submodule (psi_i_mod) psi_desc_impl_mod
contains
subroutine psi_renum_index(iperm,idx,info)
use psb_serial_mod
implicit none
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in) :: iperm(:)
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_) :: i,j,k,nh
i=1
k=idx(i)
do while (k /= -1)
i = i+1
nh = idx(i)
do j = i+1, i+nh
idx(j) = iperm(idx(j))
enddo
i = i + nh + 1
nh = idx(i)
do j = i+1, i+nh
idx(j) = iperm(idx(j))
enddo
i = i + nh + 1
k = idx(i)
enddo
subroutine psi_renum_index(iperm,idx,info) end subroutine psi_renum_index
use psi_mod, psi_protect_name => psi_renum_index
use psb_serial_mod subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold)
implicit none use psb_realloc_mod
implicit none
! ....scalars parameters....
integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:)
type(psb_desc_type), intent(inout) :: cdesc
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type), optional, intent(in) :: mold
! ....local scalars....
integer(psb_ipk_) :: np,me
integer(psb_ipk_) :: ictxt, err_act,nxch,nsnd,nrcv,j,k
! ...local array...
integer(psb_ipk_), allocatable :: idx_out(:), tmp_mst_idx(:)
! ...parameters
integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: debug=.false.
character(len=20) :: name
name='psi_cnv_desc'
call psb_get_erraction(err_act)
debug_level = psb_get_debug_level()
debug_unit = psb_get_debug_unit()
info = psb_success_
ictxt = cdesc%get_context()
call psb_info(ictxt,me,np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! 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)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999
end if
call psb_move_alloc(idx_out,cdesc%halo_index,info)
integer(psb_ipk_), intent(out) :: info if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo'
integer(psb_ipk_), intent(in) :: iperm(:) if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
integer(psb_ipk_), intent(inout) :: idx(:)
integer(psb_ipk_) :: i,j,k,nh
i=1 ! then ext index
k=idx(i) if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
do while (k /= -1) call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info)
i = i+1 if (info /= psb_success_) then
nh = idx(i) call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
do j = i+1, i+nh goto 9999
idx(j) = iperm(idx(j)) end if
enddo call psb_move_alloc(idx_out,cdesc%ext_index,info)
i = i + nh + 1
nh = idx(i) if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext'
do j = i+1, i+nh if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap'
idx(j) = iperm(idx(j))
enddo ! then the overlap index
i = i + nh + 1 call psi_crea_index(cdesc,ovrlap_in, idx_out,.true.,nxch,nsnd,nrcv,info)
k = idx(i) if (info /= psb_success_) then
enddo call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999
end subroutine psi_renum_index end if
call psb_move_alloc(idx_out,cdesc%ovrlap_index,info)
subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc')
use psi_mod, psi_protect_name => psi_cnv_dsc goto 9999
use psb_realloc_mod end if
implicit none
! ....scalars parameters.... ! next ovrlap_elem
integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem'
type(psb_desc_type), intent(inout) :: cdesc call psi_crea_ovr_elem(me,cdesc%ovrlap_index,cdesc%ovrlap_elem,info)
integer(psb_ipk_), intent(out) :: info if (debug_level>0) write(debug_unit,*) me,'Done crea_ovr_elem'
class(psb_i_base_vect_type), optional, intent(in) :: mold if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_ovr_elem')
! ....local scalars.... goto 9999
integer(psb_ipk_) :: np,me end if
integer(psb_ipk_) :: ictxt, err_act,nxch,nsnd,nrcv,j,k ! Extract ovr_mst_idx from ovrlap_elem
! ...local array... if (debug_level>0) write(debug_unit,*) me,'Calling bld_ovr_mst'
integer(psb_ipk_), allocatable :: idx_out(:), tmp_mst_idx(:) call psi_bld_ovr_mst(me,cdesc%ovrlap_elem,tmp_mst_idx,info)
if (info == psb_success_) call psi_crea_index(cdesc,&
! ...parameters & tmp_mst_idx,idx_out,.false.,nxch,nsnd,nrcv,info)
integer(psb_ipk_) :: debug_level, debug_unit if (debug_level>0) write(debug_unit,*) me,'Done crea_indx'
logical, parameter :: debug=.false. if (info /= psb_success_) then
character(len=20) :: name call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_bld_ovr_mst')
goto 9999
name='psi_cnv_desc' end if
call psb_get_erraction(err_act) call psb_move_alloc(idx_out,cdesc%ovr_mst_idx,info)
debug_level = psb_get_debug_level() if (info /= psb_success_) then
debug_unit = psb_get_debug_unit() call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc')
goto 9999
info = psb_success_ end if
ictxt = cdesc%get_context()
! finally bnd_elem
call psb_info(ictxt,me,np) call psi_crea_bnd_elem(idx_out,cdesc,info)
if (np == -1) then if (info == psb_success_) call psb_move_alloc(idx_out,cdesc%bnd_elem,info)
info = psb_err_context_error_
call psb_errpush(info,name) call cdesc%v_halo_index%bld(cdesc%halo_index,mold=mold)
goto 9999 call cdesc%v_ext_index%bld(cdesc%ext_index,mold=mold)
endif call cdesc%v_ovrlap_index%bld(cdesc%ovrlap_index,mold=mold)
call cdesc%v_ovr_mst_idx%bld(cdesc%ovr_mst_idx,mold=mold)
! first the halo index
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',& if (info /= psb_success_) then
& size(halo_in) call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_bnd_elem')
call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) goto 9999
if (info /= psb_success_) then end if
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index') if (debug_level>0) write(debug_unit,*) me,'Done crea_bnd_elem'
goto 9999
end if call psb_erractionrestore(err_act)
call psb_move_alloc(idx_out,cdesc%halo_index,info) return
if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo'
if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
! 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)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999
end if
call psb_move_alloc(idx_out,cdesc%ext_index,info)
if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext'
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)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_index')
goto 9999
end if
call psb_move_alloc(idx_out,cdesc%ovrlap_index,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc')
goto 9999
end if
! next ovrlap_elem
if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem'
call psi_crea_ovr_elem(me,cdesc%ovrlap_index,cdesc%ovrlap_elem,info)
if (debug_level>0) write(debug_unit,*) me,'Done crea_ovr_elem'
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_ovr_elem')
goto 9999
end if
! Extract ovr_mst_idx from ovrlap_elem
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)
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')
goto 9999
end if
call psb_move_alloc(idx_out,cdesc%ovr_mst_idx,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_move_alloc')
goto 9999
end if
! finally bnd_elem
call psi_crea_bnd_elem(idx_out,cdesc,info)
if (info == psb_success_) call psb_move_alloc(idx_out,cdesc%bnd_elem,info)
call cdesc%v_halo_index%bld(cdesc%halo_index,mold=mold)
call cdesc%v_ext_index%bld(cdesc%ext_index,mold=mold)
call cdesc%v_ovrlap_index%bld(cdesc%ovrlap_index,mold=mold)
call cdesc%v_ovr_mst_idx%bld(cdesc%ovr_mst_idx,mold=mold)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_crea_bnd_elem')
goto 9999
end if
if (debug_level>0) write(debug_unit,*) me,'Done crea_bnd_elem'
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act) 9999 call psb_error_handler(ictxt,err_act)
return return
end subroutine psi_cnv_dsc end subroutine psi_cnv_dsc
subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc)
use psi_mod, psi_protect_name => psi_inner_cnvs
integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:)
integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) integer(psb_ipk_), intent(inout) :: x
integer(psb_ipk_), intent(inout) :: x
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm !
! ! When a large descriptor is assembled the indices
! When a large descriptor is assembled the indices ! are kept in a (hashed) list of ordered lists.
! are kept in a (hashed) list of ordered lists. ! Thus we first hash the index, then we do a binary search on the
! Thus we first hash the index, then we do a binary search on the ! ordered sublist. The hashing is based on the low-order bits
! ordered sublist. The hashing is based on the low-order bits ! for a width of psb_hash_bits
! for a width of psb_hash_bits !
!
key = x
key = x ih = iand(key,hashmask)
ih = iand(key,hashmask) idx = hashv(ih)
idx = hashv(ih) nh = hashv(ih+1) - hashv(ih)
nh = hashv(ih+1) - hashv(ih) if (nh > 0) then
if (nh > 0) then tmp = -1
tmp = -1 lb = idx
lb = idx ub = idx+nh-1
ub = idx+nh-1 do
do if (lb>ub) exit
if (lb>ub) exit lm = (lb+ub)/2
lm = (lb+ub)/2 if (key == glb_lc(lm,1)) then
if (key == glb_lc(lm,1)) then tmp = lm
tmp = lm exit
exit else if (key<glb_lc(lm,1)) then
else if (key<glb_lc(lm,1)) then ub = lm - 1
ub = lm - 1 else
else lb = lm + 1
lb = lm + 1 end if
end if end do
end do else
else tmp = -1
tmp = -1 end if
end if if (tmp > 0) then
if (tmp > 0) then x = glb_lc(tmp,2)
x = glb_lc(tmp,2) else
else x = tmp
x = tmp end if
end if end subroutine psi_inner_cnvs
end subroutine psi_inner_cnvs
subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc)
subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc) integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:)
use psi_mod, psi_protect_name => psi_inner_cnvs2 integer(psb_ipk_), intent(in) :: x
integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) integer(psb_ipk_), intent(out) :: y
integer(psb_ipk_), intent(in) :: x
integer(psb_ipk_), intent(out) :: y integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm
!
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm ! When a large descriptor is assembled the indices
! ! are kept in a (hashed) list of ordered lists.
! When a large descriptor is assembled the indices ! Thus we first hash the index, then we do a binary search on the
! are kept in a (hashed) list of ordered lists. ! ordered sublist. The hashing is based on the low-order bits
! Thus we first hash the index, then we do a binary search on the ! for a width of psb_hash_bits
! ordered sublist. The hashing is based on the low-order bits !
! for a width of psb_hash_bits
! key = x
ih = iand(key,hashmask)
key = x idx = hashv(ih)
ih = iand(key,hashmask) nh = hashv(ih+1) - hashv(ih)
idx = hashv(ih) if (nh > 0) then
nh = hashv(ih+1) - hashv(ih) tmp = -1
if (nh > 0) then lb = idx
tmp = -1 ub = idx+nh-1
lb = idx do
ub = idx+nh-1 if (lb>ub) exit
do lm = (lb+ub)/2
if (lb>ub) exit if (key == glb_lc(lm,1)) then
lm = (lb+ub)/2 tmp = lm
if (key == glb_lc(lm,1)) then exit
tmp = lm else if (key<glb_lc(lm,1)) then
exit ub = lm - 1
else if (key<glb_lc(lm,1)) then else
ub = lm - 1 lb = lm + 1
else end if
lb = lm + 1 end do
end if else
end do tmp = -1
else end if
tmp = -1 if (tmp > 0) then
end if y = glb_lc(tmp,2)
if (tmp > 0) then else
y = glb_lc(tmp,2) y = tmp
else end if
y = tmp end subroutine psi_inner_cnvs2
end if
end subroutine psi_inner_cnvs2
subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask)
integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:)
subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) logical, intent(in), optional :: mask(:)
use psi_mod, psi_protect_name => psi_inner_cnv1 integer(psb_ipk_), intent(inout) :: x(:)
integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:)
logical, intent(in), optional :: mask(:) integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm
integer(psb_ipk_), intent(inout) :: x(:) !
! When a large descriptor is assembled the indices
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm ! are kept in a (hashed) list of ordered lists.
! ! Thus we first hash the index, then we do a binary search on the
! When a large descriptor is assembled the indices ! ordered sublist. The hashing is based on the low-order bits
! are kept in a (hashed) list of ordered lists. ! for a width of psb_hash_bits
! Thus we first hash the index, then we do a binary search on the !
! ordered sublist. The hashing is based on the low-order bits if (present(mask)) then
! for a width of psb_hash_bits do i=1, n
! if (mask(i)) then
if (present(mask)) then key = x(i)
do i=1, n ih = iand(key,hashmask)
if (mask(i)) then idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key == glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
x(i) = glb_lc(tmp,2)
else
x(i) = tmp
end if
end if
end do
else
do i=1, n
key = x(i) key = x(i)
ih = iand(key,hashmask) ih = iand(key,hashmask)
idx = hashv(ih) idx = hashv(ih)
@ -324,60 +353,62 @@ subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask)
else else
x(i) = tmp x(i) = tmp
end if end if
end if end do
end do end if
else end subroutine psi_inner_cnv1
do i=1, n
key = x(i) subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask)
ih = iand(key,hashmask) integer(psb_ipk_), intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:)
idx = hashv(ih) logical, intent(in),optional :: mask(:)
nh = hashv(ih+1) - hashv(ih) integer(psb_ipk_), intent(in) :: x(:)
if (nh > 0) then integer(psb_ipk_), intent(out) :: y(:)
tmp = -1
lb = idx integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm
ub = idx+nh-1 !
do ! When a large descriptor is assembled the indices
if (lb>ub) exit ! are kept in a (hashed) list of ordered lists.
lm = (lb+ub)/2 ! Thus we first hash the index, then we do a binary search on the
if (key == glb_lc(lm,1)) then ! ordered sublist. The hashing is based on the low-order bits
tmp = lm ! for a width of psb_hash_bits
exit !
else if (key<glb_lc(lm,1)) then if (present(mask)) then
ub = lm - 1 do i=1, n
else if (mask(i)) then
lb = lm + 1 key = x(i)
ih = iand(key,hashmask)
if (ih > ubound(hashv,1) ) then
write(psb_err_unit,*) ' In inner cnv: ',ih,ubound(hashv)
end if end if
end do idx = hashv(ih)
else nh = hashv(ih+1) - hashv(ih)
tmp = -1 if (nh > 0) then
end if tmp = -1
if (tmp > 0) then lb = idx
x(i) = glb_lc(tmp,2) ub = idx+nh-1
else do
x(i) = tmp if (lb>ub) exit
end if lm = (lb+ub)/2
end do if (key == glb_lc(lm,1)) then
end if tmp = lm
end subroutine psi_inner_cnv1 exit
else if (key<glb_lc(lm,1)) then
subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) ub = lm - 1
use psi_mod, psi_protect_name => psi_inner_cnv2 else
integer(psb_ipk_), intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) lb = lm + 1
logical, intent(in),optional :: mask(:) end if
integer(psb_ipk_), intent(in) :: x(:) end do
integer(psb_ipk_), intent(out) :: y(:) else
tmp = -1
integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm end if
! if (tmp > 0) then
! When a large descriptor is assembled the indices y(i) = glb_lc(tmp,2)
! are kept in a (hashed) list of ordered lists. else
! Thus we first hash the index, then we do a binary search on the y(i) = tmp
! ordered sublist. The hashing is based on the low-order bits end if
! for a width of psb_hash_bits end if
! end do
if (present(mask)) then else
do i=1, n do i=1, n
if (mask(i)) then
key = x(i) key = x(i)
ih = iand(key,hashmask) ih = iand(key,hashmask)
if (ih > ubound(hashv,1) ) then if (ih > ubound(hashv,1) ) then
@ -409,89 +440,54 @@ subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask)
else else
y(i) = tmp y(i) = tmp
end if end if
end do
end if
end subroutine psi_inner_cnv2
subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info)
use psb_realloc_mod
implicit none
! ....scalars parameters....
integer(psb_ipk_), intent(in) :: me, ovrlap_elem(:,:)
integer(psb_ipk_), allocatable, intent(out) :: mst_idx(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j, proc, nov,isz, ip, err_act, idx
character(len=20) :: name
name='psi_bld_ovr_mst'
call psb_get_erraction(err_act)
nov = size(ovrlap_elem,1)
isz = 3*nov+1
call psb_realloc(isz,mst_idx,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='reallocate')
goto 9999
end if
mst_idx = -1
j = 1
do i=1, nov
proc = ovrlap_elem(i,3)
if (me /= proc) then
idx = ovrlap_elem(i,1)
mst_idx(j+0) = proc
mst_idx(j+1) = 1
mst_idx(j+2) = idx
j = j + 3
end if end if
end do end do
else mst_idx(j) = -1
do i=1, n
key = x(i)
ih = iand(key,hashmask)
if (ih > ubound(hashv,1) ) then
write(psb_err_unit,*) ' In inner cnv: ',ih,ubound(hashv)
end if
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key == glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
y(i) = glb_lc(tmp,2)
else
y(i) = tmp
end if
end do
end if
end subroutine psi_inner_cnv2
subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info)
use psi_mod, psi_protect_name => psi_bld_ovr_mst
use psb_realloc_mod
implicit none
! ....scalars parameters....
integer(psb_ipk_), intent(in) :: me, ovrlap_elem(:,:)
integer(psb_ipk_), allocatable, intent(out) :: mst_idx(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, j, proc, nov,isz, ip, err_act, idx
character(len=20) :: name
name='psi_bld_ovr_mst'
call psb_get_erraction(err_act)
nov = size(ovrlap_elem,1)
isz = 3*nov+1
call psb_realloc(isz,mst_idx,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='reallocate')
goto 9999
end if
mst_idx = -1
j = 1
do i=1, nov
proc = ovrlap_elem(i,3)
if (me /= proc) then
idx = ovrlap_elem(i,1)
mst_idx(j+0) = proc
mst_idx(j+1) = 1
mst_idx(j+2) = idx
j = j + 3
end if
end do
mst_idx(j) = -1
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
end subroutine psi_bld_ovr_mst end subroutine psi_bld_ovr_mst
end submodule psi_desc_impl_mod

Write Preview
Loading…
Cancel
Save