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

[UPDATE] Removed work/aux buffer from vector routines that use psb_x_vect_type encapsulation for data exchange

Browse Source
communication_v2
Stack-1 2 months ago
parent dc61cbb0a2
commit 461a6a325f
143 changed files with 3051 additions and 3129 deletions
Show Stats Download Patch File Download Diff File

2
base/auxil/Makefile
Unescape Escape View File

@ -16,7 +16,7 @@ MODDIR=../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
CINCLUDES=-I.
objs: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(MPFOBJS)
objs: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) $(COBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)

2
base/comm/internals/Makefile
Unescape Escape View File

@ -31,7 +31,7 @@ MODDIR=../../modules
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
CINCLUDES=-I.
objs: mpfobjs $(FOBJS) $(MPFOBJS)
objs: mpfobjs $(FOBJS)
lib: objs
$(AR) $(LIBDIR)/$(LIBNAME) $(MPFOBJS) $(MPFOBJS2) $(FOBJS) $(FOBJS2) $(COBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)

29
base/comm/internals/psi_cswapdata.F90
Unescape Escape View File

@ -77,7 +77,6 @@
! beta - complex Choose overwrite or sum.
! y - type(psb_@x@_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - complex Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
@ -92,7 +91,7 @@
submodule (psi_c_comm_v_mod) psi_c_swapdata_impl
use psb_base_mod
contains
subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
subroutine psi_cswapdata_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -103,11 +102,10 @@ contains
#endif
integer(psb_ipk_), intent(in) :: flag
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
! locals
@ -117,8 +115,8 @@ contains
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
info = psb_success_
name = 'psi_cswapdata_vect'
call psb_erractionsave(err_act)
ctxt = desc_a%get_context()
@ -148,7 +146,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -174,7 +172,7 @@ contains
!
!
module subroutine psi_cswap_vidx_vect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -189,7 +187,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -207,7 +204,7 @@ contains
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
name='psi_cswap_vidx_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,me,np)
if (np == -1) then
@ -420,7 +417,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
#endif
@ -433,7 +430,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@ -475,7 +471,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -501,7 +497,7 @@ contains
!
!
module subroutine psi_cswap_vidx_multivect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -516,7 +512,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

17
base/comm/internals/psi_cswaptran.F90
Unescape Escape View File

@ -80,7 +80,6 @@
! beta - complex Choose overwrite or sum.
! y - type(psb_c_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - complex Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
@ -94,7 +93,7 @@
submodule (psi_c_comm_v_mod) psi_c_swaptran_impl
use psb_base_mod
contains
module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -108,7 +107,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -150,7 +148,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -175,7 +173,7 @@ contains
!
!
module subroutine psi_ctran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -190,7 +188,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -430,7 +427,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -444,7 +441,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -486,7 +482,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -512,7 +508,7 @@ contains
!
!
module subroutine psi_ctran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -527,7 +523,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

93
base/comm/internals/psi_dswapdata.F90
Unescape Escape View File

@ -91,7 +91,7 @@ submodule (psi_d_comm_v_mod) psi_d_swapdata_impl
use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_
use psb_base_mod
contains
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,info,data,work)
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -101,13 +101,12 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
type(psb_desc_type), target :: desc_a
real(psb_dpk_), optional, target :: work(:)
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
class(psb_d_base_vect_type), intent(inout) :: y
real(psb_dpk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a ! TODO: should this be intent(in)?
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -209,15 +208,15 @@ contains
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
integer(psb_ipk_), intent(in) :: num_neighbors, total_send, total_recv
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: np, me
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),&
& iret, nesd, nerv
@ -449,15 +448,15 @@ contains
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_), intent(in) :: beta
integer(psb_ipk_), intent(in) :: flag
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors,total_send,total_recv
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: np, me
integer(psb_mpk_) :: iret, p2pstat(mpi_status_size)
integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size
@ -606,7 +605,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,info,data,work)
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
#endif
@ -615,13 +614,12 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
type(psb_desc_type), target :: desc_a
real(psb_dpk_), optional, target :: work(:)
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
class(psb_d_base_multivect_type), intent(inout) :: y
real(psb_dpk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! local variables used to detect the communication scheme
logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait
@ -722,16 +720,16 @@ subroutine psi_dswap_baseline_multivect(ctxt,flag,beta,y,comm_indexes, &
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_), intent(in) :: beta
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_multivect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: np, me, nesd, nerv, n
integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpk_), allocatable :: prcid(:)
@ -964,26 +962,27 @@ subroutine psi_dswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,n
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_), intent(in) :: beta
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_multivect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: comm_indexes
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_mpk_) :: np, me
integer(psb_mpk_) :: iret, p2pstat(mpi_status_size)
integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size
logical :: do_start, do_wait
logical, parameter :: debug = .false.
character(len=30) :: name
integer(psb_mpk_) :: icomm
integer(psb_mpk_) :: np, me
integer(psb_mpk_) :: iret, p2pstat(mpi_status_size)
integer(psb_ipk_) :: err_act, topology_total_send, topology_total_recv, buffer_size
logical :: do_start, do_wait
logical, parameter :: debug = .false.
character(len=30) :: name
info = psb_success_
name = 'psi_dswap_nbr_vect'
name = 'psi_dswap_neighbor_topology_multivect'
call psb_erractionsave(err_act)
call psb_info(ctxt,me,np)
if (np == -1) then

40
base/comm/internals/psi_dswapdata_a.F90
Unescape Escape View File

@ -97,13 +97,14 @@ contains
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
integer(psb_mpk_), intent(in) :: n
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), intent(inout) :: y(:,:)
type(psb_desc_type),target :: desc_a
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -165,12 +166,13 @@ real(psb_dpk_), target :: work(:)
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), intent(inout) :: y(:,:)
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
@ -565,12 +567,13 @@ real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), intent(inout) :: y(:)
type(psb_desc_type),target :: desc_a
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -648,7 +651,8 @@ real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), intent(inout) :: y(:)
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv

81
base/comm/internals/psi_dswaptran.F90
Unescape Escape View File

@ -80,7 +80,6 @@
! beta - real Choose overwrite or sum.
! y - type(psb_d_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - real Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
@ -94,7 +93,7 @@
submodule (psi_d_comm_v_mod) psi_d_swaptran_impl
use psb_base_mod
contains
module subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_dswaptran_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -104,13 +103,12 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_vect_type), intent(inout) :: y
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -119,8 +117,8 @@ contains
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
info=psb_success_
name='psi_swap_tranv'
info = psb_success_
name = 'psi_dswaptran_vect'
call psb_erractionsave(err_act)
ctxt = desc_a%get_context()
@ -150,7 +148,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -175,7 +173,7 @@ contains
!
!
module subroutine psi_dtran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -185,14 +183,13 @@ contains
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_mpk_) :: np, me, nesd, nerv, n
@ -206,8 +203,8 @@ contains
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
name='psi_swap_tran'
info = psb_success_
name = 'psi_dtran_vidx_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,me,np)
if (np == -1) then
@ -430,7 +427,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -440,13 +437,12 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_multivect_type), intent(inout) :: y
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -486,7 +482,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -512,7 +508,7 @@ contains
!
!
module subroutine psi_dtran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -522,14 +518,13 @@ contains
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type), intent(inout) :: y
real(psb_dpk_), intent(in) :: beta
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
! locals
integer(psb_mpk_) :: np, me, nesd, nerv, n
@ -543,8 +538,8 @@ contains
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
name='psi_swap_tran'
info = psb_success_
name = 'psi_dtran_vidx_multivect'
call psb_erractionsave(err_act)
call psb_info(ctxt,me,np)
if (np == -1) then

38
base/comm/internals/psi_dswaptran_a.F90
Unescape Escape View File

