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

Rework use of icomm in halo and friends, add submodules

Browse Source
fixmpic
sfilippone 2 months ago
parent bdee97e991
commit 724345ab27
78 changed files with 22647 additions and 23317 deletions
Show Stats Download Patch File Download Diff File

142
base/comm/internals/psi_covrl_restr.f90
Unescape Escape View File

@ -35,90 +35,90 @@
!
!
!
subroutine psi_covrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restr_vect
use psb_c_base_vect_mod
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_covrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_v_mod) psi_c_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_covrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_covrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restr_vect
return
end subroutine psi_covrl_restr_vect
subroutine psi_covrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restr_multivect
use psb_c_base_vect_mod
module subroutine psi_covrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_c_base_multivect_type) :: x
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: x
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_covrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_covrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restr_multivect
return
end subroutine psi_covrl_restr_multivect
end submodule psi_c_ovrl_restr_v_impl

158
base/comm/internals/psi_covrl_restr_a.f90
Unescape Escape View File

@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_covrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restrr1
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_a_mod) psi_c_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_covrl_restrr1(x,xs,desc_a,info)
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restrr1
return
end subroutine psi_covrl_restrr1
subroutine psi_covrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_restrr2
module subroutine psi_covrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_covrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_restrr2
return
end subroutine psi_covrl_restrr2
end submodule psi_c_ovrl_restr_a_impl

186
base/comm/internals/psi_covrl_save.f90
Unescape Escape View File

@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_covrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_save_vect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_v_mod) psi_c_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_covrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_c_base_vect_type) :: x
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_save_vect
subroutine psi_covrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_save_multivect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_multivect_type) :: x
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_covrl_save_vect
module subroutine psi_covrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_c_base_multivect_type) :: x
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_save_multivect
return
end subroutine psi_covrl_save_multivect
end submodule psi_c_ovrl_save_v_impl

194
base/comm/internals/psi_covrl_save_a.f90
Unescape Escape View File

@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_covrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_saver1
use psb_realloc_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_a_mod) psi_c_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_covrl_saver1(x,xs,desc_a,info)
implicit none
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_covrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_saver1
subroutine psi_covrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_covrl_saver2
use psb_realloc_mod
implicit none
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_covrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_covrl_saver1
module subroutine psi_covrl_saver2(x,xs,desc_a,info)
implicit none
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_covrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_saver2
return
end subroutine psi_covrl_saver2
end submodule psi_c_ovrl_save_a_impl

314
base/comm/internals/psi_covrl_upd.f90
Unescape Escape View File

@ -36,169 +36,167 @@
!
!
!
subroutine psi_covrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_upd_vect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_c_comm_v_mod) psi_c_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_covrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_c_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_upd_vect
subroutine psi_covrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_upd_multivect
use psb_realloc_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_covrl_upd_vect
module subroutine psi_covrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_c_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_upd_multivect
return
end subroutine psi_covrl_upd_multivect
end submodule psi_c_ovrl_upd_v_impl

264
base/comm/internals/psi_covrl_upd_a.f90
Unescape Escape View File

@ -32,143 +32,143 @@
! Subroutine: psi_covrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_covrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_updr1
implicit none
complex(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_c_comm_a_mod) psi_c_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_covrl_updr1(x,desc_a,update,info)
implicit none
complex(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_updr1
subroutine psi_covrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_covrl_updr2
implicit none
complex(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_covrl_updr1
module subroutine psi_covrl_updr2(x,desc_a,update,info)
implicit none
complex(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_covrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = czero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_covrl_updr2
return
end subroutine psi_covrl_updr2
end submodule psi_c_ovrl_upd_a_impl

1201
base/comm/internals/psi_cswapdata.F90
View File

File diff suppressed because it is too large Load Diff

1617
base/comm/internals/psi_cswapdata_a.F90
View File

File diff suppressed because it is too large Load Diff

1217
base/comm/internals/psi_cswaptran.F90
View File

File diff suppressed because it is too large Load Diff

1623
base/comm/internals/psi_cswaptran_a.F90
View File

File diff suppressed because it is too large Load Diff

142
base/comm/internals/psi_dovrl_restr.f90
Unescape Escape View File

@ -35,90 +35,90 @@
!
!
!
subroutine psi_dovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restr_vect
use psb_d_base_vect_mod
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_v_mod) psi_d_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_dovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restr_vect
return
end subroutine psi_dovrl_restr_vect
subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restr_multivect
use psb_d_base_vect_mod
module subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_d_base_multivect_type) :: x
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: x
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_dovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restr_multivect
return
end subroutine psi_dovrl_restr_multivect
end submodule psi_d_ovrl_restr_v_impl

158
base/comm/internals/psi_dovrl_restr_a.f90
Unescape Escape View File

@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_dovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restrr1
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_a_mod) psi_d_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_dovrl_restrr1(x,xs,desc_a,info)
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restrr1
return
end subroutine psi_dovrl_restrr1
subroutine psi_dovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_restrr2
module subroutine psi_dovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_dovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_restrr2
return
end subroutine psi_dovrl_restrr2
end submodule psi_d_ovrl_restr_a_impl

186
base/comm/internals/psi_dovrl_save.f90
Unescape Escape View File

@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_dovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_save_vect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_v_mod) psi_d_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_dovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_d_base_vect_type) :: x
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_save_vect
subroutine psi_dovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_save_multivect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_multivect_type) :: x
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_dovrl_save_vect
module subroutine psi_dovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_d_base_multivect_type) :: x
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_save_multivect
return
end subroutine psi_dovrl_save_multivect
end submodule psi_d_ovrl_save_v_impl

194
base/comm/internals/psi_dovrl_save_a.f90
Unescape Escape View File

@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_dovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_saver1
use psb_realloc_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_a_mod) psi_d_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_dovrl_saver1(x,xs,desc_a,info)
implicit none
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_saver1
subroutine psi_dovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_dovrl_saver2
use psb_realloc_mod
implicit none
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_dovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_dovrl_saver1
module subroutine psi_dovrl_saver2(x,xs,desc_a,info)
implicit none
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_dovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_saver2
return
end subroutine psi_dovrl_saver2
end submodule psi_d_ovrl_save_a_impl

314
base/comm/internals/psi_dovrl_upd.f90
Unescape Escape View File

