Added POLY smoothers, also in SAMPLES/ADVANCED
sfilippone
1 year ago
parent
737ebb9a96
commit
30a5c7be03
@ -0,0 +1,453 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
& sweeps,work,wv,info,init,initu)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_diag_solver
|
||||
use psb_base_krylov_conv_mod, only : log_conv
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_apply_vect
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
type(psb_s_vect_type),intent(inout) :: x
|
||||
type(psb_s_vect_type),intent(inout) :: y
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_s_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_s_vect_type),intent(inout), optional :: initu
|
||||
!
|
||||
integer(psb_ipk_) :: n_row,n_col
|
||||
type(psb_s_vect_type) :: tx, ty, tz, r
|
||||
real(psb_spk_), pointer :: aux(:)
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: np, me, i, err_act
|
||||
character :: trans_, init_
|
||||
real(psb_spk_) :: res, resdenum
|
||||
character(len=20) :: name='d_poly_smoother_apply_v'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
ctxt = desc_data%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
|
||||
if (present(init)) then
|
||||
init_ = psb_toupper(init)
|
||||
else
|
||||
init_='Z'
|
||||
end if
|
||||
|
||||
trans_ = psb_toupper(trans)
|
||||
select case(trans_)
|
||||
case('N')
|
||||
case('T','C')
|
||||
case default
|
||||
call psb_errpush(psb_err_iarg_invalid_i_,name)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
if (.not.allocated(sm%sv)) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
n_row = desc_data%get_local_rows()
|
||||
n_col = desc_data%get_local_cols()
|
||||
|
||||
if (4*n_col <= size(work)) then
|
||||
aux => work(:)
|
||||
else
|
||||
allocate(aux(4*n_col),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_request_
|
||||
call psb_errpush(info,name,&
|
||||
& i_err=(/4*n_col,izero,izero,izero,izero/),&
|
||||
& a_err='real(psb_spk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
!!$ if (me == 0) write(0,*) name,' Unimplemented apply_vect '
|
||||
!!$ info =psb_err_internal_error_
|
||||
!!$ call psb_errpush(info,&
|
||||
!!$ & name,a_err='Error in sub_aply Polynomial not implemented')
|
||||
!!$ goto 9999
|
||||
|
||||
if (size(wv) < 4) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='invalid wv size in smoother_apply')
|
||||
goto 9999
|
||||
end if
|
||||
sm%pdegree = sweeps
|
||||
associate(tx => wv(1), ty => wv(2), tz => wv(3), r => wv(4))
|
||||
|
||||
call psb_geaxpby(sone,x,szero,r,desc_data,info)
|
||||
call tx%zero()
|
||||
call ty%zero()
|
||||
call tz%zero()
|
||||
|
||||
select case(sm%variant)
|
||||
case(amg_poly_lottes_)
|
||||
block
|
||||
real(psb_spk_) :: cz, cr
|
||||
! b == x
|
||||
! x == tx
|
||||
!
|
||||
do i=1, sweeps
|
||||
! B r_{k-1}
|
||||
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
|
||||
cz = (2*i*sone-3)/(2*i*sone+sone)
|
||||
cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba)
|
||||
! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1}
|
||||
call psb_geaxpby(cr,ty,cz,tz,desc_data,info)
|
||||
! r_k = b-Ax_k = x -A tx
|
||||
call psb_geaxpby(sone,tz,sone,tx,desc_data,info)
|
||||
if (.false.) then
|
||||
call psb_geaxpby(sone,x,szero,r,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_)
|
||||
else
|
||||
call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_)
|
||||
end if
|
||||
!!$ res = psb_genrm2(r,desc_data,info)
|
||||
!!$ write(0,*) 'Polynomial smoother ',i,res
|
||||
! x_k = x_{k-1} + z_k
|
||||
end do
|
||||
end block
|
||||
|
||||
case(amg_poly_lottes_beta_)
|
||||
|
||||
block
|
||||
real(psb_spk_) :: cz, cr
|
||||
! b == x
|
||||
! x == tx
|
||||
!
|
||||
if (allocated(sm%poly_beta)) then
|
||||
if (size(sm%poly_beta) /= sweeps) deallocate(sm%poly_beta)
|
||||
end if
|
||||
if (.not.allocated(sm%poly_beta)) then
|
||||
call psb_realloc(sweeps,sm%poly_beta,info)
|
||||
sm%poly_beta(1:sweeps) = amg_d_poly_beta_mat(1:sweeps,sweeps)
|
||||
end if
|
||||
|
||||
do i=1, sweeps
|
||||
! B r_{k-1}
|
||||
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
|
||||
cz = (2*i*sone-3)/(2*i*sone+sone)
|
||||
cr = (8*i*sone-4)/((2*i*sone+sone)*sm%rho_ba)
|
||||
! z_k = cz z_{k-1} + cr ty = cz z_{k-1} + cr Br_{k-1}
|
||||
call psb_geaxpby(cr,ty,cz,tz,desc_data,info)
|
||||
! r_k = b-Ax_k = x -A tx
|
||||
call psb_geaxpby(sm%poly_beta(i),tz,sone,tx,desc_data,info)
|
||||
if (.false.) then
|
||||
call psb_geaxpby(sone,x,szero,r,desc_data,info)
|
||||
call psb_spmm(-sone,sm%pa,tx,sone,r,desc_data,info,work=aux,trans=trans_)
|
||||
else
|
||||
call psb_spmm(-sone,sm%pa,tz,sone,r,desc_data,info,work=aux,trans=trans_)
|
||||
end if
|
||||
!!$ res = psb_genrm2(r,desc_data,info)
|
||||
!!$ write(0,*) 'Polynomial smoother ',i,res
|
||||
! x_k = x_{k-1} + z_k
|
||||
end do
|
||||
end block
|
||||
|
||||
case(amg_poly_new_)
|
||||
block
|
||||
real(psb_spk_) :: sigma, theta, delta, rho_old, rho
|
||||
! b == x
|
||||
! x == tx
|
||||
!
|
||||
sm%cf_a = amg_d_poly_a_vect(sweeps)
|
||||
|
||||
theta = (sone+sm%cf_a)/2
|
||||
delta = (sone-sm%cf_a)/2
|
||||
sigma = theta/delta
|
||||
rho_old = sone/sigma
|
||||
call sm%sv%apply(sone,r,szero,ty,desc_data,trans_,aux,wv(5:),info,init='Z')
|
||||
call psb_geaxpby((sone/sm%rho_ba),ty,szero,r,desc_data,info)
|
||||
call psb_geaxpby((sone/theta),r,szero,tz,desc_data,info)
|
||||
! tz == d
|
||||
do i=1, sweeps
|
||||
! x_{k+1} = x_k + d_k
|
||||
call psb_geaxpby(sone,tz,sone,tx,desc_data,info)
|
||||
!
|
||||
! r_{k-1} = r_k - (1/rho(BA)) B A d_k
|
||||
call psb_spmm(sone,sm%pa,tz,szero,ty,desc_data,info,work=aux,trans=trans_)
|
||||
call sm%sv%apply(-sone,ty,sone,r,desc_data,trans_,aux,wv(5:),info,init='Z')
|
||||
|
||||
!
|
||||
! d_{k+1} = (rho rho_old) d_k + 2(rho/delta) r_{k+1}
|
||||
rho = sone/(2*sigma - rho_old)
|
||||
call psb_geaxpby((2*rho/delta),r,(rho*rho_old),tz,desc_data,info)
|
||||
!!$ res = psb_genrm2(r,desc_data,info)
|
||||
!!$ write(0,*) 'Polynomial smoother ',i,res
|
||||
! x_k = x_{k-1} + z_k
|
||||
end do
|
||||
end block
|
||||
|
||||
|
||||
case default
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='wrong polynomial variant')
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
if (info == psb_success_) call psb_geaxpby(alpha,tx,beta,y,desc_data,info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='polynomial smoother')
|
||||
goto 9999
|
||||
end if
|
||||
end associate
|
||||
|
||||
|
||||
|
||||
|
||||
!!$ if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nd_nnz_tot==0))) then
|
||||
!!$ ! if .not.sv%is_iterative, there's no need to pass init
|
||||
!!$ call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ call psb_errpush(psb_err_internal_error_,&
|
||||
!!$ & name,a_err='Error in sub_aply Jacobi Sweeps = 1')
|
||||
!!$ goto 9999
|
||||
!!$ endif
|
||||
!!$
|
||||
!!$ else if (sweeps >= 0) then
|
||||
!!$ select type (smsv => sm%sv)
|
||||
!!$ class is (amg_s_diag_solver_type)
|
||||
!!$ !
|
||||
!!$ ! This means we are dealing with a pure Jacobi smoother/solver.
|
||||
!!$ !
|
||||
!!$ associate(tx => wv(1), ty => wv(2))
|
||||
!!$ select case (init_)
|
||||
!!$ case('Z')
|
||||
!!$
|
||||
!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
!!$
|
||||
!!$ case('Y')
|
||||
!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
!!$
|
||||
!!$ 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,x,szero,tx,desc_data,info)
|
||||
!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
!!$
|
||||
!!$ case default
|
||||
!!$ call psb_errpush(psb_err_internal_error_,name,&
|
||||
!!$ & a_err='wrong init to smoother_apply')
|
||||
!!$ goto 9999
|
||||
!!$ end select
|
||||
!!$
|
||||
!!$ do i=1, sweeps-1
|
||||
!!$ !
|
||||
!!$ ! Compute Y(j+1) = Y(j)+ D^(-1)*(X-A*Y(j)),
|
||||
!!$ ! where is the diagonal and A the matrix.
|
||||
!!$ !
|
||||
!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%pa,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) exit
|
||||
!!$
|
||||
!!$ call sm%sv%apply(sone,tx,sone,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) exit
|
||||
!!$
|
||||
!!$ if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
!!$ call psb_geaxpby(sone,x,szero,r,r,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info)
|
||||
!!$ res = psb_genrm2(r,desc_data,info)
|
||||
!!$ if( sm%printres ) then
|
||||
!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
!!$ end if
|
||||
!!$ if ( res < sm%tol*resdenum ) then
|
||||
!!$ if( (sm%printres).and.(mod(sm%printiter,sm%checkiter)/=0) ) &
|
||||
!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
!!$ exit
|
||||
!!$ end if
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end do
|
||||
!!$
|
||||
!!$
|
||||
!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ info=psb_err_internal_error_
|
||||
!!$ call psb_errpush(info,name,&
|
||||
!!$ & a_err='subsolve with Jacobi sweeps > 1')
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$
|
||||
!!$ end associate
|
||||
!!$
|
||||
!!$ class default
|
||||
!!$ !
|
||||
!!$ !
|
||||
!!$ ! Apply multiple sweeps of a block-Jacobi solver
|
||||
!!$ ! to compute an approximate solution of a linear system.
|
||||
!!$ !
|
||||
!!$ !
|
||||
!!$ if (size(wv) < 2) then
|
||||
!!$ info = psb_err_internal_error_
|
||||
!!$ call psb_errpush(info,name,&
|
||||
!!$ & a_err='invalid wv size in smoother_apply')
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$ associate(tx => wv(1), ty => wv(2))
|
||||
!!$
|
||||
!!$ !
|
||||
!!$ ! Unroll the first iteration and fold it inside SELECT CASE
|
||||
!!$ ! this will save one AXPBY and one SPMM when INIT=Z, and will be
|
||||
!!$ ! significant when sweeps=1 (a common case)
|
||||
!!$ !
|
||||
!!$ select case (init_)
|
||||
!!$ case('Z')
|
||||
!!$
|
||||
!!$ call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
|
||||
!!$
|
||||
!!$ case('Y')
|
||||
!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
!!$ call psb_geaxpby(sone,y,szero,ty,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
!!$
|
||||
!!$ 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,x,szero,tx,desc_data,info)
|
||||
!!$ call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
!!$
|
||||
!!$ case default
|
||||
!!$ call psb_errpush(psb_err_internal_error_,name,&
|
||||
!!$ & a_err='wrong init to smoother_apply')
|
||||
!!$ goto 9999
|
||||
!!$ end select
|
||||
!!$
|
||||
!!$ do i=1, sweeps-1
|
||||
!!$ !
|
||||
!!$ ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
|
||||
!!$ ! block diagonal part and the remaining part of the local matrix
|
||||
!!$ ! and Y(j) is the approximate solution at sweep j.
|
||||
!!$ !
|
||||
!!$ call psb_geaxpby(sone,x,szero,tx,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) exit
|
||||
!!$
|
||||
!!$ call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) exit
|
||||
!!$
|
||||
!!$ if ( sm%checkres.and.(mod(i,sm%checkiter) == 0) ) then
|
||||
!!$ call psb_geaxpby(sone,x,szero,r,r,desc_data,info)
|
||||
!!$ call psb_spmm(-sone,sm%pa,ty,sone,r,desc_data,info)
|
||||
!!$ res = psb_genrm2(r,desc_data,info)
|
||||
!!$ if( sm%printres ) then
|
||||
!!$ call log_conv("BJAC",me,i,sm%printiter,res,resdenum,sm%tol)
|
||||
!!$ end if
|
||||
!!$ if (res < sm%tol*resdenum ) then
|
||||
!!$ if( (sm%printres).and.( mod(sm%printiter,sm%checkiter) /=0 ) ) &
|
||||
!!$ & call log_conv("BJAC",me,i,1,res,resdenum,sm%tol)
|
||||
!!$ exit
|
||||
!!$ end if
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end do
|
||||
!!$
|
||||
!!$ if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
|
||||
!!$
|
||||
!!$ if (info /= psb_success_) then
|
||||
!!$ info=psb_err_internal_error_
|
||||
!!$ call psb_errpush(info,name,&
|
||||
!!$ & a_err='subsolve with Jacobi sweeps > 1')
|
||||
!!$ goto 9999
|
||||
!!$ end if
|
||||
!!$
|
||||
!!$ end associate
|
||||
!!$ end select
|
||||
!!$
|
||||
!!$ else
|
||||
!!$
|
||||
!!$ info = psb_err_iarg_neg_
|
||||
!!$ call psb_errpush(info,name,&
|
||||
!!$ & i_err=(/itwo,sweeps,izero,izero,izero/))
|
||||
!!$ goto 9999
|
||||
!!$
|
||||
!!$ endif
|
||||
!!$
|
||||
if (.not.(4*n_col <= size(work))) then
|
||||
deallocate(aux)
|
||||
endif
|
||||
|
||||
!!$ if(sm%checkres) then
|
||||
!!$ call psb_gefree(r,desc_data,info)
|
||||
!!$ end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_s_poly_smoother_apply_vect
|
||||
@ -0,0 +1,180 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_diag_solver
|
||||
use amg_s_l1_diag_solver
|
||||
use amg_d_poly_coeff_mod
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_bld
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(psb_sspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
! Local variables
|
||||
type(psb_sspmat_type) :: tmpa
|
||||
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nzeros
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
real(psb_spk_), allocatable :: da(:), dsv(:)
|
||||
integer(psb_ipk_) :: np, me, i, err_act, debug_unit, debug_level
|
||||
character(len=20) :: name='d_poly_smoother_bld', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt, me, np)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' start'
|
||||
|
||||
|
||||
n_row = desc_a%get_local_rows()
|
||||
n_col = desc_a%get_local_cols()
|
||||
nrow_a = a%get_nrows()
|
||||
nztota = a%get_nzeros()
|
||||
if (.false.) then
|
||||
select case(sm%variant)
|
||||
case(amg_poly_lottes_)
|
||||
! do nothing
|
||||
case(amg_poly_lottes_beta_)
|
||||
if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then
|
||||
call psb_realloc(sm%pdegree,sm%poly_beta,info)
|
||||
sm%poly_beta(1:sm%pdegree) = amg_d_poly_beta_mat(1:sm%pdegree,sm%pdegree)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='invalid sm%degree for poly_beta')
|
||||
goto 9999
|
||||
end if
|
||||
case(amg_poly_new_)
|
||||
|
||||
if ((1<=sm%pdegree).and.(sm%pdegree<=30)) then
|
||||
!Ok
|
||||
sm%cf_a = amg_d_poly_a_vect(sm%pdegree)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='invalid sm%degree for poly_a')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
case default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='invalid sm%variant')
|
||||
goto 9999
|
||||
end select
|
||||
end if
|
||||
sm%pa => a
|
||||
if (.not.allocated(sm%sv)) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name,&
|
||||
& a_err='unallocated sm%sv')
|
||||
goto 9999
|
||||
end if
|
||||
call sm%sv%build(a,desc_a,info,amold=amold,vmold=vmold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='sv%build')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
!!$ if (.false.) then
|
||||
!!$ select type(ssv => sm%sv)
|
||||
!!$ class is(amg_s_l1_diag_solver_type)
|
||||
!!$ da = a%arwsum(info)
|
||||
!!$ dsv = ssv%dv%get_vect()
|
||||
!!$ sm%rho_ba = maxval(da(1:n_row)*dsv(1:n_row))
|
||||
!!$ class default
|
||||
!!$ write(0,*) 'PolySmoother BUILD: only L1-Jacobi/L1-DIAG for now ',ssv%get_fmt()
|
||||
!!$ sm%rho_ba = sone
|
||||
!!$ end select
|
||||
!!$ else
|
||||
if (sm%rho_ba <= szero) then
|
||||
select case(sm%rho_estimate)
|
||||
case(amg_poly_rho_est_power_)
|
||||
block
|
||||
type(psb_s_vect_type) :: tq, tt, tz,wv(2)
|
||||
real(psb_spk_) :: znrm, lambda
|
||||
real(psb_spk_),allocatable :: work(:)
|
||||
integer(psb_ipk_) :: i, n_cols
|
||||
n_cols = desc_a%get_local_cols()
|
||||
allocate(work(4*n_cols))
|
||||
call psb_geasb(tz,desc_a,info,mold=vmold,scratch=.true.)
|
||||
call psb_geasb(tt,desc_a,info,mold=vmold,scratch=.true.)
|
||||
call psb_geasb(wv(1),desc_a,info,mold=vmold,scratch=.true.)
|
||||
call psb_geasb(wv(2),desc_a,info,mold=vmold,scratch=.true.)
|
||||
call psb_geall(tq,desc_a,info)
|
||||
call tq%set(sone)
|
||||
call psb_geasb(tq,desc_a,info,mold=vmold)
|
||||
call psb_spmm(sone,a,tq,szero,tt,desc_a,info) !
|
||||
call sm%sv%apply_v(sone,tt,szero,tz,desc_a,'NoTrans',work,wv,info) ! z_{k+1} = BA q_k
|
||||
do i=1,sm%rho_estimate_iterations
|
||||
znrm = psb_genrm2(tz,desc_a,info) ! znrm = |z_k|_2
|
||||
call psb_geaxpby((sone/znrm),tz,szero,tq,desc_a,info) ! q_k = z_k/znrm
|
||||
call psb_spmm(sone,a,tq,szero,tt,desc_a,info) ! t_{k+1} = BA q_k
|
||||
call sm%sv%apply_v(sone,tt,szero,tz,desc_a,'NoTrans',work,wv,info) ! z_{k+1} = B t_{k+1}
|
||||
lambda = psb_gedot(tq,tz,desc_a,info) ! lambda = q_k^T z_{k+1} = q_k^T BA q_k
|
||||
!write(0,*) 'BLD: lambda estimate ',i,lambda
|
||||
end do
|
||||
sm%rho_ba = lambda
|
||||
end block
|
||||
case default
|
||||
write(0,*) ' Unknown algorithm for RHO(BA) estimate, defaulting to a value of 1.0 '
|
||||
sm%rho_ba = sone
|
||||
end select
|
||||
end if
|
||||
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),' end'
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_s_poly_smoother_bld
|
||||
@ -0,0 +1,70 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_clear_data(sm,info)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_clear_data
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='amg_s_poly_smoother_clear_data'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
sm%pdegree = 0
|
||||
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
|
||||
sm%pa => null()
|
||||
if ((info==0).and.allocated(sm%sv)) then
|
||||
call sm%sv%clear_data(info)
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_poly_smoother_clear_data
|
||||
@ -0,0 +1,90 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_clone(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_clone
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (allocated(smout)) then
|
||||
call smout%free(info)
|
||||
if (info == psb_success_) deallocate(smout, stat=info)
|
||||
end if
|
||||
if (info == psb_success_) &
|
||||
& allocate(amg_s_poly_smoother_type :: smout, stat=info)
|
||||
if (info /= 0) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
select type(smo => smout)
|
||||
type is (amg_s_poly_smoother_type)
|
||||
smo%pdegree = sm%pdegree
|
||||
smo%rho_ba = sm%rho_ba
|
||||
smo%poly_beta = sm%poly_beta
|
||||
smo%pa => sm%pa
|
||||
if ((info==psb_success_).and.(allocated(sm%sv))) then
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == psb_success_) call sm%sv%clone(smo%sv,info)
|
||||
end if
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_poly_smoother_clone
|
||||
@ -0,0 +1,102 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! asd on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_clone_settings(sm,smout,info)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_clone_settings
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
class(amg_s_base_smoother_type), intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_poly_smoother_clone_settings'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = psb_success_
|
||||
|
||||
select type(smout)
|
||||
class is(amg_s_poly_smoother_type)
|
||||
|
||||
smout%pa => null()
|
||||
smout%pdegree = sm%pdegree
|
||||
smout%variant = sm%variant
|
||||
smout%cf_a = sm%cf_a
|
||||
smout%rho_ba = sm%rho_ba
|
||||
smout%rho_estimate = sm%rho_estimate
|
||||
smout%rho_estimate_iterations = sm%rho_estimate_iterations
|
||||
smout%poly_beta = sm%poly_beta
|
||||
|
||||
if (allocated(smout%sv)) then
|
||||
if (.not.same_type_as(sm%sv,smout%sv)) then
|
||||
call smout%sv%free(info)
|
||||
if (info == 0) deallocate(smout%sv,stat=info)
|
||||
end if
|
||||
end if
|
||||
if (info /= 0) then
|
||||
info = psb_err_internal_error_
|
||||
else
|
||||
if (allocated(smout%sv)) then
|
||||
if (same_type_as(sm%sv,smout%sv)) then
|
||||
call sm%sv%clone_settings(smout%sv,info)
|
||||
else
|
||||
info = psb_err_internal_error_
|
||||
end if
|
||||
else
|
||||
allocate(smout%sv,mold=sm%sv,stat=info)
|
||||
if (info == 0) call sm%sv%clone_settings(smout%sv,info)
|
||||
if (info /= 0) info = psb_err_internal_error_
|
||||
end if
|
||||
end if
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
end select
|
||||
|
||||
if (info /= 0) then
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_poly_smoother_clone_settings
|
||||
@ -0,0 +1,77 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_diag_solver
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_cnv
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: i, err_act, debug_unit, debug_level
|
||||
character(len=20) :: name='d_poly_smoother_cnv', ch_err
|
||||
|
||||
info=psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
debug_unit = psb_get_debug_unit()
|
||||
debug_level = psb_get_debug_level()
|
||||
|
||||
|
||||
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%cnv(info,amold=amold,vmold=vmold,imold=imold)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,&
|
||||
& a_err='solver cnv')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine amg_s_poly_smoother_cnv
|
||||
@ -0,0 +1,76 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_csetc(sm,what,val,info,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_csetc
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, ival
|
||||
character(len=20) :: name='d_poly_smoother_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
case('POLY_VARIANT')
|
||||
call sm%set(what,amg_stringval(val),info,idx=idx)
|
||||
case('POLY_RHO_ESTIMATE')
|
||||
call sm%set(what,amg_stringval(val),info,idx=idx)
|
||||
case default
|
||||
call sm%amg_s_base_smoother_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
call psb_errpush(info, name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_poly_smoother_csetc
|
||||
@ -0,0 +1,92 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_cseti(sm,what,val,info,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_poly_smoother, amg_protect_nam => amg_s_poly_smoother_cseti
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_poly_smoother_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('POLY_DEGREE')
|
||||
sm%pdegree = val
|
||||
case('POLY_VARIANT')
|
||||
select case(val)
|
||||
case(amg_poly_lottes_,amg_poly_lottes_beta_,amg_poly_new_)
|
||||
sm%variant = val
|
||||
case default
|
||||
write(0,*) 'Invalid choice for POLY_VARIANT, defaulting to amg_poly_lottes_',val
|
||||
sm%variant = amg_poly_lottes_
|
||||
end select
|
||||
case('POLY_RHO_ESTIMATE')
|
||||
select case(val)
|
||||
case (amg_poly_rho_est_power_)
|
||||
sm%rho_estimate = val
|
||||
case default
|
||||
write(0,*) 'Invalid choice for POLY_RHO_ESTIMATE, defaulting to amg_poly_rho_power'
|
||||
sm%variant = amg_poly_rho_est_power_
|
||||
end select
|
||||
case('POLY_RHO_ESTIMATE_ITERATIONS')
|
||||
if (val>0) then
|
||||
sm%rho_estimate_iterations = val
|
||||
else
|
||||
write(0,*) 'Invalid choice for POLY_RHO_ESTIMATE_ITERATIONS, defaulting to 20'
|
||||
sm%variant = 20
|
||||
end if
|
||||
case default
|
||||
call sm%amg_s_base_smoother_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_poly_smoother_cseti
|
||||
@ -0,0 +1,74 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_csetr(sm,what,val,info,idx)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_poly_smoother, amg_protect_nam => amg_s_poly_smoother_csetr
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_poly_smoother_csetr'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('POLY_RHO_BA')
|
||||
if ((szero<val).and.(val<=sone)) then
|
||||
sm%rho_ba = val
|
||||
else
|
||||
write(0,*) 'Invalid choice for POLY_RHO_BA, defaulting to compute estimate'
|
||||
sm%rho_ba = -sone
|
||||
end if
|
||||
case default
|
||||
call sm%amg_s_base_smoother_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine amg_s_poly_smoother_csetr
|
||||
@ -0,0 +1,108 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_diag_solver
|
||||
use amg_s_poly_smoother, amg_protect_name => amg_s_poly_smoother_descr
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_s_poly_smoother_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
logical :: coarse_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(coarse)) then
|
||||
coarse_ = coarse
|
||||
else
|
||||
coarse_ = .false.
|
||||
end if
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
write(iout_,*) trim(prefix_), ' Polynomial smoother '
|
||||
select case(sm%variant)
|
||||
case(amg_poly_lottes_)
|
||||
write(iout_,*) trim(prefix_), ' variant: ','POLY_LOTTES'
|
||||
!write(iout_,*) trim(prefix_), ' Degree: ',sm%pdegree
|
||||
write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba
|
||||
case(amg_poly_lottes_beta_)
|
||||
write(iout_,*) trim(prefix_), ' variant: ','POLY_LOTTES_BETA'
|
||||
!write(iout_,*) trim(prefix_), ' Degree: ',sm%pdegree
|
||||
write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba
|
||||
!if (allocated(sm%poly_beta)) write(iout_,*) trim(prefix_), ' Coefficients: ',sm%poly_beta(1:sm%pdegree)
|
||||
case(amg_poly_new_)
|
||||
write(iout_,*) trim(prefix_), ' variant: ','POLY_NEW'
|
||||
!write(iout_,*) trim(prefix_), ' Degree: ',sm%pdegree
|
||||
write(iout_,*) trim(prefix_), ' rho_ba: ',sm%rho_ba
|
||||
!write(iout_,*) trim(prefix_), ' Coefficient: ',sm%cf_a
|
||||
case default
|
||||
write(iout_,*) trim(prefix_), ' variant: ','UNKNOWN???'
|
||||
end select
|
||||
if (allocated(sm%sv)) then
|
||||
write(iout_,*) trim(prefix_), ' Local solver details:'
|
||||
call sm%sv%descr(info,iout_,coarse=coarse,prefix=prefix)
|
||||
end if
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine amg_s_poly_smoother_descr
|
||||
@ -0,0 +1,90 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
subroutine amg_s_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_s_poly_smoother, amg_protect_nam => amg_s_poly_smoother_dmp
|
||||
implicit none
|
||||
class(amg_s_poly_smoother_type), intent(in) :: sm
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
integer(psb_ipk_) :: i, j, il1, iln, lname, lev
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: iam, np
|
||||
character(len=80) :: prefix_
|
||||
character(len=120) :: fname ! len should be at least 20 more than
|
||||
integer(psb_lpk_), allocatable :: iv(:)
|
||||
logical :: smoother_, global_num_
|
||||
! len of prefix_
|
||||
|
||||
info = 0
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
|
||||
else
|
||||
prefix_ = "dump_smth_d"
|
||||
end if
|
||||
ctxt = desc%get_context()
|
||||
call psb_info(ctxt,iam,np)
|
||||
|
||||
if (present(smoother)) then
|
||||
smoother_ = smoother
|
||||
else
|
||||
smoother_ = .false.
|
||||
end if
|
||||
if (present(global_num)) then
|
||||
global_num_ = global_num
|
||||
else
|
||||
global_num_ = .false.
|
||||
end if
|
||||
lname = len_trim(prefix_)
|
||||
fname = trim(prefix_)
|
||||
write(fname(lname+1:lname+5),'(a,i3.3)') '_poly',iam
|
||||
lname = lname + 8
|
||||
! to be completed
|
||||
|
||||
|
||||
|
||||
! At base level do nothing for the smoother
|
||||
if (allocated(sm%sv)) &
|
||||
& call sm%sv%dump(desc,level,info,solver=solver,prefix=prefix,global_num=global_num)
|
||||
|
||||
end subroutine amg_s_poly_smoother_dmp
|
||||
@ -0,0 +1,89 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
module amg_d_pde2d_gauss_mod
|
||||
use psb_base_mod, only : psb_dpk_, done, dzero
|
||||
real(psb_dpk_), save, private :: epsilon=done/80
|
||||
contains
|
||||
subroutine pde_set_parm2d_gauss(dat)
|
||||
real(psb_dpk_), intent(in) :: dat
|
||||
epsilon = dat
|
||||
end subroutine pde_set_parm2d_gauss
|
||||
!
|
||||
! functions parametrizing the differential equation
|
||||
!
|
||||
function b1_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_dpk_) :: b1_gauss
|
||||
real(psb_dpk_), intent(in) :: x,y
|
||||
b1_gauss=done/sqrt(3.0_psb_dpk_)-2*x*exp(-(x**2+y**2))
|
||||
end function b1_gauss
|
||||
function b2_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_dpk_) :: b2_gauss
|
||||
real(psb_dpk_), intent(in) :: x,y
|
||||
b2_gauss=done/sqrt(3.0_psb_dpk_)-2*y*exp(-(x**2+y**2))
|
||||
end function b2_gauss
|
||||
function c_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_dpk_) :: c_gauss
|
||||
real(psb_dpk_), intent(in) :: x,y
|
||||
c_gauss=dzero
|
||||
end function c_gauss
|
||||
function a1_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_dpk_) :: a1_gauss
|
||||
real(psb_dpk_), intent(in) :: x,y
|
||||
a1_gauss=epsilon*exp(-(x**2+y**2))
|
||||
end function a1_gauss
|
||||
function a2_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_dpk_) :: a2_gauss
|
||||
real(psb_dpk_), intent(in) :: x,y
|
||||
a2_gauss=epsilon*exp(-(x**2+y**2))
|
||||
end function a2_gauss
|
||||
function g_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_dpk_) :: g_gauss
|
||||
real(psb_dpk_), intent(in) :: x,y
|
||||
g_gauss = dzero
|
||||
if (x == done) then
|
||||
g_gauss = done
|
||||
else if (x == dzero) then
|
||||
g_gauss = done
|
||||
end if
|
||||
end function g_gauss
|
||||
end module amg_d_pde2d_gauss_mod
|
||||
@ -0,0 +1,101 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
module amg_d_pde3d_box_mod
|
||||
use psb_base_mod, only : psb_dpk_, done, dzero
|
||||
real(psb_dpk_), save, private :: epsilon=done/80
|
||||
contains
|
||||
subroutine pde_set_parm3d_box(dat)
|
||||
real(psb_dpk_), intent(in) :: dat
|
||||
epsilon = dat
|
||||
end subroutine pde_set_parm3d_box
|
||||
!
|
||||
! functions parametrizing the differential equation
|
||||
!
|
||||
function b1_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: b1_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
b1_box=done/sqrt(3.0_psb_dpk_)
|
||||
end function b1_box
|
||||
function b2_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: b2_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
b2_box=done/sqrt(3.0_psb_dpk_)
|
||||
end function b2_box
|
||||
function b3_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: b3_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
b3_box=done/sqrt(3.0_psb_dpk_)
|
||||
end function b3_box
|
||||
function c_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: c_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
c_box=dzero
|
||||
end function c_box
|
||||
function a1_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: a1_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
a1_box=epsilon
|
||||
end function a1_box
|
||||
function a2_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: a2_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
a2_box=epsilon
|
||||
end function a2_box
|
||||
function a3_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: a3_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
a3_box=epsilon
|
||||
end function a3_box
|
||||
function g_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_dpk_) :: g_box
|
||||
real(psb_dpk_), intent(in) :: x,y,z
|
||||
g_box= dzero
|
||||
if (x == done) then
|
||||
g_box = done
|
||||
else if (x == dzero) then
|
||||
g_box = done
|
||||
end if
|
||||
end function g_box
|
||||
end module amg_d_pde3d_box_mod
|
||||
@ -0,0 +1,89 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
module amg_s_pde2d_gauss_mod
|
||||
use psb_base_mod, only : psb_spk_, sone, szero
|
||||
real(psb_spk_), save, private :: epsilon=sone/80
|
||||
contains
|
||||
subroutine pde_set_parm2d_gauss(dat)
|
||||
real(psb_spk_), intent(in) :: dat
|
||||
epsilon = dat
|
||||
end subroutine pde_set_parm2d_gauss
|
||||
!
|
||||
! functions parametrizing the differential equation
|
||||
!
|
||||
function b1_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_spk_) :: b1_gauss
|
||||
real(psb_spk_), intent(in) :: x,y
|
||||
b1_gauss=sone/sqrt(3.0_psb_spk_)-2*x*exp(-(x**2+y**2))
|
||||
end function b1_gauss
|
||||
function b2_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_spk_) :: b2_gauss
|
||||
real(psb_spk_), intent(in) :: x,y
|
||||
b2_gauss=sone/sqrt(3.0_psb_spk_)-2*y*exp(-(x**2+y**2))
|
||||
end function b2_gauss
|
||||
function c_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_spk_) :: c_gauss
|
||||
real(psb_spk_), intent(in) :: x,y
|
||||
c_gauss=szero
|
||||
end function c_gauss
|
||||
function a1_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_spk_) :: a1_gauss
|
||||
real(psb_spk_), intent(in) :: x,y
|
||||
a1_gauss=epsilon*exp(-(x**2+y**2))
|
||||
end function a1_gauss
|
||||
function a2_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_spk_) :: a2_gauss
|
||||
real(psb_spk_), intent(in) :: x,y
|
||||
a2_gauss=epsilon*exp(-(x**2+y**2))
|
||||
end function a2_gauss
|
||||
function g_gauss(x,y)
|
||||
implicit none
|
||||
real(psb_spk_) :: g_gauss
|
||||
real(psb_spk_), intent(in) :: x,y
|
||||
g_gauss = szero
|
||||
if (x == sone) then
|
||||
g_gauss = sone
|
||||
else if (x == szero) then
|
||||
g_gauss = sone
|
||||
end if
|
||||
end function g_gauss
|
||||
end module amg_s_pde2d_gauss_mod
|
||||
@ -0,0 +1,101 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
module amg_s_pde3d_box_mod
|
||||
use psb_base_mod, only : psb_spk_, sone, szero
|
||||
real(psb_spk_), save, private :: epsilon=sone/80
|
||||
contains
|
||||
subroutine pde_set_parm3d_box(dat)
|
||||
real(psb_spk_), intent(in) :: dat
|
||||
epsilon = dat
|
||||
end subroutine pde_set_parm3d_box
|
||||
!
|
||||
! functions parametrizing the differential equation
|
||||
!
|
||||
function b1_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: b1_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
b1_box=sone/sqrt(3.0_psb_spk_)
|
||||
end function b1_box
|
||||
function b2_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: b2_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
b2_box=sone/sqrt(3.0_psb_spk_)
|
||||
end function b2_box
|
||||
function b3_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: b3_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
b3_box=sone/sqrt(3.0_psb_spk_)
|
||||
end function b3_box
|
||||
function c_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: c_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
c_box=szero
|
||||
end function c_box
|
||||
function a1_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: a1_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
a1_box=epsilon
|
||||
end function a1_box
|
||||
function a2_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: a2_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
a2_box=epsilon
|
||||
end function a2_box
|
||||
function a3_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: a3_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
a3_box=epsilon
|
||||
end function a3_box
|
||||
function g_box(x,y,z)
|
||||
implicit none
|
||||
real(psb_spk_) :: g_box
|
||||
real(psb_spk_), intent(in) :: x,y,z
|
||||
g_box= szero
|
||||
if (x == sone) then
|
||||
g_box = sone
|
||||
else if (x == szero) then
|
||||
g_box = sone
|
||||
end if
|
||||
end function g_box
|
||||
end module amg_s_pde3d_box_mod
|
||||
Loading…
Reference in New Issue