@ -30,7 +30,7 @@
!
!
!
! File: psi_dswaptran.F90
! File: psi_dswaptran_a.F90
!
! Subroutine: psi_dswaptranm
! Implements the data exchange among processes. This is similar to Xswapdata, but
@ -101,13 +101,14 @@ contains
include 'mpif.h'
#endif
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
integer(psb_mpk_), intent(in) :: n
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), intent(inout) :: y(:,:)
type(psb_desc_type),target :: desc_a
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -149,7 +150,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -174,7 +175,8 @@ contains
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_), intent(inout) :: y(:,:)
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
@ -579,12 +581,13 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), intent(inout) :: y(:)
type(psb_desc_type),target :: desc_a
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -659,7 +662,8 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_), intent(inout) :: y(:)
real(psb_dpk_), intent(in) :: beta
real(psb_dpk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv

2
base/comm/internals/psi_eswaptran_a.F90
Unescape Escape View File

@ -30,7 +30,7 @@
!
!
!
! File: psi_eswaptran.F90
! File: psi_eswaptran_a.F90
!
! Subroutine: psi_eswaptranm
! Implements the data exchange among processes. This is similar to Xswapdata, but

22
base/comm/internals/psi_iswapdata.F90
Unescape Escape View File

@ -77,8 +77,6 @@
! beta - integer Choose overwrite or sum.
! y - type(psb_@x@_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - integer Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
! default psb_comm_halo_
@ -92,7 +90,7 @@
submodule (psi_i_comm_v_mod) psi_i_swapdata_impl
use psb_base_mod
contains
subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
subroutine psi_iswapdata_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -106,7 +104,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@ -148,7 +145,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -174,7 +171,7 @@ contains
!
!
module subroutine psi_iswap_vidx_vect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -189,7 +186,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -206,8 +202,8 @@ contains
logical, parameter :: usersend=.false., debug=.false.
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
info = psb_success_
name = 'psi_iswap_vidx_vect'
call psb_erractionsave(err_act)
call psb_info(ctxt,me,np)
if (np == -1) then
@ -420,7 +416,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
#endif
@ -433,7 +429,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@ -475,7 +470,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -501,7 +496,7 @@ contains
!
!
module subroutine psi_iswap_vidx_multivect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -516,7 +511,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

21
base/comm/internals/psi_iswaptran.F90
Unescape Escape View File

@ -80,7 +80,6 @@
! beta - integer Choose overwrite or sum.
! y - type(psb_i_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - integer Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
@ -94,7 +93,7 @@
submodule (psi_i_comm_v_mod) psi_i_swaptran_impl
use psb_base_mod
contains
module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -108,7 +107,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -119,8 +117,8 @@ contains
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
info=psb_success_
name='psi_swap_tranv'
info = psb_success_
name = 'psi_iswaptran_vect'
call psb_erractionsave(err_act)
ctxt = desc_a%get_context()
@ -150,7 +148,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -175,7 +173,7 @@ contains
!
!
module subroutine psi_itran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -190,7 +188,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -430,7 +427,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -444,7 +441,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -486,7 +482,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -512,7 +508,7 @@ contains
!
!
module subroutine psi_itran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -527,7 +523,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

18
base/comm/internals/psi_lswapdata.F90
Unescape Escape View File

@ -77,8 +77,6 @@
! beta - integer Choose overwrite or sum.
! y - type(psb_@x@_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - integer Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
! default psb_comm_halo_
@ -92,7 +90,7 @@
submodule (psi_l_comm_v_mod) psi_l_swapdata_impl
use psb_base_mod
contains
subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data)
subroutine psi_lswapdata_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -106,7 +104,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@ -148,7 +145,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -174,7 +171,7 @@ contains
!
!
module subroutine psi_lswap_vidx_vect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -189,7 +186,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -420,7 +416,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
#endif
@ -433,7 +429,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@ -475,7 +470,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -501,7 +496,7 @@ contains
!
!
module subroutine psi_lswap_vidx_multivect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -516,7 +511,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

18
base/comm/internals/psi_lswaptran.F90
Unescape Escape View File

@ -80,8 +80,6 @@
! beta - integer Choose overwrite or sum.
! y - type(psb_l_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - integer Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
! default psb_comm_halo_
@ -94,7 +92,7 @@
submodule (psi_l_comm_v_mod) psi_l_swaptran_impl
use psb_base_mod
contains
module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -108,7 +106,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -150,7 +147,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -175,7 +172,7 @@ contains
!
!
module subroutine psi_ltran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -190,7 +187,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -430,7 +426,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -444,7 +440,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -486,7 +481,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -512,7 +507,7 @@ contains
!
!
module subroutine psi_ltran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -527,7 +522,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

BIN
base/comm/internals/psi_s_comm_v_mod@psi_s_ovrl_restr_v_impl.smod0
View File

Binary file not shown.

41
base/comm/internals/psi_sswapdata.F90
Unescape Escape View File

@ -77,7 +77,6 @@
! beta - real Choose overwrite or sum.
! y - type(psb_@x@_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - real Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
@ -93,7 +92,7 @@ submodule (psi_s_comm_v_mod) psi_s_swapdata_impl
use psb_desc_const_mod, only: psb_swap_start_, psb_swap_wait_
use psb_base_mod
contains
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data,work)
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -103,13 +102,12 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
real(psb_spk_), target, optional :: work(:)
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(inout) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -127,8 +125,8 @@ contains
character(len=30) :: name
info=psb_success_
name='psi_sswapdata_vect'
info = psb_success_
name = 'psi_sswapdata_vect'
call psb_erractionsave(err_act)
ctxt = desc_a%get_context()
@ -223,8 +221,8 @@ subroutine psi_sswap_baseline_vect(ctxt,flag,beta,y,idx, &
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_) :: beta
class(psb_s_base_vect_type), intent(inout) :: y
real(psb_spk_), intent(in) :: beta
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
@ -464,7 +462,7 @@ subroutine psi_sswap_neighbor_topology_vect(ctxt,flag,beta,y,idx, &
integer(psb_mpk_) :: icomm
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
class(psb_s_base_vect_type), intent(inout) :: y
real(psb_spk_), intent(in) :: beta
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: num_neighbors,total_send, total_recv
@ -620,7 +618,7 @@ end subroutine psi_sswap_neighbor_topology_vect
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,info,data,work)
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
#endif
@ -629,13 +627,12 @@ end subroutine psi_sswap_neighbor_topology_vect
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
real(psb_spk_), target, optional :: work(:)
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type), intent(inout) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt

62
base/comm/internals/psi_sswaptran.F90
Unescape Escape View File

@ -80,7 +80,6 @@
! beta - real Choose overwrite or sum.
! y - type(psb_s_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - real Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
@ -94,7 +93,7 @@
submodule (psi_s_comm_v_mod) psi_s_swaptran_impl
use psb_base_mod
contains
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,info,data,work)
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -104,13 +103,12 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
real(psb_spk_), intent(in) :: beta
class(psb_s_base_vect_type), intent(inout) :: y
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -119,8 +117,8 @@ contains
class(psb_i_base_vect_type), pointer :: d_vidx
character(len=20) :: name
info=psb_success_
name='psi_swap_tranv'
info = psb_success_
name = 'psi_sswaptran_vect'
call psb_erractionsave(err_act)
ctxt = desc_a%get_context()
@ -150,7 +148,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -175,7 +173,7 @@ contains
!
!
module subroutine psi_stran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -188,9 +186,8 @@ contains
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
class(psb_s_base_vect_type), intent(inout) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -430,7 +427,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data,work)
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -440,13 +437,12 @@ contains
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), intent(in) :: flag
real(psb_spk_), intent(in) :: beta
class(psb_s_base_multivect_type), intent(inout) :: y
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
! locals
type(psb_ctxt_type) :: ctxt
@ -486,7 +482,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -512,7 +508,7 @@ contains
!
!
module subroutine psi_stran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -522,14 +518,14 @@ contains
include 'mpif.h'
#endif
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_spk_), intent(in) :: beta
class(psb_s_base_multivect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd,totrcv
integer(psb_ipk_), intent(out) :: info
! locals
integer(psb_mpk_) :: np, me, nesd, nerv, n

2
base/comm/internals/psi_sswaptran_a.F90
Unescape Escape View File

@ -30,7 +30,7 @@
!
!
!
! File: psi_sswaptran.F90
! File: psi_sswaptran_a.F90
!
! Subroutine: psi_sswaptranm
! Implements the data exchange among processes. This is similar to Xswapdata, but

18
base/comm/internals/psi_zswapdata.F90
Unescape Escape View File

@ -77,8 +77,6 @@
! beta - complex Choose overwrite or sum.
! y - type(psb_@x@_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - complex Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
! default psb_comm_halo_
@ -92,7 +90,7 @@
submodule (psi_z_comm_v_mod) psi_z_swapdata_impl
use psb_base_mod
contains
subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
subroutine psi_zswapdata_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -106,7 +104,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@ -148,7 +145,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -174,7 +171,7 @@ contains
!
!
module subroutine psi_zswap_vidx_vect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -189,7 +186,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -420,7 +416,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
#endif
@ -433,7 +429,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
@ -475,7 +470,7 @@ contains
goto 9999
end if
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -501,7 +496,7 @@ contains
!
!
module subroutine psi_zswap_vidx_multivect(ctxt,flag,beta,y,idx, &
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -516,7 +511,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

18
base/comm/internals/psi_zswaptran.F90
Unescape Escape View File

@ -80,8 +80,6 @@
! beta - complex Choose overwrite or sum.
! y - type(psb_z_vect_type) The data area
! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - complex Buffer space. If not sufficient, will do
! our own internal allocation.
! info - integer. return code.
! data - integer which list is to be used to exchange data
! default psb_comm_halo_
@ -94,7 +92,7 @@
submodule (psi_z_comm_v_mod) psi_z_swaptran_impl
use psb_base_mod
contains
module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -108,7 +106,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -150,7 +147,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -175,7 +172,7 @@ contains
!
!
module subroutine psi_ztran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -190,7 +187,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
@ -430,7 +426,7 @@ contains
! Takes care of Y an encaspulated multivector.
!
!
module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,info,data)
#ifdef PSB_MPI_MOD
use mpi
@ -444,7 +440,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
@ -486,7 +481,7 @@ contains
goto 9999
end if
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
@ -512,7 +507,7 @@ contains
!
!
module subroutine psi_ztran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
#ifdef PSB_MPI_MOD
use mpi
@ -527,7 +522,6 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv

115
base/comm/psb_chalo.f90
Unescape Escape View File

@ -41,7 +41,6 @@
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -52,33 +51,32 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_chalo_vect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_chalo_vect
use psi_mod
implicit none
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_chalov'
info=psb_success_
name = 'psb_chalo_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
info = psb_err_internal_error_
goto 9999
end if
ctxt=desc_a%get_context()
@ -129,39 +127,11 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,czero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,czero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,cone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,cone,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -174,9 +144,6 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -196,7 +163,6 @@ end subroutine psb_chalo_vect
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -207,36 +173,34 @@ end subroutine psb_chalo_vect
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_chalo_multivect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_chalo_multivect
use psi_mod
implicit none
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_chalov'
info=psb_success_
name = 'psb_chalo_multivect'
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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -285,39 +249,11 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,czero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,czero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,cone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,cone,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -325,14 +261,11 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
end if
if (info /= psb_success_) then
ch_err='PSI_swapdata'
ch_err = 'PSI_swapdata'
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

4
base/comm/psb_chalo_a.f90
Unescape Escape View File

@ -29,7 +29,7 @@
! POSSIBILITY OF SUCH DAMAGE.
!
!
! File: psb_chalo.f90
! File: psb_chalo_a.f90
!
! Subroutine: psb_chalom
! This subroutine performs the exchange of the halo elements in a
@ -52,7 +52,7 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data)
subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_chalom
use psi_mod
implicit none

86
base/comm/psb_covrl.f90
Unescape Escape View File

@ -42,7 +42,6 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -63,7 +62,7 @@
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_covrl_vect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_covrl_vect
use psi_mod
implicit none
@ -71,27 +70,25 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_covrlv'
info=psb_success_
name = 'psb_covrl_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -137,41 +134,15 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,cone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,cone,x%v,desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -192,7 +163,6 @@ end subroutine psb_covrl_vect
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -213,29 +183,27 @@ end subroutine psb_covrl_vect
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_covrl_multivect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_covrl_multivect
use psi_mod
implicit none
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_spk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_covrlv'
info=psb_success_
name = 'psb_covrl_multivect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -289,32 +257,9 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,cone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,cone,x%v, desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@ -322,9 +267,6 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

2
base/comm/psb_covrl_a.f90
Unescape Escape View File

@ -30,7 +30,7 @@
!
!
!
! File: psb_covrl.f90
! File: psb_covrl_a.f90
!
! Subroutine: psb_covrlm
! This subroutine performs the exchange of the overlap elements in a

101
base/comm/psb_dhalo.f90
Unescape Escape View File

@ -41,7 +41,6 @@
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - real(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -52,7 +51,7 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_dhalo_vect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_dhalo_vect
use psi_mod
implicit none
@ -60,16 +59,14 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
integer(psb_ipk_), intent(in), optional :: mode,data
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode,data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
@ -129,38 +126,12 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(flag=imode, info=info, y=x%v, beta=dzero, desc_a=desc_a, &
& data=data_, work=iwork)
call psi_swapdata(imode,dzero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,done,x%v,desc_a,iwork,info)
call psi_swaptran(imode,done,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -168,14 +139,11 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
end if
if (info /= psb_success_) then
ch_err='PSI_swapdata'
ch_err = 'PSI_swapdata'
call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -195,7 +163,6 @@ end subroutine psb_dhalo_vect
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - real(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -206,36 +173,34 @@ end subroutine psb_dhalo_vect
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_dhalo_multivect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_dhalo_multivect
use psi_mod
implicit none
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: tran
integer(psb_ipk_), intent(in), optional :: mode,data
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dhalov'
info=psb_success_
name = 'psb_dhalo_multivect'
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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -284,38 +249,11 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(flag=imode, info=info, y=x%v, beta=dzero, desc_a=desc_a, data=data_, work=iwork)
call psi_swapdata(imode,dzero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,done,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,done,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -328,9 +266,6 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

2
base/comm/psb_dhalo_a.f90
Unescape Escape View File

@ -52,7 +52,7 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_dhalom
use psi_mod
implicit none

96
base/comm/psb_dovrl.f90
Unescape Escape View File

@ -42,7 +42,6 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - real(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -63,35 +62,33 @@
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_dovrl_vect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_dovrl_vect
use psi_mod
implicit none
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dovrlv'
info=psb_success_
name = 'psb_dovrl_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -137,41 +134,15 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(flag=mode_, beta=done, y=x%v, desc_a=desc_a, &
& data=psb_comm_ovr_, info=info, work=iwork)
call psi_swapdata(mode_, done, x%v, desc_a, info, data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -192,7 +163,6 @@ end subroutine psb_dovrl_vect
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - real(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -213,29 +183,27 @@ end subroutine psb_dovrl_vect
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_dovrl_multivect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_dovrl_multivect
use psi_mod
implicit none
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dovrlv'
info=psb_success_
name = 'psb_dovrl_multivect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -289,32 +257,9 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(flag=mode_, beta=done, y=x%v, desc_a=desc_a, &
& data=psb_comm_ovr_, info=info, work=iwork)
call psi_swapdata(mode_, done, x%v, desc_a, info, data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@ -322,9 +267,6 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

6
base/comm/psb_ehalo_a.f90
Unescape Escape View File

@ -52,7 +52,7 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data)
subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_ehalom
use psi_mod
implicit none
@ -174,7 +174,7 @@ subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data)
& desc_a,iwork,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,k,eone,xp,&
&desc_a,iwork,info)
& desc_a,iwork,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -254,7 +254,7 @@ end subroutine psb_ehalom
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data)
subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_ehalov
use psi_mod
implicit none

110
base/comm/psb_ihalo.f90
Unescape Escape View File

@ -41,7 +41,6 @@
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -52,36 +51,34 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_ihalo_vect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_ihalo_vect
use psi_mod
implicit none
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode,data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_ihalov'
info=psb_success_
name = 'psb_ihalo_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -129,39 +126,11 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,izero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,izero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,ione,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,ione,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -174,9 +143,6 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -196,7 +162,6 @@ end subroutine psb_ihalo_vect
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -207,36 +172,34 @@ end subroutine psb_ihalo_vect
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_ihalo_multivect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_ihalo_multivect
use psi_mod
implicit none
type(psb_i_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_i_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_ihalov'
info=psb_success_
name = 'psb_ihalo_multivect'
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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -285,39 +248,11 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,izero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,izero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,ione,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,ione,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -330,9 +265,6 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

99
base/comm/psb_iovrl.f90
Unescape Escape View File

@ -42,7 +42,6 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -63,35 +62,33 @@
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_iovrl_vect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_iovrl_vect
use psi_mod
implicit none
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_iovrlv'
info=psb_success_
name = 'psb_iovrl_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -137,41 +134,15 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,ione,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,ione,x%v,desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -192,7 +163,6 @@ end subroutine psb_iovrl_vect
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -213,35 +183,34 @@ end subroutine psb_iovrl_vect
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_iovrl_multivect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_iovrl_multivect
use psi_mod
implicit none
type(psb_i_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_ipk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_iovrlv'
info=psb_success_
name = 'psb_iovrl_multivect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
info = psb_err_internal_error_
goto 9999
end if
ctxt=desc_a%get_context()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -289,32 +258,9 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,ione,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,ione,x%v,desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@ -322,9 +268,6 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

119
base/comm/psb_lhalo.f90
Unescape Escape View File

@ -41,7 +41,6 @@
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -52,36 +51,35 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_lhalo_vect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_lhalo_vect
use psi_mod
implicit none
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_lhalov'
info=psb_success_
name = 'psb_lhalo_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
info = psb_err_internal_error_
goto 9999
end if
ctxt=desc_a%get_context()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -124,44 +122,17 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data)
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_ ; ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,lzero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,lzero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,lone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,lone,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -174,9 +145,6 @@ subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -196,7 +164,6 @@ end subroutine psb_lhalo_vect
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -207,36 +174,35 @@ end subroutine psb_lhalo_vect
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_lhalo_multivect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_lhalo_multivect
use psi_mod
implicit none
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_lhalov'
info=psb_success_
name = 'psb_lhalo_multivect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
info = psb_err_internal_error_
goto 9999
end if
ctxt=desc_a%get_context()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -285,39 +251,11 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,lzero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,lzero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,lone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,lone,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -330,9 +268,6 @@ subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

96
base/comm/psb_lovrl.f90
Unescape Escape View File

@ -42,7 +42,6 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -63,35 +62,33 @@
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_lovrl_vect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_lovrl_vect
use psi_mod
implicit none
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_lovrlv'
info=psb_success_
name = 'psb_lovrl_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -137,41 +134,15 @@ subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,lone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,lone,x%v,desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -192,7 +163,6 @@ end subroutine psb_lovrl_vect
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - integer(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -213,29 +183,27 @@ end subroutine psb_lovrl_vect
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_lovrl_multivect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_lovrl_multivect
use psi_mod
implicit none
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
integer(psb_lpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_lovrlv'
info=psb_success_
name = 'psb_lovrl_multivect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -289,32 +257,9 @@ subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,lone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,lone,x%v,desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@ -322,9 +267,6 @@ subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

111
base/comm/psb_shalo.f90
Unescape Escape View File

@ -41,7 +41,6 @@
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - real(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -52,36 +51,34 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_shalo_vect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_shalo_vect
use psi_mod
implicit none
type(psb_s_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_shalov'
info=psb_success_
name = 'psb_shalo_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -124,44 +121,17 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_ ; ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(flag=imode, beta=szero, y=x%v, desc_a=desc_a, &
& data=data_, info=info, work=iwork)
call psi_swapdata(imode, szero, x%v, desc_a, info, data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(flag=imode, beta=sone, y=x%v, desc_a=desc_a, &
& info=info, work=iwork)
call psi_swaptran(imode, sone, x%v, desc_a, info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -174,9 +144,6 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -196,7 +163,6 @@ end subroutine psb_shalo_vect
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - real(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -207,36 +173,34 @@ end subroutine psb_shalo_vect
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_shalo_multivect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_shalo_multivect
use psi_mod
implicit none
type(psb_s_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_s_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_shalov'
info=psb_success_
name = 'psb_shalo_multivect'
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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -285,37 +249,11 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(flag=imode, beta=szero, y=x%v, desc_a=desc_a, info=info, data=data_, work=iwork)
call psi_swapdata(imode, szero, x%v, desc_a, info, data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(flag=imode, beta=sone, y=x%v, desc_a=desc_a, info=info, work=iwork)
call psi_swaptran(imode, sone, x%v, desc_a, info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -328,9 +266,6 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

4
base/comm/psb_shalo_a.f90
Unescape Escape View File

@ -29,7 +29,7 @@
! POSSIBILITY OF SUCH DAMAGE.
!
!
! File: psb_shalo.f90
! File: psb_shalo_a.f90
!
! Subroutine: psb_shalom
! This subroutine performs the exchange of the halo elements in a
@ -52,7 +52,7 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data)
subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_shalom
use psi_mod
implicit none

95
base/comm/psb_sovrl.f90
Unescape Escape View File

@ -42,7 +42,6 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - real(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -63,35 +62,33 @@
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_sovrl_vect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_sovrl_vect
use psi_mod
implicit none
type(psb_s_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_s_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_sovrlv'
info=psb_success_
name = 'psb_sovrl_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -137,31 +134,9 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(flag=mode_, beta=sone, y=x%v, desc_a=desc_a, info=info, data=psb_comm_ovr_, work=iwork)
call psi_swapdata(mode_, sone, x%v, desc_a, info, data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@ -169,9 +144,6 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -191,7 +163,6 @@ end subroutine psb_sovrl_vect
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - real(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -212,35 +183,33 @@ end subroutine psb_sovrl_vect
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_sovrl_multivect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_sovrl_multivect
use psi_mod
implicit none
type(psb_s_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
real(psb_spk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_sovrlv'
info=psb_success_
name = 'psb_sovrl_multivect'
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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -288,32 +257,9 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,sone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_, sone, x%v, desc_a, info, data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@ -321,9 +267,6 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

110
base/comm/psb_zhalo.f90
Unescape Escape View File

@ -41,7 +41,6 @@
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -52,36 +51,34 @@
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_zhalo_vect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_zhalo_vect
use psi_mod
implicit none
type(psb_z_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_zhalov'
info=psb_success_
name = 'psb_zhalo_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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -129,39 +126,11 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,zzero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,zzero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,zone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,zone,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -174,9 +143,6 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -196,7 +162,6 @@ end subroutine psb_zhalo_vect
! info - integer. Return code
! jx - integer(optional). The starting column of the global matrix.
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). Work area.
! tran - character(optional). Transpose exchange.
! mode - integer(optional). Communication mode (see Swapdata)
! data - integer Which index list in desc_a should be used
@ -207,36 +172,34 @@ end subroutine psb_zhalo_vect
! psb_comm_mov_ use ovr_mst_idx
!
!
subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_zhalo_multivect(x,desc_a,info,tran,mode,data)
use psb_base_mod, psb_protect_name => psb_zhalo_multivect
use psi_mod
implicit none
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, iix, jjx, &
& nrow, ncol, lldx, imode, liwork,data_
& nrow, ncol, lldx, imode, data_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
character :: tran_
character(len=20) :: name, ch_err
logical :: aliw
name='psb_zhalov'
info=psb_success_
name = 'psb_zhalo_multivect'
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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -285,39 +248,11 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
liwork=nrow
if (present(work)) then
if(size(work) >= liwork) then
iwork => work
aliw=.false.
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
else
aliw=.true.
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! exchange halo elements
if(tran_ == 'N') then
call psi_swapdata(imode,zzero,x%v,&
& desc_a,iwork,info,data=data_)
call psi_swapdata(imode,zzero,x%v,desc_a,info,data=data_)
else if((tran_ == 'T').or.(tran_ == 'C')) then
call psi_swaptran(imode,zone,x%v,&
& desc_a,iwork,info)
call psi_swaptran(imode,zone,x%v,desc_a,info)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid tran')
@ -330,9 +265,6 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

96
base/comm/psb_zovrl.f90
Unescape Escape View File

@ -42,7 +42,6 @@
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -63,29 +62,27 @@
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_zovrl_vect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_zovrl_vect
use psi_mod
implicit none
type(psb_z_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_z_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_zovrlv'
info=psb_success_
name = 'psb_zovrl_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -137,41 +134,15 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,zone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,zone,x%v,desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return
@ -192,7 +163,6 @@ end subroutine psb_zovrl_vect
! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
@ -213,35 +183,33 @@ end subroutine psb_zovrl_vect
! - if (swap_recv): use psb_rcv (completing a
! previous call with swap_send)
!
subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_zovrl_multivect(x,desc_a,info,update,mode)
use psb_base_mod, psb_protect_name => psb_zovrl_multivect
use psi_mod
implicit none
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional, target, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
! locals
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me, err_act, k, iix, jjx, &
& nrow, ncol, ldx, liwork, data_, update_, mode_
& nrow, ncol, ldx, data_, update_, mode_
integer(psb_lpk_) :: m, n, ix, ijx
complex(psb_dpk_),pointer :: iwork(:)
logical :: do_swap
character(len=20) :: name, ch_err
logical :: aliw
name='psb_zovrlv'
info=psb_success_
name = 'psb_zovrl_multivect'
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()
ctxt = desc_a%get_context()
! check on blacs grid
call psb_info(ctxt, me, np)
@ -289,32 +257,9 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
! check for presence/size of a work area
liwork=ncol
if (present(work)) then
if(size(work) >= liwork) then
aliw=.false.
else
aliw=.true.
end if
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate')
goto 9999
end if
else
iwork => work
end if
! exchange overlap elements
if (do_swap) then
call psi_swapdata(mode_,zone,x%v,&
& desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(mode_,zone,x%v,desc_a,info,data=psb_comm_ovr_)
end if
if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info)
if (info /= psb_success_) then
@ -322,9 +267,6 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode)
goto 9999
end if
if (aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)
return

42
base/modules/comm/psb_c_comm_mod.f90
Unescape Escape View File

@ -37,52 +37,48 @@ module psb_c_comm_mod
use psb_c_multivect_mod, only : psb_c_multivect_type, psb_c_base_multivect_type
interface psb_ovrl
subroutine psb_covrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_covrl_vect(x,desc_a,info,update,mode)
import
implicit none
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_covrl_vect
subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_covrl_multivect(x,desc_a,info,update,mode)
import
implicit none
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_covrl_multivect
end interface psb_ovrl
interface psb_halo
subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_chalo_vect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_c_vect_type), intent(inout) :: x
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_chalo_vect
subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_chalo_multivect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_c_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_chalo_multivect
end interface psb_halo
interface psb_scatter
subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold)
subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold)
import
implicit none
type(psb_c_vect_type), intent(inout) :: locx

6
base/modules/comm/psb_c_linmap_mod.f90
Unescape Escape View File

@ -73,7 +73,7 @@ module psb_c_linmap_mod
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine psb_c_map_U2V_a
subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_c_vect_mod, only : psb_c_vect_type
import :: psb_ipk_, psb_spk_, psb_clinmap_type
implicit none
@ -81,7 +81,6 @@ module psb_c_linmap_mod
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_c_map_U2V_v
end interface
@ -97,7 +96,7 @@ module psb_c_linmap_mod
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine psb_c_map_V2U_a
subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_c_vect_mod, only : psb_c_vect_type
import :: psb_ipk_, psb_spk_, psb_clinmap_type
implicit none
@ -105,7 +104,6 @@ module psb_c_linmap_mod
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_c_map_V2U_v
end interface

28
base/modules/comm/psb_d_comm_a_mod.f90
Unescape Escape View File

@ -36,11 +36,11 @@ module psb_d_comm_a_mod
subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
import
implicit none
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
end subroutine psb_dovrlm
subroutine psb_dovrlv(x,desc_a,info,work,update,mode)
import
@ -57,22 +57,22 @@ module psb_d_comm_a_mod
subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data)
import
implicit none
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
end subroutine psb_dhalom
subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data)
import
implicit none
real(psb_dpk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_dhalov
end interface psb_halo

44
base/modules/comm/psb_d_comm_mod.f90
Unescape Escape View File

@ -37,46 +37,42 @@ module psb_d_comm_mod
use psb_d_multivect_mod, only : psb_d_multivect_type, psb_d_base_multivect_type
interface psb_ovrl
subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_dovrl_vect(x,desc_a,info,update,mode)
import
implicit none
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_dovrl_vect
subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_dovrl_multivect(x,desc_a,info,update,mode)
import
implicit none
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_dovrl_multivect
end interface psb_ovrl
interface psb_halo
subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_dhalo_vect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_d_vect_type), intent(inout) :: x
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: tran
integer(psb_ipk_), intent(in), optional :: mode,data
end subroutine psb_dhalo_vect
subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_dhalo_multivect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_d_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: tran
integer(psb_ipk_), intent(in), optional :: mode,data
end subroutine psb_dhalo_multivect
end interface psb_halo

6
base/modules/comm/psb_d_linmap_mod.f90
Unescape Escape View File

@ -73,7 +73,7 @@ module psb_d_linmap_mod
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine psb_d_map_U2V_a
subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_d_vect_mod, only : psb_d_vect_type
import :: psb_ipk_, psb_dpk_, psb_dlinmap_type
implicit none
@ -81,7 +81,6 @@ module psb_d_linmap_mod
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_d_map_U2V_v
end interface
@ -97,7 +96,7 @@ module psb_d_linmap_mod
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine psb_d_map_V2U_a
subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_d_vect_mod, only : psb_d_vect_type
import :: psb_ipk_, psb_dpk_, psb_dlinmap_type
implicit none
@ -105,7 +104,6 @@ module psb_d_linmap_mod
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_d_map_V2U_v
end interface

40
base/modules/comm/psb_i_comm_mod.f90
Unescape Escape View File

@ -36,46 +36,42 @@ module psb_i_comm_mod
use psb_i_multivect_mod, only : psb_i_multivect_type, psb_i_base_multivect_type
interface psb_ovrl
subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_iovrl_vect(x,desc_a,info,update,mode)
import
implicit none
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_iovrl_vect
subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_iovrl_multivect(x,desc_a,info,update,mode)
import
implicit none
type(psb_i_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_i_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_iovrl_multivect
end interface psb_ovrl
interface psb_halo
subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_ihalo_vect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_i_vect_type), intent(inout) :: x
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_ihalo_vect
subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_ihalo_multivect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_i_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_i_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_ihalo_multivect
end interface psb_halo

40
base/modules/comm/psb_l_comm_mod.f90
Unescape Escape View File

@ -36,46 +36,42 @@ module psb_l_comm_mod
use psb_l_multivect_mod, only : psb_l_multivect_type, psb_l_base_multivect_type
interface psb_ovrl
subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_lovrl_vect(x,desc_a,info,update,mode)
import
implicit none
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_lovrl_vect
subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_lovrl_multivect(x,desc_a,info,update,mode)
import
implicit none
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_lovrl_multivect
end interface psb_ovrl
interface psb_halo
subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_lhalo_vect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_l_vect_type), intent(inout) :: x
type(psb_l_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_lhalo_vect
subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_lhalo_multivect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_l_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_lhalo_multivect
end interface psb_halo

40
base/modules/comm/psb_s_comm_mod.f90
Unescape Escape View File

@ -37,46 +37,42 @@ module psb_s_comm_mod
use psb_s_multivect_mod, only : psb_s_multivect_type, psb_s_base_multivect_type
interface psb_ovrl
subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_sovrl_vect(x,desc_a,info,update,mode)
import
implicit none
type(psb_s_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_sovrl_vect
subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_sovrl_multivect(x,desc_a,info,update,mode)
import
implicit none
type(psb_s_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_s_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_sovrl_multivect
end interface psb_ovrl
interface psb_halo
subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_shalo_vect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_s_vect_type), intent(inout) :: x
type(psb_s_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_shalo_vect
subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_shalo_multivect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_s_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_s_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_shalo_multivect
end interface psb_halo

6
base/modules/comm/psb_s_linmap_mod.f90
Unescape Escape View File

@ -73,7 +73,7 @@ module psb_s_linmap_mod
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine psb_s_map_U2V_a
subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_s_vect_mod, only : psb_s_vect_type
import :: psb_ipk_, psb_spk_, psb_slinmap_type
implicit none
@ -81,7 +81,6 @@ module psb_s_linmap_mod
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_s_map_U2V_v
end interface
@ -97,7 +96,7 @@ module psb_s_linmap_mod
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine psb_s_map_V2U_a
subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_s_vect_mod, only : psb_s_vect_type
import :: psb_ipk_, psb_spk_, psb_slinmap_type
implicit none
@ -105,7 +104,6 @@ module psb_s_linmap_mod
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_s_map_V2U_v
end interface

40
base/modules/comm/psb_z_comm_mod.f90
Unescape Escape View File

@ -37,46 +37,42 @@ module psb_z_comm_mod
use psb_z_multivect_mod, only : psb_z_multivect_type, psb_z_base_multivect_type
interface psb_ovrl
subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode)
subroutine psb_zovrl_vect(x,desc_a,info,update,mode)
import
implicit none
type(psb_z_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_zovrl_vect
subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode)
subroutine psb_zovrl_multivect(x,desc_a,info,update,mode)
import
implicit none
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_zovrl_multivect
end interface psb_ovrl
interface psb_halo
subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data)
subroutine psb_zhalo_vect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_z_vect_type), intent(inout) :: x
type(psb_z_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_zhalo_vect
subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data)
subroutine psb_zhalo_multivect(x,desc_a,info,tran,mode,data)
import
implicit none
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
type(psb_z_multivect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_zhalo_multivect
end interface psb_halo

6
base/modules/comm/psb_z_linmap_mod.f90
Unescape Escape View File

@ -73,7 +73,7 @@ module psb_z_linmap_mod
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine psb_z_map_U2V_a
subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_z_vect_mod, only : psb_z_vect_type
import :: psb_ipk_, psb_dpk_, psb_zlinmap_type
implicit none
@ -81,7 +81,6 @@ module psb_z_linmap_mod
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_z_map_U2V_v
end interface
@ -97,7 +96,7 @@ module psb_z_linmap_mod
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine psb_z_map_V2U_a
subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_z_vect_mod, only : psb_z_vect_type
import :: psb_ipk_, psb_dpk_, psb_zlinmap_type
implicit none
@ -105,7 +104,6 @@ module psb_z_linmap_mod
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
end subroutine psb_z_map_V2U_v
end interface

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

@ -36,43 +36,39 @@ module psi_c_comm_v_mod
use psb_c_base_multivect_mod, only : psb_c_base_multivect_type
interface psi_swapdata
module subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_cswapdata_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdata_vect
module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswapdata_multivect
module subroutine psi_cswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_cswap_vidx_vect
module subroutine psi_cswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_cswap_vidx_multivect
@ -80,43 +76,39 @@ module psi_c_comm_v_mod
interface psi_swaptran
module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptran_vect
module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_cswaptran_multivect
module subroutine psi_ctran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ctran_vidx_vect
module subroutine psi_ctran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_multivect_type) :: y
complex(psb_spk_) :: beta
complex(psb_spk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ctran_vidx_multivect

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

@ -35,40 +35,44 @@ module psi_d_comm_a_mod
interface psi_swapdata
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_mpk_), intent(in) :: n
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:,:)
type(psb_desc_type), target :: desc_a
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdatam
module subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:)
type(psb_desc_type), target :: desc_a
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdatav
module subroutine psi_dswapidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_mpk_), intent(in) :: n
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:,:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxm
module subroutine psi_dswapidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dswapidxv
end interface psi_swapdata
@ -77,38 +81,42 @@ module psi_d_comm_a_mod
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
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:,:)
type(psb_desc_type), target :: desc_a
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), optional :: data !! TODO: Is this used in the code? If not, remove it.
end subroutine psi_dswaptranm
module subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:)
type(psb_desc_type), target :: desc_a
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
integer(psb_ipk_), optional :: data !! TODO: Is this used in the code? If not, remove it.
end subroutine psi_dswaptranv
module subroutine psi_dtranidxm(ctxt,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(in) :: n
integer(psb_ipk_), intent(in) :: flag
integer(psb_mpk_), intent(in) :: n
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:,:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:,:), beta
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxm
module subroutine psi_dtranidxv(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_),intent(in) :: beta
real(psb_dpk_),intent(inout) :: y(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_) :: y(:), beta
real(psb_dpk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_dtranidxv
end interface psi_swaptran

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

@ -40,23 +40,21 @@ module psi_d_comm_v_mod
! Wrapper that calls different communications schemes depending on
! flag variable using communication buff obtained from desc_a%get_list_p
! ---------------------------------------------------------------
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_dpk_), optional, target :: work(:)
module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_vect_type), intent(inout) :: y
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_vect
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_dpk_), optional, target :: work(:)
module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_multivect_type), intent(inout) :: y
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
end subroutine psi_dswapdata_multivect
end interface psi_swapdata
@ -65,23 +63,21 @@ module psi_d_comm_v_mod
! ---------------------------------------------------------------
! Upper call in order to populate idx using desc_a%get_list_p
! ---------------------------------------------------------------
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
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
module subroutine psi_dswaptran_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_vect_type), intent(inout) :: y
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptran_vect
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
real(psb_dpk_) :: beta
real(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
module subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_dpk_), intent(in) :: beta
class(psb_d_base_multivect_type), intent(inout) :: y
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
end subroutine psi_dswaptran_multivect
! ---------------------------------------------------------------
@ -91,24 +87,22 @@ module psi_d_comm_v_mod
! flag variable
! ---------------------------------------------------------------
module subroutine psi_dtran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_d_base_vect_type), intent(inout) :: y
real(psb_dpk_), intent(in) :: beta
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dtran_vidx_vect
module subroutine psi_dtran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_multivect_type) :: y
real(psb_dpk_) :: beta
real(psb_dpk_), target :: work(:)
class(psb_d_base_multivect_type), intent(inout) :: y
real(psb_dpk_), intent(in) :: beta
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_dtran_vidx_multivect

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

