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_bld_tmphalo.f90
 base/internals/psi_bld_tmpovrl.f90
 base/internals/psi_crea_bnd_elem.f90

New submodules for psi_mod
psblas3-submodules
Salvatore Filippone 10 years ago
parent 1c6795bdb9
commit e173841a60
3 changed files with 249 additions and 237 deletions
Show Stats Download Patch File Download Diff File

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

@ -44,105 +44,110 @@
! desc - type(psb_desc_type). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! !
subroutine psi_bld_tmphalo(desc,info) submodule (psi_i_mod) psi_bld_tmphalo_impl_mod
use psb_desc_mod
use psb_serial_mod contains
use psb_const_mod
use psb_error_mod subroutine psi_bld_tmphalo(desc,info)
use psb_penv_mod use psb_desc_mod
use psb_realloc_mod use psb_serial_mod
use psi_mod, psb_protect_name => psi_bld_tmphalo use psb_const_mod
implicit none use psb_error_mod
type(psb_desc_type), intent(inout) :: desc use psb_penv_mod
integer(psb_ipk_), intent(out) :: info use psb_realloc_mod
implicit none
integer(psb_ipk_),allocatable :: helem(:),hproc(:) type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_),allocatable :: tmphl(:) integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,& integer(psb_ipk_),allocatable :: helem(:),hproc(:)
& n_col, err_act, key, ih, nh, idx, nk,icomm integer(psb_ipk_),allocatable :: tmphl(:)
integer(psb_ipk_) :: ictxt,n_row
character(len=20) :: name,ch_err integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,&
& n_col, err_act, key, ih, nh, idx, nk,icomm
info = psb_success_ integer(psb_ipk_) :: ictxt,n_row
name = 'psi_bld_tmphalo' character(len=20) :: name,ch_err
call psb_erractionsave(err_act)
info = psb_success_
ictxt = desc%get_context() name = 'psi_bld_tmphalo'
icomm = desc%get_mpic() call psb_erractionsave(err_act)
n_row = desc%get_local_rows()
n_col = desc%get_local_cols() ictxt = desc%get_context()
icomm = desc%get_mpic()
! check on blacs grid n_row = desc%get_local_rows()
call psb_info(ictxt, me, np) n_col = desc%get_local_cols()
if (np == -1) then
info = psb_err_context_error_ ! check on blacs grid
call psb_errpush(info,name) call psb_info(ictxt, me, np)
goto 9999 if (np == -1) then
endif info = psb_err_context_error_
call psb_errpush(info,name)
if (.not.(desc%is_bld())) then goto 9999
info = psb_err_invalid_cd_state_ endif
call psb_errpush(info,name)
goto 9999 if (.not.(desc%is_bld())) then
end if
! Here we do not know yet who owns what, so we have
! to call fnd_owner.
nh = (n_col-n_row)
Allocate(helem(max(1,nh)),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
do i=1, nh
helem(i) = n_row+i ! desc%loc_to_glob(n_row+i)
end do
call desc%indxmap%l2gip(helem(1:nh),info)
call desc%indxmap%fnd_owner(helem(1:nh),hproc,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='fnd_owner')
goto 9999
endif
if (nh > size(hproc)) then
info=psb_err_from_subroutine_
call psb_errpush(psb_err_from_subroutine_,name,a_err='nh > size(hproc)')
goto 9999
end if
allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
j = 1
do i=1,nh
tmphl(j+0) = hproc(i)
if (tmphl(j+0)<0) then
write(psb_err_unit,*) me,'Unrecoverable error: missing proc from asb',&
& i, nh, n_row+i,helem(i),hproc(i)
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
tmphl(j+1) = 1
tmphl(j+2) = n_row+i
j = j + 3
end do
tmphl(j) = -1
lhalo = j
nhalo = (lhalo-1)/3
call psb_move_alloc(tmphl,desc%halo_index,info) ! Here we do not know yet who owns what, so we have
! to call fnd_owner.
nh = (n_col-n_row)
Allocate(helem(max(1,nh)),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
do i=1, nh
helem(i) = n_row+i ! desc%loc_to_glob(n_row+i)
end do
call desc%indxmap%l2gip(helem(1:nh),info)
call desc%indxmap%fnd_owner(helem(1:nh),hproc,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='fnd_owner')
goto 9999
endif
if (nh > size(hproc)) then
info=psb_err_from_subroutine_
call psb_errpush(psb_err_from_subroutine_,name,a_err='nh > size(hproc)')
goto 9999
end if
call psb_erractionrestore(err_act) allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info)
return if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
j = 1
do i=1,nh
tmphl(j+0) = hproc(i)
if (tmphl(j+0)<0) then
write(psb_err_unit,*) me,'Unrecoverable error: missing proc from asb',&
& i, nh, n_row+i,helem(i),hproc(i)
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
tmphl(j+1) = 1
tmphl(j+2) = n_row+i
j = j + 3
end do
tmphl(j) = -1
lhalo = j
nhalo = (lhalo-1)/3
call psb_move_alloc(tmphl,desc%halo_index,info)
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_bld_tmphalo end subroutine psi_bld_tmphalo
end submodule psi_bld_tmphalo_impl_mod

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

@ -50,101 +50,105 @@
! desc - type(psb_desc_type). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! !
subroutine psi_bld_tmpovrl(iv,desc,info) submodule (psi_i_mod) psi_bld_tmpovrl_impl_mod
use psb_desc_mod
use psb_serial_mod contains
use psb_const_mod subroutine psi_bld_tmpovrl(iv,desc,info)
use psb_error_mod use psb_desc_mod
use psb_penv_mod use psb_serial_mod
use psb_realloc_mod use psb_const_mod
use psi_mod, psb_protect_name => psi_bld_tmpovrl use psb_error_mod
implicit none use psb_penv_mod
integer(psb_ipk_), intent(in) :: iv(:) use psb_realloc_mod
type(psb_desc_type), intent(inout) :: desc implicit none
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in) :: iv(:)
type(psb_desc_type), intent(inout) :: desc
!locals integer(psb_ipk_), intent(out) :: info
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 !locals
integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:) 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
integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:)
character(len=20) :: name,ch_err
integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level
info = psb_success_ character(len=20) :: name,ch_err
name = 'psi_bld_tmpovrl'
call psb_erractionsave(err_act) info = psb_success_
debug_unit = psb_get_debug_unit() name = 'psi_bld_tmpovrl'
debug_level = psb_get_debug_level() call psb_erractionsave(err_act)
ictxt = desc%get_context() debug_unit = psb_get_debug_unit()
icomm = desc%get_mpic() debug_level = psb_get_debug_level()
ictxt = desc%get_context()
! check on blacs grid icomm = desc%get_mpic()
call psb_info(ictxt, me, np)
if (np == -1) then ! check on blacs grid
info = psb_err_context_error_ call psb_info(ictxt, me, np)
call psb_errpush(info,name) if (np == -1) then
goto 9999 info = psb_err_context_error_
endif call psb_errpush(info,name)
goto 9999
l_ov_ix=0 endif
l_ov_el=0
i = 1 l_ov_ix=0
do while (iv(i) /= -1) l_ov_el=0
idx = iv(i) i = 1
i = i + 1 do while (iv(i) /= -1)
nprocs = iv(i) idx = iv(i)
i = i + 1 i = i + 1
l_ov_ix = l_ov_ix+3*(nprocs-1) nprocs = iv(i)
l_ov_el = l_ov_el + 1 i = i + 1
i = i + nprocs l_ov_ix = l_ov_ix+3*(nprocs-1)
enddo l_ov_el = l_ov_el + 1
i = i + nprocs
l_ov_ix = l_ov_ix+3
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': Ov len',l_ov_ix,l_ov_el
allocate(ov_idx(l_ov_ix),ov_el(l_ov_el,3), stat=info)
if (info /= psb_no_err_) then
info=psb_err_from_subroutine_
err=info
call psb_errpush(err,name,a_err='psb_realloc')
goto 9999
end if
l_ov_ix=0
l_ov_el=0
i = 1
do while (iv(i) /= -1)
idx = iv(i)
i = i+1
nprocs = iv(i)
l_ov_el = l_ov_el+1
ov_el(l_ov_el,1) = idx ! Index
ov_el(l_ov_el,2) = nprocs ! How many procs
ov_el(l_ov_el,3) = minval(iv(i+1:i+nprocs)) ! master proc
do j=1, nprocs
if (iv(i+j) /= me) then
ov_idx(l_ov_ix+1) = iv(i+j)
ov_idx(l_ov_ix+2) = 1
ov_idx(l_ov_ix+3) = idx
l_ov_ix = l_ov_ix+3
endif
enddo enddo
i = i + nprocs + 1
enddo
l_ov_ix = l_ov_ix + 1
ov_idx(l_ov_ix) = -1
call psb_move_alloc(ov_idx,desc%ovrlap_index,info)
if (info == psb_success_) call psb_move_alloc(ov_el,desc%ovrlap_elem,info)
l_ov_ix = l_ov_ix+3
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': Ov len',l_ov_ix,l_ov_el
call psb_erractionrestore(err_act) allocate(ov_idx(l_ov_ix),ov_el(l_ov_el,3), stat=info)
return if (info /= psb_no_err_) then
info=psb_err_from_subroutine_
err=info
call psb_errpush(err,name,a_err='psb_realloc')
goto 9999
end if
l_ov_ix=0
l_ov_el=0
i = 1
do while (iv(i) /= -1)
idx = iv(i)
i = i+1
nprocs = iv(i)
l_ov_el = l_ov_el+1
ov_el(l_ov_el,1) = idx ! Index
ov_el(l_ov_el,2) = nprocs ! How many procs
ov_el(l_ov_el,3) = minval(iv(i+1:i+nprocs)) ! master proc
do j=1, nprocs
if (iv(i+j) /= me) then
ov_idx(l_ov_ix+1) = iv(i+j)
ov_idx(l_ov_ix+2) = 1
ov_idx(l_ov_ix+3) = idx
l_ov_ix = l_ov_ix+3
endif
enddo
i = i + nprocs + 1
enddo
l_ov_ix = l_ov_ix + 1
ov_idx(l_ov_ix) = -1
call psb_move_alloc(ov_idx,desc%ovrlap_index,info)
if (info == psb_success_) call psb_move_alloc(ov_el,desc%ovrlap_elem,info)
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_bld_tmpovrl end subroutine psi_bld_tmpovrl
end submodule psi_bld_tmpovrl_impl_mod

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

