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.
! info - integer. return code.
!
subroutine psi_bld_tmphalo(desc,info)
use psb_desc_mod
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psi_mod, psb_protect_name => psi_bld_tmphalo
implicit none
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),allocatable :: helem(:),hproc(:)
integer(psb_ipk_),allocatable :: tmphl(:)
integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,&
& n_col, err_act, key, ih, nh, idx, nk,icomm
integer(psb_ipk_) :: ictxt,n_row
character(len=20) :: name,ch_err
info = psb_success_
name = 'psi_bld_tmphalo'
call psb_erractionsave(err_act)
ictxt = desc%get_context()
icomm = desc%get_mpic()
n_row = desc%get_local_rows()
n_col = desc%get_local_cols()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.(desc%is_bld())) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
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)
submodule (psi_i_mod) psi_bld_tmphalo_impl_mod
contains
subroutine psi_bld_tmphalo(desc,info)
use psb_desc_mod
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
implicit none
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),allocatable :: helem(:),hproc(:)
integer(psb_ipk_),allocatable :: tmphl(:)
integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,&
& n_col, err_act, key, ih, nh, idx, nk,icomm
integer(psb_ipk_) :: ictxt,n_row
character(len=20) :: name,ch_err
info = psb_success_
name = 'psi_bld_tmphalo'
call psb_erractionsave(err_act)
ictxt = desc%get_context()
icomm = desc%get_mpic()
n_row = desc%get_local_rows()
n_col = desc%get_local_cols()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.(desc%is_bld())) then
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)
! 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)
return
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_
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)
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.
! info - integer. return code.
!
subroutine psi_bld_tmpovrl(iv,desc,info)
use psb_desc_mod
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psi_mod, psb_protect_name => psi_bld_tmpovrl
implicit none
integer(psb_ipk_), intent(in) :: iv(:)
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: 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
integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:)
integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level
character(len=20) :: name,ch_err
info = psb_success_
name = 'psi_bld_tmpovrl'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc%get_context()
icomm = desc%get_mpic()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
l_ov_ix=0
l_ov_el=0
i = 1
do while (iv(i) /= -1)
idx = iv(i)
i = i + 1
nprocs = iv(i)
i = i + 1
l_ov_ix = l_ov_ix+3*(nprocs-1)
l_ov_el = l_ov_el + 1
i = i + nprocs
enddo
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
submodule (psi_i_mod) psi_bld_tmpovrl_impl_mod
contains
subroutine psi_bld_tmpovrl(iv,desc,info)
use psb_desc_mod
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: iv(:)
type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: 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
integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:)
integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level
character(len=20) :: name,ch_err
info = psb_success_
name = 'psi_bld_tmpovrl'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc%get_context()
icomm = desc%get_mpic()
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
l_ov_ix=0
l_ov_el=0
i = 1
do while (iv(i) /= -1)
idx = iv(i)
i = i + 1
nprocs = iv(i)
i = i + 1
l_ov_ix = l_ov_ix+3*(nprocs-1)
l_ov_el = l_ov_el + 1
i = i + nprocs
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)
return
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
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)
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.
! info - integer. return code.
!
subroutine psi_crea_bnd_elem(bndel,desc_a,info)
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
submodule (psi_i_mod) psi_crea_bnd_elem_impl_mod
integer(psb_ipk_), allocatable :: work(:)
integer(psb_ipk_) :: i, j, nr, ns, k, err_act
character(len=20) :: name
contains
subroutine psi_crea_bnd_elem(bndel,desc_a,info)
use psb_realloc_mod
use psb_desc_mod
use psb_error_mod
use psb_serial_mod
implicit none
info = psb_success_
name='psi_crea_bnd_elem'
call psb_erractionsave(err_act)
integer(psb_ipk_), allocatable :: bndel(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
allocate(work(size(desc_a%halo_index)),stat=info)
if (info /= psb_success_ ) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
integer(psb_ipk_), allocatable :: work(:)
integer(psb_ipk_) :: i, j, nr, ns, k, err_act
character(len=20) :: name
i=0
j=1
do while(desc_a%halo_index(j) /= -1)
info = psb_success_
name='psi_crea_bnd_elem'
call psb_erractionsave(err_act)
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)
allocate(work(size(desc_a%halo_index)),stat=info)
if (info /= psb_success_ ) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
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
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 (j>=0) then
call psb_realloc(j,bndel,info)
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 (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
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
bndel(j+1) = -1
endif
deallocate(work)
call psb_erractionrestore(err_act)
return
deallocate(work)
call psb_erractionrestore(err_act)
return
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