@ -37,43 +37,39 @@ module psi_i_comm_v_mod
use psb_i_base_multivect_mod, only : psb_i_base_multivect_type
interface psi_swapdata
module subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_iswapdata_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswapdata_vect
module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswapdata_multivect
module subroutine psi_iswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_iswap_vidx_vect
module subroutine psi_iswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_iswap_vidx_multivect
@ -81,43 +77,39 @@ module psi_i_comm_v_mod
interface psi_swaptran
module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswaptran_vect
module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_iswaptran_multivect
module subroutine psi_itran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_itran_vidx_vect
module subroutine psi_itran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_multivect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_itran_vidx_multivect

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

@ -38,43 +38,39 @@ module psi_l_comm_v_mod
use psb_l_base_multivect_mod, only : psb_l_base_multivect_type
interface psi_swapdata
module subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_lswapdata_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswapdata_vect
module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswapdata_multivect
module subroutine psi_lswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_lswap_vidx_vect
module subroutine psi_lswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_lswap_vidx_multivect
@ -82,43 +78,39 @@ module psi_l_comm_v_mod
interface psi_swaptran
module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswaptran_vect
module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_lswaptran_multivect
module subroutine psi_ltran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_vect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ltran_vidx_vect
module subroutine psi_ltran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_l_base_multivect_type) :: y
integer(psb_lpk_) :: beta
integer(psb_lpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ltran_vidx_multivect

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

@ -36,68 +36,62 @@ module psi_s_comm_v_mod
use psb_s_base_multivect_mod, only : psb_s_base_multivect_type
interface psi_swapdata
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_spk_), intent(in) :: beta
class(psb_s_base_vect_type), intent(inout) :: y
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdata_vect
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
real(psb_spk_), intent(in) :: beta
class(psb_s_base_multivect_type), intent(inout) :: y
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
end subroutine psi_sswapdata_multivect
end interface psi_swapdata
interface psi_swaptran
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(inout) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptran_vect
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data,work)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
real(psb_spk_),target, optional :: work(:)
module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
class(psb_s_base_multivect_type), intent(inout) :: y
real(psb_spk_), intent(in) :: beta
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional :: data
end subroutine psi_sswaptran_multivect
module subroutine psi_stran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_spk_), intent(in) :: beta
class(psb_s_base_vect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
integer(psb_ipk_), intent(out) :: info
end subroutine psi_stran_vidx_vect
module subroutine psi_stran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_multivect_type) :: y
real(psb_spk_), intent(in) :: beta
real(psb_spk_), target, optional :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
real(psb_spk_), intent(in) :: beta
class(psb_s_base_multivect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
integer(psb_ipk_), intent(out) :: info
end subroutine psi_stran_vidx_multivect
end interface psi_swaptran

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

@ -36,43 +36,39 @@ module psi_z_comm_v_mod
use psb_z_base_multivect_mod, only : psb_z_base_multivect_type
interface psi_swapdata
module subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_zswapdata_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdata_vect
module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswapdata_multivect
module subroutine psi_zswap_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_zswap_vidx_vect
module subroutine psi_zswap_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_zswap_vidx_multivect
@ -80,43 +76,39 @@ module psi_z_comm_v_mod
interface psi_swaptran
module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptran_vect
module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data)
module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,info,data)
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_),target :: work(:)
type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data
end subroutine psi_zswaptran_multivect
module subroutine psi_ztran_vidx_vect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ztran_vidx_vect
module subroutine psi_ztran_vidx_multivect(ctxt,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
& totxch,totsnd,totrcv,info)
type(psb_ctxt_type), intent(in) :: ctxt
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_multivect_type) :: y
complex(psb_dpk_) :: beta
complex(psb_dpk_), target :: work(:)
class(psb_i_base_vect_type), intent(inout) :: idx
integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv
end subroutine psi_ztran_vidx_multivect

