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

Simplified basic preconditioners.

Browse Source
This commit is contained in:
Salvatore Filippone
2007-01-23 17:27:00 +00:00
parent 20d5e2ed40
commit c61e0af41e
23 changed files with 325 additions and 830 deletions
Download Patch File Download Diff File Expand all files Collapse all files
baseprec/Makefile
+2 -2
View File
@@ -6,13 +6,13 @@ MODOBJS= psb_prec_type.o psb_prec_mod.o
F90OBJS= psb_dilu_bld.o psb_dilu_fct.o\
psb_dsp_renum.o\
psb_dprecbld.o psb_dprecfree.o psb_dprecset.o \
psb_dbaseprc_bld.o psb_ddiagsc_bld.o \
psb_ddiagsc_bld.o \
psb_dprc_aply.o \
psb_dbaseprc_aply.o psb_dbjac_aply.o\
psb_zilu_bld.o psb_zilu_fct.o\
psb_zsp_renum.o\
psb_zprecbld.o psb_zprecfree.o psb_zprecset.o \
psb_zbaseprc_bld.o psb_zdiagsc_bld.o \
psb_zdiagsc_bld.o \
psb_zprc_aply.o psb_zbaseprc_aply.o psb_zbjac_aply.o
LIBMOD=psb_prec_mod$(.mod)
baseprec/psb_dbaseprc_aply.f90
+2 -2
View File
@@ -39,7 +39,7 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
implicit none
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbaseprc_type), intent(in) :: prec
type(psb_dprec_type), intent(in) :: prec
real(kind(0.d0)),intent(inout) :: x(:), y(:)
real(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
@@ -61,7 +61,7 @@ subroutine psb_dbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use psb_prec_type
type(psb_desc_type), intent(in) :: desc_data
type(psb_dbaseprc_type), intent(in) :: prec
type(psb_dprec_type), intent(in) :: prec
real(kind(0.d0)),intent(inout) :: x(:), y(:)
real(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
baseprec/psb_dbaseprc_bld.f90
-205
View File
@@ -1,205 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_type
Implicit None
type(psb_dspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_dbaseprc_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
interface psb_diagsc_bld
subroutine psb_ddiagsc_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbaseprc_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_ddiagsc_bld
end interface
interface psb_ilu_bld
subroutine psb_dilu_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbaseprc_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_dilu_bld
end interface
! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:)
integer :: int_err(5)
character :: iupd
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
err=0
call psb_erractionsave(err_act)
name = 'psb_baseprc_bld'
if (debug) write(0,*) 'Entering baseprc_bld'
info = 0
int_err(1) = 0
ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call psb_info(ictxt, me, np)
if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd
if ((UPD.eq.'F').or.(UPD.eq.'T')) then
IUPD=UPD
else
IUPD='F'
endif
else
IUPD='F'
endif
!
! Should add check to ensure all procs have the same...
!
! ALso should define symbolic names for the preconditioners.
!
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
& diagsc_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(p_type_))
case (noprec_)
! Do nothing.
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (diagsc_)
call psb_diagsc_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_diagsc_bld'
if(info /= 0) then
info=4010
ch_err='psb_diagsc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (bja_)
call psb_check_def(p%iprcparm(iren_),'renumbering',&
& renum_none_,is_legal_renum)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call psb_barrier(ictxt)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call psb_barrier(ictxt)
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
case default
info=4010
ch_err='Unknown p_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_dbaseprc_bld
baseprec/psb_dbjac_aply.f90
+2 -2
View File
@@ -41,7 +41,7 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
implicit none
type(psb_desc_type), intent(in) :: desc_data
type(psb_dbaseprc_type), intent(in) :: prec
type(psb_dprec_type), intent(in) :: prec
real(kind(0.d0)),intent(inout) :: x(:), y(:)
real(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
@@ -99,7 +99,7 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999
end if
endif
if (prec%iprcparm(jac_sweeps_) == 1) then
baseprec/psb_ddiagsc_bld.f90
+1 -1
View File
@@ -36,7 +36,7 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
type(psb_dspmat_type), target :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dbaseprc_type),intent(inout) :: p
type(psb_dprec_type),intent(inout) :: p
character, intent(in) :: upd
integer, intent(out) :: info
baseprec/psb_dilu_bld.f90
+2 -3
View File
@@ -37,7 +37,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
integer, intent(out) :: info
! .. array Arguments ..
type(psb_dspmat_type), intent(in), target :: a
type(psb_dbaseprc_type), intent(inout) :: p
type(psb_dprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
@@ -74,7 +74,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
! .. array Arguments ..
type(psb_dspmat_type), intent(in) :: a
type(psb_dspmat_type), intent(inout) :: atmp
type(psb_dbaseprc_type), intent(inout) :: p
type(psb_dprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
end subroutine psb_dsp_renum
@@ -266,7 +266,6 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
if (debug) write(0,*) me,'End of ilu_bld'
call psb_erractionrestore(err_act)
return
baseprec/psb_dprc_aply.f90
+3 -10
View File
@@ -54,7 +54,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
use psb_base_mod
use psb_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbaseprc_type), intent(in) :: prec
type(psb_dprec_type), intent(in) :: prec
real(kind(0.d0)),intent(inout) :: x(:), y(:)
real(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
@@ -86,15 +86,8 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
end if
end if
if (.not.(allocated(prec%baseprecv))) then
write(0,*) 'Inconsistent preconditioner: neither SMTH nor BASE?'
end if
if (size(prec%baseprecv) == 1) then
call psb_baseprc_aply(done,prec%baseprecv(1),x,dzero,y,desc_data,trans_, work_,info)
else
write(0,*) 'Inconsistent preconditioner: size of baseprecv???'
endif
call psb_baseprc_aply(done,prec,x,dzero,y,desc_data,trans_,work_,info)
if (present(work)) then
else
baseprec/psb_dprecbld.f90
+114 -38
View File
@@ -32,7 +32,6 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_type
use psb_prec_mod, only : psb_baseprc_bld
Implicit None
type(psb_dspmat_type), target :: a
@@ -41,8 +40,35 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
integer, intent(out) :: info
character, intent(in), optional :: upd
interface psb_diagsc_bld
subroutine psb_ddiagsc_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_dprec_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_ddiagsc_bld
end interface
interface psb_ilu_bld
subroutine psb_dilu_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_dprec_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_dilu_bld
end interface
! Local scalars
Integer :: err,i,j,k,ictxt, me,np,lw, err_act
Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:)
integer :: int_err(5)
character :: iupd
@@ -74,35 +100,100 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
else
iupd='F'
endif
if (.not.allocated(p%baseprecv)) then
!! Error 1: should call precset
info=4010
ch_err='unallocated bpv'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a)
!
! Should add check to ensure all procs have the same...
!
! ALso should define symbolic names for the preconditioners.
!
call init_baseprc_av(p%baseprecv(1),info)
if (info /= 0) then
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
& diagsc_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(p_type_))
case (noprec_)
! Do nothing.
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (diagsc_)
call psb_diagsc_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_diagsc_bld'
if(info /= 0) then
info=4010
ch_err='psb_diagsc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (bja_)
call psb_check_def(p%iprcparm(iren_),'renumbering',&
& renum_none_,is_legal_renum)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call psb_barrier(ictxt)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(p%av(max_avsz),stat=info)
if(info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld',info
if (debug) call psb_barrier(ictxt)
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
case default
info=4010
ch_err='allocate'
ch_err='Unknown p_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
if (info /= 0) then
info=4010
ch_err='baseprc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
end select
call psb_erractionrestore(err_act)
return
@@ -115,21 +206,6 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
end if
return
contains
subroutine init_baseprc_av(p,info)
type(psb_dbaseprc_type), intent(inout) :: p
integer :: info
if (allocated(p%av)) then
! Have not decided what to do yet
end if
allocate(p%av(max_avsz),stat=info)
!!$ if (info /= 0) return
do k=1,size(p%av)
call psb_nullify_sp(p%av(k))
end do
end subroutine init_baseprc_av
end subroutine psb_dprecbld
baseprec/psb_dprecfree.f90
+1 -7
View File
@@ -48,13 +48,7 @@ subroutine psb_dprecfree(p,info)
call psb_erractionsave(err_act)
me=-1
if (allocated(p%baseprecv)) then
do i=1,size(p%baseprecv)
call psb_base_precfree(p%baseprecv(i),info)
end do
deallocate(p%baseprecv)
end if
call psb_base_precfree(p,info)
call psb_erractionrestore(err_act)
return
baseprec/psb_dprecset.f90
+20 -35
View File
@@ -28,7 +28,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
subroutine psb_dprecset(p,ptype,info,iv,rs,rv)
use psb_base_mod
use psb_prec_type
@@ -37,7 +37,6 @@ subroutine psb_dprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
character(len=*), intent(in) :: ptype
integer, intent(out) :: info
integer, optional, intent(in) :: iv(:)
integer, optional, intent(in) :: nlev,ilev
real(kind(1.d0)), optional, intent(in) :: rs
real(kind(1.d0)), optional, intent(in) :: rv(:)
@@ -46,48 +45,34 @@ subroutine psb_dprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
info = 0
ilev_ = 1
nlev_ = 1
if (.not.allocated(p%baseprecv)) then
allocate(p%baseprecv(nlev_),stat=err)
else
nlev_ = size(p%baseprecv)
endif
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
info = -1
return
endif
call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
call psb_realloc(ifpsz,p%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%iprcparm(:) = 0
select case(toupper(ptype(1:len_trim(ptype))))
case ('NONE','NOPREC')
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = noprec_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%iprcparm(:) = 0
p%iprcparm(p_type_) = noprec_
p%iprcparm(f_type_) = f_none_
p%iprcparm(iren_) = 0
p%iprcparm(jac_sweeps_) = 1
case ('DIAG','DIAGSC')
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = diagsc_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%iprcparm(:) = 0
p%iprcparm(p_type_) = diagsc_
p%iprcparm(f_type_) = f_none_
p%iprcparm(iren_) = 0
p%iprcparm(jac_sweeps_) = 1
case ('BJA','ILU')
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = bja_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%iprcparm(:) = 0
p%iprcparm(p_type_) = bja_
p%iprcparm(f_type_) = f_ilu_n_
p%iprcparm(iren_) = 0
p%iprcparm(ilu_fill_in_) = 0
p%iprcparm(jac_sweeps_) = 1
case default
write(0,*) 'Unknown preconditioner type request "',ptype,'"'
baseprec/psb_dsp_renum.f90
+1 -1
View File
@@ -36,7 +36,7 @@ subroutine psb_dsp_renum(a,desc_a,p,atmp,info)
! .. array Arguments ..
type(psb_dspmat_type), intent(in) :: a
type(psb_dspmat_type), intent(inout) :: atmp
type(psb_dbaseprc_type), intent(inout) :: p
type(psb_dprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
baseprec/psb_prec_mod.f90
+2 -25
View File
@@ -56,7 +56,7 @@ module psb_prec_mod
end interface
interface psb_precset
subroutine psb_dprecset(prec,ptype,info,iv,rs,rv,ilev,nlev)
subroutine psb_dprecset(prec,ptype,info,iv,rs,rv)
use psb_base_mod
use psb_prec_type
implicit none
@@ -64,11 +64,10 @@ module psb_prec_mod
character(len=*), intent(in) :: ptype
integer, intent(out) :: info
integer, optional, intent(in) :: iv(:)
integer, optional, intent(in) :: nlev,ilev
real(kind(1.d0)), optional, intent(in) :: rs
real(kind(1.d0)), optional, intent(in) :: rv(:)
end subroutine psb_dprecset
subroutine psb_zprecset(prec,ptype,info,iv,rs,rv,ilev,nlev)
subroutine psb_zprecset(prec,ptype,info,iv,rs,rv)
use psb_base_mod
use psb_prec_type
implicit none
@@ -78,7 +77,6 @@ module psb_prec_mod
integer, optional, intent(in) :: iv(:)
real(kind(1.d0)), optional, intent(in) :: rs
real(kind(1.d0)), optional, intent(in) :: rv(:)
integer, optional, intent(in) :: nlev,ilev
end subroutine psb_zprecset
end interface
@@ -139,25 +137,4 @@ module psb_prec_mod
end subroutine psb_zprc_aply1
end interface
interface psb_baseprc_bld
subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_type
type(psb_dspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_dbaseprc_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine psb_dbaseprc_bld
subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_type
type(psb_zspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_zbaseprc_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine psb_zbaseprc_bld
end interface
end module psb_prec_mod
baseprec/psb_prec_type.f90
+28 -201
View File
@@ -60,38 +60,23 @@ module psb_prec_type
integer, parameter :: smth_avsz=6, max_avsz=smth_avsz
type psb_dbaseprc_type
type psb_dprec_type
type(psb_dspmat_type), allocatable :: av(:)
real(kind(1.d0)), allocatable :: d(:)
type(psb_desc_type) :: desc_data
integer, allocatable :: iprcparm(:)
real(kind(1.d0)), allocatable :: dprcparm(:)
integer, allocatable :: perm(:), invperm(:)
end type psb_dbaseprc_type
type psb_dprec_type
type(psb_dbaseprc_type), allocatable :: baseprecv(:)
! contain type of preconditioning to be performed
integer :: prec, base_prec
end type psb_dprec_type
type psb_zbaseprc_type
type psb_zprec_type
type(psb_zspmat_type), allocatable :: av(:)
complex(kind(1.d0)), allocatable :: d(:)
type(psb_desc_type) :: desc_data
integer, allocatable :: iprcparm(:)
real(kind(1.d0)), allocatable :: dprcparm(:)
integer, allocatable :: perm(:), invperm(:)
end type psb_zbaseprc_type
type psb_zprec_type
type(psb_zbaseprc_type), allocatable :: baseprecv(:)
! contain type of preconditioning to be performed
integer :: prec, base_prec
end type psb_zprec_type
@@ -117,10 +102,6 @@ module psb_prec_type
& psb_zout_prec_descr, psb_zfile_prec_descr
end interface
interface psb_prec_short_descr
module procedure psb_prec_short_descr, psb_zprec_short_descr
end interface
contains
subroutine psb_out_prec_descr(p)
@@ -137,191 +118,38 @@ contains
integer, intent(in) :: iout
type(psb_dprec_type), intent(in) :: p
integer :: ilev
write(iout,*) 'Preconditioner description'
if (allocated(p%baseprecv)) then
if (size(p%baseprecv)>=1) then
write(iout,*) 'Base preconditioner'
select case(p%baseprecv(1)%iprcparm(p_type_))
case(noprec_)
write(iout,*) 'No preconditioning'
case(diagsc_)
write(iout,*) 'Diagonal scaling'
case(bja_)
write(iout,*) 'Block Jacobi with: ',&
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
end select
end if
else
write(iout,*) 'No Base preconditioner available, something is wrong!'
return
endif
write(iout,*) 'Base preconditioner'
select case(p%iprcparm(p_type_))
case(noprec_)
write(iout,*) 'No preconditioning'
case(diagsc_)
write(iout,*) 'Diagonal scaling'
case(bja_)
write(iout,*) 'Block Jacobi with: ',&
& fact_names(p%iprcparm(f_type_))
end select
end subroutine psb_file_prec_descr
function psb_prec_short_descr(p)
type(psb_dprec_type), intent(in) :: p
character(len=20) :: psb_prec_short_descr
psb_prec_short_descr = ' '
!!$ write(iout,*) 'Preconditioner description'
!!$ if (associated(p%baseprecv)) then
!!$ if (size(p%baseprecv)>=1) then
!!$ write(iout,*) 'Base preconditioner'
!!$ select case(p%baseprecv(1)%iprcparm(p_type_))
!!$ case(noprec_)
!!$ write(iout,*) 'No preconditioning'
!!$ case(diagsc_)
!!$ write(iout,*) 'Diagonal scaling'
!!$ case(bja_)
!!$ write(iout,*) 'Block Jacobi with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ case(asm_,ras_,ash_,rash_)
!!$ write(iout,*) 'Additive Schwarz with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ write(iout,*) 'Overlap:',&
!!$ & p%baseprecv(1)%iprcparm(n_ovr_)
!!$ write(iout,*) 'Restriction: ',&
!!$ & restrict_names(p%baseprecv(1)%iprcparm(restr_))
!!$ write(iout,*) 'Prolongation: ',&
!!$ & prolong_names(p%baseprecv(1)%iprcparm(prol_))
!!$ end select
!!$ end if
!!$ if (size(p%baseprecv)>=2) then
!!$ if (.not.associated(p%baseprecv(2)%iprcparm)) then
!!$ write(iout,*) 'Inconsistent MLPREC part!'
!!$ return
!!$ endif
!!$ write(iout,*) 'Multilevel: ',ml_names(p%baseprecv(2)%iprcparm(ml_type_))
!!$ if (p%baseprecv(2)%iprcparm(ml_type_)>no_ml_) then
!!$ write(iout,*) 'Multilevel aggregation: ', &
!!$ & aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
!!$ write(iout,*) 'Smoother: ', &
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
!!$ write(iout,*) 'Smoothing position: ',&
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
!!$ write(iout,*) 'Coarse matrix: ',&
!!$ & matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
!!$ write(iout,*) 'Factorization type: ',&
!!$ & fact_names(p%baseprecv(2)%iprcparm(f_type_))
!!$ select case(p%baseprecv(2)%iprcparm(f_type_))
!!$ case(f_ilu_n_)
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
!!$ case(f_ilu_e_)
!!$ write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
!!$ case(f_slu_,f_umf_)
!!$ case default
!!$ write(iout,*) 'Should never get here!'
!!$ end select
!!$ write(iout,*) 'Number of Jacobi sweeps: ', &
!!$ & (p%baseprecv(2)%iprcparm(jac_sweeps_))
!!$
!!$ end if
!!$ end if
!!$
!!$ else
!!$ write(iout,*) 'No Base preconditioner available, something is wrong!'
!!$ return
!!$ endif
end function psb_prec_short_descr
subroutine psb_zfile_prec_descr(iout,p)
integer, intent(in) :: iout
type(psb_zprec_type), intent(in) :: p
write(iout,*) 'Preconditioner description'
if (allocated(p%baseprecv)) then
if (size(p%baseprecv)>=1) then
write(iout,*) 'Base preconditioner'
select case(p%baseprecv(1)%iprcparm(p_type_))
case(noprec_)
write(iout,*) 'No preconditioning'
case(diagsc_)
write(iout,*) 'Diagonal scaling'
case(bja_)
write(iout,*) 'Block Jacobi with: ',&
& fact_names(p%baseprecv(1)%iprcparm(f_type_))
end select
end if
else
write(iout,*) 'No Base preconditioner available, something is wrong!'
return
endif
write(iout,*) 'Base preconditioner'
select case(p%iprcparm(p_type_))
case(noprec_)
write(iout,*) 'No preconditioning'
case(diagsc_)
write(iout,*) 'Diagonal scaling'
case(bja_)
write(iout,*) 'Block Jacobi with: ',&
& fact_names(p%iprcparm(f_type_))
end select
end subroutine psb_zfile_prec_descr
function psb_zprec_short_descr(p)
type(psb_zprec_type), intent(in) :: p
character(len=20) :: psb_zprec_short_descr
psb_zprec_short_descr = ' '
!!$ write(iout,*) 'Preconditioner description'
!!$ if (associated(p%baseprecv)) then
!!$ if (size(p%baseprecv)>=1) then
!!$ write(iout,*) 'Base preconditioner'
!!$ select case(p%baseprecv(1)%iprcparm(p_type_))
!!$ case(noprec_)
!!$ write(iout,*) 'No preconditioning'
!!$ case(diagsc_)
!!$ write(iout,*) 'Diagonal scaling'
!!$ case(bja_)
!!$ write(iout,*) 'Block Jacobi with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ case(asm_,ras_,ash_,rash_)
!!$ write(iout,*) 'Additive Schwarz with: ',&
!!$ & fact_names(p%baseprecv(1)%iprcparm(f_type_))
!!$ write(iout,*) 'Overlap:',&
!!$ & p%baseprecv(1)%iprcparm(n_ovr_)
!!$ write(iout,*) 'Restriction: ',&
!!$ & restrict_names(p%baseprecv(1)%iprcparm(restr_))
!!$ write(iout,*) 'Prolongation: ',&
!!$ & prolong_names(p%baseprecv(1)%iprcparm(prol_))
!!$ end select
!!$ end if
!!$ if (size(p%baseprecv)>=2) then
!!$ if (.not.associated(p%baseprecv(2)%iprcparm)) then
!!$ write(iout,*) 'Inconsistent MLPREC part!'
!!$ return
!!$ endif
!!$ write(iout,*) 'Multilevel: ',ml_names(p%baseprecv(2)%iprcparm(ml_type_))
!!$ if (p%baseprecv(2)%iprcparm(ml_type_)>no_ml_) then
!!$ write(iout,*) 'Multilevel aggregation: ', &
!!$ & aggr_names(p%baseprecv(2)%iprcparm(aggr_alg_))
!!$ write(iout,*) 'Smoother: ', &
!!$ & smooth_kinds(p%baseprecv(2)%iprcparm(smth_kind_))
!!$ write(iout,*) 'Smoothing omega: ', p%baseprecv(2)%dprcparm(smooth_omega_)
!!$ write(iout,*) 'Smoothing position: ',&
!!$ & smooth_names(p%baseprecv(2)%iprcparm(smth_pos_))
!!$ write(iout,*) 'Coarse matrix: ',&
!!$ & matrix_names(p%baseprecv(2)%iprcparm(coarse_mat_))
!!$ write(iout,*) 'Factorization type: ',&
!!$ & fact_names(p%baseprecv(2)%iprcparm(f_type_))
!!$ select case(p%baseprecv(2)%iprcparm(f_type_))
!!$ case(f_ilu_n_)
!!$ write(iout,*) 'Fill level :',p%baseprecv(2)%iprcparm(ilu_fill_in_)
!!$ case(f_ilu_e_)
!!$ write(iout,*) 'Fill threshold :',p%baseprecv(2)%dprcparm(fact_eps_)
!!$ case(f_slu_,f_umf_)
!!$ case default
!!$ write(iout,*) 'Should never get here!'
!!$ end select
!!$ write(iout,*) 'Number of Jacobi sweeps: ', &
!!$ & (p%baseprecv(2)%iprcparm(jac_sweeps_))
!!$
!!$ end if
!!$ end if
!!$
!!$ else
!!$ write(iout,*) 'No Base preconditioner available, something is wrong!'
!!$ return
!!$ endif
end function psb_zprec_short_descr
function is_legal_base_prec(ip)
integer, intent(in) :: ip
@@ -394,7 +222,7 @@ contains
end subroutine psb_dcheck_def
subroutine psb_dbase_precfree(p,info)
type(psb_dbaseprc_type), intent(inout) :: p
type(psb_dprec_type), intent(inout) :: p
integer, intent(out) :: info
integer :: i
@@ -441,7 +269,7 @@ contains
end subroutine psb_dbase_precfree
subroutine psb_nullify_dbaseprec(p)
type(psb_dbaseprc_type), intent(inout) :: p
type(psb_dprec_type), intent(inout) :: p
!!$ nullify(p%av,p%d,p%iprcparm,p%dprcparm,p%perm,p%invperm,p%mlia,&
!!$ & p%nlaggr,p%base_a,p%base_desc,p%dorig,p%desc_data, p%desc_ac)
@@ -449,7 +277,7 @@ contains
end subroutine psb_nullify_dbaseprec
subroutine psb_zbase_precfree(p,info)
type(psb_zbaseprc_type), intent(inout) :: p
type(psb_zprec_type), intent(inout) :: p
integer, intent(out) :: info
integer :: i
@@ -493,8 +321,7 @@ contains
end subroutine psb_zbase_precfree
subroutine psb_nullify_zbaseprec(p)
type(psb_zbaseprc_type), intent(inout) :: p
type(psb_zprec_type), intent(inout) :: p
end subroutine psb_nullify_zbaseprec
baseprec/psb_zbaseprc_aply.f90
+2 -2
View File
@@ -39,7 +39,7 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
implicit none
type(psb_desc_type),intent(in) :: desc_data
type(psb_zbaseprc_type), intent(in) :: prec
type(psb_zprec_type), intent(in) :: prec
complex(kind(0.d0)),intent(inout) :: x(:), y(:)
complex(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
@@ -61,7 +61,7 @@ subroutine psb_zbaseprc_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use psb_prec_type
type(psb_desc_type), intent(in) :: desc_data
type(psb_zbaseprc_type), intent(in) :: prec
type(psb_zprec_type), intent(in) :: prec
complex(kind(0.d0)),intent(inout) :: x(:), y(:)
complex(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
baseprec/psb_zbaseprc_bld.f90
-204
View File
@@ -1,204 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_type
Implicit None
type(psb_zspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_zbaseprc_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
interface psb_diagsc_bld
subroutine psb_zdiagsc_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_zbaseprc_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_zdiagsc_bld
end interface
interface psb_ilu_bld
subroutine psb_zilu_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_zbaseprc_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_zilu_bld
end interface
! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:)
integer :: int_err(5)
character :: iupd
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
err=0
call psb_erractionsave(err_act)
name = 'psb_baseprc_bld'
if (debug) write(0,*) 'Entering baseprc_bld'
info = 0
int_err(1) = 0
ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call psb_info(ictxt, me, np)
if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd
if ((UPD.eq.'F').or.(UPD.eq.'T')) then
IUPD=UPD
else
IUPD='F'
endif
else
IUPD='F'
endif
!
! Should add check to ensure all procs have the same...
!
! ALso should define symbolic names for the preconditioners.
!
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
& diagsc_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(p_type_))
case (noprec_)
! Do nothing.
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (diagsc_)
call psb_diagsc_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_diagsc_bld'
if(info /= 0) then
info=4010
ch_err='psb_diagsc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (bja_)
call psb_check_def(p%iprcparm(iren_),'renumbering',&
& renum_none_,is_legal_renum)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call psb_barrier(ictxt)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call psb_barrier(ictxt)
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
case default
info=4010
ch_err='Unknown p_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_zbaseprc_bld
baseprec/psb_zbjac_aply.f90
+1 -1
View File
@@ -41,7 +41,7 @@ subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
implicit none
type(psb_desc_type), intent(in) :: desc_data
type(psb_zbaseprc_type), intent(in) :: prec
type(psb_zprec_type), intent(in) :: prec
complex(kind(0.d0)),intent(inout) :: x(:), y(:)
complex(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
baseprec/psb_zdiagsc_bld.f90
+1 -1
View File
@@ -36,7 +36,7 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
type(psb_zspmat_type), target :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zbaseprc_type),intent(inout) :: p
type(psb_zprec_type),intent(inout) :: p
character, intent(in) :: upd
integer, intent(out) :: info
baseprec/psb_zilu_bld.f90
+2 -2
View File
@@ -37,7 +37,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
integer, intent(out) :: info
! .. array Arguments ..
type(psb_zspmat_type), intent(in), target :: a
type(psb_zbaseprc_type), intent(inout) :: p
type(psb_zprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
@@ -74,7 +74,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
! .. array Arguments ..
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(inout) :: atmp
type(psb_zbaseprc_type), intent(inout) :: p
type(psb_zprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
end subroutine psb_zsp_renum
baseprec/psb_zprc_aply.f90
+2 -9
View File
@@ -54,7 +54,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
use psb_base_mod
use psb_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_zbaseprc_type), intent(in) :: prec
type(psb_zprec_type), intent(in) :: prec
complex(kind(0.d0)),intent(inout) :: x(:), y(:)
complex(kind(0.d0)),intent(in) :: alpha,beta
character(len=1) :: trans
@@ -86,15 +86,8 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
end if
end if
if (.not.(allocated(prec%baseprecv))) then
write(0,*) 'Inconsistent preconditioner: neither SMTH nor BASE?'
end if
if (size(prec%baseprecv) == 1) then
call psb_baseprc_aply(zone,prec%baseprecv(1),x,zzero,y,desc_data,trans_, work_,info)
else
write(0,*) 'Inconsistent preconditioner: size of baseprecv???'
endif
call psb_baseprc_aply(zone,prec,x,zzero,y,desc_data,trans_, work_,info)
if (present(work)) then
else
baseprec/psb_zprecbld.f90
+117 -37
View File
@@ -32,7 +32,6 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_type
use psb_prec_mod, only : psb_baseprc_bld
Implicit None
type(psb_zspmat_type), target :: a
@@ -43,10 +42,40 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
! Local scalars
Integer :: err,i,j,k,ictxt, me,np,lw, err_act
interface psb_diagsc_bld
subroutine psb_zdiagsc_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_zprec_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_zdiagsc_bld
end interface
interface psb_ilu_bld
subroutine psb_zilu_bld(a,desc_data,p,upd,info)
use psb_base_mod
use psb_prec_type
integer, intent(out) :: info
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_zprec_type), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_zilu_bld
end interface
! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,np,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:)
integer :: int_err(5)
character :: iupd
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err
@@ -75,35 +104,100 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
else
iupd='F'
endif
if (.not.allocated(p%baseprecv)) then
!! Error 1: should call precset
info=4010
ch_err='unallocated bpv'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a)
!
! Should add check to ensure all procs have the same...
!
! ALso should define symbolic names for the preconditioners.
!
call init_baseprc_av(p%baseprecv(1),info)
if (info /= 0) then
call psb_check_def(p%iprcparm(p_type_),'base_prec',&
& diagsc_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(p_type_))
case (noprec_)
! Do nothing.
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (diagsc_)
call psb_diagsc_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_diagsc_bld'
if(info /= 0) then
info=4010
ch_err='psb_diagsc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (bja_)
call psb_check_def(p%iprcparm(iren_),'renumbering',&
& renum_none_,is_legal_renum)
call psb_check_def(p%iprcparm(f_type_),'fact',&
& f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call psb_barrier(ictxt)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(p%av(max_avsz),stat=info)
if(info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call psb_barrier(ictxt)
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_none_)
write(0,*) 'Fact=None in BASEPRC_BLD Bja/ASM??'
info=4010
ch_err='Inconsistent prec f_none_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
case default
write(0,*) 'Unknown factor type in baseprc_bld bja/asm: ',&
&p%iprcparm(f_type_)
info=4010
ch_err='Unknown f_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
case default
info=4010
ch_err='allocate'
ch_err='Unknown p_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
if (info /= 0) then
info=4010
ch_err='baseprc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
end select
call psb_erractionrestore(err_act)
return
@@ -116,20 +210,6 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
end if
return
contains
subroutine init_baseprc_av(p,info)
type(psb_zbaseprc_type), intent(inout) :: p
integer :: info
if (allocated(p%av)) then
! Have not decided what to do yet
end if
allocate(p%av(max_avsz),stat=info)
!!$ if (info /= 0) return
do k=1,size(p%av)
call psb_nullify_sp(p%av(k))
end do
end subroutine init_baseprc_av
end subroutine psb_zprecbld
baseprec/psb_zprecfree.f90
+1 -6
View File
@@ -49,12 +49,7 @@ subroutine psb_zprecfree(p,info)
me=-1
if (allocated(p%baseprecv)) then
do i=1,size(p%baseprecv)
call psb_base_precfree(p%baseprecv(i),info)
end do
deallocate(p%baseprecv)
end if
call psb_base_precfree(p,info)
call psb_erractionrestore(err_act)
return
baseprec/psb_zprecset.f90
+20 -35
View File
@@ -28,7 +28,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_zprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
subroutine psb_zprecset(p,ptype,info,iv,rs,rv)
use psb_base_mod
use psb_prec_type
@@ -38,7 +38,6 @@ subroutine psb_zprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
character(len=*), intent(in) :: ptype
integer, intent(out) :: info
integer, optional, intent(in) :: iv(:)
integer, optional, intent(in) :: nlev,ilev
real(kind(1.d0)), optional, intent(in) :: rs
real(kind(1.d0)), optional, intent(in) :: rv(:)
@@ -47,48 +46,34 @@ subroutine psb_zprecset(p,ptype,info,iv,rs,rv,ilev,nlev)
info = 0
ilev_ = 1
nlev_ = 1
if (.not.allocated(p%baseprecv)) then
allocate(p%baseprecv(nlev_),stat=err)
else
nlev_ = size(p%baseprecv)
endif
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
info = -1
return
endif
call psb_realloc(ifpsz,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%baseprecv(ilev_)%dprcparm,info)
call psb_realloc(ifpsz,p%iprcparm,info)
if (info == 0) call psb_realloc(dfpsz,p%dprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%iprcparm(:) = 0
select case(toupper(ptype(1:len_trim(ptype))))
case ('NONE','NOPREC')
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = noprec_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%iprcparm(:) = 0
p%iprcparm(p_type_) = noprec_
p%iprcparm(f_type_) = f_none_
p%iprcparm(iren_) = 0
p%iprcparm(jac_sweeps_) = 1
case ('DIAG','DIAGSC')
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = diagsc_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_none_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%iprcparm(:) = 0
p%iprcparm(p_type_) = diagsc_
p%iprcparm(f_type_) = f_none_
p%iprcparm(iren_) = 0
p%iprcparm(jac_sweeps_) = 1
case ('BJA','ILU')
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(p_type_) = bja_
p%baseprecv(ilev_)%iprcparm(f_type_) = f_ilu_n_
p%baseprecv(ilev_)%iprcparm(iren_) = 0
p%baseprecv(ilev_)%iprcparm(ilu_fill_in_) = 0
p%baseprecv(ilev_)%iprcparm(jac_sweeps_) = 1
p%iprcparm(:) = 0
p%iprcparm(p_type_) = bja_
p%iprcparm(f_type_) = f_ilu_n_
p%iprcparm(iren_) = 0
p%iprcparm(ilu_fill_in_) = 0
p%iprcparm(jac_sweeps_) = 1
case default
write(0,*) 'Unknown preconditioner type request "',ptype,'"'
baseprec/psb_zsp_renum.f90
+1 -1
View File
@@ -36,7 +36,7 @@ subroutine psb_zsp_renum(a,desc_a,p,atmp,info)
! .. array Arguments ..
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(inout) :: atmp
type(psb_zbaseprc_type), intent(inout) :: p
type(psb_zprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info