fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 12:22:10 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas:

Browse Source 
base/internals/Makefile
 base/internals/psi_dswapdata.F90
 base/internals/psi_dswaptran.F90
 base/internals/psi_iswapdata.F90
 base/internals/psi_iswaptran.F90
 base/internals/psi_zswapdata.F90
 base/internals/psi_zswaptran.F90
 base/modules/Makefile
 base/modules/psb_base_mod.f90
 base/modules/psb_desc_type.f90
 base/modules/psb_inter_desc_type.f90
 base/modules/psb_realloc_mod.F90
 base/modules/psb_serial_mod.f90
 base/modules/psb_spmat_type.f90
 base/modules/psb_tools_mod.f90
 base/modules/psi_mod.f90
 base/modules/psi_serial_mod.f90
 base/tools/psb_cdcpy.f90
 base/tools/psb_dcdovr.F90
 base/tools/psb_glob_to_loc.f90
 base/tools/psb_loc_to_glob.f90
 base/tools/psb_zcdovr.F90

Merged changes from psblas-intermesh branch up to rev. 2809.
This commit is contained in:
Salvatore Filippone
2008-02-08 12:35:30 +00:00
parent 348a88de3b
commit 9dc5a8bc11
22 changed files with 3699 additions and 1415 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/Makefile
+8 -7
View File
@@ -3,9 +3,8 @@ include ../../Make.inc
MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \
psb_desc_type.o psb_spsb_mod.o psb_sort_mod.o\
psb_serial_mod.o psb_tools_mod.o \
psb_error_mod.o \
psb_const_mod.o \
psb_comm_mod.o psb_psblas_mod.o psi_mod.o \
psb_error_mod.o psb_const_mod.o psb_inter_desc_type.o \
psb_comm_mod.o psb_psblas_mod.o psi_serial_mod.o psi_mod.o \
psb_check_mod.o psb_gps_mod.o
# psb_methd_mod.o psb_prec_type.o psb_prec_mod.o blacs_env.o
@@ -28,16 +27,18 @@ psb_realloc_mod.o : psb_error_mod.o
psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o
psb_error_mod.o: psb_const_mod.o
psb_penv_mod.o: psb_const_mod.o psb_error_mod.o psb_realloc_mod.o
psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o
psi_serial_mod.o: psb_const_mod.o
psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o psi_serial_mod.o
psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o
psb_inter_desc_type.o: psb_desc_type.o psb_spmat_type.o psb_error_mod.o psb_serial_mod.o psb_comm_mod.o
psb_check_mod.o: psb_desc_type.o
psb_serial_mod: psb_spmat_type.o psb_string_mod.o psb_sort_mod.o
psb_serial_mod.o: psb_spmat_type.o psb_string_mod.o psb_sort_mod.o psi_serial_mod.o
psb_sort_mod.o: psb_error_mod.o psb_realloc_mod.o
psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o
psb_tools_mod.o: psb_spmat_type.o psb_desc_type.o psi_mod.o psb_gps_mod.o
psb_tools_mod.o: psb_spmat_type.o psb_desc_type.o psi_mod.o psb_gps_mod.o psb_inter_desc_type.o
psb_gps_mod.o: psb_realloc_mod.o
$(LIBMOD): $(MODULES:.o:$(.mod))
psb_base_mod.o: $(MODULES)
mpfobjs:
(make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)")
base/modules/psb_base_mod.f90
+2
View File
@@ -34,9 +34,11 @@ module psb_base_mod
use psb_penv_mod
use psb_check_mod
use psb_descriptor_type
use psb_inter_descriptor_type
use psb_serial_mod
use psb_comm_mod
use psb_psblas_mod
use psb_gps_mod
use psb_tools_mod
end module psb_base_mod
base/modules/psb_desc_type.f90
+124 -23
View File
@@ -55,8 +55,13 @@ module psb_descriptor_type
integer, parameter :: psb_no_comm_=-1
integer, parameter :: psb_comm_halo_=1, psb_comm_ovr_=2
integer, parameter :: psb_comm_ext_=3, psb_comm_mov_=4
integer, parameter :: psb_ovt_xhal_ = 123, psb_ovt_asov_=psb_ovt_xhal_+1
! Types of mapping between descriptors.
integer, parameter :: psb_map_xhal_ = 123
integer, parameter :: psb_map_asov_ = psb_map_xhal_+1
integer, parameter :: psb_map_aggr_ = psb_map_asov_+1
integer, parameter :: psb_map_gen_linear_ = psb_map_aggr_+1
integer, parameter :: psb_ovt_xhal_ = psb_map_xhal_, psb_ovt_asov_=psb_map_asov_
!
! Entries and values in desc%matrix_data
!
@@ -81,10 +86,12 @@ module psb_descriptor_type
integer, parameter :: psb_desc_bld_=psb_desc_asb_+1
integer, parameter :: psb_desc_repl_=3199
integer, parameter :: psb_desc_upd_=psb_desc_bld_+1
integer, parameter :: psb_desc_normal_=3299
integer, parameter :: psb_desc_large_=psb_desc_normal_+1
! these two are reserved for descriptors which are
! "overlap-extensions" of base descriptors.
integer, parameter :: psb_cd_ovl_bld_=3399
integer, parameter :: psb_cd_ovl_asb_=psb_cd_ovl_bld_+1
integer, parameter :: psb_desc_normal_=3299
integer, parameter :: psb_desc_large_=psb_desc_normal_+1
!
! Constants for hashing into desc%hashv(:) and desc%glb_lc(:,:)
!
@@ -292,18 +299,44 @@ module psb_descriptor_type
integer, allocatable :: hashv(:), glb_lc(:,:), ptree(:)
integer, allocatable :: lprm(:)
integer, allocatable :: idx_space(:)
type(psb_desc_type), pointer :: base_desc => null()
end type psb_desc_type
interface psb_sizeof
module procedure psb_cd_sizeof
end interface
interface psb_is_ok_desc
module procedure psb_is_ok_desc
end interface
interface psb_is_asb_desc
module procedure psb_is_asb_desc
end interface
interface psb_is_upd_desc
module procedure psb_is_upd_desc
end interface
interface psb_is_ovl_desc
module procedure psb_is_ovl_desc
end interface
interface psb_is_bld_desc
module procedure psb_is_bld_desc
end interface
interface psb_is_large_desc
module procedure psb_is_large_desc
end interface
integer, private, save :: cd_large_threshold=psb_default_large_threshold
contains
function psb_cd_sizeof(desc)
implicit none
!....Parameters...
@@ -401,6 +434,13 @@ contains
end function psb_is_upd_desc
logical function psb_is_ovl_desc(desc)
type(psb_desc_type), intent(in) :: desc
psb_is_ovl_desc = psb_is_ovl_dec(psb_cd_get_dectype(desc))
end function psb_is_ovl_desc
logical function psb_is_asb_desc(desc)
type(psb_desc_type), intent(in) :: desc
@@ -414,6 +454,7 @@ contains
integer :: dectype
psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.&
&(dectype == psb_cd_ovl_asb_).or.(dectype == psb_cd_ovl_bld_).or.&
&(dectype == psb_desc_upd_).or.&
&(dectype== psb_desc_repl_))
end function psb_is_ok_dec
@@ -421,7 +462,7 @@ contains
logical function psb_is_bld_dec(dectype)
integer :: dectype
psb_is_bld_dec = (dectype == psb_desc_bld_)
psb_is_bld_dec = (dectype == psb_desc_bld_).or.(dectype == psb_cd_ovl_bld_)
end function psb_is_bld_dec
logical function psb_is_upd_dec(dectype)
@@ -436,10 +477,18 @@ contains
integer :: dectype
psb_is_asb_dec = (dectype == psb_desc_asb_).or.&
& (dectype== psb_desc_repl_)
& (dectype== psb_desc_repl_).or.(dectype == psb_cd_ovl_asb_)
end function psb_is_asb_dec
logical function psb_is_ovl_dec(dectype)
integer :: dectype
psb_is_ovl_dec = (dectype == psb_cd_ovl_bld_).or.&
& (dectype == psb_cd_ovl_asb_)
end function psb_is_ovl_dec
integer function psb_cd_get_local_rows(desc)
type(psb_desc_type), intent(in) :: desc
@@ -573,6 +622,61 @@ contains
return
end subroutine psb_cd_set_bld
subroutine psb_cd_set_ovl_asb(desc,info)
!
! Change state of a descriptor into ovl_build.
implicit none
type(psb_desc_type), intent(inout) :: desc
integer :: info
if (psb_is_asb_desc(desc)) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_asb_
end subroutine psb_cd_set_ovl_asb
subroutine psb_cd_set_ovl_bld(desc,info)
!
! Change state of a descriptor into ovl_build.
implicit none
type(psb_desc_type), intent(inout) :: desc
integer :: info
call psb_cd_set_bld(desc,info)
if (info == 0) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_
end subroutine psb_cd_set_ovl_bld
subroutine psb_get_xch_idx(idx,totxch,totsnd,totrcv)
implicit none
integer, intent(in) :: idx(:)
integer, intent(out) :: totxch,totsnd,totrcv
integer :: ip, nerv, nesd
character(len=20), parameter :: name='psb_get_xch_idx'
totxch = 0
totsnd = 0
totrcv = 0
ip = 1
do
if (ip > size(idx)) then
write(0,*) trim(name),': Warning: out of size of input vector '
exit
end if
if (idx(ip) == -1) exit
totxch = totxch+1
nerv = idx(ip+psb_n_elem_recv_)
nesd = idx(ip+nerv+psb_n_elem_send_)
totsnd = totsnd + nesd
totrcv = totrcv + nerv
ip = ip+nerv+nesd+3
end do
end subroutine psb_get_xch_idx
subroutine psb_cd_get_list(data,desc,ipnt,totxch,idxr,idxs,info)
use psb_const_mod
@@ -600,33 +704,30 @@ contains
select case(data)
case(psb_comm_halo_)
ipnt => desc%halo_index
totxch = desc%matrix_data(psb_thal_xch_)
idxr = desc%matrix_data(psb_thal_rcv_)
idxs = desc%matrix_data(psb_thal_snd_)
case(psb_comm_ovr_)
ipnt => desc%ovrlap_index
totxch = desc%matrix_data(psb_tovr_xch_)
idxr = desc%matrix_data(psb_tovr_rcv_)
idxs = desc%matrix_data(psb_tovr_snd_)
case(psb_comm_ext_)
ipnt => desc%ext_index
totxch = desc%matrix_data(psb_text_xch_)
idxr = desc%matrix_data(psb_text_rcv_)
idxs = desc%matrix_data(psb_text_snd_)
if (.not.associated(desc%base_desc)) then
write(0,*) trim(name),&
& ': Warning: trying to get ext_index on a descriptor ',&
& 'which does not have a base_desc!'
end if
if (.not.psb_is_ovl_desc(desc)) then
write(0,*) trim(name),&
& ': Warning: trying to get ext_index on a descriptor ',&
& 'which is not overlap-extended!'
end if
case(psb_comm_mov_)
ipnt => desc%ovr_mst_idx
totxch = desc%matrix_data(psb_tmov_xch_)
idxr = desc%matrix_data(psb_tmov_rcv_)
idxs = desc%matrix_data(psb_tmov_snd_)
case default
info=4010
call psb_errpush(info,name,a_err='wrong Data selector')
goto 9999
end select
call psb_get_xch_idx(ipnt,totxch,idxs,idxr)
call psb_erractionrestore(err_act)
return
base/modules/psb_inter_desc_type.f90
+655
View File
@@ -0,0 +1,655 @@
module psb_inter_descriptor_type
use psb_spmat_type
use psb_descriptor_type
! Inter-descriptor mapping data structures.
integer, parameter :: psb_map_kind_ = 1
integer, parameter :: psb_map_data_ = 2
integer, parameter :: psb_map_integer_ = 1
integer, parameter :: psb_map_double_ = 2
integer, parameter :: psb_map_complex_ = 3
integer, parameter :: psb_fw_tmp_kind_ = 5
integer, parameter :: psb_fw_tmp_sz_ = 6
integer, parameter :: psb_bk_tmp_kind_ = 7
integer, parameter :: psb_bk_tmp_sz_ = 8
integer, parameter :: psb_itd_data_size_=20
type psb_d_map_type
type(psb_dspmat_type) :: map_fw, map_bk
end type psb_d_map_type
type psb_z_map_type
type(psb_zspmat_type) :: map_fw, map_bk
end type psb_z_map_type
type psb_inter_desc_type
integer, allocatable :: itd_data(:)
type(psb_desc_type), pointer :: desc_1=>null(), desc_2=>null()
integer, allocatable :: exch_fw_idx(:), exch_bk_idx(:)
type(psb_d_map_type) :: dmap
type(psb_z_map_type) :: zmap
end type psb_inter_desc_type
interface psb_forward_map
module procedure psb_d_forward_map, psb_z_forward_map
end interface
interface psb_backward_map
module procedure psb_d_backward_map, psb_z_backward_map
end interface
interface psb_is_ok_desc
module procedure psb_is_ok_inter_desc
end interface
interface psb_is_asb_desc
module procedure psb_is_asb_inter_desc
end interface
interface psb_inter_desc
module procedure psb_d_inter_desc, psb_d_inter_desc_noidx,&
& psb_z_inter_desc, psb_z_inter_desc_noidx
end interface
interface psb_sizeof
module procedure psb_itd_sizeof,&
& psb_d_map_sizeof, psb_z_map_sizeof
end interface
contains
function psb_cd_get_map_kind(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_map_kind
if (psb_is_ok_desc(desc)) then
psb_cd_get_map_kind = desc%itd_data(psb_map_kind_)
else
psb_cd_get_map_kind = -1
end if
end function psb_cd_get_map_kind
subroutine psb_cd_set_map_kind(map_kind,desc)
implicit none
integer, intent(in) :: map_kind
type(psb_inter_desc_type), intent(inout) :: desc
desc%itd_data(psb_map_kind_) = map_kind
end subroutine psb_cd_set_map_kind
function psb_cd_get_map_data(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_map_data
if (psb_is_ok_desc(desc)) then
psb_cd_get_map_data = desc%itd_data(psb_map_data_)
else
psb_cd_get_map_data = -1
end if
end function psb_cd_get_map_data
subroutine psb_cd_set_map_data(map_data,desc)
implicit none
integer, intent(in) :: map_data
type(psb_inter_desc_type), intent(inout) :: desc
desc%itd_data(psb_map_data_) = map_data
end subroutine psb_cd_set_map_data
function psb_cd_get_fw_tmp_sz(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_fw_tmp_sz
psb_cd_get_fw_tmp_sz = desc%itd_data(psb_fw_tmp_sz_)
end function psb_cd_get_fw_tmp_sz
function psb_cd_get_bk_tmp_sz(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_bk_tmp_sz
psb_cd_get_bk_tmp_sz = desc%itd_data(psb_bk_tmp_sz_)
end function psb_cd_get_bk_tmp_sz
subroutine psb_cd_set_fw_tmp_sz(isz,desc)
implicit none
type(psb_inter_desc_type), intent(inout) :: desc
integer, intent(in) :: isz
desc%itd_data(psb_fw_tmp_sz_) =isz
end subroutine psb_cd_set_fw_tmp_sz
subroutine psb_cd_set_bk_tmp_sz(isz,desc)
implicit none
type(psb_inter_desc_type), intent(inout) :: desc
integer, intent(in) :: isz
desc%itd_data(psb_bk_tmp_sz_) =isz
end subroutine psb_cd_set_bk_tmp_sz
logical function psb_is_asb_inter_desc(desc)
type(psb_inter_desc_type), intent(in) :: desc
psb_is_asb_inter_desc = .false.
if (.not.allocated(desc%itd_data)) return
if (.not.associated(desc%desc_1)) return
if (.not.associated(desc%desc_2)) return
psb_is_asb_inter_desc = &
& psb_is_asb_desc(desc%desc_1).and.psb_is_asb_desc(desc%desc_2)
end function psb_is_asb_inter_desc
logical function psb_is_ok_inter_desc(desc)
type(psb_inter_desc_type), intent(in) :: desc
psb_is_ok_inter_desc = .false.
if (.not.allocated(desc%itd_data)) return
select case(desc%itd_data(psb_map_data_))
case(psb_map_integer_, psb_map_double_, psb_map_complex_)
! Ok go ahead
case default
! Since it's false so far, simply return
return
end select
if (.not.associated(desc%desc_1)) return
if (.not.associated(desc%desc_2)) return
psb_is_ok_inter_desc = &
& psb_is_ok_desc(desc%desc_1).and.psb_is_ok_desc(desc%desc_2)
end function psb_is_ok_inter_desc
function psb_d_map_sizeof(map)
implicit none
type(psb_d_map_type), intent(in) :: map
Integer :: psb_d_map_sizeof
integer :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
psb_d_map_sizeof = val
end function psb_d_map_sizeof
function psb_z_map_sizeof(map)
implicit none
type(psb_z_map_type), intent(in) :: map
Integer :: psb_z_map_sizeof
integer :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
psb_z_map_sizeof = val
end function psb_z_map_sizeof
function psb_itd_sizeof(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_itd_sizeof
integer :: val
val = 0
if (allocated(desc%itd_data)) val = val + 4*size(desc%itd_data)
if (allocated(desc%exch_fw_idx)) val = val + 4*size(desc%exch_fw_idx)
if (allocated(desc%exch_bk_idx)) val = val + 4*size(desc%exch_bk_idx)
val = val + psb_sizeof(desc%dmap)
val = val + psb_sizeof(desc%zmap)
psb_itd_sizeof = val
end function psb_itd_sizeof
function psb_d_inter_desc(map_kind,desc1, desc2, map_fw, map_bk, idx_fw, idx_bk)
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type) :: psb_d_inter_desc
type(psb_desc_type), target :: desc1, desc2
type(psb_dspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:)
!
type(psb_inter_desc_type) :: this
integer :: info
character(len=20), parameter :: name='psb_inter_desc'
info = 0
if (psb_is_ok_desc(desc1)) then
this%desc_1=>desc1
else
info = 2
endif
if (psb_is_ok_desc(desc2)) then
this%desc_2=>desc2
else
info = 3
endif
if (info == 0) call psb_sp_clone(map_fw,this%dmap%map_fw,info)
if (info == 0) call psb_sp_clone(map_bk,this%dmap%map_bk,info)
if (info == 0) call psb_safe_cpy(idx_fw,this%exch_fw_idx,info)
if (info == 0) call psb_safe_cpy(idx_bk,this%exch_bk_idx,info)
if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info)
if (info == 0) then
call psb_cd_set_map_kind(map_kind, this)
call psb_cd_set_map_data(psb_map_double_, this)
!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this)
!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this)
end if
if (info /= 0) then
write(0,*) trim(name),' Invalid descriptor input'
return
end if
psb_d_inter_desc = this
end function psb_d_inter_desc
function psb_d_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk)
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type) :: psb_d_inter_desc_noidx
type(psb_desc_type), target :: desc1, desc2
type(psb_dspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind
!
type(psb_inter_desc_type) :: this
integer :: info
character(len=20), parameter :: name='psb_inter_desc'
info = 0
select case(map_kind)
case (psb_map_aggr_)
! OK
case default
write(0,*) 'Bad mapp kind into psb_inter_desc ',map_kind
info = 1
end select
if (psb_is_ok_desc(desc1)) then
this%desc_1=>desc1
else
info = 2
endif
if (psb_is_ok_desc(desc2)) then
this%desc_2=>desc2
else
info = 3
endif
if (info == 0) call psb_sp_clone(map_fw,this%dmap%map_fw,info)
if (info == 0) call psb_sp_clone(map_bk,this%dmap%map_bk,info)
if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info)
if (info == 0) then
call psb_cd_set_map_kind(map_kind, this)
call psb_cd_set_map_data(psb_map_double_, this)
!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this)
!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this)
end if
if (info /= 0) then
write(0,*) trim(name),' Invalid descriptor input'
return
end if
psb_d_inter_desc_noidx = this
end function psb_d_inter_desc_noidx
function psb_z_inter_desc(map_kind,desc1, desc2, map_fw, map_bk, idx_fw, idx_bk)
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type) :: psb_z_inter_desc
type(psb_desc_type), target :: desc1, desc2
type(psb_zspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:)
!
type(psb_inter_desc_type) :: this
integer :: info
character(len=20), parameter :: name='psb_inter_desc'
info = 0
if (psb_is_ok_desc(desc1)) then
this%desc_1=>desc1
else
info = 2
endif
if (psb_is_ok_desc(desc2)) then
this%desc_2=>desc2
else
info = 3
endif
if (info == 0) call psb_sp_clone(map_fw,this%zmap%map_fw,info)
if (info == 0) call psb_sp_clone(map_bk,this%zmap%map_bk,info)
if (info == 0) call psb_safe_cpy(idx_fw,this%exch_fw_idx,info)
if (info == 0) call psb_safe_cpy(idx_bk,this%exch_bk_idx,info)
if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info)
if (info == 0) then
call psb_cd_set_map_kind(map_kind, this)
call psb_cd_set_map_data(psb_map_complex_, this)
!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this)
!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this)
end if
if (info /= 0) then
write(0,*) trim(name),' Invalid descriptor input'
return
end if
psb_z_inter_desc = this
end function psb_z_inter_desc
function psb_z_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk)
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type) :: psb_z_inter_desc_noidx
type(psb_desc_type), target :: desc1, desc2
type(psb_zspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind
!
type(psb_inter_desc_type) :: this
integer :: info
character(len=20), parameter :: name='psb_inter_desc'
info = 0
select case(map_kind)
case (psb_map_aggr_)
! OK
case default
write(0,*) 'Bad mapp kind into psb_inter_desc ',map_kind
info = 1
end select
if (psb_is_ok_desc(desc1)) then
this%desc_1=>desc1
else
info = 2
endif
if (psb_is_ok_desc(desc2)) then
this%desc_2=>desc2
else
info = 3
endif
if (info == 0) call psb_sp_clone(map_fw,this%zmap%map_fw,info)
if (info == 0) call psb_sp_clone(map_bk,this%zmap%map_bk,info)
if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info)
if (info == 0) then
call psb_cd_set_map_kind(map_kind, this)
call psb_cd_set_map_data(psb_map_complex_, this)
!!$ call psb_cd_set_fw_tmp_sz(map_fw%k, this)
!!$ call psb_cd_set_bk_tmp_sz(map_bk%k, this)
end if
if (info /= 0) then
write(0,*) trim(name),' Invalid descriptor input'
return
end if
psb_z_inter_desc_noidx = this
end function psb_z_inter_desc_noidx
!
! Takes a vector X from space desc%desc_1 and maps it onto
! desc%desc_2 under desc%map_fw possibly with communication
! due to exch_fw_idx
!
subroutine psb_d_forward_map(alpha,x,beta,y,desc,info,work)
use psb_comm_mod
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type), intent(in) :: desc
real(kind(1.d0)), intent(in) :: alpha,beta
real(kind(1.d0)), intent(inout) :: x(:)
real(kind(1.d0)), intent(out) :: y(:)
integer, intent(out) :: info
real(kind(1.d0)), optional :: work(:)
!
real(kind(1.d0)), allocatable :: xt(:)
integer :: itsz, i, j,totxch,totsnd,totrcv,&
& map_kind, map_data
character(len=20), parameter :: name='psb_forward_map'
info = 0
if (.not.psb_is_asb_desc(desc)) then
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end if
itsz = psb_cd_get_fw_tmp_sz(desc)
map_kind = psb_cd_get_map_kind(desc)
map_data = psb_cd_get_map_data(desc)
if (map_data /= psb_map_double_) then
write(0,*) trim(name),' Invalid descriptor inupt: map_data', &
& map_data,psb_map_double_
info = 1
return
endif
select case(map_kind)
case(psb_map_aggr_)
! Ok, we just need to call a halo update and a matrix-vector product.
call psb_halo(x,desc%desc_1,info,work=work)
if (info == 0) call psb_csmm(alpha,desc%dmap%map_fw,x,beta,y,info)
if (info /= 0) then
write(0,*) trim(name),' Error from inner routines',info
info = -1
end if
case default
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end select
end subroutine psb_d_forward_map
!
! Takes a vector X from space desc%desc_2 and maps it onto
! desc%desc_1 under desc%map_bk possibly with communication
! due to exch_bk_idx
!
subroutine psb_d_backward_map(alpha,x,beta,y,desc,info,work)
use psb_comm_mod
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type), intent(in) :: desc
real(kind(1.d0)), intent(in) :: alpha,beta
real(kind(1.d0)), intent(inout) :: x(:)
real(kind(1.d0)), intent(out) :: y(:)
integer, intent(out) :: info
real(kind(1.d0)), optional :: work(:)
!
real(kind(1.d0)), allocatable :: xt(:)
integer :: itsz, i, j,totxch,totsnd,totrcv,&
& map_kind, map_data
character(len=20), parameter :: name='psb_backward_map'
info = 0
if (.not.psb_is_asb_desc(desc)) then
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end if
itsz = psb_cd_get_bk_tmp_sz(desc)
map_kind = psb_cd_get_map_kind(desc)
map_data = psb_cd_get_map_data(desc)
if (map_data /= psb_map_double_) then
write(0,*) trim(name),' Invalid descriptor inupt: map_data',&
& map_data,psb_map_double_
info = 1
return
endif
select case(map_kind)
case(psb_map_aggr_)
! Ok, we just need to call a halo update and a matrix-vector product.
call psb_halo(x,desc%desc_2,info,work=work)
if (info == 0) call psb_csmm(alpha,desc%dmap%map_bk,x,beta,y,info)
if (info /= 0) then
write(0,*) trim(name),' Error from inner routines',info
info = -1
end if
case default
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end select
end subroutine psb_d_backward_map
!
! Takes a vector X from space desc%desc_1 and maps it onto
! desc%desc_2 under desc%map_fw possibly with communication
! due to exch_fw_idx
!
subroutine psb_z_forward_map(alpha,x,beta,y,desc,info,work)
use psb_comm_mod
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type), intent(in) :: desc
complex(kind(1.d0)), intent(in) :: alpha,beta
complex(kind(1.d0)), intent(inout) :: x(:)
complex(kind(1.d0)), intent(out) :: y(:)
integer, intent(out) :: info
complex(kind(1.d0)), optional :: work(:)
!
complex(kind(1.d0)), allocatable :: xt(:)
integer :: itsz, i, j,totxch,totsnd,totrcv,&
& map_kind, map_data
character(len=20), parameter :: name='psb_forward_map'
info = 0
if (.not.psb_is_asb_desc(desc)) then
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end if
itsz = psb_cd_get_fw_tmp_sz(desc)
map_kind = psb_cd_get_map_kind(desc)
map_data = psb_cd_get_map_data(desc)
if (map_data /= psb_map_complex_) then
write(0,*) trim(name),' Invalid descriptor inupt: map_data',&
& map_data,psb_map_complex_
info = 1
return
endif
select case(map_kind)
case(psb_map_aggr_)
! Ok, we just need to call a halo update and a matrix-vector product.
call psb_halo(x,desc%desc_1,info,work=work)
if (info == 0) call psb_csmm(alpha,desc%zmap%map_fw,x,beta,y,info)
if (info /= 0) then
write(0,*) trim(name),' Error from inner routines',info
info = -1
end if
case default
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end select
end subroutine psb_z_forward_map
!
! Takes a vector X from space desc%desc_2 and maps it onto
! desc%desc_1 under desc%map_bk possibly with communication
! due to exch_bk_idx
!
subroutine psb_z_backward_map(alpha,x,beta,y,desc,info,work)
use psb_comm_mod
use psb_serial_mod
use psi_mod
implicit none
type(psb_inter_desc_type), intent(in) :: desc
complex(kind(1.d0)), intent(in) :: alpha,beta
complex(kind(1.d0)), intent(inout) :: x(:)
complex(kind(1.d0)), intent(out) :: y(:)
integer, intent(out) :: info
complex(kind(1.d0)), optional :: work(:)
!
complex(kind(1.d0)), allocatable :: xt(:)
integer :: itsz, i, j,totxch,totsnd,totrcv,&
& map_kind, map_data
character(len=20), parameter :: name='psb_backward_map'
info = 0
if (.not.psb_is_asb_desc(desc)) then
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end if
itsz = psb_cd_get_bk_tmp_sz(desc)
map_kind = psb_cd_get_map_kind(desc)
map_data = psb_cd_get_map_data(desc)
if (map_data /= psb_map_complex_) then
write(0,*) trim(name),' Invalid descriptor inupt: map_data',&
& map_data,psb_map_complex_
info = 1
return
endif
select case(map_kind)
case(psb_map_aggr_)
! Ok, we just need to call a halo update and a matrix-vector product.
call psb_halo(x,desc%desc_2,info,work=work)
if (info == 0) call psb_csmm(alpha,desc%zmap%map_bk,x,beta,y,info)
if (info /= 0) then
write(0,*) trim(name),' Error from inner routines',info
info = -1
end if
case default
write(0,*) trim(name),' Invalid descriptor inupt'
info = 1
return
end select
end subroutine psb_z_backward_map
end module psb_inter_descriptor_type
base/modules/psb_realloc_mod.F90
+303 -20
View File
@@ -57,9 +57,14 @@ module psb_realloc_mod
module procedure psb_ztransfer2d
end interface
Interface psb_safe_ab_cpy
module procedure psb_i_ab_cpy1d,psb_i_ab_cpy2d, &
& psb_d_ab_cpy1d, psb_d_ab_cpy2d, psb_z_ab_cpy1d, psb_z_ab_cpy2d
end Interface
Interface psb_safe_cpy
module procedure psb_icpy1d,psb_icpy2d, &
& psb_dcpy1d, psb_dcpy2d, psb_zcpy1d, psb_zcpy2d
module procedure psb_i_cpy1d,psb_i_cpy2d, &
& psb_d_cpy1d, psb_d_cpy2d, psb_z_cpy1d, psb_z_cpy2d
end Interface
!
@@ -80,7 +85,7 @@ module psb_realloc_mod
Contains
subroutine psb_icpy1d(vin,vout,info)
subroutine psb_i_ab_cpy1d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
@@ -93,7 +98,7 @@ Contains
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_cpy1d'
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
@@ -125,9 +130,9 @@ Contains
end if
return
end subroutine psb_icpy1d
end subroutine psb_i_ab_cpy1d
subroutine psb_icpy2d(vin,vout,info)
subroutine psb_i_ab_cpy2d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
@@ -140,7 +145,7 @@ Contains
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_cpy1d'
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
@@ -174,9 +179,9 @@ Contains
end if
return
end subroutine psb_icpy2d
end subroutine psb_i_ab_cpy2d
subroutine psb_dcpy1d(vin,vout,info)
subroutine psb_d_ab_cpy1d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
@@ -189,7 +194,7 @@ Contains
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_cpy1d'
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
@@ -221,9 +226,9 @@ Contains
end if
return
end subroutine psb_dcpy1d
end subroutine psb_d_ab_cpy1d
subroutine psb_dcpy2d(vin,vout,info)
subroutine psb_d_ab_cpy2d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
@@ -236,7 +241,7 @@ Contains
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_cpy1d'
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
@@ -270,9 +275,9 @@ Contains
end if
return
end subroutine psb_dcpy2d
end subroutine psb_d_ab_cpy2d
subroutine psb_zcpy1d(vin,vout,info)
subroutine psb_z_ab_cpy1d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
@@ -285,7 +290,7 @@ Contains
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_cpy1d'
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
@@ -317,9 +322,9 @@ Contains
end if
return
end subroutine psb_zcpy1d
end subroutine psb_z_ab_cpy1d
subroutine psb_zcpy2d(vin,vout,info)
subroutine psb_z_ab_cpy2d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
@@ -332,7 +337,7 @@ Contains
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_cpy1d'
name='psb_safe_ab_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
@@ -366,7 +371,285 @@ Contains
end if
return
end subroutine psb_zcpy2d
end subroutine psb_z_ab_cpy2d
subroutine psb_i_cpy1d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
Integer, intent(in) :: vin(:)
Integer, allocatable, intent(out) :: vout(:)
integer :: info
! ...Local Variables
Integer :: isz,err_act,lb
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_safe_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
info = 0
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
vout(:) = vin(:)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_i_cpy1d
subroutine psb_i_cpy2d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
Integer, intent(in) :: vin(:,:)
Integer, allocatable, intent(out) :: vout(:,:)
integer :: info
! ...Local Variables
Integer :: isz1, isz2,err_act, lb1, lb2
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_safe_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
info = 0
isz1 = size(vin,1)
isz2 = size(vin,2)
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
vout(:,:) = vin(:,:)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_i_cpy2d
subroutine psb_d_cpy1d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
real(kind(1.d0)), intent(in) :: vin(:)
real(kind(1.d0)), allocatable, intent(out) :: vout(:)
integer :: info
! ...Local Variables
Integer :: isz,err_act,lb
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_safe_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
info = 0
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
vout(:) = vin(:)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_d_cpy1d
subroutine psb_d_cpy2d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
real(kind(1.d0)), intent(in) :: vin(:,:)
real(kind(1.d0)), allocatable, intent(out) :: vout(:,:)
integer :: info
! ...Local Variables
Integer :: isz1, isz2,err_act, lb1, lb2
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_safe_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
info = 0
isz1 = size(vin,1)
isz2 = size(vin,2)
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
vout(:,:) = vin(:,:)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_d_cpy2d
subroutine psb_z_cpy1d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
complex(kind(1.d0)), intent(in) :: vin(:)
complex(kind(1.d0)), allocatable, intent(out) :: vout(:)
integer :: info
! ...Local Variables
Integer :: isz,err_act,lb
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_safe_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
info = 0
isz = size(vin)
lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb)
if (info /= 0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
vout(:) = vin(:)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_z_cpy1d
subroutine psb_z_cpy2d(vin,vout,info)
use psb_error_mod
! ...Subroutine Arguments
complex(kind(1.d0)), intent(in) :: vin(:,:)
complex(kind(1.d0)), allocatable, intent(out) :: vout(:,:)
integer :: info
! ...Local Variables
Integer :: isz1, isz2,err_act, lb1, lb2
character(len=20) :: name, char_err
logical, parameter :: debug=.false.
name='psb_safe_cpy'
call psb_erractionsave(err_act)
if(psb_get_errstatus() /= 0) return
info = 0
isz1 = size(vin,1)
isz2 = size(vin,2)
lb1 = lbound(vin,1)
lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= 0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
vout(:,:) = vin(:,:)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error()
end if
return
end subroutine psb_z_cpy2d
function psb_isize1d(vin)
integer :: psb_isize1d
base/modules/psb_serial_mod.f90
+5
View File
@@ -33,6 +33,11 @@ module psb_serial_mod
use psb_string_mod
use psb_sort_mod
use psi_serial_mod, &
& psb_gth => psi_gth,&
& psb_sct => psi_sct
interface psb_csdp
subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl)
use psb_spmat_type
base/modules/psb_spmat_type.f90
+10 -10
View File
@@ -610,11 +610,11 @@ contains
INFO = 0
call psb_nullify_sp(b)
call psb_safe_cpy(a%aspk,b%aspk,info)
if (info == 0) call psb_safe_cpy(a%ia1,b%ia1,info)
if (info == 0) call psb_safe_cpy(a%ia2,b%ia2,info)
if (info == 0) call psb_safe_cpy(a%pl,b%pl,info)
if (info == 0) call psb_safe_cpy(a%pr,b%pr,info)
call psb_safe_ab_cpy(a%aspk,b%aspk,info)
if (info == 0) call psb_safe_ab_cpy(a%ia1,b%ia1,info)
if (info == 0) call psb_safe_ab_cpy(a%ia2,b%ia2,info)
if (info == 0) call psb_safe_ab_cpy(a%pl,b%pl,info)
if (info == 0) call psb_safe_ab_cpy(a%pr,b%pr,info)
if (info /= 0) then
info=2023
return
@@ -1141,11 +1141,11 @@ contains
INFO = 0
call psb_nullify_sp(b)
call psb_safe_cpy(a%aspk,b%aspk,info)
if (info == 0) call psb_safe_cpy(a%ia1,b%ia1,info)
if (info == 0) call psb_safe_cpy(a%ia2,b%ia2,info)
if (info == 0) call psb_safe_cpy(a%pl,b%pl,info)
if (info == 0) call psb_safe_cpy(a%pr,b%pr,info)
call psb_safe_ab_cpy(a%aspk,b%aspk,info)
if (info == 0) call psb_safe_ab_cpy(a%ia1,b%ia1,info)
if (info == 0) call psb_safe_ab_cpy(a%ia2,b%ia2,info)
if (info == 0) call psb_safe_ab_cpy(a%pl,b%pl,info)
if (info == 0) call psb_safe_ab_cpy(a%pr,b%pr,info)
if (info /= 0) then
info=2023
return
base/modules/psb_tools_mod.f90
+62 -22
View File
@@ -30,7 +30,6 @@
!!$
Module psb_tools_mod
use psb_const_mod
use psb_gps_mod
use psb_spmat_type
interface psb_geall
@@ -337,22 +336,22 @@ Module psb_tools_mod
Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info,extype)
use psb_descriptor_type
Use psb_spmat_type
integer, intent(in) :: novr
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info
integer, intent(in),optional :: extype
integer, intent(in) :: novr
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in), target :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info
integer, intent(in),optional :: extype
end Subroutine psb_dcdovr
Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info,extype)
use psb_descriptor_type
Use psb_spmat_type
integer, intent(in) :: novr
Type(psb_zspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info
integer, intent(in),optional :: extype
integer, intent(in) :: novr
Type(psb_zspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in), target :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info
integer, intent(in),optional :: extype
end Subroutine psb_zcdovr
end interface
@@ -490,6 +489,27 @@ Module psb_tools_mod
logical, intent(in), optional :: owned
character, intent(in), optional :: iact
end subroutine psb_glob_to_loc
subroutine psb_glob_to_loc2s(x,y,desc_a,info,iact,owned)
use psb_descriptor_type
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer,intent(in) :: x
integer,intent(out) :: y
integer, intent(out) :: info
character, intent(in), optional :: iact
logical, intent(in), optional :: owned
end subroutine psb_glob_to_loc2s
subroutine psb_glob_to_locs(x,desc_a,info,iact,owned)
use psb_descriptor_type
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer,intent(inout) :: x
integer, intent(out) :: info
character, intent(in), optional :: iact
logical, intent(in), optional :: owned
end subroutine psb_glob_to_locs
end interface
interface psb_loc_to_glob
@@ -508,8 +528,25 @@ Module psb_tools_mod
integer, intent(out) :: info
character, intent(in), optional :: iact
end subroutine psb_loc_to_glob
end interface
subroutine psb_loc_to_glob2s(x,y,desc_a,info,iact)
use psb_descriptor_type
implicit none
type(psb_desc_type), intent(in) :: desc_a
integer,intent(in) :: x
integer,intent(out) :: y
integer, intent(out) :: info
character, intent(in), optional :: iact
end subroutine psb_loc_to_glob2s
subroutine psb_loc_to_globs(x,desc_a,info,iact)
use psb_descriptor_type
type(psb_desc_type), intent(in) :: desc_a
integer,intent(inout) :: x
integer, intent(out) :: info
character, intent(in), optional :: iact
end subroutine psb_loc_to_globs
end interface
interface psb_get_boundary
module procedure psb_get_boundary
@@ -606,6 +643,8 @@ contains
goto 999
endif
desc_a%base_desc => null()
if (present(parts)) then
if (.not.present(mg)) then
info=581
@@ -678,14 +717,14 @@ contains
subroutine psb_cdasb(desc_a,info)
use psb_descriptor_type
interface
subroutine psb_icdasb(desc_a,info,ext_hv)
use psb_descriptor_type
Type(psb_desc_type), intent(inout) :: desc_a
integer, intent(out) :: info
logical, intent(in),optional :: ext_hv
end subroutine psb_icdasb
end interface
interface
subroutine psb_icdasb(desc_a,info,ext_hv)
use psb_descriptor_type
Type(psb_desc_type), intent(inout) :: desc_a
integer, intent(out) :: info
logical, intent(in),optional :: ext_hv
end subroutine psb_icdasb
end interface
Type(psb_desc_type), intent(inout) :: desc_a
integer, intent(out) :: info
@@ -694,4 +733,5 @@ contains
end subroutine psb_cdasb
end module psb_tools_mod
base/modules/psi_mod.f90
+400 -326
View File
@@ -28,9 +28,11 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module psi_mod
use psi_serial_mod
interface
subroutine psi_compute_size(desc_data,&
& index_in, dl_lda, info)
@@ -111,6 +113,20 @@ module psi_mod
type(psb_desc_type), target :: desc_a
integer, optional :: data
end subroutine psi_dswapdatav
subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag, n
integer, intent(out) :: info
real(kind(1.d0)) :: y(:,:), beta
real(kind(1.d0)),target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxm
subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
real(kind(1.d0)) :: y(:), beta
real(kind(1.d0)),target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxv
subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_descriptor_type
integer, intent(in) :: flag, n
@@ -129,6 +145,20 @@ module psi_mod
type(psb_desc_type), target :: desc_a
integer, optional :: data
end subroutine psi_iswapdatav
subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag, n
integer, intent(out) :: info
integer :: y(:,:), beta
integer,target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_iswapidxm
subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
integer :: y(:), beta
integer,target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_iswapidxv
subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_descriptor_type
integer, intent(in) :: flag, n
@@ -147,6 +177,20 @@ module psi_mod
type(psb_desc_type), target :: desc_a
integer, optional :: data
end subroutine psi_zswapdatav
subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag, n
integer, intent(out) :: info
complex(kind(1.d0)) :: y(:,:), beta
complex(kind(1.d0)),target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_zswapidxm
subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
complex(kind(1.d0)) :: y(:), beta
complex(kind(1.d0)),target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_zswapidxv
end interface
@@ -169,6 +213,20 @@ module psi_mod
type(psb_desc_type), target :: desc_a
integer, optional :: data
end subroutine psi_dswaptranv
subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag, n
integer, intent(out) :: info
real(kind(1.d0)) :: y(:,:), beta
real(kind(1.d0)),target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxm
subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
real(kind(1.d0)) :: y(:), beta
real(kind(1.d0)),target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxv
subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psb_descriptor_type
integer, intent(in) :: flag, n
@@ -187,6 +245,20 @@ module psi_mod
type(psb_desc_type), target :: desc_a
integer, optional :: data
end subroutine psi_iswaptranv
subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag, n
integer, intent(out) :: info
integer :: y(:,:), beta
integer, target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_itranidxm
subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
integer :: y(:), beta
integer, target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_itranidxv
subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psb_descriptor_type
integer, intent(in) :: flag, n
@@ -205,6 +277,20 @@ module psi_mod
type(psb_desc_type), target :: desc_a
integer, optional :: data
end subroutine psi_zswaptranv
subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag, n
integer, intent(out) :: info
complex(kind(1.d0)) :: y(:,:), beta
complex(kind(1.d0)), target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ztranidxm
subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
integer, intent(in) :: ictxt,icomm,flag
integer, intent(out) :: info
complex(kind(1.d0)) :: y(:), beta
complex(kind(1.d0)), target :: work(:)
integer, intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_ztranidxv
end interface
interface
@@ -344,18 +430,6 @@ module psi_mod
& psi_zovrl_restrr1, psi_zovrl_restrr2
end interface
interface psi_gth
module procedure psi_igthm, psi_igthv,&
& psi_dgthm, psi_dgthv,&
& psi_zgthm, psi_zgthv
end interface
interface psi_sct
module procedure psi_isctm, psi_isctv,&
& psi_dsctm, psi_dsctv,&
& psi_zsctm, psi_zsctv
end interface
contains
@@ -1677,319 +1751,319 @@ contains
end subroutine psi_iovrl_restrr2
subroutine psi_dgthm(n,k,idx,x,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
real(kind(1.d0)) :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_dgthm
subroutine psi_dgthv(n,idx,x,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
real(kind(1.d0)) :: x(:), y(:)
! Locals
integer :: i
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_dgthv
subroutine psi_dsctm(n,k,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta == dzero) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta == done) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_dsctm
subroutine psi_dsctv(n,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:)
! Locals
integer :: i
if (beta == dzero) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta == done) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_dsctv
subroutine psi_igthm(n,k,idx,x,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
integer :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_igthm
subroutine psi_igthv(n,idx,x,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
integer :: x(:), y(:)
! Locals
integer :: i
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_igthv
subroutine psi_isctm(n,k,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
integer :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta == izero) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta == ione) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_isctm
subroutine psi_isctv(n,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
integer :: beta, x(:), y(:)
! Locals
integer :: i
if (beta == izero) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta == ione) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_isctv
subroutine psi_zgthm(n,k,idx,x,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
complex(kind(1.d0)) :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_zgthm
subroutine psi_zgthv(n,idx,x,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
complex(kind(1.d0)) :: x(:), y(:)
! Locals
integer :: i
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_zgthv
subroutine psi_zsctm(n,k,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta == zzero) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta == zone) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_zsctm
subroutine psi_zsctv(n,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:)
! Locals
integer :: i
if (beta == zzero) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta == zone) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_zsctv
!!$ subroutine psi_dgthzm(n,k,idx,x,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, k, idx(:)
!!$ real(kind(1.d0)) :: x(:,:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i, j, pt
!!$
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(pt)=x(idx(i),j)
!!$ end do
!!$ end do
!!$
!!$ end subroutine psi_dgthzm
!!$
!!$ subroutine psi_dgthzv(n,idx,x,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, idx(:)
!!$ real(kind(1.d0)) :: x(:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i
!!$
!!$ do i=1,n
!!$ y(i)=x(idx(i))
!!$ end do
!!$
!!$ end subroutine psi_dgthzv
!!$
!!$
!!$ subroutine psi_dsctm(n,k,idx,x,beta,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, k, idx(:)
!!$ real(kind(1.d0)) :: beta, x(:), y(:,:)
!!$
!!$ ! Locals
!!$ integer :: i, j, pt
!!$
!!$ if (beta == dzero) then
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = x(pt)
!!$ end do
!!$ end do
!!$ else if (beta == done) then
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = y(idx(i),j)+x(pt)
!!$ end do
!!$ end do
!!$ else
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = beta*y(idx(i),j)+x(pt)
!!$ end do
!!$ end do
!!$ end if
!!$ end subroutine psi_dsctm
!!$
!!$ subroutine psi_dsctv(n,idx,x,beta,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, idx(:)
!!$ real(kind(1.d0)) :: beta, x(:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i
!!$
!!$ if (beta == dzero) then
!!$ do i=1,n
!!$ y(idx(i)) = x(i)
!!$ end do
!!$ else if (beta == done) then
!!$ do i=1,n
!!$ y(idx(i)) = y(idx(i))+x(i)
!!$ end do
!!$ else
!!$ do i=1,n
!!$ y(idx(i)) = beta*y(idx(i))+x(i)
!!$ end do
!!$ end if
!!$ end subroutine psi_dsctv
!!$
!!$
!!$ subroutine psi_igthzm(n,k,idx,x,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, k, idx(:)
!!$ integer :: x(:,:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i, j, pt
!!$
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(pt)=x(idx(i),j)
!!$ end do
!!$ end do
!!$
!!$ end subroutine psi_igthzm
!!$
!!$
!!$ subroutine psi_igthzv(n,idx,x,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, idx(:)
!!$ integer :: x(:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i
!!$
!!$ do i=1,n
!!$ y(i)=x(idx(i))
!!$ end do
!!$
!!$ end subroutine psi_igthzv
!!$
!!$
!!$
!!$ subroutine psi_isctm(n,k,idx,x,beta,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, k, idx(:)
!!$ integer :: beta, x(:), y(:,:)
!!$
!!$ ! Locals
!!$ integer :: i, j, pt
!!$
!!$ if (beta == izero) then
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = x(pt)
!!$ end do
!!$ end do
!!$ else if (beta == ione) then
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = y(idx(i),j)+x(pt)
!!$ end do
!!$ end do
!!$ else
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = beta*y(idx(i),j)+x(pt)
!!$ end do
!!$ end do
!!$ end if
!!$ end subroutine psi_isctm
!!$
!!$ subroutine psi_isctv(n,idx,x,beta,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, idx(:)
!!$ integer :: beta, x(:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i
!!$
!!$ if (beta == izero) then
!!$ do i=1,n
!!$ y(idx(i)) = x(i)
!!$ end do
!!$ else if (beta == ione) then
!!$ do i=1,n
!!$ y(idx(i)) = y(idx(i))+x(i)
!!$ end do
!!$ else
!!$ do i=1,n
!!$ y(idx(i)) = beta*y(idx(i))+x(i)
!!$ end do
!!$ end if
!!$ end subroutine psi_isctv
!!$
!!$
!!$ subroutine psi_zgthzm(n,k,idx,x,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, k, idx(:)
!!$ complex(kind(1.d0)) :: x(:,:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i, j, pt
!!$
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(pt)=x(idx(i),j)
!!$ end do
!!$ end do
!!$
!!$ end subroutine psi_zgthzm
!!$
!!$
!!$ subroutine psi_zgthzv(n,idx,x,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, idx(:)
!!$ complex(kind(1.d0)) :: x(:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i
!!$
!!$ do i=1,n
!!$ y(i)=x(idx(i))
!!$ end do
!!$
!!$ end subroutine psi_zgthzv
!!$
!!$ subroutine psi_zsctm(n,k,idx,x,beta,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, k, idx(:)
!!$ complex(kind(1.d0)) :: beta, x(:), y(:,:)
!!$
!!$ ! Locals
!!$ integer :: i, j, pt
!!$
!!$ if (beta == zzero) then
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = x(pt)
!!$ end do
!!$ end do
!!$ else if (beta == zone) then
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = y(idx(i),j)+x(pt)
!!$ end do
!!$ end do
!!$ else
!!$ pt=0
!!$ do j=1,k
!!$ do i=1,n
!!$ pt=pt+1
!!$ y(idx(i),j) = beta*y(idx(i),j)+x(pt)
!!$ end do
!!$ end do
!!$ end if
!!$ end subroutine psi_zsctm
!!$
!!$
!!$ subroutine psi_zsctv(n,idx,x,beta,y)
!!$
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ integer :: n, idx(:)
!!$ complex(kind(1.d0)) :: beta, x(:), y(:)
!!$
!!$ ! Locals
!!$ integer :: i
!!$
!!$ if (beta == zzero) then
!!$ do i=1,n
!!$ y(idx(i)) = x(i)
!!$ end do
!!$ else if (beta == zone) then
!!$ do i=1,n
!!$ y(idx(i)) = y(idx(i))+x(i)
!!$ end do
!!$ else
!!$ do i=1,n
!!$ y(idx(i)) = beta*y(idx(i))+x(i)
!!$ end do
!!$ end if
!!$ end subroutine psi_zsctv
subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info)
use psb_const_mod
base/modules/psi_serial_mod.f90
+518
View File
@@ -0,0 +1,518 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
module psi_serial_mod
interface psi_gth
module procedure &
& psi_igthv, psi_dgthv, psi_zgthv,&
& psi_igthzv, psi_dgthzv, psi_zgthzv,&
& psi_igthzmv, psi_dgthzmv, psi_zgthzmv
end interface
interface psi_sct
module procedure psi_isctmv, psi_isctv,&
& psi_dsctmv, psi_dsctv,&
& psi_zsctmv, psi_zsctv
end interface
contains
subroutine psi_igthv(n,idx,alpha,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
integer :: x(:), y(:), alpha, beta
! Locals
integer :: i
if (beta == izero) then
if (alpha == ione) then
do i=1,n
y(i) = x(idx(i))
end do
else if (alpha == -ione) then
do i=1,n
y(i) = -x(idx(i))
end do
else
do i=1,n
y(i) = alpha*x(idx(i))
end do
end if
else
if (beta == ione) then
! Do nothing
else if (beta == -ione) then
y(1:n) = -y(1:n)
else
y(1:n) = beta*y(1:n)
end if
if (alpha == ione) then
do i=1,n
y(i) = y(i) + x(idx(i))
end do
else if (alpha == -ione) then
do i=1,n
y(i) = y(i) - x(idx(i))
end do
else
do i=1,n
y(i) = y(i) + alpha*x(idx(i))
end do
end if
end if
end subroutine psi_igthv
subroutine psi_dgthv(n,idx,alpha,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
real(kind(1.d0)) :: x(:), y(:), alpha, beta
! Locals
integer :: i
if (beta == dzero) then
if (alpha == done) then
do i=1,n
y(i) = x(idx(i))
end do
else if (alpha == -done) then
do i=1,n
y(i) = -x(idx(i))
end do
else
do i=1,n
y(i) = alpha*x(idx(i))
end do
end if
else
if (beta == done) then
! Do nothing
else if (beta == -done) then
y(1:n) = -y(1:n)
else
y(1:n) = beta*y(1:n)
end if
if (alpha == done) then
do i=1,n
y(i) = y(i) + x(idx(i))
end do
else if (alpha == -done) then
do i=1,n
y(i) = y(i) - x(idx(i))
end do
else
do i=1,n
y(i) = y(i) + alpha*x(idx(i))
end do
end if
end if
end subroutine psi_dgthv
subroutine psi_zgthv(n,idx,alpha,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
complex(kind(1.d0)) :: x(:), y(:),alpha,beta
! Locals
integer :: i
if (beta == zzero) then
if (alpha == zone) then
do i=1,n
y(i) = x(idx(i))
end do
else if (alpha == -zone) then
do i=1,n
y(i) = -x(idx(i))
end do
else
do i=1,n
y(i) = alpha*x(idx(i))
end do
end if
else
if (beta == zone) then
! Do nothing
else if (beta == -zone) then
y(1:n) = -y(1:n)
else
y(1:n) = beta*y(1:n)
end if
if (alpha == zone) then
do i=1,n
y(i) = y(i) + x(idx(i))
end do
else if (alpha == -zone) then
do i=1,n
y(i) = y(i) - x(idx(i))
end do
else
do i=1,n
y(i) = y(i) + alpha*x(idx(i))
end do
end if
end if
end subroutine psi_zgthv
subroutine psi_dgthzmv(n,k,idx,x,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
real(kind(1.d0)) :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_dgthzmv
subroutine psi_igthzmv(n,k,idx,x,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
integer :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_igthzmv
subroutine psi_zgthzmv(n,k,idx,x,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
complex(kind(1.d0)) :: x(:,:), y(:)
! Locals
integer :: i, j, pt
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(pt)=x(idx(i),j)
end do
end do
end subroutine psi_zgthzmv
subroutine psi_dgthzv(n,idx,x,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
real(kind(1.d0)) :: x(:), y(:)
! Locals
integer :: i
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_dgthzv
subroutine psi_igthzv(n,idx,x,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
integer :: x(:), y(:)
! Locals
integer :: i
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_igthzv
subroutine psi_zgthzv(n,idx,x,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
complex(kind(1.d0)) :: x(:), y(:)
! Locals
integer :: i
do i=1,n
y(i)=x(idx(i))
end do
end subroutine psi_zgthzv
subroutine psi_dsctmv(n,k,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta == dzero) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta == done) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_dsctmv
subroutine psi_dsctv(n,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
real(kind(1.d0)) :: beta, x(:), y(:)
! Locals
integer :: i
if (beta == dzero) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta == done) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))
end do
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
end if
end subroutine psi_dsctv
subroutine psi_isctmv(n,k,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
integer :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta == izero) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta == ione) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_isctmv
subroutine psi_isctv(n,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
integer :: beta, x(:), y(:)
! Locals
integer :: i
if (beta == izero) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta == ione) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_isctv
subroutine psi_zsctmv(n,k,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, k, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:,:)
! Locals
integer :: i, j, pt
if (beta == zzero) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = x(pt)
end do
end do
else if (beta == zone) then
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = y(idx(i),j)+x(pt)
end do
end do
else
pt=0
do j=1,k
do i=1,n
pt=pt+1
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
end do
end do
end if
end subroutine psi_zsctmv
subroutine psi_zsctv(n,idx,x,beta,y)
use psb_const_mod
implicit none
integer :: n, idx(:)
complex(kind(1.d0)) :: beta, x(:), y(:)
! Locals
integer :: i
if (beta == zzero) then
do i=1,n
y(idx(i)) = x(i)
end do
else if (beta == zone) then
do i=1,n
y(idx(i)) = y(idx(i))+x(i)
end do
else
do i=1,n
y(idx(i)) = beta*y(idx(i))+x(i)
end do
end if
end subroutine psi_zsctv
end module psi_serial_mod