22
base/modules/psblas/psb_c_psblas_mod.F90
Unescape Escape View File

@ -421,18 +421,17 @@ module psb_c_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cspmv
subroutine psb_cspmv_vect(alpha, a, x, beta, y,&
& desc_a, info, trans, work,doswap)
& desc_a, info, trans,doswap)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_c_vect_type, psb_cspmat_type
type(psb_cspmat_type), intent(in) :: a
type(psb_c_vect_type), intent(inout) :: x
type(psb_c_vect_type), intent(inout) :: y
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans
complex(psb_spk_), optional, intent(inout),target :: work(:)
logical, optional, intent(in) :: doswap
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in) :: a
type(psb_c_vect_type), intent(inout) :: x
type(psb_c_vect_type), intent(inout) :: y
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans
logical, optional, intent(in) :: doswap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cspmv_vect
end interface
@ -472,7 +471,7 @@ module psb_c_psblas_mod
end subroutine psb_cspsv
subroutine psb_cspsv_vect(alpha, t, x, beta, y,&
& desc_a, info, trans, scale, choice,&
& diag, work)
& diag)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_c_vect_type, psb_cspmat_type
type(psb_cspmat_type), intent(inout) :: t
@ -483,7 +482,6 @@ module psb_c_psblas_mod
character, optional, intent(in) :: trans, scale
integer(psb_ipk_), optional, intent(in) :: choice
type(psb_c_vect_type), intent(inout), optional :: diag
complex(psb_spk_), optional, intent(inout), target :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_cspsv_vect
end interface

6
base/modules/psblas/psb_d_psblas_mod.F90
Unescape Escape View File

@ -432,7 +432,7 @@ module psb_d_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_dspmv
subroutine psb_dspmv_vect(alpha, a, x, beta, y,&
& desc_a, info, trans, work,doswap)
& desc_a, info, trans,doswap)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_d_vect_type, psb_dspmat_type
type(psb_dspmat_type), intent(in) :: a
@ -441,7 +441,6 @@ module psb_d_psblas_mod
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans
real(psb_dpk_), optional, intent(inout),target :: work(:)
logical, optional, intent(in) :: doswap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_dspmv_vect
@ -483,7 +482,7 @@ module psb_d_psblas_mod
end subroutine psb_dspsv
subroutine psb_dspsv_vect(alpha, t, x, beta, y,&
& desc_a, info, trans, scale, choice,&
& diag, work)
& diag)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_d_vect_type, psb_dspmat_type
type(psb_dspmat_type), intent(inout) :: t
@ -494,7 +493,6 @@ module psb_d_psblas_mod
character, optional, intent(in) :: trans, scale
integer(psb_ipk_), optional, intent(in) :: choice
type(psb_d_vect_type), intent(inout), optional :: diag
real(psb_dpk_), optional, intent(inout), target :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_dspsv_vect
end interface

6
base/modules/psblas/psb_s_psblas_mod.F90
Unescape Escape View File

@ -432,7 +432,7 @@ module psb_s_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_sspmv
subroutine psb_sspmv_vect(alpha, a, x, beta, y,&
& desc_a, info, trans, work,doswap)
& desc_a, info, trans,doswap)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_s_vect_type, psb_sspmat_type
type(psb_sspmat_type), intent(in) :: a
@ -441,7 +441,6 @@ module psb_s_psblas_mod
real(psb_spk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans
real(psb_spk_), optional, intent(inout),target :: work(:)
logical, optional, intent(in) :: doswap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_sspmv_vect
@ -483,7 +482,7 @@ module psb_s_psblas_mod
end subroutine psb_sspsv
subroutine psb_sspsv_vect(alpha, t, x, beta, y,&
& desc_a, info, trans, scale, choice,&
& diag, work)
& diag)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_s_vect_type, psb_sspmat_type
type(psb_sspmat_type), intent(inout) :: t
@ -494,7 +493,6 @@ module psb_s_psblas_mod
character, optional, intent(in) :: trans, scale
integer(psb_ipk_), optional, intent(in) :: choice
type(psb_s_vect_type), intent(inout), optional :: diag
real(psb_spk_), optional, intent(inout), target :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_sspsv_vect
end interface

6
base/modules/psblas/psb_z_psblas_mod.F90
Unescape Escape View File

@ -421,7 +421,7 @@ module psb_z_psblas_mod
integer(psb_ipk_), intent(out) :: info
end subroutine psb_zspmv
subroutine psb_zspmv_vect(alpha, a, x, beta, y,&
& desc_a, info, trans, work,doswap)
& desc_a, info, trans,doswap)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_z_vect_type, psb_zspmat_type
type(psb_zspmat_type), intent(in) :: a
@ -430,7 +430,6 @@ module psb_z_psblas_mod
complex(psb_dpk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans
complex(psb_dpk_), optional, intent(inout),target :: work(:)
logical, optional, intent(in) :: doswap
integer(psb_ipk_), intent(out) :: info
end subroutine psb_zspmv_vect
@ -472,7 +471,7 @@ module psb_z_psblas_mod
end subroutine psb_zspsv
subroutine psb_zspsv_vect(alpha, t, x, beta, y,&
& desc_a, info, trans, scale, choice,&
& diag, work)
& diag)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_z_vect_type, psb_zspmat_type
type(psb_zspmat_type), intent(inout) :: t
@ -483,7 +482,6 @@ module psb_z_psblas_mod
character, optional, intent(in) :: trans, scale
integer(psb_ipk_), optional, intent(in) :: choice
type(psb_z_vect_type), intent(inout), optional :: diag
complex(psb_dpk_), optional, intent(inout), target :: work(:)
integer(psb_ipk_), intent(out) :: info
end subroutine psb_zspsv_vect
end interface

79
base/psblas/psb_cspmm.f90
Unescape Escape View File

@ -51,11 +51,10 @@
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! trans - character(optional). Whether A or A'. Default: 'N'
! work(:) - complex,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, work, doswap)
subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, doswap)
use psb_base_mod, psb_protect_name => psb_cspmv_vect
use psi_mod
implicit none
@ -66,7 +65,6 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans
logical, intent(in), optional :: doswap
@ -74,10 +72,10 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me,&
& err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, &
& liwork, iiy, jjy, ib, ip, idx
& iiy, jjy, ib, ip, idx
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja
integer(psb_ipk_), parameter :: nb=4
complex(psb_spk_), pointer :: iwork(:), xp(:), yp(:)
complex(psb_spk_), pointer :: xp(:), yp(:)
complex(psb_spk_), allocatable :: xvsave(:)
character :: trans_
character(len=20) :: name, ch_err
@ -87,8 +85,8 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_cspmv'
info=psb_success_
name = 'psb_cspmv_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -157,38 +155,12 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
@ -202,14 +174,12 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(psb_swap_send_,czero,x%v,desc_a,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(psb_swap_recv_,czero,x%v,desc_a,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,cone,y%v,info)
@ -224,8 +194,7 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),czero,x%v,desc_a,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
@ -268,10 +237,8 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if (doswap_) then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& cone,y%v,desc_a,iwork,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& cone,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),cone,y%v,desc_a,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),cone,y%v,desc_a,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
@ -285,18 +252,6 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
nullify(iwork)
call psb_erractionrestore(err_act)
if (debug_level >= psb_debug_comp_) then
call psb_barrier(ctxt)
@ -340,7 +295,7 @@ end subroutine psb_cspmv_vect
! work(:) - complex,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
& trans, k, jx, jy, work, doswap)
use psb_base_mod, psb_protect_name => psb_cspmm
use psi_mod
@ -371,8 +326,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,&
logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit
name='psb_cspmm'
info=psb_success_
name = 'psb_cspmm'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -689,7 +644,7 @@ end subroutine psb_cspmm
! work(:) - complex,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,&
& trans, work, doswap)
use psb_base_mod, psb_protect_name => psb_cspmv
use psi_mod

60
base/psblas/psb_cspsm.f90
Unescape Escape View File

