From c61e0af41e0efbecbf038e3505b7fd3ff6204f03 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 23 Jan 2007 17:27:00 +0000 Subject: [PATCH] Simplified basic preconditioners. --- baseprec/Makefile | 4 +- baseprec/psb_dbaseprc_aply.f90 | 4 +- baseprec/psb_dbaseprc_bld.f90 | 205 ----------------------------- baseprec/psb_dbjac_aply.f90 | 4 +- baseprec/psb_ddiagsc_bld.f90 | 2 +- baseprec/psb_dilu_bld.f90 | 5 +- baseprec/psb_dprc_aply.f90 | 13 +- baseprec/psb_dprecbld.f90 | 152 ++++++++++++++++------ baseprec/psb_dprecfree.f90 | 8 +- baseprec/psb_dprecset.f90 | 55 +++----- baseprec/psb_dsp_renum.f90 | 2 +- baseprec/psb_prec_mod.f90 | 27 +--- baseprec/psb_prec_type.f90 | 229 ++++----------------------------- baseprec/psb_zbaseprc_aply.f90 | 4 +- baseprec/psb_zbaseprc_bld.f90 | 204 ----------------------------- baseprec/psb_zbjac_aply.f90 | 2 +- baseprec/psb_zdiagsc_bld.f90 | 2 +- baseprec/psb_zilu_bld.f90 | 4 +- baseprec/psb_zprc_aply.f90 | 11 +- baseprec/psb_zprecbld.f90 | 154 ++++++++++++++++------ baseprec/psb_zprecfree.f90 | 7 +- baseprec/psb_zprecset.f90 | 55 +++----- baseprec/psb_zsp_renum.f90 | 2 +- 23 files changed, 325 insertions(+), 830 deletions(-) delete mode 100644 baseprec/psb_dbaseprc_bld.f90 delete mode 100644 baseprec/psb_zbaseprc_bld.f90 diff --git a/baseprec/Makefile b/baseprec/Makefile index 1d545097..c1e2257f 100644 --- a/baseprec/Makefile +++ b/baseprec/Makefile @@ -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) diff --git a/baseprec/psb_dbaseprc_aply.f90 b/baseprec/psb_dbaseprc_aply.f90 index fde394f0..a681b975 100644 --- a/baseprec/psb_dbaseprc_aply.f90 +++ b/baseprec/psb_dbaseprc_aply.f90 @@ -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 diff --git a/baseprec/psb_dbaseprc_bld.f90 b/baseprec/psb_dbaseprc_bld.f90 deleted file mode 100644 index 994369b9..00000000 --- a/baseprec/psb_dbaseprc_bld.f90 +++ /dev/null @@ -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 - diff --git a/baseprec/psb_dbjac_aply.f90 b/baseprec/psb_dbjac_aply.f90 index d2983392..604ca0e1 100644 --- a/baseprec/psb_dbjac_aply.f90 +++ b/baseprec/psb_dbjac_aply.f90 @@ -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 diff --git a/baseprec/psb_ddiagsc_bld.f90 b/baseprec/psb_ddiagsc_bld.f90 index 4fea5237..1fc771ef 100644 --- a/baseprec/psb_ddiagsc_bld.f90 +++ b/baseprec/psb_ddiagsc_bld.f90 @@ -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 diff --git a/baseprec/psb_dilu_bld.f90 b/baseprec/psb_dilu_bld.f90 index 609667b8..f6684ce7 100644 --- a/baseprec/psb_dilu_bld.f90 +++ b/baseprec/psb_dilu_bld.f90 @@ -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 diff --git a/baseprec/psb_dprc_aply.f90 b/baseprec/psb_dprc_aply.f90 index b5a527e7..398f658a 100644 --- a/baseprec/psb_dprc_aply.f90 +++ b/baseprec/psb_dprc_aply.f90 @@ -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 diff --git a/baseprec/psb_dprecbld.f90 b/baseprec/psb_dprecbld.f90 index a7cba74d..1d0ba22e 100644 --- a/baseprec/psb_dprecbld.f90 +++ b/baseprec/psb_dprecbld.f90 @@ -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 - info=4010 - ch_err='allocate' - 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 + + 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='baseprc_bld' + ch_err='Unknown p_type_' 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 diff --git a/baseprec/psb_dprecfree.f90 b/baseprec/psb_dprecfree.f90 index a8a871f7..a268133b 100644 --- a/baseprec/psb_dprecfree.f90 +++ b/baseprec/psb_dprecfree.f90 @@ -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 diff --git a/baseprec/psb_dprecset.f90 b/baseprec/psb_dprecset.f90 index 493e381d..09a6ea84 100644 --- a/baseprec/psb_dprecset.f90 +++ b/baseprec/psb_dprecset.f90 @@ -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,'"' diff --git a/baseprec/psb_dsp_renum.f90 b/baseprec/psb_dsp_renum.f90 index 066b641a..fd80d674 100644 --- a/baseprec/psb_dsp_renum.f90 +++ b/baseprec/psb_dsp_renum.f90 @@ -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 diff --git a/baseprec/psb_prec_mod.f90 b/baseprec/psb_prec_mod.f90 index 9b419135..5255c532 100644 --- a/baseprec/psb_prec_mod.f90 +++ b/baseprec/psb_prec_mod.f90 @@ -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 diff --git a/baseprec/psb_prec_type.f90 b/baseprec/psb_prec_type.f90 index 620e454b..660722d1 100644 --- a/baseprec/psb_prec_type.f90 +++ b/baseprec/psb_prec_type.f90 @@ -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 diff --git a/baseprec/psb_zbaseprc_aply.f90 b/baseprec/psb_zbaseprc_aply.f90 index bca2494d..f4ef8f69 100644 --- a/baseprec/psb_zbaseprc_aply.f90 +++ b/baseprec/psb_zbaseprc_aply.f90 @@ -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 diff --git a/baseprec/psb_zbaseprc_bld.f90 b/baseprec/psb_zbaseprc_bld.f90 deleted file mode 100644 index bd49c619..00000000 --- a/baseprec/psb_zbaseprc_bld.f90 +++ /dev/null @@ -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 - diff --git a/baseprec/psb_zbjac_aply.f90 b/baseprec/psb_zbjac_aply.f90 index 9418aa5b..fd34710d 100644 --- a/baseprec/psb_zbjac_aply.f90 +++ b/baseprec/psb_zbjac_aply.f90 @@ -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 diff --git a/baseprec/psb_zdiagsc_bld.f90 b/baseprec/psb_zdiagsc_bld.f90 index 166edd37..1085c0dd 100644 --- a/baseprec/psb_zdiagsc_bld.f90 +++ b/baseprec/psb_zdiagsc_bld.f90 @@ -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 diff --git a/baseprec/psb_zilu_bld.f90 b/baseprec/psb_zilu_bld.f90 index 279431a2..ebf3a1f3 100644 --- a/baseprec/psb_zilu_bld.f90 +++ b/baseprec/psb_zilu_bld.f90 @@ -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 diff --git a/baseprec/psb_zprc_aply.f90 b/baseprec/psb_zprc_aply.f90 index e83ae236..b17d22f9 100644 --- a/baseprec/psb_zprc_aply.f90 +++ b/baseprec/psb_zprc_aply.f90 @@ -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 diff --git a/baseprec/psb_zprecbld.f90 b/baseprec/psb_zprecbld.f90 index 5221d0e6..58a34623 100644 --- a/baseprec/psb_zprecbld.f90 +++ b/baseprec/psb_zprecbld.f90 @@ -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 - info=4010 - ch_err='allocate' - 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 + + 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='baseprc_bld' + ch_err='Unknown p_type_' 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 diff --git a/baseprec/psb_zprecfree.f90 b/baseprec/psb_zprecfree.f90 index 42abde35..026c1b64 100644 --- a/baseprec/psb_zprecfree.f90 +++ b/baseprec/psb_zprecfree.f90 @@ -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 diff --git a/baseprec/psb_zprecset.f90 b/baseprec/psb_zprecset.f90 index 24616557..b9d0d73b 100644 --- a/baseprec/psb_zprecset.f90 +++ b/baseprec/psb_zprecset.f90 @@ -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,'"' diff --git a/baseprec/psb_zsp_renum.f90 b/baseprec/psb_zsp_renum.f90 index 84d3a7ad..1cf7b1f2 100644 --- a/baseprec/psb_zsp_renum.f90 +++ b/baseprec/psb_zsp_renum.f90 @@ -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