@ -43,77 +43,80 @@
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! !
subroutine psi_crea_bnd_elem(bndel,desc_a,info) submodule (psi_i_mod) psi_crea_bnd_elem_impl_mod
use psi_mod, psb_protect_name => psi_crea_bnd_elem
use psb_realloc_mod
use psb_desc_mod
use psb_error_mod
use psb_serial_mod
implicit none
integer(psb_ipk_), allocatable :: bndel(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), allocatable :: work(:) contains
integer(psb_ipk_) :: i, j, nr, ns, k, err_act subroutine psi_crea_bnd_elem(bndel,desc_a,info)
character(len=20) :: name use psb_realloc_mod
use psb_desc_mod
use psb_error_mod
use psb_serial_mod
implicit none
info = psb_success_ integer(psb_ipk_), allocatable :: bndel(:)
name='psi_crea_bnd_elem' type(psb_desc_type), intent(in) :: desc_a
call psb_erractionsave(err_act) integer(psb_ipk_), intent(out) :: info
allocate(work(size(desc_a%halo_index)),stat=info) integer(psb_ipk_), allocatable :: work(:)
if (info /= psb_success_ ) then integer(psb_ipk_) :: i, j, nr, ns, k, err_act
info = psb_err_alloc_dealloc_ character(len=20) :: name
call psb_errpush(info,name)
goto 9999
end if
i=0 info = psb_success_
j=1 name='psi_crea_bnd_elem'
do while(desc_a%halo_index(j) /= -1) call psb_erractionsave(err_act)
nr = desc_a%halo_index(j+1) allocate(work(size(desc_a%halo_index)),stat=info)
ns = desc_a%halo_index(j+1+nr+1) if (info /= psb_success_ ) then
do k=1, ns info = psb_err_alloc_dealloc_
i = i + 1 call psb_errpush(info,name)
work(i) = desc_a%halo_index(j+1+nr+1+k) goto 9999
end if
i=0
j=1
do while(desc_a%halo_index(j) /= -1)
nr = desc_a%halo_index(j+1)
ns = desc_a%halo_index(j+1+nr+1)
do k=1, ns
i = i + 1
work(i) = desc_a%halo_index(j+1+nr+1+k)
enddo
j = j + 1 + ns + 1 + nr + 1
enddo enddo
j = j + 1 + ns + 1 + nr + 1
enddo
call psb_msort_unique(work(1:i),j) call psb_msort_unique(work(1:i),j)
if (.true.) then if (.true.) then
if (j>=0) then if (j>=0) then
call psb_realloc(j,bndel,info) call psb_realloc(j,bndel,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
bndel(1:j) = work(1:j)
else
if (allocated(bndel)) then
deallocate(bndel)
end if
end if
else
call psb_realloc(j+1,bndel,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
bndel(1:j) = work(1:j) bndel(1:j) = work(1:j)
else bndel(j+1) = -1
if (allocated(bndel)) then endif
deallocate(bndel)
end if
end if
else
call psb_realloc(j+1,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
deallocate(work) deallocate(work)
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_crea_bnd_elem end subroutine psi_crea_bnd_elem
end submodule psi_crea_bnd_elem_impl_mod

Write Preview
Loading…
Cancel
Save