@ -64,10 +64,9 @@
! the diagonal matrix D.
! choice - integer(optional). The kind of update to perform on overlap elements.
! d(:) - complex, optional Matrix for diagonal scaling.
! work(:) - complex, optional Working area.
!
subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag, work)
subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag)
use psb_base_mod, psb_protect_name => psb_cspsv_vect
use psi_mod
implicit none
@ -79,7 +78,6 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
type(psb_c_vect_type), intent(inout), optional :: diag
complex(psb_spk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans, scale
integer(psb_ipk_), intent(in), optional :: choice
@ -88,23 +86,23 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_) :: np, me, &
& err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,&
& ix, iy, ik, jx, jy, i, lld,&
& m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm
& m, nrow, ncol, iiy, jjy, idx, ndm
character :: lscale
integer(psb_ipk_), parameter :: nb=4
complex(psb_spk_),pointer :: iwork(:), xp(:), yp(:)
complex(psb_spk_),pointer :: xp(:), yp(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_cspsv_vect'
info=psb_success_
name = 'psb_cspsv_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()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
@ -159,40 +157,12 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
iwork(1)=0.d0
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
@ -201,16 +171,14 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='dcssm'
ch_err = 'dcssm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
! update overlap elements
if (choice_ > 0) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& cone,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),cone,y%v,desc_a,info,data=psb_comm_ovr_)
if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info)
if (info /= psb_success_) then
@ -219,8 +187,6 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
end if
if (aliw) deallocate(iwork)
call psb_erractionrestore(err_act)
return
@ -271,7 +237,7 @@ end subroutine psb_cspsv_vect
! jy - integer(optional). The column offset for ( Y ). Default: 1
! work(:) - complex, optional Working area.
!
subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag, k, jx, jy, work)
use psb_base_mod, psb_protect_name => psb_cspsm
use psi_mod
@ -517,7 +483,7 @@ end subroutine psb_cspsm
! d(:) - complex, optional Matrix for diagonal scaling.
! work(:) - complex, optional Working area.
!
subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag, work)
use psb_base_mod, psb_protect_name => psb_cspsv
use psi_mod

112
base/psblas/psb_dspmm.f90
Unescape Escape View File

@ -51,11 +51,10 @@
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! trans - character(optional). Whether A or A'. Default: 'N'
! work(:) - real,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, work, doswap)
subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, doswap)
use psb_base_mod, psb_protect_name => psb_dspmv_vect
use psi_mod
implicit none
@ -66,7 +65,6 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans
logical, intent(in), optional :: doswap
@ -74,10 +72,10 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me,&
& err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, &
& liwork, iiy, jjy, ib, ip, idx
& iiy, jjy, ib, ip, idx
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja
integer(psb_ipk_), parameter :: nb=4
real(psb_dpk_), pointer :: iwork(:), xp(:), yp(:)
real(psb_dpk_), pointer :: xp(:), yp(:)
real(psb_dpk_), allocatable :: xvsave(:)
character :: trans_
character(len=20) :: name, ch_err
@ -87,8 +85,8 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_dspmv'
info=psb_success_
name = 'psb_dspmv_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -96,7 +94,7 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt=desc_a%get_context()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
@ -157,38 +155,12 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
info = psb_err_from_subroutine_
ch_err='reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
@ -202,14 +174,12 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(flag=psb_swap_send_, beta=dzero, y=x%v, desc_a=desc_a, &
& data=psb_comm_halo_, info=info, work=iwork)
if (doswap_) call psi_swapdata(psb_swap_send_, dzero, x%v, desc_a, info, data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(flag=psb_swap_recv_, beta=dzero, y=x%v, desc_a=desc_a, &
& data=psb_comm_halo_, info=info, work=iwork)
if (doswap_) call psi_swapdata(psb_swap_recv_, dzero, x%v, desc_a, info, data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,done,y%v,info)
@ -224,8 +194,7 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=dzero, y=x%v, desc_a=desc_a, &
& data=psb_comm_halo_, info=info, work=iwork)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_), dzero, x%v, desc_a, info, data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
@ -267,10 +236,11 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
goto 9999
end if
if (doswap_) then
call psi_swaptran(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, y=y%v, desc_a=desc_a, info=info, work=iwork)
if (info == psb_success_) call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, y=y%v, desc_a=desc_a, &
& data=psb_comm_ovr_, info=info, work=iwork)
if (doswap_) then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_), done, y%v, desc_a, info)
if (info == psb_success_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_), done, y%v, desc_a, info, data=psb_comm_ovr_)
end if
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
@ -284,18 +254,6 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
nullify(iwork)
call psb_erractionrestore(err_act)
if (debug_level >= psb_debug_comp_) then
call psb_barrier(ctxt)
@ -339,7 +297,7 @@ end subroutine psb_dspmv_vect
! work(:) - real,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
& trans, k, jx, jy, work, doswap)
use psb_base_mod, psb_protect_name => psb_dspmm
use psi_mod
@ -370,8 +328,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit
name='psb_dspmm'
info=psb_success_
name = 'psb_dspmm'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -506,9 +464,9 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
if (doswap_.and.(np>1)) then
ib1=min(nb,lik)
xp => x(iix:lldx,jjx:jjx+ib1-1)
if (doswap_)&
& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ib1,dzero,xp,desc_a,iwork,info)
if (doswap_) &
& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ib1,dzero,xp,desc_a,iwork,info)
blk: do i=1, lik, nb
@ -594,18 +552,18 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info)
if (doswap_) then
call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=dzero, &
& y=x(:,1:lik), desc_a=desc_a, data=psb_comm_halo_, info=info, work=iwork)
end if
call psi_swaptran(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, &
& y=y(:,1:ik), desc_a=desc_a, info=info, work=iwork)
if (info == psb_success_) then
call psi_swapdata(flag=ior(psb_swap_send_,psb_swap_recv_), beta=done, &
& y=y(:,1:ik), desc_a=desc_a, data=psb_comm_ovr_, info=info, work=iwork)
end if
if (doswap_)then
ik = lik ! This should not be an issue, we are expecting the values
! to be small, within PSB_IPK
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& ik,done,y(:,1:ik),desc_a,iwork,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ik,done,y(:,1:ik),desc_a,iwork,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
@ -691,7 +649,7 @@ end subroutine psb_dspmm
! work(:) - real,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
& trans, work, doswap)
use psb_base_mod, psb_protect_name => psb_dspmv
use psi_mod
@ -721,8 +679,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit
name='psb_dspmv'
info=psb_success_
name = 'psb_dspmv'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999

55
base/psblas/psb_dspsm.f90
Unescape Escape View File

@ -64,10 +64,9 @@
! the diagonal matrix D.
! choice - integer(optional). The kind of update to perform on overlap elements.
! d(:) - real, optional Matrix for diagonal scaling.
! work(:) - real, optional Working area.
!
subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag, work)
subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag)
use psb_base_mod, psb_protect_name => psb_dspsv_vect
use psi_mod
implicit none
@ -79,7 +78,6 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
type(psb_d_vect_type), intent(inout), optional :: diag
real(psb_dpk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans, scale
integer(psb_ipk_), intent(in), optional :: choice
@ -88,23 +86,23 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_) :: np, me, &
& err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,&
& ix, iy, ik, jx, jy, i, lld,&
& m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm
& m, nrow, ncol, iiy, jjy, idx, ndm
character :: lscale
integer(psb_ipk_), parameter :: nb=4
real(psb_dpk_),pointer :: iwork(:), xp(:), yp(:)
real(psb_dpk_),pointer :: xp(:), yp(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspsv_vect'
info=psb_success_
name = 'psb_dspsv_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()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
@ -159,40 +157,12 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
iwork(1)=0.d0
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
@ -201,15 +171,14 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='dcssm'
ch_err = 'dcssm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
! update overlap elements
if (choice_ > 0) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& done,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),done,y%v,desc_a,info,data=psb_comm_ovr_)
if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info)
@ -219,8 +188,6 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
end if
if (aliw) deallocate(iwork)
call psb_erractionrestore(err_act)
return

71
base/psblas/psb_sspmm.f90
Unescape Escape View File

@ -51,11 +51,10 @@
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! trans - character(optional). Whether A or A'. Default: 'N'
! work(:) - real,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, work, doswap)
subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, doswap)
use psb_base_mod, psb_protect_name => psb_sspmv_vect
use psi_mod
implicit none
@ -66,7 +65,6 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans
logical, intent(in), optional :: doswap
@ -77,7 +75,7 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& liwork, iiy, jjy, ib, ip, idx
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja
integer(psb_ipk_), parameter :: nb=4
real(psb_spk_), pointer :: iwork(:), xp(:), yp(:)
real(psb_spk_), pointer :: xp(:), yp(:)
real(psb_spk_), allocatable :: xvsave(:)
character :: trans_
character(len=20) :: name, ch_err
@ -87,8 +85,8 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_sspmv'
info=psb_success_
name = 'psb_sspmv_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -96,7 +94,7 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt=desc_a%get_context()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
@ -157,38 +155,12 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
@ -202,14 +174,12 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(psb_swap_send_,szero,x%v,desc_a,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(psb_swap_recv_,szero,x%v,desc_a,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,sone,y%v,info)
@ -224,8 +194,7 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),szero,x%v,desc_a,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
@ -268,10 +237,8 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if (doswap_) then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& sone,y%v,desc_a,iwork,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& sone,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),sone,y%v,desc_a,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),sone,y%v,desc_a,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
@ -285,18 +252,6 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
nullify(iwork)
call psb_erractionrestore(err_act)
if (debug_level >= psb_debug_comp_) then
call psb_barrier(ctxt)

51
base/psblas/psb_sspsm.f90
Unescape Escape View File

@ -64,10 +64,9 @@
! the diagonal matrix D.
! choice - integer(optional). The kind of update to perform on overlap elements.
! d(:) - real, optional Matrix for diagonal scaling.
! work(:) - real, optional Working area.
!
subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag, work)
subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag)
use psb_base_mod, psb_protect_name => psb_sspsv_vect
use psi_mod
implicit none
@ -79,7 +78,6 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
type(psb_s_vect_type), intent(inout), optional :: diag
real(psb_spk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans, scale
integer(psb_ipk_), intent(in), optional :: choice
@ -88,23 +86,23 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_) :: np, me, &
& err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,&
& ix, iy, ik, jx, jy, i, lld,&
& m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm
& m, nrow, ncol, iiy, jjy, idx, ndm
character :: lscale
integer(psb_ipk_), parameter :: nb=4
real(psb_spk_),pointer :: iwork(:), xp(:), yp(:)
real(psb_spk_),pointer :: xp(:), yp(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_sspsv_vect'
info=psb_success_
name = 'psb_sspsv_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()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
@ -165,34 +163,6 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
iwork(1)=0.d0
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
@ -208,8 +178,7 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
! update overlap elements
if (choice_ > 0) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& sone,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),sone,y%v,desc_a,info,data=psb_comm_ovr_)
if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info)
@ -219,8 +188,6 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
end if
if (aliw) deallocate(iwork)
call psb_erractionrestore(err_act)
return
@ -271,7 +238,7 @@ end subroutine psb_sspsv_vect
! jy - integer(optional). The column offset for ( Y ). Default: 1
! work(:) - real, optional Working area.
!
subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag, k, jx, jy, work)
use psb_base_mod, psb_protect_name => psb_sspsm
use psi_mod

73
base/psblas/psb_zspmm.f90
Unescape Escape View File

@ -51,11 +51,10 @@
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! trans - character(optional). Whether A or A'. Default: 'N'
! work(:) - complex,(optional). Working area.
! doswap - logical(optional). Whether to performe halo updates.
!
subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, work, doswap)
subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, doswap)
use psb_base_mod, psb_protect_name => psb_zspmv_vect
use psi_mod
implicit none
@ -66,7 +65,6 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans
logical, intent(in), optional :: doswap
@ -77,7 +75,7 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
& liwork, iiy, jjy, ib, ip, idx
integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja
integer(psb_ipk_), parameter :: nb=4
complex(psb_dpk_), pointer :: iwork(:), xp(:), yp(:)
complex(psb_dpk_), pointer :: xp(:), yp(:)
complex(psb_dpk_), allocatable :: xvsave(:)
character :: trans_
character(len=20) :: name, ch_err
@ -87,8 +85,8 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_zspmv'
info=psb_success_
name = 'psb_zspmv_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
@ -96,7 +94,7 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ctxt=desc_a%get_context()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
info = psb_err_context_error_
@ -157,38 +155,12 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
@ -202,14 +174,12 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
!if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(psb_swap_send_,zzero,x%v,desc_a,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (doswap_) call psi_swapdata(psb_swap_recv_,zzero,x%v,desc_a,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,zone,y%v,info)
@ -224,8 +194,7 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),zzero,x%v,desc_a,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
@ -262,16 +231,14 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (info == psb_success_) call psi_ovrl_restore(x%v,xvsave,desc_a,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='psb_csmm'
ch_err = 'psb_csmm'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (doswap_) then
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& zone,y%v,desc_a,iwork,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& zone,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),zone,y%v,desc_a,info)
if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),zone,y%v,desc_a,info,data=psb_comm_ovr_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
@ -285,18 +252,6 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= psb_success_) then
info = psb_err_from_subroutine_
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
nullify(iwork)
call psb_erractionrestore(err_act)
if (debug_level >= psb_debug_comp_) then
call psb_barrier(ctxt)

56
base/psblas/psb_zspsm.f90
Unescape Escape View File

@ -64,10 +64,9 @@
! the diagonal matrix D.
! choice - integer(optional). The kind of update to perform on overlap elements.
! d(:) - complex, optional Matrix for diagonal scaling.
! work(:) - complex, optional Working area.
!
subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag, work)
subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
& trans, scale, choice, diag)
use psb_base_mod, psb_protect_name => psb_zspsv_vect
use psi_mod
implicit none
@ -79,7 +78,6 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
type(psb_z_vect_type), intent(inout), optional :: diag
complex(psb_dpk_), optional, target, intent(inout) :: work(:)
character, intent(in), optional :: trans, scale
integer(psb_ipk_), intent(in), optional :: choice
@ -88,23 +86,24 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
integer(psb_ipk_) :: np, me, &
& err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,&
& ix, iy, ik, jx, jy, i, lld,&
& m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm
& m, nrow, ncol, iiy, jjy, idx, ndm
character :: lscale
integer(psb_ipk_), parameter :: nb=4
complex(psb_dpk_),pointer :: iwork(:), xp(:), yp(:)
complex(psb_dpk_),pointer :: xp(:), yp(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_zspsv_vect'
info=psb_success_
name = 'psb_zspsv_vect'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_ ; goto 9999
info = psb_err_internal_error_
goto 9999
end if
ctxt=desc_a%get_context()
ctxt = desc_a%get_context()
call psb_info(ctxt, me, np)
if (np == -1) then
@ -159,40 +158,12 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='reall'
info = psb_err_from_subroutine_
ch_err = 'reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
allocate(iwork(liwork),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
iwork(1)=0.d0
! Perform local triangular system solve
if (present(diag)) then
call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
@ -208,8 +179,7 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
! update overlap elements
if (choice_ > 0) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& zone,y%v,desc_a,iwork,info,data=psb_comm_ovr_)
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),zone,y%v,desc_a,info,data=psb_comm_ovr_)
if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info)
@ -219,8 +189,6 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,&
end if
end if
if (aliw) deallocate(iwork)
call psb_erractionrestore(err_act)
return