@ -36,169 +36,167 @@
!
!
!
subroutine psi_dovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_upd_vect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_d_comm_v_mod) psi_d_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_dovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_d_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_upd_vect
subroutine psi_dovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_upd_multivect
use psb_realloc_mod
use psb_d_base_vect_mod
implicit none
class(psb_d_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_dovrl_upd_vect
module subroutine psi_dovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_d_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_upd_multivect
return
end subroutine psi_dovrl_upd_multivect
end submodule psi_d_ovrl_upd_v_impl

264
base/comm/internals/psi_dovrl_upd_a.f90
Unescape Escape View File

@ -32,143 +32,143 @@
! Subroutine: psi_dovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_dovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_updr1
implicit none
real(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_d_comm_a_mod) psi_d_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_dovrl_updr1(x,desc_a,update,info)
implicit none
real(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_updr1
subroutine psi_dovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_dovrl_updr2
implicit none
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_dovrl_updr1
module subroutine psi_dovrl_updr2(x,desc_a,update,info)
implicit none
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_dovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = dzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_dovrl_updr2
return
end subroutine psi_dovrl_updr2
end submodule psi_d_ovrl_upd_a_impl

1201
base/comm/internals/psi_dswapdata.F90
View File

File diff suppressed because it is too large Load Diff

1617
base/comm/internals/psi_dswapdata_a.F90
View File

File diff suppressed because it is too large Load Diff

1217
base/comm/internals/psi_dswaptran.F90
View File

File diff suppressed because it is too large Load Diff

1623
base/comm/internals/psi_dswaptran_a.F90
View File

File diff suppressed because it is too large Load Diff

158
base/comm/internals/psi_eovrl_restr_a.f90
Unescape Escape View File

@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_eovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_restrr1
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_e_comm_a_mod) psi_e_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_eovrl_restrr1(x,xs,desc_a,info)
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_restrr1
return
end subroutine psi_eovrl_restrr1
subroutine psi_eovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_restrr2
module subroutine psi_eovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_eovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_restrr2
return
end subroutine psi_eovrl_restrr2
end submodule psi_e_ovrl_restr_a_impl

194
base/comm/internals/psi_eovrl_save_a.f90
Unescape Escape View File

@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_eovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_saver1
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_e_comm_a_mod) psi_e_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_eovrl_saver1(x,xs,desc_a,info)
implicit none
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_eovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_saver1
subroutine psi_eovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_eovrl_saver2
use psb_realloc_mod
implicit none
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_eovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_eovrl_saver1
module subroutine psi_eovrl_saver2(x,xs,desc_a,info)
implicit none
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_eovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_saver2
return
end subroutine psi_eovrl_saver2
end submodule psi_e_ovrl_save_a_impl

264
base/comm/internals/psi_eovrl_upd_a.f90
Unescape Escape View File

@ -32,143 +32,143 @@
! Subroutine: psi_eovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_eovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_eovrl_updr1
implicit none
integer(psb_epk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_e_comm_a_mod) psi_e_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_eovrl_updr1(x,desc_a,update,info)
implicit none
integer(psb_epk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_updr1
subroutine psi_eovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_eovrl_updr2
implicit none
integer(psb_epk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_eovrl_updr1
module subroutine psi_eovrl_updr2(x,desc_a,update,info)
implicit none
integer(psb_epk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_eovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = ezero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_eovrl_updr2
return
end subroutine psi_eovrl_updr2
end submodule psi_e_ovrl_upd_a_impl

1617
base/comm/internals/psi_eswapdata_a.F90
View File

File diff suppressed because it is too large Load Diff

1623
base/comm/internals/psi_eswaptran_a.F90
View File

File diff suppressed because it is too large Load Diff

158
base/comm/internals/psi_i2ovrl_restr_a.f90
Unescape Escape View File

@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_restrr1
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_i2_comm_a_mod) psi_i2_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_restrr1
return
end subroutine psi_i2ovrl_restrr1
subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_restrr2
module subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_i2ovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_restrr2
return
end subroutine psi_i2ovrl_restrr2
end submodule psi_i2_ovrl_restr_a_impl

194
base/comm/internals/psi_i2ovrl_save_a.f90
Unescape Escape View File

@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_saver1
use psb_realloc_mod
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_i2_comm_a_mod) psi_i2_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
implicit none
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_saver1
subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_i2ovrl_saver2
use psb_realloc_mod
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_i2ovrl_saver1
module subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
implicit none
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_i2ovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_saver2
return
end subroutine psi_i2ovrl_saver2
end submodule psi_i2_ovrl_save_a_impl

264
base/comm/internals/psi_i2ovrl_upd_a.f90
Unescape Escape View File

@ -32,143 +32,143 @@
! Subroutine: psi_i2ovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_i2ovrl_updr1
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_i2_comm_a_mod) psi_i2_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_updr1
subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_i2ovrl_updr2
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_i2ovrl_updr1
module subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
implicit none
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_i2ovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = i2zero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_i2ovrl_updr2
return
end subroutine psi_i2ovrl_updr2
end submodule psi_i2_ovrl_upd_a_impl

1617
base/comm/internals/psi_i2swapdata_a.F90
View File

File diff suppressed because it is too large Load Diff

1623
base/comm/internals/psi_i2swaptran_a.F90
View File

File diff suppressed because it is too large Load Diff

142
base/comm/internals/psi_iovrl_restr.f90
Unescape Escape View File

@ -35,90 +35,90 @@
!
!
!
subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_restr_vect
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_iovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
call psb_erractionrestore(err_act)
return
submodule (psi_i_comm_v_mod) psi_i_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_iovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_restr_vect
return
end subroutine psi_iovrl_restr_vect
subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_restr_multivect
use psb_i_base_vect_mod
module subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_iovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_iovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_restr_multivect
return
end subroutine psi_iovrl_restr_multivect
end submodule psi_i_ovrl_restr_v_impl

186
base/comm/internals/psi_iovrl_save.f90
Unescape Escape View File

@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_save_vect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_i_comm_v_mod) psi_i_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_i_base_vect_type) :: x
integer(psb_ipk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_save_vect
subroutine psi_iovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_iovrl_save_multivect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_iovrl_save_vect
module subroutine psi_iovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_save_multivect
return
end subroutine psi_iovrl_save_multivect
end submodule psi_i_ovrl_save_v_impl

314
base/comm/internals/psi_iovrl_upd.f90
Unescape Escape View File

@ -36,169 +36,167 @@
!
!
!
subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_iovrl_upd_vect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_i_comm_v_mod) psi_i_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_i_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_upd_vect
subroutine psi_iovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_iovrl_upd_multivect
use psb_realloc_mod
use psb_i_base_vect_mod
implicit none
class(psb_i_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_iovrl_upd_vect
module subroutine psi_iovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_i_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_iovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = izero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_iovrl_upd_multivect
return
end subroutine psi_iovrl_upd_multivect
end submodule psi_i_ovrl_upd_v_impl

1201
base/comm/internals/psi_iswapdata.F90
View File

File diff suppressed because it is too large Load Diff

1217
base/comm/internals/psi_iswaptran.F90
View File

File diff suppressed because it is too large Load Diff

142
base/comm/internals/psi_lovrl_restr.f90
Unescape Escape View File

@ -35,90 +35,90 @@
!
!
!
subroutine psi_lovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_restr_vect
use psb_l_base_vect_mod
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_lovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
call psb_erractionrestore(err_act)
return
submodule (psi_l_comm_v_mod) psi_l_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_lovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_lovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_restr_vect
return
end subroutine psi_lovrl_restr_vect
subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_restr_multivect
use psb_l_base_vect_mod
module subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_lovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_lovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_restr_multivect
return
end subroutine psi_lovrl_restr_multivect
end submodule psi_l_ovrl_restr_v_impl

186
base/comm/internals/psi_lovrl_save.f90
Unescape Escape View File

@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_lovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_save_vect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_l_comm_v_mod) psi_l_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_lovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_l_base_vect_type) :: x
integer(psb_lpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_save_vect
subroutine psi_lovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_lovrl_save_multivect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_lovrl_save_vect
module subroutine psi_lovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_save_multivect
return
end subroutine psi_lovrl_save_multivect
end submodule psi_l_ovrl_save_v_impl

314
base/comm/internals/psi_lovrl_upd.f90
Unescape Escape View File

@ -36,169 +36,167 @@
!
!
!
subroutine psi_lovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_lovrl_upd_vect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_l_comm_v_mod) psi_l_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_lovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_l_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_upd_vect
subroutine psi_lovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_lovrl_upd_multivect
use psb_realloc_mod
use psb_l_base_vect_mod
implicit none
class(psb_l_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_lovrl_upd_vect
module subroutine psi_lovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_l_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_lovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = lzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_lovrl_upd_multivect
return
end subroutine psi_lovrl_upd_multivect
end submodule psi_l_ovrl_upd_v_impl

1201
base/comm/internals/psi_lswapdata.F90
View File

File diff suppressed because it is too large Load Diff

1217
base/comm/internals/psi_lswaptran.F90
View File

File diff suppressed because it is too large Load Diff

158
base/comm/internals/psi_movrl_restr_a.f90
Unescape Escape View File

@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_movrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_restrr1
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_m_comm_a_mod) psi_m_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_movrl_restrr1(x,xs,desc_a,info)
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_restrr1
return
end subroutine psi_movrl_restrr1
subroutine psi_movrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_restrr2
module subroutine psi_movrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_movrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_restrr2
return
end subroutine psi_movrl_restrr2
end submodule psi_m_ovrl_restr_a_impl

