From 66e70fa1451aac78348eeb3be4a7259a103905ae Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 4 Jul 2016 14:16:00 +0000 Subject: [PATCH] mld2p4-2: mlprec/impl/smoother/mld_c_as_smoother_apply.f90 mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 mlprec/impl/smoother/mld_d_as_smoother_apply.f90 mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 mlprec/impl/smoother/mld_s_as_smoother_apply.f90 mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 mlprec/impl/smoother/mld_z_as_smoother_apply.f90 mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 Fix usage of init/initu for AS --- .../impl/smoother/mld_c_as_smoother_apply.f90 | 34 ++++++++++++------ .../smoother/mld_c_as_smoother_apply_vect.f90 | 36 +++++++++++-------- .../impl/smoother/mld_d_as_smoother_apply.f90 | 34 ++++++++++++------ .../smoother/mld_d_as_smoother_apply_vect.f90 | 36 +++++++++++-------- .../impl/smoother/mld_s_as_smoother_apply.f90 | 34 ++++++++++++------ .../smoother/mld_s_as_smoother_apply_vect.f90 | 36 +++++++++++-------- .../impl/smoother/mld_z_as_smoother_apply.f90 | 34 ++++++++++++------ .../smoother/mld_z_as_smoother_apply_vect.f90 | 36 +++++++++++-------- 8 files changed, 180 insertions(+), 100 deletions(-) diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 index 2d6f8f69..830f8fef 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 @@ -54,7 +54,8 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i - complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), pointer :: ww(:), aux(:) + complex(psb_spk_), allocatable :: tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) character :: trans_, init_ character(len=20) :: name='c_as_smoother_apply', ch_err @@ -95,12 +96,10 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& if ((6*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) aux => work(3*isz+1:) else if ((4*isz) <= size(work)) then aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) + allocate(ww(isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/3*isz,izero,izero,izero,izero/),& @@ -109,8 +108,6 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& end if else if ((3*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) allocate(aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& @@ -119,8 +116,7 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) + allocate(ww(isz), aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/4*isz,izero,izero,izero,izero/),& @@ -154,8 +150,26 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& else - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = czero + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = czero + case('Y') + call psb_geaxpby(cone,y,czero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 index 94557429..d3fcd8a9 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 @@ -155,21 +155,27 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(czero) - call vty%set(czero) - call vww%set(czero) - - - call vtx%set(vx(1:nrow_d)) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vty,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vww,sm%desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call vtx%zero() + case('Y') + call psb_geaxpby(cone,y,czero,vtx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,vtx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 index e895e88d..8acfe8a4 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 @@ -54,7 +54,8 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), pointer :: ww(:), aux(:) + real(psb_dpk_), allocatable :: tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) character :: trans_, init_ character(len=20) :: name='d_as_smoother_apply', ch_err @@ -95,12 +96,10 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& if ((6*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) aux => work(3*isz+1:) else if ((4*isz) <= size(work)) then aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) + allocate(ww(isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/3*isz,izero,izero,izero,izero/),& @@ -109,8 +108,6 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& end if else if ((3*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) allocate(aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& @@ -119,8 +116,7 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) + allocate(ww(isz), aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/4*isz,izero,izero,izero,izero/),& @@ -154,8 +150,26 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& else - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = dzero + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = dzero + case('Y') + call psb_geaxpby(done,y,dzero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 index 7ea48bbf..58442077 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 @@ -155,21 +155,27 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(dzero) - call vty%set(dzero) - call vww%set(dzero) - - - call vtx%set(vx(1:nrow_d)) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vty,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vww,sm%desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call vtx%zero() + case('Y') + call psb_geaxpby(done,y,dzero,vtx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,vtx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 index 60520217..0033da63 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 @@ -54,7 +54,8 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), pointer :: ww(:), aux(:) + real(psb_spk_), allocatable :: tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) character :: trans_, init_ character(len=20) :: name='s_as_smoother_apply', ch_err @@ -95,12 +96,10 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& if ((6*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) aux => work(3*isz+1:) else if ((4*isz) <= size(work)) then aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) + allocate(ww(isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/3*isz,izero,izero,izero,izero/),& @@ -109,8 +108,6 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& end if else if ((3*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) allocate(aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& @@ -119,8 +116,7 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) + allocate(ww(isz), aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/4*isz,izero,izero,izero,izero/),& @@ -154,8 +150,26 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& else - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = szero + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = szero + case('Y') + call psb_geaxpby(sone,y,szero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 index ae2650a4..73e583ba 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 @@ -155,21 +155,27 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(szero) - call vty%set(szero) - call vww%set(szero) - - - call vtx%set(vx(1:nrow_d)) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vty,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vww,sm%desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call vtx%zero() + case('Y') + call psb_geaxpby(sone,y,szero,vtx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,vtx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 index 5a98958d..b74aebba 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 @@ -54,7 +54,8 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i - complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), pointer :: ww(:), aux(:) + complex(psb_dpk_), allocatable :: tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) character :: trans_, init_ character(len=20) :: name='z_as_smoother_apply', ch_err @@ -95,12 +96,10 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& if ((6*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) aux => work(3*isz+1:) else if ((4*isz) <= size(work)) then aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) + allocate(ww(isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/3*isz,izero,izero,izero,izero/),& @@ -109,8 +108,6 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& end if else if ((3*isz) <= size(work)) then ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) allocate(aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& @@ -119,8 +116,7 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) + allocate(ww(isz), aux(4*isz),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_request_,name,& & i_err=(/4*isz,izero,izero,izero,izero/),& @@ -154,8 +150,26 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& else - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = zzero + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = zzero + case('Y') + call psb_geaxpby(zone,y,zzero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 index bccc1299..c55a9f48 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 @@ -155,21 +155,27 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(zzero) - call vty%set(zzero) - call vww%set(zzero) - - - call vtx%set(vx(1:nrow_d)) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vty,sm%desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(vww,sm%desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call vtx%zero() + case('Y') + call psb_geaxpby(zone,y,zzero,vtx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,vtx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (sweeps == 1) then