22
base/tools/psb_c_map.f90
Unescape Escape View File

@ -71,7 +71,7 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,x,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -91,7 +91,7 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,xt,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -112,14 +112,13 @@ subroutine psb_c_map_U2V_a(alpha,x,beta,y,map,info,work)
end subroutine psb_c_map_U2V_a
subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_c_map_U2V_v
implicit none
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_c_vect_type), target :: xt, yt
@ -152,7 +151,7 @@ subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,x,czero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -186,7 +185,7 @@ subroutine psb_c_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
end if
call psb_geaxpby(cone,x,czero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info)
if (info == psb_success_) call psb_csmm(cone,map%mat_U2V,ptx,czero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -254,7 +253,7 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,x,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -274,7 +273,7 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,xt,czero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -294,14 +293,13 @@ subroutine psb_c_map_V2U_a(alpha,x,beta,y,map,info,work)
end subroutine psb_c_map_V2U_a
subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_c_map_V2U_v
implicit none
class(psb_clinmap_type), intent(in) :: map
complex(psb_spk_), intent(in) :: alpha,beta
type(psb_c_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_spk_), optional :: work(:)
type(psb_c_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_c_vect_type), target :: xt, yt
@ -334,7 +332,7 @@ subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_U,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,x,czero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -369,7 +367,7 @@ subroutine psb_c_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geaxpby(cone,x,czero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info)
if (info == psb_success_) call psb_csmm(cone,map%mat_V2U,ptx,czero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()

22
base/tools/psb_d_map.f90
Unescape Escape View File

@ -71,7 +71,7 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,x,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -91,7 +91,7 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,xt,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -112,14 +112,13 @@ subroutine psb_d_map_U2V_a(alpha,x,beta,y,map,info,work)
end subroutine psb_d_map_U2V_a
subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_d_map_U2V_v
implicit none
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_d_vect_type), target :: xt, yt
@ -152,7 +151,7 @@ subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,x,dzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -186,7 +185,7 @@ subroutine psb_d_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
end if
call psb_geaxpby(done,x,dzero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info)
if (info == psb_success_) call psb_csmm(done,map%mat_U2V,ptx,dzero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -254,7 +253,7 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,x,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -274,7 +273,7 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,xt,dzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -294,14 +293,13 @@ subroutine psb_d_map_V2U_a(alpha,x,beta,y,map,info,work)
end subroutine psb_d_map_V2U_a
subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_d_map_V2U_v
implicit none
class(psb_dlinmap_type), intent(in) :: map
real(psb_dpk_), intent(in) :: alpha,beta
type(psb_d_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), optional :: work(:)
type(psb_d_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_d_vect_type), target :: xt, yt
@ -334,7 +332,7 @@ subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_U,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,x,dzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -369,7 +367,7 @@ subroutine psb_d_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geaxpby(done,x,dzero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info)
if (info == psb_success_) call psb_csmm(done,map%mat_V2U,ptx,dzero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()

22
base/tools/psb_s_map.f90
Unescape Escape View File

@ -71,7 +71,7 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,x,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -91,7 +91,7 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,xt,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -112,14 +112,13 @@ subroutine psb_s_map_U2V_a(alpha,x,beta,y,map,info,work)
end subroutine psb_s_map_U2V_a
subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_s_map_U2V_v
implicit none
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_s_vect_type), target :: xt, yt
@ -152,7 +151,7 @@ subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,x,szero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -186,7 +185,7 @@ subroutine psb_s_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
end if
call psb_geaxpby(sone,x,szero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info)
if (info == psb_success_) call psb_csmm(sone,map%mat_U2V,ptx,szero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -254,7 +253,7 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,x,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -274,7 +273,7 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,xt,szero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -294,14 +293,13 @@ subroutine psb_s_map_V2U_a(alpha,x,beta,y,map,info,work)
end subroutine psb_s_map_V2U_a
subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_s_map_V2U_v
implicit none
class(psb_slinmap_type), intent(in) :: map
real(psb_spk_), intent(in) :: alpha,beta
type(psb_s_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
real(psb_spk_), optional :: work(:)
type(psb_s_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_s_vect_type), target :: xt, yt
@ -334,7 +332,7 @@ subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_U,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,x,szero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -369,7 +367,7 @@ subroutine psb_s_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geaxpby(sone,x,szero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info)
if (info == psb_success_) call psb_csmm(sone,map%mat_V2U,ptx,szero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()

22
base/tools/psb_z_map.f90
Unescape Escape View File

@ -71,7 +71,7 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_V%get_global_rows()
nc2 = map%p_desc_V%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,x,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -91,7 +91,7 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_V%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_U,info,work)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,xt,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_V)) then
call psb_sum(ctxt,yt(1:nr2))
@ -112,14 +112,13 @@ subroutine psb_z_map_U2V_a(alpha,x,beta,y,map,info,work)
end subroutine psb_z_map_U2V_a
subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_z_map_U2V_v
implicit none
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_z_vect_type), target :: xt, yt
@ -152,7 +151,7 @@ subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_V,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_U,info)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,x,zzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -186,7 +185,7 @@ subroutine psb_z_map_U2V_v(alpha,x,beta,y,map,info,work,vtx,vty)
end if
call psb_geaxpby(zone,x,zzero,ptx,map%desc_U,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_U,info)
if (info == psb_success_) call psb_csmm(zone,map%mat_U2V,ptx,zzero,pty,info)
if ((info == psb_success_) .and. map%desc_V%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -254,7 +253,7 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_U%get_global_rows()
nc2 = map%p_desc_U%get_local_cols()
allocate(yt(nc2),stat=info)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,x,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%p_desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -274,7 +273,7 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work)
nc2 = map%desc_U%get_local_cols()
allocate(xt(nc1),yt(nc2),stat=info)
xt(1:nr1) = x(1:nr1)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(xt,map%desc_V,info,work)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,xt,zzero,yt,info)
if ((info == psb_success_) .and. psb_is_repl_desc(map%desc_U)) then
call psb_sum(ctxt,yt(1:nr2))
@ -294,14 +293,13 @@ subroutine psb_z_map_V2U_a(alpha,x,beta,y,map,info,work)
end subroutine psb_z_map_V2U_a
subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,vtx,vty)
use psb_base_mod, psb_protect_name => psb_z_map_V2U_v
implicit none
class(psb_zlinmap_type), intent(in) :: map
complex(psb_dpk_), intent(in) :: alpha,beta
type(psb_z_vect_type), intent(inout) :: x,y
integer(psb_ipk_), intent(out) :: info
complex(psb_dpk_), optional :: work(:)
type(psb_z_vect_type), optional, target, intent(inout) :: vtx,vty
! Local
type(psb_z_vect_type), target :: xt, yt
@ -334,7 +332,7 @@ subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geasb(yt,map%p_desc_U,info,scratch=.true.,mold=x%v)
pty => yt
end if
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info,work=work)
if (info == psb_success_) call psb_halo(x,map%p_desc_V,info)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,x,zzero,pty,info)
if ((info == psb_success_) .and. map%p_desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()
@ -369,7 +367,7 @@ subroutine psb_z_map_V2U_v(alpha,x,beta,y,map,info,work,vtx,vty)
call psb_geaxpby(zone,x,zzero,ptx,map%desc_V,info)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info,work=work)
if (info == psb_success_) call psb_halo(ptx,map%desc_V,info)
if (info == psb_success_) call psb_csmm(zone,map%mat_V2U,ptx,zzero,pty,info)
if ((info == psb_success_) .and. map%desc_U%is_repl().and.(np>1)) then
yta = pty%get_vect()

23
linsolve/impl/psb_cbicg.f90
Unescape Escape View File