194
base/comm/internals/psi_movrl_save_a.f90
Unescape Escape View File

@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_movrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_saver1
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_m_comm_a_mod) psi_m_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_movrl_saver1(x,xs,desc_a,info)
implicit none
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_movrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_saver1
subroutine psi_movrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_movrl_saver2
use psb_realloc_mod
implicit none
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_movrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_movrl_saver1
module subroutine psi_movrl_saver2(x,xs,desc_a,info)
implicit none
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_movrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_saver2
return
end subroutine psi_movrl_saver2
end submodule psi_m_ovrl_save_a_impl

264
base/comm/internals/psi_movrl_upd_a.f90
Unescape Escape View File

@ -32,143 +32,143 @@
! Subroutine: psi_movrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_movrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_movrl_updr1
implicit none
integer(psb_mpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_m_comm_a_mod) psi_m_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_movrl_updr1(x,desc_a,update,info)
implicit none
integer(psb_mpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_updr1
subroutine psi_movrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_movrl_updr2
implicit none
integer(psb_mpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_movrl_updr1
module subroutine psi_movrl_updr2(x,desc_a,update,info)
implicit none
integer(psb_mpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_movrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = mzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_movrl_updr2
return
end subroutine psi_movrl_updr2
end submodule psi_m_ovrl_upd_a_impl

1617
base/comm/internals/psi_mswapdata_a.F90
View File

File diff suppressed because it is too large Load Diff

1623
base/comm/internals/psi_mswaptran_a.F90
View File

File diff suppressed because it is too large Load Diff

142
base/comm/internals/psi_sovrl_restr.f90
Unescape Escape View File

@ -35,90 +35,90 @@
!
!
!
subroutine psi_sovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restr_vect
use psb_s_base_vect_mod
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_sovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_v_mod) psi_s_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_sovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_sovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restr_vect
return
end subroutine psi_sovrl_restr_vect
subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restr_multivect
use psb_s_base_vect_mod
module subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_s_base_multivect_type) :: x
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: x
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_sovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_sovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restr_multivect
return
end subroutine psi_sovrl_restr_multivect
end submodule psi_s_ovrl_restr_v_impl

158
base/comm/internals/psi_sovrl_restr_a.f90
Unescape Escape View File

@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_sovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restrr1
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_a_mod) psi_s_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_sovrl_restrr1(x,xs,desc_a,info)
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restrr1
return
end subroutine psi_sovrl_restrr1
subroutine psi_sovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_restrr2
module subroutine psi_sovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_sovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_restrr2
return
end subroutine psi_sovrl_restrr2
end submodule psi_s_ovrl_restr_a_impl

186
base/comm/internals/psi_sovrl_save.f90
Unescape Escape View File

@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_sovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_save_vect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_v_mod) psi_s_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_sovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_s_base_vect_type) :: x
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_save_vect
subroutine psi_sovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_save_multivect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_multivect_type) :: x
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_sovrl_save_vect
module subroutine psi_sovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_s_base_multivect_type) :: x
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_save_multivect
return
end subroutine psi_sovrl_save_multivect
end submodule psi_s_ovrl_save_v_impl

194
base/comm/internals/psi_sovrl_save_a.f90
Unescape Escape View File

@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_sovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_saver1
use psb_realloc_mod
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_a_mod) psi_s_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_sovrl_saver1(x,xs,desc_a,info)
implicit none
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_sovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_saver1
subroutine psi_sovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_sovrl_saver2
use psb_realloc_mod
implicit none
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_sovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_sovrl_saver1
module subroutine psi_sovrl_saver2(x,xs,desc_a,info)
implicit none
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_sovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_saver2
return
end subroutine psi_sovrl_saver2
end submodule psi_s_ovrl_save_a_impl

314
base/comm/internals/psi_sovrl_upd.f90
Unescape Escape View File

@ -36,169 +36,167 @@
!
!
!
subroutine psi_sovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_upd_vect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_s_comm_v_mod) psi_s_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_sovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_s_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_upd_vect
subroutine psi_sovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_upd_multivect
use psb_realloc_mod
use psb_s_base_vect_mod
implicit none
class(psb_s_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_sovrl_upd_vect
module subroutine psi_sovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_s_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
real(psb_spk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_upd_multivect
return
end subroutine psi_sovrl_upd_multivect
end submodule psi_s_ovrl_upd_v_impl

264
base/comm/internals/psi_sovrl_upd_a.f90
Unescape Escape View File

@ -32,143 +32,143 @@
! Subroutine: psi_sovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_sovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_updr1
implicit none
real(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_s_comm_a_mod) psi_s_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_sovrl_updr1(x,desc_a,update,info)
implicit none
real(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_updr1
subroutine psi_sovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_sovrl_updr2
implicit none
real(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_sovrl_updr1
module subroutine psi_sovrl_updr2(x,desc_a,update,info)
implicit none
real(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_sovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = szero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_sovrl_updr2
return
end subroutine psi_sovrl_updr2
end submodule psi_s_ovrl_upd_a_impl

1201
base/comm/internals/psi_sswapdata.F90
View File

File diff suppressed because it is too large Load Diff

1617
base/comm/internals/psi_sswapdata_a.F90
View File

File diff suppressed because it is too large Load Diff

1217
base/comm/internals/psi_sswaptran.F90
View File

File diff suppressed because it is too large Load Diff

1623
base/comm/internals/psi_sswaptran_a.F90
View File

File diff suppressed because it is too large Load Diff

142
base/comm/internals/psi_zovrl_restr.f90
Unescape Escape View File

@ -35,90 +35,90 @@
!
!
!
subroutine psi_zovrl_restr_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restr_vect
use psb_z_base_vect_mod
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_zovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_v_mod) psi_z_ovrl_restr_v_impl
use psb_base_mod
contains
module subroutine psi_zovrl_restr_vect(x,xs,desc_a,info)
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_zovrl_restr_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restr_vect
return
end subroutine psi_zovrl_restr_vect
subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restr_multivect
use psb_z_base_vect_mod
module subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info)
implicit none
implicit none
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz,nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_zovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_zovrl_restr_mv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
isz = size(desc_a%ovrlap_elem,1)
call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero)
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restr_multivect
return
end subroutine psi_zovrl_restr_multivect
end submodule psi_z_ovrl_restr_v_impl

158
base/comm/internals/psi_zovrl_restr_a.f90
Unescape Escape View File

@ -34,98 +34,100 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_zovrl_restrr1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restrr1
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_a_mod) psi_z_ovrl_restr_a_impl
use psb_base_mod
contains
module subroutine psi_zovrl_restrr1(x,xs,desc_a,info)
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_restrr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx) = xs(i)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restrr1
return
end subroutine psi_zovrl_restrr1
subroutine psi_zovrl_restrr2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_restrr2
module subroutine psi_zovrl_restrr2(x,xs,desc_a,info)
implicit none
implicit none
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
name='psi_zovrl_restrr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
if (size(x,2) /= size(xs,2)) then
info = psb_err_internal_error_
call psb_errpush(info,name, a_err='Mismacth columns X vs XS')
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
isz = size(desc_a%ovrlap_elem,1)
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
x(idx,:) = xs(i,:)
end do
call psb_erractionrestore(err_act)
return
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_restrr2
return
end subroutine psi_zovrl_restrr2
end submodule psi_z_ovrl_restr_a_impl

