From 22e7df48daed94561cd48f770571a382485502c4 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Wed, 26 Feb 2020 09:46:59 +0100 Subject: [PATCH] Added out-of-place psb_mlt subroutine interface --- base/modules/psblas/psb_c_psblas_mod.F90 | 11 +++ base/modules/psblas/psb_d_psblas_mod.F90 | 11 +++ base/modules/psblas/psb_s_psblas_mod.F90 | 11 +++ base/modules/psblas/psb_z_psblas_mod.F90 | 11 +++ base/psblas/psb_cmlt_vect.f90 | 93 ++++++++++++++++++++++++ base/psblas/psb_dmlt_vect.f90 | 93 ++++++++++++++++++++++++ base/psblas/psb_smlt_vect.f90 | 93 ++++++++++++++++++++++++ base/psblas/psb_zmlt_vect.f90 | 93 ++++++++++++++++++++++++ cbind/base/psb_c_cbase.h | 1 + cbind/base/psb_c_dbase.h | 1 + cbind/base/psb_c_psblas_cbind_mod.f90 | 42 +++++++++++ cbind/base/psb_c_sbase.h | 1 + cbind/base/psb_c_zbase.h | 1 + cbind/base/psb_d_psblas_cbind_mod.f90 | 42 +++++++++++ cbind/base/psb_s_psblas_cbind_mod.f90 | 42 +++++++++++ cbind/base/psb_z_psblas_cbind_mod.f90 | 42 +++++++++++ 16 files changed, 588 insertions(+) diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index e290b833..37fd313e 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -459,6 +459,17 @@ module psb_c_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_cmlt_vect + subroutine psb_cmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type, psb_spk_ + complex(psb_spk_), intent(in) :: alpha,beta + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_cmlt_vect2 end interface interface psb_gediv diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index 606ede75..5c5d7992 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -470,6 +470,17 @@ module psb_d_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_dmlt_vect + subroutine psb_dmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_dmlt_vect2 end interface interface psb_gediv diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index 0baf228d..90c306ce 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -470,6 +470,17 @@ module psb_s_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_smlt_vect + subroutine psb_smlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_smlt_vect2 end interface interface psb_gediv diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index 6f3444c8..162fe8d3 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -459,6 +459,17 @@ module psb_z_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_zmlt_vect + subroutine psb_zmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx,conjgy) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type, psb_dpk_ + complex(psb_dpk_), intent(in) :: alpha,beta + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + end subroutine psb_zmlt_vect2 end interface interface psb_gediv diff --git a/base/psblas/psb_cmlt_vect.f90 b/base/psblas/psb_cmlt_vect.f90 index 89679c0f..e2b09270 100644 --- a/base/psblas/psb_cmlt_vect.f90 +++ b/base/psblas/psb_cmlt_vect.f90 @@ -103,3 +103,96 @@ subroutine psb_cmlt_vect(x,y,desc_a,info) return end subroutine psb_cmlt_vect + +! +! Subroutine: psb_cmlt_vect2 +! + +subroutine psb_cmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_cmlt_vect2 + implicit none + complex(psb_spk_), intent(in) :: alpha,beta + type(psb_c_vect_type), intent (inout) :: x + type(psb_c_vect_type), intent (inout) :: y + type(psb_c_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_c_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cmlt_vect2 diff --git a/base/psblas/psb_dmlt_vect.f90 b/base/psblas/psb_dmlt_vect.f90 index 2f282824..ac45802f 100644 --- a/base/psblas/psb_dmlt_vect.f90 +++ b/base/psblas/psb_dmlt_vect.f90 @@ -103,3 +103,96 @@ subroutine psb_dmlt_vect(x,y,desc_a,info) return end subroutine psb_dmlt_vect + +! +! Subroutine: psb_dmlt_vect2 +! + +subroutine psb_dmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_dmlt_vect2 + implicit none + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent (inout) :: x + type(psb_d_vect_type), intent (inout) :: y + type(psb_d_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_d_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dmlt_vect2 diff --git a/base/psblas/psb_smlt_vect.f90 b/base/psblas/psb_smlt_vect.f90 index f135e97d..8f1623d9 100644 --- a/base/psblas/psb_smlt_vect.f90 +++ b/base/psblas/psb_smlt_vect.f90 @@ -103,3 +103,96 @@ subroutine psb_smlt_vect(x,y,desc_a,info) return end subroutine psb_smlt_vect + +! +! Subroutine: psb_smlt_vect2 +! + +subroutine psb_smlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_smlt_vect2 + implicit none + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent (inout) :: x + type(psb_s_vect_type), intent (inout) :: y + type(psb_s_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_s_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_smlt_vect2 diff --git a/base/psblas/psb_zmlt_vect.f90 b/base/psblas/psb_zmlt_vect.f90 index 5d3153b5..598a12a7 100644 --- a/base/psblas/psb_zmlt_vect.f90 +++ b/base/psblas/psb_zmlt_vect.f90 @@ -103,3 +103,96 @@ subroutine psb_zmlt_vect(x,y,desc_a,info) return end subroutine psb_zmlt_vect + +! +! Subroutine: psb_zmlt_vect2 +! + +subroutine psb_zmlt_vect2(alpha,x,y,beta,z,desc_a,info,conjgx, conjgy) + use psb_base_mod, psb_protect_name => psb_zmlt_vect2 + implicit none + complex(psb_dpk_), intent(in) :: alpha,beta + type(psb_z_vect_type), intent (inout) :: x + type(psb_z_vect_type), intent (inout) :: y + type(psb_z_vect_type), intent (inout) :: z + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + character(len=1), intent(in), optional :: conjgx, conjgy + + ! locals + integer(psb_ipk_) :: ictxt, np, me,& + & err_act, iix, jjx, iiy, jjy, iiz, jjz + integer(psb_lpk_) :: ix, ijx, iy, ijy, iz, ijz, m + character(len=20) :: name, ch_err + + name='psb_z_mlt_vect2' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(y%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(z%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ix = ione + iy = ione + iz = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 2' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_chkvect(m,lone,z%get_nrows(),iz,lone,desc_a,info,iiz,jjz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 3' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call z%mlt(alpha,x,y,beta,info,conjgx,conjgy) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zmlt_vect2 diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index 1f7b2c04..86f57f3f 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -62,6 +62,7 @@ psb_i_t psb_c_cspsm(psb_c_t alpha, psb_c_cspmat *th, psb_c_cvector *xh, psb_c_t beta, psb_c_cvector *yh, psb_c_descriptor *cdh); /* Additional computational routines */ psb_i_t psb_c_cgemlt(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_cgemlt2(psb_c_t alpha, psb_c_cvector *xh, psb_c_cvector *yh, psb_c_t beta, psb_c_cvector *zh, psb_c_descriptor *cdh); psb_i_t psb_c_cgediv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_cgediv_check(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_cgeinv(psb_c_cvector *xh,psb_c_cvector *yh,psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index baa81eee..aa203064 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -62,6 +62,7 @@ psb_i_t psb_c_dspsm(psb_d_t alpha, psb_c_dspmat *th, psb_c_dvector *xh, psb_d_t beta, psb_c_dvector *yh, psb_c_descriptor *cdh); /* Additional computational routines */ psb_i_t psb_c_dgemlt(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_dgemlt2(psb_d_t alpha, psb_c_dvector *xh, psb_c_dvector *yh, psb_d_t beta, psb_c_dvector *zh, psb_c_descriptor *cdh); psb_i_t psb_c_dgediv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_dgediv_check(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_dgeinv(psb_c_dvector *xh,psb_c_dvector *yh,psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_psblas_cbind_mod.f90 b/cbind/base/psb_c_psblas_cbind_mod.f90 index 595d6962..25b6e445 100644 --- a/cbind/base/psb_c_psblas_cbind_mod.f90 +++ b/cbind/base/psb_c_psblas_cbind_mod.f90 @@ -78,6 +78,48 @@ contains end function psb_c_cgemlt + function psb_c_cgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_cvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_c_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + complex(psb_spk_), intent(in) :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_cgemlt2 + function psb_c_cgediv(xh,yh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index 6211f86a..f9e855fe 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -62,6 +62,7 @@ psb_i_t psb_c_sspsm(psb_s_t alpha, psb_c_sspmat *th, psb_c_svector *xh, psb_s_t beta, psb_c_svector *yh, psb_c_descriptor *cdh); /* Additional computational routines */ psb_i_t psb_c_sgemlt(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_sgemlt2(psb_s_t alpha, psb_c_svector *xh, psb_c_svector *yh, psb_s_t beta, psb_c_svector *zh, psb_c_descriptor *cdh); psb_i_t psb_c_sgediv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_sgediv_check(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_sgeinv(psb_c_svector *xh,psb_c_svector *yh,psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index 830d5342..401826dc 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -62,6 +62,7 @@ psb_i_t psb_c_zspsm(psb_z_t alpha, psb_c_zspmat *th, psb_c_zvector *xh, psb_z_t beta, psb_c_zvector *yh, psb_c_descriptor *cdh); /* Additional computational routines */ psb_i_t psb_c_zgemlt(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); +psb_i_t psb_c_zgemlt2(psb_z_t alpha, psb_c_zvector *xh, psb_c_zvector *yh, psb_z_t beta, psb_c_zvector *zh, psb_c_descriptor *cdh); psb_i_t psb_c_zgediv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_zgediv_check(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); psb_i_t psb_c_zgeinv(psb_c_zvector *xh,psb_c_zvector *yh,psb_c_descriptor *cdh); diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 143ab84b..8fd05660 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -78,6 +78,48 @@ contains end function psb_c_dgemlt + function psb_c_dgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_dvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_d_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + real(psb_dpk_), intent(in) :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_dgemlt2 + function psb_c_dgediv(xh,yh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index cbf6fe11..f4c306ef 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -78,6 +78,48 @@ contains end function psb_c_sgemlt + function psb_c_sgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_svector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_s_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + real(psb_spk_), intent(in) :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_sgemlt2 + function psb_c_sgediv(xh,yh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res diff --git a/cbind/base/psb_z_psblas_cbind_mod.f90 b/cbind/base/psb_z_psblas_cbind_mod.f90 index 81c1d2ca..ae814d6d 100644 --- a/cbind/base/psb_z_psblas_cbind_mod.f90 +++ b/cbind/base/psb_z_psblas_cbind_mod.f90 @@ -78,6 +78,48 @@ contains end function psb_c_zgemlt + function psb_c_zgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + implicit none + integer(psb_c_ipk_) :: res + + type(psb_c_zvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + + + type(psb_desc_type), pointer :: descp + type(psb_z_vect_type), pointer :: xp,yp,zp + integer(psb_c_ipk_) :: info + complex(psb_dpk_), intent(in) :: alpha,beta + + res = -1 + + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(xh%item)) then + call c_f_pointer(xh%item,xp) + else + return + end if + if (c_associated(yh%item)) then + call c_f_pointer(yh%item,yp) + else + return + end if + if (c_associated(zh%item)) then + call c_f_pointer(zh%item,zp) + else + return + end if + + call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) + + res = info + + end function psb_c_zgemlt2 + function psb_c_zgediv(xh,yh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res