@ -112,11 +112,10 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
! !$ local data
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -188,14 +187,11 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
info=psb_err_from_subroutine_non_
ch_err='psb_asb'
info = psb_err_from_subroutine_non_
ch_err = 'psb_asb'
err=info
call psb_errpush(info,name,a_err=ch_err)
goto 9999
@ -239,7 +235,7 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(cone,b,czero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt,desc_a,info)
@ -265,8 +261,8 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
call prec%apply(r,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@ -286,10 +282,8 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(cone,zt,beta,pt,desc_a,info)
end if
call psb_spmm(cone,a,p,czero,q,desc_a,info,&
& work=aux)
call psb_spmm(cone,a,pt,czero,qt,desc_a,info,&
& work=aux,trans='c')
call psb_spmm(cone,a,p,czero,q,desc_a,info)
call psb_spmm(cone,a,pt,czero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == czero) then
@ -319,7 +313,6 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

13
linsolve/impl/psb_ccg.F90
Unescape Escape View File

@ -113,12 +113,12 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
! = Local data
complex(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
complex(psb_spk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: q, p, r, z, w
complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -171,8 +171,6 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@ -215,7 +213,7 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
it = 0
call psb_geaxpby(cone,b,czero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -235,7 +233,7 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@ -252,7 +250,7 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(cone,z,beta,p,desc_a,info)
end if
call psb_spmm(cone,a,p,czero,q,desc_a,info,work=aux)
call psb_spmm(cone,a,p,czero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == czero) then
if (debug_level >= psb_debug_ext_)&
@ -285,7 +283,6 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

18
linsolve/impl/psb_ccgs.f90
Unescape Escape View File

@ -110,11 +110,10 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@ -165,8 +164,6 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
Allocate(aux(naux),stat=info)
if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@ -215,7 +212,7 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(cone,b,czero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (info == psb_success_) call psb_geaxpby(cone,r,czero,rt,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@ -260,10 +257,9 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(cone,uv,beta,p,desc_a,info)
end if
if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(cone,a,f,czero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@ -285,12 +281,11 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(cone,uv,czero,s,desc_a,info)
if (info == psb_success_) call psb_geaxpby(cone,q,cone,s,desc_a,info)
if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(s,z,desc_a,info)
if (info == psb_success_) call psb_geaxpby(alpha,z,cone,x,desc_a,info)
if (info == psb_success_) call psb_spmm(cone,a,z,czero,qt,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(cone,a,z,czero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,cone,r,desc_a,info)
@ -312,7 +307,6 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

18
linsolve/impl/psb_ccgstab.f90
Unescape Escape View File

@ -110,10 +110,10 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = Local data
complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:)
complex(psb_spk_), allocatable, target :: wwrk(:,:)
type(psb_c_vect_type) :: q, r, p, v, s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it,itrace_,&
integer(psb_ipk_) :: itmax_, it,itrace_,&
& n_row, n_col
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -179,8 +179,6 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
if (info == psb_success_) allocate(aux(naux),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
@ -230,7 +228,7 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
it = 0
call psb_geaxpby(cone,b,czero,r,desc_a,info)
call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,r,desc_a,info)
call psb_geaxpby(cone,r,czero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
@ -279,10 +277,9 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(cone,r,beta,p,desc_a,info)
End If
call prec%apply(p,f,desc_a,info,work=aux)
call prec%apply(p,f,desc_a,info)
call psb_spmm(cone,a,f,czero,v,desc_a,info,&
& work=aux)
call psb_spmm(cone,a,f,czero,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
@ -316,8 +313,8 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
end if
call prec%apply(s,z,desc_a,info,work=aux)
Call psb_spmm(cone,a,z,czero,t,desc_a,info,work=aux)
call prec%apply(s,z,desc_a,info)
Call psb_spmm(cone,a,z,czero,t,desc_a,info)
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
@ -367,7 +364,6 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
deallocate(aux,stat=info)
call x%sync()
call psb_gefree(q,desc_a,info)

15
linsolve/impl/psb_ccgstabl.f90
Unescape Escape View File

@ -121,13 +121,13 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
complex(psb_spk_), allocatable, target :: aux(:), gamma(:),&
complex(psb_spk_), allocatable, target :: gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:),uh(:), rh(:)
type(psb_c_vect_type), Pointer :: ww, q, r, rt0, p, v, &
& s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, nl, err_act
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False.
@ -213,10 +213,6 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux),gamma(0:nl),gamma1(nl),&
&gamma2(nl),taum(nl,nl),sigma(nl), stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
@ -263,7 +259,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
it = 0
call psb_geaxpby(cone,b,czero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (info == psb_success_) call prec%apply(r,desc_a,info)
@ -318,7 +314,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
! = call psb_geaxpby(cone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_geaxpby(cone,rh(k),-beta,uh(k),desc_a,info)
end do
call psb_spmm(cone,a,uh(j),czero,uh(j+1),desc_a,info,work=aux)
call psb_spmm(cone,a,uh(j),czero,uh(j+1),desc_a,info)
call prec%apply(uh(j+1),desc_a,info)
@ -340,7 +336,7 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,uh(k+1),cone,rh(k),desc_a,info)
end do
call psb_geaxpby(alpha,uh(0),cone,x,desc_a,info)
call psb_spmm(cone,a,rh(j),czero,rh(j+1),desc_a,info,work=aux)
call psb_spmm(cone,a,rh(j),czero,rh(j+1),desc_a,info)
call prec%apply(rh(j+1),desc_a,info)
@ -403,7 +399,6 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(uh,desc_a,info)
if (info == psb_success_) call psb_gefree(rh,desc_a,info)
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

10
linsolve/impl/psb_cfcg.F90
Unescape Escape View File

@ -125,12 +125,11 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
complex(psb_spk_) :: alpha, beta, delta, gamma, theta
real(psb_dpk_) :: derr
integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
complex(psb_spk_), allocatable, target :: aux(:)
complex(psb_spk_) :: vres(3)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
@ -177,9 +176,6 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (present(itmax)) then
itmax_ = itmax
@ -234,7 +230,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v=Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(cone,a,v,czero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -289,7 +285,7 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v = Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(cone,a,v,czero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&

14
linsolve/impl/psb_cgcr.f90
Unescape Escape View File

@ -130,14 +130,13 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
type(psb_c_vect_type) :: r
real(psb_dpk_) :: r_norm, b_norm, a_norm, derr
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst
complex(psb_spk_) :: hjj
complex(psb_spk_), allocatable, target :: aux(:)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
character(len=*), parameter :: methdname='GCR'
@ -223,10 +222,6 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
endif
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c_scale(nl+1),c(nl+1),z(nl+1), alpha(nl+1), stat=info)
h = czero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@ -261,7 +256,7 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(cone, b, czero, r, desc_a, info)
call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -278,9 +273,9 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
j = it
!Apply preconditioner
call prec%apply(r,z(j),desc_a,info,work=aux)
call prec%apply(r,z(j),desc_a,info)
call psb_spmm(cone,a,z(j),czero,c(1),desc_a,info,work=aux)
call psb_spmm(cone,a,z(j),czero,c(1),desc_a,info)
do i =1, j - 1
h(i,j) = psb_gedot(c_scale(i), c(i), desc_a, info)
@ -347,7 +342,6 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(c(i),desc_a,info)
end do
if (info == psb_success_) deallocate(aux,h,c_scale,z,c,alpha,stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

16
linsolve/impl/psb_crgmres.f90
Unescape Escape View File

@ -124,13 +124,12 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
complex(psb_spk_), allocatable :: aux(:)
complex(psb_spk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
type(psb_c_vect_type), allocatable :: v(:)
type(psb_c_vect_type) :: w, w1, xt
real(psb_spk_) :: tmp
complex(psb_spk_) :: scal, gm, rti, rti1
integer(psb_ipk_) ::litmax, naux, it, k, itrace_,&
integer(psb_ipk_) ::litmax, it, k, itrace_,&
& n_row, n_col, nl
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true.
@ -230,10 +229,6 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
end if
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info)
if (info == psb_success_) call psb_geall(v,desc_a,info,n=nl+1)
if (info == psb_success_) call psb_geall(w,desc_a,info)
if (info == psb_success_) call psb_geall(w1,desc_a,info)
@ -266,7 +261,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -301,7 +296,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info,work=aux)
call psb_spmm(-cone,a,x,cone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -358,7 +353,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
call prec%apply(v(i),w1,desc_a,info)
call psb_spmm(cone,a,w1,czero,w,desc_a,info,work=aux)
call psb_spmm(cone,a,w1,czero,w,desc_a,info)
!
do k = 1, i
@ -397,7 +392,7 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
call prec%apply(xt,desc_a,info)
call psb_geaxpby(cone,x,cone,xt,desc_a,info)
call psb_geaxpby(cone,b,czero,w1,desc_a,info)
call psb_spmm(-cone,a,xt,cone,w1,desc_a,info,work=aux)
call psb_spmm(-cone,a,xt,cone,w1,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@ -490,7 +485,6 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(w,desc_a,info)
if (info == psb_success_) call psb_gefree(w1,desc_a,info)
if (info == psb_success_) call psb_gefree(xt,desc_a,info)
if (info == psb_success_) deallocate(aux,h,c,s,rs,rst, stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

16
linsolve/impl/psb_crichardson.f90
Unescape Escape View File

@ -91,11 +91,10 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
logical :: do_alloc_wrk
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me,np,err_act
complex(psb_spk_), allocatable, target :: aux(:)
type(psb_c_vect_type), allocatable, target :: wwrk(:)
type(psb_c_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: derr
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -155,12 +154,10 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@ -171,9 +168,9 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
w => wwrk(5)
call psb_geaxpby(cone,b,czero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
info = psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
@ -186,17 +183,16 @@ Subroutine psb_crichardson_vect(a,prec,b,x,eps,desc_a,info,&
End If
loop: do itx=1,itmax_
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
call psb_geaxpby(cone,z,cone,x,desc_a,info)
call psb_geaxpby(cone,b,czero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-cone,a,x,cone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit loop
end do loop
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)
if(info /= psb_success_) then

18
linsolve/impl/psb_dbicg.f90
Unescape Escape View File

@ -112,11 +112,10 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
! !$ local data
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -188,9 +187,7 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
@ -239,7 +236,7 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
@ -265,8 +262,8 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
call prec%apply(r,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@ -286,10 +283,8 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(done,zt,beta,pt,desc_a,info)
end if
call psb_spmm(done,a,p,dzero,q,desc_a,info,&
& work=aux)
call psb_spmm(done,a,pt,dzero,qt,desc_a,info,&
& work=aux,trans='c')
call psb_spmm(done,a,p,dzero,q,desc_a,info)
call psb_spmm(done,a,pt,dzero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == dzero) then
@ -319,7 +314,6 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

13
linsolve/impl/psb_dcg.F90
Unescape Escape View File

@ -113,12 +113,12 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
! = Local data
real(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
real(psb_dpk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -171,8 +171,6 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@ -223,7 +221,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -243,7 +241,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@ -260,7 +258,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(done,z,beta,p,desc_a,info)
end if
call psb_spmm(done,a,p,dzero,q,desc_a,info,work=aux)
call psb_spmm(done,a,p,dzero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == dzero) then
if (debug_level >= psb_debug_ext_)&
@ -318,7 +316,6 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

18
linsolve/impl/psb_dcgs.f90
Unescape Escape View File

@ -110,11 +110,10 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@ -165,8 +164,6 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
Allocate(aux(naux),stat=info)
if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@ -215,7 +212,7 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@ -260,10 +257,9 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(done,uv,beta,p,desc_a,info)
end if
if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@ -285,12 +281,11 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(done,uv,dzero,s,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,q,done,s,desc_a,info)
if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(s,z,desc_a,info)
if (info == psb_success_) call psb_geaxpby(alpha,z,done,x,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,z,dzero,qt,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(done,a,z,dzero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,done,r,desc_a,info)
@ -312,7 +307,6 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

20
linsolve/impl/psb_dcgstab.f90
Unescape Escape View File

@ -110,11 +110,10 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = Local data
real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
real(psb_dpk_), allocatable, target :: wwrk(:,:)
type(psb_d_vect_type) :: q, r, p, v, s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it,itrace_,&
& n_row, n_col
integer(psb_ipk_) :: itmax_, it, itrace_, n_row, n_col
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False.
@ -179,8 +178,7 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
if (info == psb_success_) allocate(aux(naux),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
@ -230,7 +228,7 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,r,desc_a,info)
call psb_geaxpby(done,r,dzero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
@ -279,10 +277,9 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(done,r,beta,p,desc_a,info)
End If
call prec%apply(p,f,desc_a,info,work=aux)
call prec%apply(p,f,desc_a,info)
call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux)
call psb_spmm(done,a,f,dzero,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
@ -316,8 +313,8 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
end if
call prec%apply(s,z,desc_a,info,work=aux)
Call psb_spmm(done,a,z,dzero,t,desc_a,info,work=aux)
call prec%apply(s,z,desc_a,info)
Call psb_spmm(done,a,z,dzero,t,desc_a,info)
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
@ -367,7 +364,6 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
deallocate(aux,stat=info)
call x%sync()
call psb_gefree(q,desc_a,info)

15
linsolve/impl/psb_dcgstabl.f90
Unescape Escape View File

@ -121,13 +121,13 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
real(psb_dpk_), allocatable, target :: aux(:), gamma(:),&
real(psb_dpk_), allocatable, target :: gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:),uh(:), rh(:)
type(psb_d_vect_type), Pointer :: ww, q, r, rt0, p, v, &
& s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, nl, err_act
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False.
@ -213,10 +213,6 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux),gamma(0:nl),gamma1(nl),&
&gamma2(nl),taum(nl,nl),sigma(nl), stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
@ -263,7 +259,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info)
if (info == psb_success_) call prec%apply(r,desc_a,info)
@ -318,7 +314,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
! = call psb_geaxpby(done,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_geaxpby(done,rh(k),-beta,uh(k),desc_a,info)
end do
call psb_spmm(done,a,uh(j),dzero,uh(j+1),desc_a,info,work=aux)
call psb_spmm(done,a,uh(j),dzero,uh(j+1),desc_a,info)
call prec%apply(uh(j+1),desc_a,info)
@ -340,7 +336,7 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,uh(k+1),done,rh(k),desc_a,info)
end do
call psb_geaxpby(alpha,uh(0),done,x,desc_a,info)
call psb_spmm(done,a,rh(j),dzero,rh(j+1),desc_a,info,work=aux)
call psb_spmm(done,a,rh(j),dzero,rh(j+1),desc_a,info)
call prec%apply(rh(j+1),desc_a,info)
@ -403,7 +399,6 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(uh,desc_a,info)
if (info == psb_success_) call psb_gefree(rh,desc_a,info)
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

10
linsolve/impl/psb_dfcg.F90
Unescape Escape View File

@ -125,12 +125,11 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
real(psb_dpk_) :: alpha, beta, delta, gamma, theta
real(psb_dpk_) :: derr
integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
real(psb_dpk_), allocatable, target :: aux(:)
real(psb_dpk_) :: vres(3)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
@ -177,9 +176,6 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (present(itmax)) then
itmax_ = itmax
@ -234,7 +230,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v=Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,v,dzero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -289,7 +285,7 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v = Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,v,dzero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&

15
linsolve/impl/psb_dgcr.f90
Unescape Escape View File

@ -130,14 +130,13 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
type(psb_d_vect_type) :: r
real(psb_dpk_) :: r_norm, b_norm, a_norm, derr
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst
real(psb_dpk_) :: hjj
real(psb_dpk_), allocatable, target :: aux(:)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
character(len=*), parameter :: methdname='GCR'
@ -223,10 +222,6 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
endif
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c_scale(nl+1),c(nl+1),z(nl+1), alpha(nl+1), stat=info)
h = dzero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@ -261,7 +256,7 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(done, b, dzero, r, desc_a, info)
call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -278,9 +273,9 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
j = it
!Apply preconditioner
call prec%apply(r,z(j),desc_a,info,work=aux)
call prec%apply(r,z(j),desc_a,info)
call psb_spmm(done,a,z(j),dzero,c(1),desc_a,info,work=aux)
call psb_spmm(done,a,z(j),dzero,c(1),desc_a,info)
do i =1, j - 1
h(i,j) = psb_gedot(c_scale(i), c(i), desc_a, info)
@ -347,7 +342,7 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(c(i),desc_a,info)
end do
if (info == psb_success_) deallocate(aux,h,c_scale,z,c,alpha,stat=info)
if (info == psb_success_) deallocate(h,c_scale,z,c,alpha,stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

18
linsolve/impl/psb_drgmres.f90
Unescape Escape View File

@ -124,13 +124,12 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
real(psb_dpk_), allocatable :: aux(:)
real(psb_dpk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
type(psb_d_vect_type), allocatable :: v(:)
type(psb_d_vect_type) :: w, w1, xt
real(psb_dpk_) :: tmp
real(psb_dpk_) :: scal, gm, rti, rti1
integer(psb_ipk_) ::litmax, naux, it, k, itrace_,&
integer(psb_ipk_) ::litmax, it, k, itrace_,&
& n_row, n_col, nl
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true.
@ -229,11 +228,6 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info)
if (info == psb_success_) call psb_geall(v,desc_a,info,n=nl+1)
if (info == psb_success_) call psb_geall(w,desc_a,info)
if (info == psb_success_) call psb_geall(w1,desc_a,info)
@ -266,7 +260,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-done,a,x,done,v(1),desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -301,7 +295,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-done,a,x,done,v(1),desc_a,info,work=aux)
call psb_spmm(-done,a,x,done,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -358,7 +352,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
call prec%apply(v(i),w1,desc_a,info)
call psb_spmm(done,a,w1,dzero,w,desc_a,info,work=aux)
call psb_spmm(done,a,w1,dzero,w,desc_a,info)
!
do k = 1, i
@ -397,7 +391,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
call prec%apply(xt,desc_a,info)
call psb_geaxpby(done,x,done,xt,desc_a,info)
call psb_geaxpby(done,b,dzero,w1,desc_a,info)
call psb_spmm(-done,a,xt,done,w1,desc_a,info,work=aux)
call psb_spmm(-done,a,xt,done,w1,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@ -490,7 +484,7 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(w,desc_a,info)
if (info == psb_success_) call psb_gefree(w1,desc_a,info)
if (info == psb_success_) call psb_gefree(xt,desc_a,info)
if (info == psb_success_) deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == psb_success_) deallocate(h,c,s,rs,rst, stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

14
linsolve/impl/psb_drichardson.f90
Unescape Escape View File

@ -91,12 +91,11 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
logical :: do_alloc_wrk
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me,np,err_act
real(psb_dpk_), allocatable, target :: aux(:)
type(psb_d_vect_type), allocatable, target :: wwrk(:)
type(psb_d_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: derr
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_itconv_type) :: stopdat
@ -155,8 +154,6 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@ -171,7 +168,7 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
w => wwrk(5)
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -186,17 +183,16 @@ Subroutine psb_drichardson_vect(a,prec,b,x,eps,desc_a,info,&
End If
loop: do itx=1,itmax_
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
call psb_geaxpby(done,z,done,x,desc_a,info)
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit loop
end do loop
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)
if(info /= psb_success_) then

20
linsolve/impl/psb_sbicg.f90
Unescape Escape View File

@ -112,11 +112,10 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_spk_), optional, intent(out) :: err
! !$ local data
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -187,10 +186,6 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
@ -239,7 +234,7 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(sone,b,szero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt,desc_a,info)
@ -265,8 +260,8 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
call prec%apply(r,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@ -286,10 +281,8 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(sone,zt,beta,pt,desc_a,info)
end if
call psb_spmm(sone,a,p,szero,q,desc_a,info,&
& work=aux)
call psb_spmm(sone,a,pt,szero,qt,desc_a,info,&
& work=aux,trans='c')
call psb_spmm(sone,a,p,szero,q,desc_a,info)
call psb_spmm(sone,a,pt,szero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == szero) then
@ -319,7 +312,6 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

13
linsolve/impl/psb_scg.F90
Unescape Escape View File

@ -113,12 +113,12 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err,cond
! = Local data
real(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
real(psb_spk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: q, p, r, z, w
real(psb_spk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -171,8 +171,6 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@ -223,7 +221,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
it = 0
call psb_geaxpby(sone,b,szero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -243,7 +241,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@ -260,7 +258,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(sone,z,beta,p,desc_a,info)
end if
call psb_spmm(sone,a,p,szero,q,desc_a,info,work=aux)
call psb_spmm(sone,a,p,szero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == szero) then
if (debug_level >= psb_debug_ext_)&
@ -318,7 +316,6 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

18
linsolve/impl/psb_scgs.f90
Unescape Escape View File

@ -110,11 +110,10 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@ -165,8 +164,6 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
Allocate(aux(naux),stat=info)
if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@ -215,7 +212,7 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(sone,b,szero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (info == psb_success_) call psb_geaxpby(sone,r,szero,rt,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@ -260,10 +257,9 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(sone,uv,beta,p,desc_a,info)
end if
if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(sone,a,f,szero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(sone,a,f,szero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@ -285,12 +281,11 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(sone,uv,szero,s,desc_a,info)
if (info == psb_success_) call psb_geaxpby(sone,q,sone,s,desc_a,info)
if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(s,z,desc_a,info)
if (info == psb_success_) call psb_geaxpby(alpha,z,sone,x,desc_a,info)
if (info == psb_success_) call psb_spmm(sone,a,z,szero,qt,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(sone,a,z,szero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,sone,r,desc_a,info)
@ -312,7 +307,6 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

25
linsolve/impl/psb_scgstab.f90
Unescape Escape View File

@ -110,10 +110,10 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = Local data
real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:)
real(psb_spk_), allocatable, target :: wwrk(:,:)
type(psb_s_vect_type) :: q, r, p, v, s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it,itrace_,&
integer(psb_ipk_) :: itmax_, it,itrace_,&
& n_row, n_col
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -179,14 +179,6 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
if (info == psb_success_) allocate(aux(naux),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
End If
call psb_geasb(q,desc_a,info,mold=x%v,scratch=.true.)
call psb_geasb(r,desc_a,info,mold=x%v,scratch=.true.)
@ -230,7 +222,7 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
it = 0
call psb_geaxpby(sone,b,szero,r,desc_a,info)
call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,r,desc_a,info)
call psb_geaxpby(sone,r,szero,q,desc_a,info)
! Perhaps we already satisfy the convergence criterion...
@ -279,10 +271,9 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_geaxpby(sone,r,beta,p,desc_a,info)
End If
call prec%apply(p,f,desc_a,info,work=aux)
call prec%apply(p,f,desc_a,info)
call psb_spmm(sone,a,f,szero,v,desc_a,info,&
& work=aux)
call psb_spmm(sone,a,f,szero,v,desc_a,info)
sigma = psb_gedot(q,v,desc_a,info)
@ -316,8 +307,8 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
end if
call prec%apply(s,z,desc_a,info,work=aux)
Call psb_spmm(sone,a,z,szero,t,desc_a,info,work=aux)
call prec%apply(s,z,desc_a,info)
Call psb_spmm(sone,a,z,szero,t,desc_a,info)
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
@ -367,8 +358,6 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
deallocate(aux,stat=info)
call x%sync()
call psb_gefree(q,desc_a,info)
call psb_gefree(r,desc_a,info)

15
linsolve/impl/psb_scgstabl.f90
Unescape Escape View File

@ -121,13 +121,13 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
real(psb_spk_), allocatable, target :: aux(:), gamma(:),&
real(psb_spk_), allocatable, target :: gamma(:),&
& gamma1(:), gamma2(:), taum(:,:), sigma(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:),uh(:), rh(:)
type(psb_s_vect_type), Pointer :: ww, q, r, rt0, p, v, &
& s, t, z, f
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, nl, err_act
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False.
@ -213,10 +213,6 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux),gamma(0:nl),gamma1(nl),&
&gamma2(nl),taum(nl,nl),sigma(nl), stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
@ -263,7 +259,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
it = 0
call psb_geaxpby(sone,b,szero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (info == psb_success_) call prec%apply(r,desc_a,info)
@ -318,7 +314,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
! = call psb_geaxpby(sone,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_geaxpby(sone,rh(k),-beta,uh(k),desc_a,info)
end do
call psb_spmm(sone,a,uh(j),szero,uh(j+1),desc_a,info,work=aux)
call psb_spmm(sone,a,uh(j),szero,uh(j+1),desc_a,info)
call prec%apply(uh(j+1),desc_a,info)
@ -340,7 +336,7 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(-alpha,uh(k+1),sone,rh(k),desc_a,info)
end do
call psb_geaxpby(alpha,uh(0),sone,x,desc_a,info)
call psb_spmm(sone,a,rh(j),szero,rh(j+1),desc_a,info,work=aux)
call psb_spmm(sone,a,rh(j),szero,rh(j+1),desc_a,info)
call prec%apply(rh(j+1),desc_a,info)
@ -403,7 +399,6 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(uh,desc_a,info)
if (info == psb_success_) call psb_gefree(rh,desc_a,info)
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

10
linsolve/impl/psb_sfcg.F90
Unescape Escape View File

@ -125,12 +125,11 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
real(psb_spk_) :: alpha, beta, delta, gamma, theta
real(psb_dpk_) :: derr
integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
real(psb_spk_), allocatable, target :: aux(:)
real(psb_spk_) :: vres(3)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
@ -177,9 +176,6 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (present(itmax)) then
itmax_ = itmax
@ -234,7 +230,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v=Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(sone,a,v,szero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -289,7 +285,7 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,&
! Apply the preconditioner v = Pr
! Compute w = Av
call prec%apply(r,v,desc_a,info,work=aux)
call prec%apply(r,v,desc_a,info)
if (info == psb_success_) call psb_spmm(sone,a,v,szero,w,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&

21
linsolve/impl/psb_sgcr.f90
Unescape Escape View File

@ -130,14 +130,13 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
type(psb_s_vect_type) :: r
real(psb_dpk_) :: r_norm, b_norm, a_norm, derr
integer(psb_ipk_) :: n_col, naux, err_act
integer(psb_ipk_) :: n_col, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: np, me
integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst
real(psb_spk_) :: hjj
real(psb_spk_), allocatable, target :: aux(:)
character(len=20) :: name
type(psb_itconv_type) :: stopdat
character(len=*), parameter :: methdname='GCR'
@ -223,17 +222,9 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
endif
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c_scale(nl+1),c(nl+1),z(nl+1), alpha(nl+1), stat=info)
h = szero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
call psb_geasb(r, desc_a,info, scratch=.true.,mold=x%v)
do i =1,nl+1
@ -261,7 +252,7 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(sone, b, szero, r, desc_a, info)
call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -278,9 +269,9 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
j = it
!Apply preconditioner
call prec%apply(r,z(j),desc_a,info,work=aux)
call prec%apply(r,z(j),desc_a,info)
call psb_spmm(sone,a,z(j),szero,c(1),desc_a,info,work=aux)
call psb_spmm(sone,a,z(j),szero,c(1),desc_a,info)
do i =1, j - 1
h(i,j) = psb_gedot(c_scale(i), c(i), desc_a, info)
@ -347,7 +338,7 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(c(i),desc_a,info)
end do
if (info == psb_success_) deallocate(aux,h,c_scale,z,c,alpha,stat=info)
if (info == psb_success_) deallocate(h,c_scale,z,c,alpha,stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

18
linsolve/impl/psb_srgmres.f90
Unescape Escape View File

@ -124,13 +124,12 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_spk_), Optional, Intent(out) :: err
! = local data
real(psb_spk_), allocatable :: aux(:)
real(psb_spk_), allocatable :: c(:), s(:), h(:,:), rs(:), rst(:)
type(psb_s_vect_type), allocatable :: v(:)
type(psb_s_vect_type) :: w, w1, xt
real(psb_spk_) :: tmp
real(psb_spk_) :: scal, gm, rti, rti1
integer(psb_ipk_) ::litmax, naux, it, k, itrace_,&
integer(psb_ipk_) ::litmax, it, k, itrace_,&
& n_row, n_col, nl
integer(psb_lpk_) :: mglob
Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true.
@ -229,11 +228,6 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info)
if (info == psb_success_) call psb_geall(v,desc_a,info,n=nl+1)
if (info == psb_success_) call psb_geall(w,desc_a,info)
if (info == psb_success_) call psb_geall(w1,desc_a,info)
@ -266,7 +260,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -301,7 +295,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info,work=aux)
call psb_spmm(-sone,a,x,sone,v(1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -358,7 +352,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
itx = itx + 1
call prec%apply(v(i),w1,desc_a,info)
call psb_spmm(sone,a,w1,szero,w,desc_a,info,work=aux)
call psb_spmm(sone,a,w1,szero,w,desc_a,info)
!
do k = 1, i
@ -397,7 +391,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
call prec%apply(xt,desc_a,info)
call psb_geaxpby(sone,x,sone,xt,desc_a,info)
call psb_geaxpby(sone,b,szero,w1,desc_a,info)
call psb_spmm(-sone,a,xt,sone,w1,desc_a,info,work=aux)
call psb_spmm(-sone,a,xt,sone,w1,desc_a,info)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
@ -490,7 +484,7 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_gefree(w,desc_a,info)
if (info == psb_success_) call psb_gefree(w1,desc_a,info)
if (info == psb_success_) call psb_gefree(xt,desc_a,info)
if (info == psb_success_) deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == psb_success_) deallocate(h,c,s,rs,rst, stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)

12
linsolve/impl/psb_srichardson.f90
Unescape Escape View File

@ -91,11 +91,10 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
logical :: do_alloc_wrk
type(psb_ctxt_type) :: ctxt
integer(psb_ipk_) :: me,np,err_act
real(psb_spk_), allocatable, target :: aux(:)
type(psb_s_vect_type), allocatable, target :: wwrk(:)
type(psb_s_vect_type), pointer :: q, p, r, z, w
real(psb_dpk_) :: derr
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -155,8 +154,6 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@ -171,7 +168,7 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
w => wwrk(5)
call psb_geaxpby(sone,b,szero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -186,17 +183,16 @@ Subroutine psb_srichardson_vect(a,prec,b,x,eps,desc_a,info,&
End If
loop: do itx=1,itmax_
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
call psb_geaxpby(sone,z,sone,x,desc_a,info)
call psb_geaxpby(sone,b,szero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-sone,a,x,sone,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit loop
end do loop
call psb_end_conv(methdname,itx,desc_a,stopdat,info,derr,iter)
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if ((info==psb_success_).and.do_alloc_wrk) call prec%free_wrk(info)
if(info /= psb_success_) then

19
linsolve/impl/psb_zbicg.f90
Unescape Escape View File

@ -112,11 +112,10 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
! !$ local data
complex(psb_dpk_), allocatable, target :: aux(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
type(psb_z_vect_type), pointer :: ww, q, r, p,&
& zt, pt, z, rt, qt
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col, istop_, err_act
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -188,9 +187,6 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v)
if(info /= psb_success_) then
@ -239,7 +235,7 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(zone,b,zzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt,desc_a,info)
@ -265,8 +261,8 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
call prec%apply(r,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c',work=aux)
call prec%apply(r,z,desc_a,info)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='c')
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
@ -286,10 +282,8 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(zone,zt,beta,pt,desc_a,info)
end if
call psb_spmm(zone,a,p,zzero,q,desc_a,info,&
& work=aux)
call psb_spmm(zone,a,pt,zzero,qt,desc_a,info,&
& work=aux,trans='c')
call psb_spmm(zone,a,p,zzero,q,desc_a,info)
call psb_spmm(zone,a,pt,zzero,qt,desc_a,info,trans='c')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == zzero) then
@ -319,7 +313,6 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

13
linsolve/impl/psb_zcg.F90
Unescape Escape View File

@ -113,12 +113,12 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
! = Local data
complex(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:)
complex(psb_dpk_), allocatable, target :: td(:),tu(:),eig(:),ewrk(:)
integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
type(psb_z_vect_type), pointer :: q, p, r, z, w
complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,&
integer(psb_ipk_) :: itmax_, istop_, it, itx, itrace_,&
& n_col, n_row,err_act, ieg,nspl, istebz
integer(psb_lpk_) :: mglob
integer(psb_ipk_) :: debug_level, debug_unit
@ -171,8 +171,6 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=5_psb_ipk_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info,mold=x%v,scratch=.true.)
if (info /= psb_success_) then
@ -215,7 +213,7 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
it = 0
call psb_geaxpby(zone,b,zzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
@ -235,7 +233,7 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
call prec%apply(r,z,desc_a,info)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
@ -252,7 +250,7 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
call psb_geaxpby(zone,z,beta,p,desc_a,info)
end if
call psb_spmm(zone,a,p,zzero,q,desc_a,info,work=aux)
call psb_spmm(zone,a,p,zzero,q,desc_a,info)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == zzero) then
if (debug_level >= psb_debug_ext_)&
@ -285,7 +283,6 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

18
linsolve/impl/psb_zcgs.f90
Unescape Escape View File

@ -110,11 +110,10 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
integer(psb_ipk_), Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
! = local data
complex(psb_dpk_), allocatable, target :: aux(:)
type(psb_z_vect_type), allocatable, target :: wwrk(:)
type(psb_z_vect_type), pointer :: ww, q, r, p, v,&
& s, z, f, rt, qt, uv
integer(psb_ipk_) :: itmax_, naux, it, itrace_,&
integer(psb_ipk_) :: itmax_, it, itrace_,&
& n_row, n_col,istop_, itx, err_act
integer(psb_lpk_) :: mglob
type(psb_ctxt_type) :: ctxt
@ -165,8 +164,6 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
goto 9999
end if
naux=4*n_col
Allocate(aux(naux),stat=info)
if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11_psb_ipk_)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info,mold=x%v)
if (info /= psb_success_) Then
@ -215,7 +212,7 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(zone,b,zzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(-zone,a,x,zone,r,desc_a,info)
if (info == psb_success_) call psb_geaxpby(zone,r,zzero,rt,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
@ -260,10 +257,9 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(zone,uv,beta,p,desc_a,info)
end if
if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(p,f,desc_a,info)
if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(zone,a,f,zzero,v,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
@ -285,12 +281,11 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (info == psb_success_) call psb_geaxpby(zone,uv,zzero,s,desc_a,info)
if (info == psb_success_) call psb_geaxpby(zone,q,zone,s,desc_a,info)
if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(s,z,desc_a,info)
if (info == psb_success_) call psb_geaxpby(alpha,z,zone,x,desc_a,info)
if (info == psb_success_) call psb_spmm(zone,a,z,zzero,qt,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_spmm(zone,a,z,zzero,qt,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,zone,r,desc_a,info)
@ -312,7 +307,6 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,&
if (present(err)) err = derr
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) deallocate(aux,stat=info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save