186
base/comm/internals/psi_zovrl_save.f90
Unescape Escape View File

@ -34,103 +34,101 @@
! for the transpose matrix-vector product when there is a nonempty overlap.
!
!
subroutine psi_zovrl_save_vect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_save_vect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_v_mod) psi_z_ovrl_save_v_impl
use psb_base_mod
contains
module subroutine psi_zovrl_save_vect(x,xs,desc_a,info)
implicit none
class(psb_z_base_vect_type) :: x
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_save_vect
subroutine psi_zovrl_save_multivect(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_save_multivect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
return
end subroutine psi_zovrl_save_vect
module subroutine psi_zovrl_save_multivect(x,xs,desc_a,info)
implicit none
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nc
integer(psb_ipk_) :: err_act, i, idx
character(len=20) :: name, ch_err
name='psi_dovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
call x%gth(isz,desc_a%ovrlap_elem(:,1),xs)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_save_multivect
return
end subroutine psi_zovrl_save_multivect
end submodule psi_z_ovrl_save_v_impl

194
base/comm/internals/psi_zovrl_save_a.f90
Unescape Escape View File

@ -34,108 +34,104 @@
! These subroutines save the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap.
!
subroutine psi_zovrl_saver1(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_saver1
use psb_realloc_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_a_mod) psi_z_ovrl_save_a_impl
use psb_base_mod
contains
module subroutine psi_zovrl_saver1(x,xs,desc_a,info)
implicit none
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz
character(len=20) :: name, ch_err
name='psi_zovrl_saver1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
call psb_realloc(isz,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i) = x(idx)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_saver1
subroutine psi_zovrl_saver2(x,xs,desc_a,info)
use psi_mod, psi_protect_name => psi_zovrl_saver2
use psb_realloc_mod
implicit none
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_zovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
return
end subroutine psi_zovrl_saver1
module subroutine psi_zovrl_saver2(x,xs,desc_a,info)
implicit none
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc
character(len=20) :: name, ch_err
name='psi_zovrl_saver2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
isz = size(desc_a%ovrlap_elem,1)
nc = size(x,2)
call psb_realloc(isz,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
endif
do i=1, isz
idx = desc_a%ovrlap_elem(i,1)
xs(i,:) = x(idx,:)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_saver2
return
end subroutine psi_zovrl_saver2
end submodule psi_z_ovrl_save_a_impl

314
base/comm/internals/psi_zovrl_upd.f90
Unescape Escape View File

@ -36,169 +36,167 @@
!
!
!
subroutine psi_zovrl_upd_vect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_upd_vect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
submodule (psi_z_comm_v_mod) psi_z_ovrl_upd_v_impl
use psb_base_mod
contains
module subroutine psi_zovrl_upd_vect(x,desc_a,update,info)
implicit none
class(psb_z_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, nx, ndm
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
call psb_realloc(nx,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i) = xs(i)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_upd_vect
subroutine psi_zovrl_upd_multivect(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_upd_multivect
use psb_realloc_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
return
end subroutine psi_zovrl_upd_vect
module subroutine psi_zovrl_upd_multivect(x,desc_a,update,info)
implicit none
class(psb_z_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: np, me, isz, ndm, nx, nc
integer(psb_ipk_) :: err_act, i, idx
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
endif
nx = size(desc_a%ovrlap_elem,1)
nc = x%get_ncols()
call psb_realloc(nx,nc,xs,info)
if (info /= psb_success_) then
info = psb_err_alloc_Dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (update /= psb_sum_) then
call x%gth(nx,desc_a%ovrlap_elem(:,1),xs)
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,nx
ndm = desc_a%ovrlap_elem(i,2)
xs(i,:) = xs(i,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,nx
if (me /= desc_a%ovrlap_elem(i,3))&
& xs(i,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero)
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_upd_multivect
return
end subroutine psi_zovrl_upd_multivect
end submodule psi_z_ovrl_upd_v_impl

264
base/comm/internals/psi_zovrl_upd_a.f90
Unescape Escape View File

@ -32,143 +32,143 @@
! Subroutine: psi_zovrl_update
! These subroutines update the overlap region of a vector; they are used
! for the transpose matrix-vector product when there is a nonempty overlap,
! or for the application of Additive Schwarz preconditioners.
! or for the application of Additive Schwarz preconditioners.
!
!
subroutine psi_zovrl_updr1(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_updr1
implicit none
complex(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
submodule (psi_z_comm_a_mod) psi_z_ovrl_upd_a_impl
use psb_base_mod
contains
module subroutine psi_zovrl_updr1(x,desc_a,update,info)
implicit none
complex(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr1'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx) = x(idx)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_updr1
subroutine psi_zovrl_updr2(x,desc_a,update,info)
use psi_mod, psi_protect_name => psi_zovrl_updr2
implicit none
complex(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
return
end subroutine psi_zovrl_updr1
module subroutine psi_zovrl_updr2(x,desc_a,update,info)
implicit none
complex(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, i, idx, ndm
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name, ch_err
name='psi_zovrl_updr2'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
end if
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
! switch on update type
select case (update)
case(psb_square_root_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/sqrt(real(ndm))
end do
case(psb_avg_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
ndm = desc_a%ovrlap_elem(i,2)
x(idx,:) = x(idx,:)/real(ndm)
end do
case(psb_setzero_)
do i=1,size(desc_a%ovrlap_elem,1)
idx = desc_a%ovrlap_elem(i,1)
if (me /= desc_a%ovrlap_elem(i,3))&
& x(idx,:) = zzero
end do
case(psb_sum_)
! do nothing
case default
! wrong value for choice argument
info = psb_err_iarg_invalid_value_
ierr(1) = 3; ierr(2)=update;
call psb_errpush(info,name,i_err=ierr)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ctxt,err_act)
return
end subroutine psi_zovrl_updr2
return
end subroutine psi_zovrl_updr2
end submodule psi_z_ovrl_upd_a_impl

1201
base/comm/internals/psi_zswapdata.F90
View File

File diff suppressed because it is too large Load Diff

1617
base/comm/internals/psi_zswapdata_a.F90
View File

File diff suppressed because it is too large Load Diff

1217
base/comm/internals/psi_zswaptran.F90
View File

File diff suppressed because it is too large Load Diff

1623
base/comm/internals/psi_zswaptran_a.F90
View File

File diff suppressed because it is too large Load Diff

48
base/modules/comm/psi_c_comm_a_mod.f90
Unescape Escape View File

@ -34,8 +34,7 @@ module psi_c_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type
interface psi_swapdata
subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -44,8 +43,7 @@ module psi_c_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdatam
subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
@ -53,11 +51,9 @@ module psi_c_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdatav
subroutine psi_cswapidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_cswapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -65,11 +61,9 @@ module psi_c_comm_a_mod
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_cswapidxm
subroutine psi_cswapidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_cswapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_Mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
@ -80,8 +74,7 @@ module psi_c_comm_a_mod
interface psi_swaptran
subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_Mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
@ -90,8 +83,7 @@ module psi_c_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptranm
subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
@ -99,11 +91,9 @@ module psi_c_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptranv
subroutine psi_ctranidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_ctranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -111,11 +101,9 @@ module psi_c_comm_a_mod
complex(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ctranidxm
subroutine psi_ctranidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ctranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_) :: y(:), beta
@ -123,17 +111,15 @@ module psi_c_comm_a_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ctranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_covrl_updr1(x,desc_a,update,info)
import
module subroutine psi_covrl_updr1(x,desc_a,update,info)
complex(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_covrl_updr1
subroutine psi_covrl_updr2(x,desc_a,update,info)
import
module subroutine psi_covrl_updr2(x,desc_a,update,info)
complex(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -142,15 +128,13 @@ module psi_c_comm_a_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_covrl_saver1(x,xs,desc_a,info)
import
module subroutine psi_covrl_saver1(x,xs,desc_a,info)
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_covrl_saver1
subroutine psi_covrl_saver2(x,xs,desc_a,info)
import
module subroutine psi_covrl_saver2(x,xs,desc_a,info)
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -159,15 +143,13 @@ module psi_c_comm_a_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_covrl_restrr1(x,xs,desc_a,info)
import
module subroutine psi_covrl_restrr1(x,xs,desc_a,info)
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_covrl_restrr1
subroutine psi_covrl_restrr2(x,xs,desc_a,info)
import
module subroutine psi_covrl_restrr2(x,xs,desc_a,info)
complex(psb_spk_), intent(inout) :: x(:,:)
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

46
base/modules/comm/psi_c_comm_v_mod.f90
Unescape Escape View File

@ -36,8 +36,7 @@ module psi_c_comm_v_mod
use psb_c_base_multivect_mod, only : psb_c_base_multivect_type
interface psi_swapdata
subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
@ -46,8 +45,7 @@ module psi_c_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdata_vect
subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
@ -56,11 +54,9 @@ module psi_c_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdata_multivect
subroutine psi_cswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_cswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
@ -69,11 +65,9 @@ module psi_c_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_cswap_vidx_vect
subroutine psi_cswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_cswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
@ -86,8 +80,7 @@ module psi_c_comm_v_mod
interface psi_swaptran
subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
@ -96,8 +89,7 @@ module psi_c_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptran_vect
subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
@ -106,11 +98,9 @@ module psi_c_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptran_multivect
subroutine psi_ctran_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ctran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
@ -119,11 +109,9 @@ module psi_c_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ctran_vidx_vect
subroutine psi_ctran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ctran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
@ -135,15 +123,13 @@ module psi_c_comm_v_mod
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_covrl_upd_vect(x,desc_a,update,info)
import
module subroutine psi_covrl_upd_vect(x,desc_a,update,info)
class(psb_c_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_covrl_upd_vect
subroutine psi_covrl_upd_multivect(x,desc_a,update,info)
import
module subroutine psi_covrl_upd_multivect(x,desc_a,update,info)
class(psb_c_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -152,15 +138,13 @@ module psi_c_comm_v_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_covrl_save_vect(x,xs,desc_a,info)
import
module subroutine psi_covrl_save_vect(x,xs,desc_a,info)
class(psb_c_base_vect_type) :: x
complex(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_covrl_save_vect
subroutine psi_covrl_save_multivect(x,xs,desc_a,info)
import
module subroutine psi_covrl_save_multivect(x,xs,desc_a,info)
class(psb_c_base_multivect_type) :: x
complex(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -169,15 +153,13 @@ module psi_c_comm_v_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_covrl_restr_vect(x,xs,desc_a,info)
import
module subroutine psi_covrl_restr_vect(x,xs,desc_a,info)
class(psb_c_base_vect_type) :: x
complex(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_covrl_restr_vect
subroutine psi_covrl_restr_multivect(x,xs,desc_a,info)
import
module subroutine psi_covrl_restr_multivect(x,xs,desc_a,info)
class(psb_c_base_multivect_type) :: x
complex(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

48
base/modules/comm/psi_d_comm_a_mod.f90
Unescape Escape View File

@ -34,8 +34,7 @@ module psi_d_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type
interface psi_swapdata
subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -44,8 +43,7 @@ module psi_d_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdatam
subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
@ -53,11 +51,9 @@ module psi_d_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdatav
subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_dswapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -65,11 +61,9 @@ module psi_d_comm_a_mod
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxm
subroutine psi_dswapidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_dswapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_Mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
@ -80,8 +74,7 @@ module psi_d_comm_a_mod
interface psi_swaptran
subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_Mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
@ -90,8 +83,7 @@ module psi_d_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptranm
subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
@ -99,11 +91,9 @@ module psi_d_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptranv
subroutine psi_dtranidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_dtranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -111,11 +101,9 @@ module psi_d_comm_a_mod
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxm
subroutine psi_dtranidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_dtranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
@ -123,17 +111,15 @@ module psi_d_comm_a_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_dovrl_updr1(x,desc_a,update,info)
import
module subroutine psi_dovrl_updr1(x,desc_a,update,info)
real(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dovrl_updr1
subroutine psi_dovrl_updr2(x,desc_a,update,info)
import
module subroutine psi_dovrl_updr2(x,desc_a,update,info)
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -142,15 +128,13 @@ module psi_d_comm_a_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_dovrl_saver1(x,xs,desc_a,info)
import
module subroutine psi_dovrl_saver1(x,xs,desc_a,info)
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dovrl_saver1
subroutine psi_dovrl_saver2(x,xs,desc_a,info)
import
module subroutine psi_dovrl_saver2(x,xs,desc_a,info)
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -159,15 +143,13 @@ module psi_d_comm_a_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_dovrl_restrr1(x,xs,desc_a,info)
import
module subroutine psi_dovrl_restrr1(x,xs,desc_a,info)
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dovrl_restrr1
subroutine psi_dovrl_restrr2(x,xs,desc_a,info)
import
module subroutine psi_dovrl_restrr2(x,xs,desc_a,info)
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

46
base/modules/comm/psi_d_comm_v_mod.f90
Unescape Escape View File

@ -36,8 +36,7 @@ module psi_d_comm_v_mod
use psb_d_base_multivect_mod, only : psb_d_base_multivect_type
interface psi_swapdata
subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
@ -46,8 +45,7 @@ module psi_d_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_vect
subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
@ -56,11 +54,9 @@ module psi_d_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_multivect
subroutine psi_dswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_dswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
@ -69,11 +65,9 @@ module psi_d_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dswap_vidx_vect
subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_dswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
@ -86,8 +80,7 @@ module psi_d_comm_v_mod
interface psi_swaptran
subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
@ -96,8 +89,7 @@ module psi_d_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptran_vect
subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
@ -106,11 +98,9 @@ module psi_d_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptran_multivect
subroutine psi_dtran_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_dtran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
@ -119,11 +109,9 @@ module psi_d_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dtran_vidx_vect
subroutine psi_dtran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_dtran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
@ -135,15 +123,13 @@ module psi_d_comm_v_mod
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_dovrl_upd_vect(x,desc_a,update,info)
import
module subroutine psi_dovrl_upd_vect(x,desc_a,update,info)
class(psb_d_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dovrl_upd_vect
subroutine psi_dovrl_upd_multivect(x,desc_a,update,info)
import
module subroutine psi_dovrl_upd_multivect(x,desc_a,update,info)
class(psb_d_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -152,15 +138,13 @@ module psi_d_comm_v_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_dovrl_save_vect(x,xs,desc_a,info)
import
module subroutine psi_dovrl_save_vect(x,xs,desc_a,info)
class(psb_d_base_vect_type) :: x
real(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dovrl_save_vect
subroutine psi_dovrl_save_multivect(x,xs,desc_a,info)
import
module subroutine psi_dovrl_save_multivect(x,xs,desc_a,info)
class(psb_d_base_multivect_type) :: x
real(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -169,15 +153,13 @@ module psi_d_comm_v_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_dovrl_restr_vect(x,xs,desc_a,info)
import
module subroutine psi_dovrl_restr_vect(x,xs,desc_a,info)
class(psb_d_base_vect_type) :: x
real(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_dovrl_restr_vect
subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info)
import
module subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info)
class(psb_d_base_multivect_type) :: x
real(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

48
base/modules/comm/psi_e_comm_a_mod.f90
Unescape Escape View File

@ -34,8 +34,7 @@ module psi_e_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_
interface psi_swapdata
subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -44,8 +43,7 @@ module psi_e_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_eswapdatam
subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_epk_) :: y(:), beta
@ -53,11 +51,9 @@ module psi_e_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_eswapdatav
subroutine psi_eswapidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_eswapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -65,11 +61,9 @@ module psi_e_comm_a_mod
integer(psb_epk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_eswapidxm
subroutine psi_eswapidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_eswapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_Mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_epk_) :: y(:), beta
@ -80,8 +74,7 @@ module psi_e_comm_a_mod
interface psi_swaptran
subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_Mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
@ -90,8 +83,7 @@ module psi_e_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_eswaptranm
subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_epk_) :: y(:), beta
@ -99,11 +91,9 @@ module psi_e_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_eswaptranv
subroutine psi_etranidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_etranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -111,11 +101,9 @@ module psi_e_comm_a_mod
integer(psb_epk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_etranidxm
subroutine psi_etranidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_etranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_epk_) :: y(:), beta
@ -123,17 +111,15 @@ module psi_e_comm_a_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_etranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_eovrl_updr1(x,desc_a,update,info)
import
module subroutine psi_eovrl_updr1(x,desc_a,update,info)
integer(psb_epk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_eovrl_updr1
subroutine psi_eovrl_updr2(x,desc_a,update,info)
import
module subroutine psi_eovrl_updr2(x,desc_a,update,info)
integer(psb_epk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -142,15 +128,13 @@ module psi_e_comm_a_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_eovrl_saver1(x,xs,desc_a,info)
import
module subroutine psi_eovrl_saver1(x,xs,desc_a,info)
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_eovrl_saver1
subroutine psi_eovrl_saver2(x,xs,desc_a,info)
import
module subroutine psi_eovrl_saver2(x,xs,desc_a,info)
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -159,15 +143,13 @@ module psi_e_comm_a_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_eovrl_restrr1(x,xs,desc_a,info)
import
module subroutine psi_eovrl_restrr1(x,xs,desc_a,info)
integer(psb_epk_), intent(inout) :: x(:)
integer(psb_epk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_eovrl_restrr1
subroutine psi_eovrl_restrr2(x,xs,desc_a,info)
import
module subroutine psi_eovrl_restrr2(x,xs,desc_a,info)
integer(psb_epk_), intent(inout) :: x(:,:)
integer(psb_epk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

48
base/modules/comm/psi_i2_comm_a_mod.f90
Unescape Escape View File

@ -34,8 +34,7 @@ module psi_i2_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_
interface psi_swapdata
subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -44,8 +43,7 @@ module psi_i2_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swapdatam
subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
@ -53,11 +51,9 @@ module psi_i2_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swapdatav
subroutine psi_i2swapidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_i2swapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -65,11 +61,9 @@ module psi_i2_comm_a_mod
integer(psb_i2pk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_i2swapidxm
subroutine psi_i2swapidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_i2swapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_Mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
@ -80,8 +74,7 @@ module psi_i2_comm_a_mod
interface psi_swaptran
subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_Mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
@ -90,8 +83,7 @@ module psi_i2_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swaptranm
subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
@ -99,11 +91,9 @@ module psi_i2_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_i2swaptranv
subroutine psi_i2tranidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_i2tranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -111,11 +101,9 @@ module psi_i2_comm_a_mod
integer(psb_i2pk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_i2tranidxm
subroutine psi_i2tranidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_i2tranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_i2pk_) :: y(:), beta
@ -123,17 +111,15 @@ module psi_i2_comm_a_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_i2tranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
import
module subroutine psi_i2ovrl_updr1(x,desc_a,update,info)
integer(psb_i2pk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_updr1
subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
import
module subroutine psi_i2ovrl_updr2(x,desc_a,update,info)
integer(psb_i2pk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -142,15 +128,13 @@ module psi_i2_comm_a_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
import
module subroutine psi_i2ovrl_saver1(x,xs,desc_a,info)
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_saver1
subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
import
module subroutine psi_i2ovrl_saver2(x,xs,desc_a,info)
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -159,15 +143,13 @@ module psi_i2_comm_a_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
import
module subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info)
integer(psb_i2pk_), intent(inout) :: x(:)
integer(psb_i2pk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_i2ovrl_restrr1
subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
import
module subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info)
integer(psb_i2pk_), intent(inout) :: x(:,:)
integer(psb_i2pk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

46
base/modules/comm/psi_i_comm_v_mod.f90
Unescape Escape View File

@ -37,8 +37,7 @@ module psi_i_comm_v_mod
use psb_i_base_multivect_mod, only : psb_i_base_multivect_type
interface psi_swapdata
subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
@ -47,8 +46,7 @@ module psi_i_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswapdata_vect
subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
@ -57,11 +55,9 @@ module psi_i_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswapdata_multivect
subroutine psi_iswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_iswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
@ -70,11 +66,9 @@ module psi_i_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_iswap_vidx_vect
subroutine psi_iswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_iswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
@ -87,8 +81,7 @@ module psi_i_comm_v_mod
interface psi_swaptran
subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
@ -97,8 +90,7 @@ module psi_i_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswaptran_vect
subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
@ -107,11 +99,9 @@ module psi_i_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswaptran_multivect
subroutine psi_itran_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_itran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
@ -120,11 +110,9 @@ module psi_i_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_itran_vidx_vect
subroutine psi_itran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_itran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
@ -136,15 +124,13 @@ module psi_i_comm_v_mod
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
import
module subroutine psi_iovrl_upd_vect(x,desc_a,update,info)
class(psb_i_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_upd_vect
subroutine psi_iovrl_upd_multivect(x,desc_a,update,info)
import
module subroutine psi_iovrl_upd_multivect(x,desc_a,update,info)
class(psb_i_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -153,15 +139,13 @@ module psi_i_comm_v_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
import
module subroutine psi_iovrl_save_vect(x,xs,desc_a,info)
class(psb_i_base_vect_type) :: x
integer(psb_ipk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_save_vect
subroutine psi_iovrl_save_multivect(x,xs,desc_a,info)
import
module subroutine psi_iovrl_save_multivect(x,xs,desc_a,info)
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -170,15 +154,13 @@ module psi_i_comm_v_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
import
module subroutine psi_iovrl_restr_vect(x,xs,desc_a,info)
class(psb_i_base_vect_type) :: x
integer(psb_ipk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_iovrl_restr_vect
subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info)
import
module subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info)
class(psb_i_base_multivect_type) :: x
integer(psb_ipk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

46
base/modules/comm/psi_l_comm_v_mod.f90
Unescape Escape View File

@ -38,8 +38,7 @@ module psi_l_comm_v_mod
use psb_l_base_multivect_mod, only : psb_l_base_multivect_type
interface psi_swapdata
subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
@ -48,8 +47,7 @@ module psi_l_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswapdata_vect
subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
@ -58,11 +56,9 @@ module psi_l_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswapdata_multivect
subroutine psi_lswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_lswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
@ -71,11 +67,9 @@ module psi_l_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_lswap_vidx_vect
subroutine psi_lswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_lswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
@ -88,8 +82,7 @@ module psi_l_comm_v_mod
interface psi_swaptran
subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
@ -98,8 +91,7 @@ module psi_l_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswaptran_vect
subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
@ -108,11 +100,9 @@ module psi_l_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswaptran_multivect
subroutine psi_ltran_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ltran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
@ -121,11 +111,9 @@ module psi_l_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ltran_vidx_vect
subroutine psi_ltran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ltran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
@ -137,15 +125,13 @@ module psi_l_comm_v_mod
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_lovrl_upd_vect(x,desc_a,update,info)
import
module subroutine psi_lovrl_upd_vect(x,desc_a,update,info)
class(psb_l_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_lovrl_upd_vect
subroutine psi_lovrl_upd_multivect(x,desc_a,update,info)
import
module subroutine psi_lovrl_upd_multivect(x,desc_a,update,info)
class(psb_l_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -154,15 +140,13 @@ module psi_l_comm_v_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_lovrl_save_vect(x,xs,desc_a,info)
import
module subroutine psi_lovrl_save_vect(x,xs,desc_a,info)
class(psb_l_base_vect_type) :: x
integer(psb_lpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_lovrl_save_vect
subroutine psi_lovrl_save_multivect(x,xs,desc_a,info)
import
module subroutine psi_lovrl_save_multivect(x,xs,desc_a,info)
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -171,15 +155,13 @@ module psi_l_comm_v_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_lovrl_restr_vect(x,xs,desc_a,info)
import
module subroutine psi_lovrl_restr_vect(x,xs,desc_a,info)
class(psb_l_base_vect_type) :: x
integer(psb_lpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_lovrl_restr_vect
subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info)
import
module subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info)
class(psb_l_base_multivect_type) :: x
integer(psb_lpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

48
base/modules/comm/psi_m_comm_a_mod.f90
Unescape Escape View File

@ -34,8 +34,7 @@ module psi_m_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_
interface psi_swapdata
subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -44,8 +43,7 @@ module psi_m_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_mswapdatam
subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: y(:), beta
@ -53,11 +51,9 @@ module psi_m_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_mswapdatav
subroutine psi_mswapidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_mswapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -65,11 +61,9 @@ module psi_m_comm_a_mod
integer(psb_mpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_mswapidxm
subroutine psi_mswapidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_mswapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_Mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: y(:), beta
@ -80,8 +74,7 @@ module psi_m_comm_a_mod
interface psi_swaptran
subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_Mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
@ -90,8 +83,7 @@ module psi_m_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_mswaptranm
subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: y(:), beta
@ -99,11 +91,9 @@ module psi_m_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_mswaptranv
subroutine psi_mtranidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_mtranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -111,11 +101,9 @@ module psi_m_comm_a_mod
integer(psb_mpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_mtranidxm
subroutine psi_mtranidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_mtranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
integer(psb_mpk_) :: y(:), beta
@ -123,17 +111,15 @@ module psi_m_comm_a_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_mtranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_movrl_updr1(x,desc_a,update,info)
import
module subroutine psi_movrl_updr1(x,desc_a,update,info)
integer(psb_mpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_movrl_updr1
subroutine psi_movrl_updr2(x,desc_a,update,info)
import
module subroutine psi_movrl_updr2(x,desc_a,update,info)
integer(psb_mpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -142,15 +128,13 @@ module psi_m_comm_a_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_movrl_saver1(x,xs,desc_a,info)
import
module subroutine psi_movrl_saver1(x,xs,desc_a,info)
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_movrl_saver1
subroutine psi_movrl_saver2(x,xs,desc_a,info)
import
module subroutine psi_movrl_saver2(x,xs,desc_a,info)
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -159,15 +143,13 @@ module psi_m_comm_a_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_movrl_restrr1(x,xs,desc_a,info)
import
module subroutine psi_movrl_restrr1(x,xs,desc_a,info)
integer(psb_mpk_), intent(inout) :: x(:)
integer(psb_mpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_movrl_restrr1
subroutine psi_movrl_restrr2(x,xs,desc_a,info)
import
module subroutine psi_movrl_restrr2(x,xs,desc_a,info)
integer(psb_mpk_), intent(inout) :: x(:,:)
integer(psb_mpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

48
base/modules/comm/psi_s_comm_a_mod.f90
Unescape Escape View File

@ -34,8 +34,7 @@ module psi_s_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type
interface psi_swapdata
subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -44,8 +43,7 @@ module psi_s_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdatam
subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
@ -53,11 +51,9 @@ module psi_s_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdatav
subroutine psi_sswapidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_sswapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -65,11 +61,9 @@ module psi_s_comm_a_mod
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_sswapidxm
subroutine psi_sswapidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_sswapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_Mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
@ -80,8 +74,7 @@ module psi_s_comm_a_mod
interface psi_swaptran
subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_Mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
@ -90,8 +83,7 @@ module psi_s_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptranm
subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
@ -99,11 +91,9 @@ module psi_s_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptranv
subroutine psi_stranidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_stranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -111,11 +101,9 @@ module psi_s_comm_a_mod
real(psb_spk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_stranidxm
subroutine psi_stranidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_stranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_spk_) :: y(:), beta
@ -123,17 +111,15 @@ module psi_s_comm_a_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_stranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_sovrl_updr1(x,desc_a,update,info)
import
module subroutine psi_sovrl_updr1(x,desc_a,update,info)
real(psb_spk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sovrl_updr1
subroutine psi_sovrl_updr2(x,desc_a,update,info)
import
module subroutine psi_sovrl_updr2(x,desc_a,update,info)
real(psb_spk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -142,15 +128,13 @@ module psi_s_comm_a_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_sovrl_saver1(x,xs,desc_a,info)
import
module subroutine psi_sovrl_saver1(x,xs,desc_a,info)
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sovrl_saver1
subroutine psi_sovrl_saver2(x,xs,desc_a,info)
import
module subroutine psi_sovrl_saver2(x,xs,desc_a,info)
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -159,15 +143,13 @@ module psi_s_comm_a_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_sovrl_restrr1(x,xs,desc_a,info)
import
module subroutine psi_sovrl_restrr1(x,xs,desc_a,info)
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sovrl_restrr1
subroutine psi_sovrl_restrr2(x,xs,desc_a,info)
import
module subroutine psi_sovrl_restrr2(x,xs,desc_a,info)
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

46
base/modules/comm/psi_s_comm_v_mod.f90
Unescape Escape View File

@ -36,8 +36,7 @@ module psi_s_comm_v_mod
use psb_s_base_multivect_mod, only : psb_s_base_multivect_type
interface psi_swapdata
subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
@ -46,8 +45,7 @@ module psi_s_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdata_vect
subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
@ -56,11 +54,9 @@ module psi_s_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdata_multivect
subroutine psi_sswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_sswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
@ -69,11 +65,9 @@ module psi_s_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_sswap_vidx_vect
subroutine psi_sswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_sswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
@ -86,8 +80,7 @@ module psi_s_comm_v_mod
interface psi_swaptran
subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
@ -96,8 +89,7 @@ module psi_s_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptran_vect
subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
@ -106,11 +98,9 @@ module psi_s_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptran_multivect
subroutine psi_stran_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_stran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
@ -119,11 +109,9 @@ module psi_s_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_stran_vidx_vect
subroutine psi_stran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_stran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
@ -135,15 +123,13 @@ module psi_s_comm_v_mod
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_sovrl_upd_vect(x,desc_a,update,info)
import
module subroutine psi_sovrl_upd_vect(x,desc_a,update,info)
class(psb_s_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sovrl_upd_vect
subroutine psi_sovrl_upd_multivect(x,desc_a,update,info)
import
module subroutine psi_sovrl_upd_multivect(x,desc_a,update,info)
class(psb_s_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -152,15 +138,13 @@ module psi_s_comm_v_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_sovrl_save_vect(x,xs,desc_a,info)
import
module subroutine psi_sovrl_save_vect(x,xs,desc_a,info)
class(psb_s_base_vect_type) :: x
real(psb_spk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sovrl_save_vect
subroutine psi_sovrl_save_multivect(x,xs,desc_a,info)
import
module subroutine psi_sovrl_save_multivect(x,xs,desc_a,info)
class(psb_s_base_multivect_type) :: x
real(psb_spk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -169,15 +153,13 @@ module psi_s_comm_v_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_sovrl_restr_vect(x,xs,desc_a,info)
import
module subroutine psi_sovrl_restr_vect(x,xs,desc_a,info)
class(psb_s_base_vect_type) :: x
real(psb_spk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_sovrl_restr_vect
subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info)
import
module subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info)
class(psb_s_base_multivect_type) :: x
real(psb_spk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

48
base/modules/comm/psi_z_comm_a_mod.f90
Unescape Escape View File

@ -34,8 +34,7 @@ module psi_z_comm_a_mod
use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type
interface psi_swapdata
subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -44,8 +43,7 @@ module psi_z_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdatam
subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
@ -53,11 +51,9 @@ module psi_z_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdatav
subroutine psi_zswapidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_zswapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -65,11 +61,9 @@ module psi_z_comm_a_mod
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_zswapidxm
subroutine psi_zswapidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_zswapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_Mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
@ -80,8 +74,7 @@ module psi_z_comm_a_mod
interface psi_swaptran
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_Mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
@ -90,8 +83,7 @@ module psi_z_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptranm
subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
@ -99,11 +91,9 @@ module psi_z_comm_a_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptranv
subroutine psi_ztranidxm(ctxt,icomm,flag,n,beta,y,idx,&
module subroutine psi_ztranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
@ -111,11 +101,9 @@ module psi_z_comm_a_mod
complex(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ztranidxm
subroutine psi_ztranidxv(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ztranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_) :: y(:), beta
@ -123,17 +111,15 @@ module psi_z_comm_a_mod
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ztranidxv
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_zovrl_updr1(x,desc_a,update,info)
import
module subroutine psi_zovrl_updr1(x,desc_a,update,info)
complex(psb_dpk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zovrl_updr1
subroutine psi_zovrl_updr2(x,desc_a,update,info)
import
module subroutine psi_zovrl_updr2(x,desc_a,update,info)
complex(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -142,15 +128,13 @@ module psi_z_comm_a_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_zovrl_saver1(x,xs,desc_a,info)
import
module subroutine psi_zovrl_saver1(x,xs,desc_a,info)
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zovrl_saver1
subroutine psi_zovrl_saver2(x,xs,desc_a,info)
import
module subroutine psi_zovrl_saver2(x,xs,desc_a,info)
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -159,15 +143,13 @@ module psi_z_comm_a_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_zovrl_restrr1(x,xs,desc_a,info)
import
module subroutine psi_zovrl_restrr1(x,xs,desc_a,info)
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zovrl_restrr1
subroutine psi_zovrl_restrr2(x,xs,desc_a,info)
import
module subroutine psi_zovrl_restrr2(x,xs,desc_a,info)
complex(psb_dpk_), intent(inout) :: x(:,:)
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

46
base/modules/comm/psi_z_comm_v_mod.f90
Unescape Escape View File

@ -36,8 +36,7 @@ module psi_z_comm_v_mod
use psb_z_base_multivect_mod, only : psb_z_base_multivect_type
interface psi_swapdata
subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
@ -46,8 +45,7 @@ module psi_z_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdata_vect
subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
@ -56,11 +54,9 @@ module psi_z_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdata_multivect
subroutine psi_zswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_zswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
@ -69,11 +65,9 @@ module psi_z_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_zswap_vidx_vect
subroutine psi_zswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_zswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
@ -86,8 +80,7 @@ module psi_z_comm_v_mod
interface psi_swaptran
subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
@ -96,8 +89,7 @@ module psi_z_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptran_vect
subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
import
module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
@ -106,11 +98,9 @@ module psi_z_comm_v_mod
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptran_multivect
subroutine psi_ztran_vidx_vect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ztran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
@ -119,11 +109,9 @@ module psi_z_comm_v_mod
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ztran_vidx_vect
subroutine psi_ztran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,&
module subroutine psi_ztran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
import
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
@ -135,15 +123,13 @@ module psi_z_comm_v_mod
end interface psi_swaptran
interface psi_ovrl_upd
subroutine psi_zovrl_upd_vect(x,desc_a,update,info)
import
module subroutine psi_zovrl_upd_vect(x,desc_a,update,info)
class(psb_z_base_vect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zovrl_upd_vect
subroutine psi_zovrl_upd_multivect(x,desc_a,update,info)
import
module subroutine psi_zovrl_upd_multivect(x,desc_a,update,info)
class(psb_z_base_multivect_type) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(in) :: update
@ -152,15 +138,13 @@ module psi_z_comm_v_mod
end interface psi_ovrl_upd
interface psi_ovrl_save
subroutine psi_zovrl_save_vect(x,xs,desc_a,info)
import
module subroutine psi_zovrl_save_vect(x,xs,desc_a,info)
class(psb_z_base_vect_type) :: x
complex(psb_dpk_), allocatable :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zovrl_save_vect
subroutine psi_zovrl_save_multivect(x,xs,desc_a,info)
import
module subroutine psi_zovrl_save_multivect(x,xs,desc_a,info)
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_), allocatable :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a
@ -169,15 +153,13 @@ module psi_z_comm_v_mod
end interface psi_ovrl_save
interface psi_ovrl_restore
subroutine psi_zovrl_restr_vect(x,xs,desc_a,info)
import
module subroutine psi_zovrl_restr_vect(x,xs,desc_a,info)
class(psb_z_base_vect_type) :: x
complex(psb_dpk_) :: xs(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
end subroutine psi_zovrl_restr_vect
subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info)
import
module subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info)
class(psb_z_base_multivect_type) :: x
complex(psb_dpk_) :: xs(:,:)
type(psb_desc_type), intent(in) :: desc_a

Write Preview
Loading…
Cancel
Save