diff --git a/prec/Makefile b/prec/Makefile index 39fb4983..fa49936f 100644 --- a/prec/Makefile +++ b/prec/Makefile @@ -25,15 +25,17 @@ LIBMOD=psb_prec_mod$(.mod) LOCAL_MODS=$(MODOBJS:.o=$(.mod)) LIBNAME=$(PRECLIBNAME) COBJS= -FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). +FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) OBJS=$(F90OBJS) $(COBJS) $(MPFOBJS) $(MODOBJS) -lib: $(OBJS) +lib: $(OBJS) impld $(AR) $(HERE)/$(LIBNAME) $(OBJS) $(RANLIB) $(HERE)/$(LIBNAME) /bin/cp -p $(CPUPDFLAG) $(HERE)/$(LIBNAME) $(LIBDIR) /bin/cp -p $(CPUPDFLAG) $(LIBMOD) $(LOCAL_MODS) $(LIBDIR) +impld: $(OBJS) + cd impl && $(MAKE) $(OBJS): $(LIBDIR)/psb_base_mod$(.mod) diff --git a/prec/impl/Makefile b/prec/impl/Makefile new file mode 100644 index 00000000..48947be3 --- /dev/null +++ b/prec/impl/Makefile @@ -0,0 +1,30 @@ +include ../../Make.inc + +LIBDIR=../../lib +HERE=.. +OBJS=psb_s_prec_type_impl.o psb_d_prec_type_impl.o \ + psb_c_prec_type_impl.o psb_z_prec_type_impl.o + + +F90OBJS= psb_dilu_fct.o\ + psb_dprecbld.o psb_dprecset.o psb_dprecinit.o \ + psb_silu_fct.o\ + psb_sprecbld.o psb_sprecset.o psb_sprecinit.o \ + psb_cilu_fct.o\ + psb_cprecbld.o psb_cprecset.o psb_cprecinit.o \ + psb_zilu_fct.o\ + psb_zprecbld.o psb_zprecset.o psb_zprecinit.o + +LIBNAME=$(PRECLIBNAME) +COBJS= +FINCLUDES=$(FMFLAG).. $(FMFLAG)$(LIBDIR) + +lib: $(OBJS) + $(AR) $(HERE)/$(LIBNAME) $(OBJS) + $(RANLIB) $(HERE)/$(LIBNAME) + +veryclean: clean + +clean: + /bin/rm -f $(OBJS) $(LOCAL_MODS) + diff --git a/prec/impl/psb_c_prec_type_impl.f90 b/prec/impl/psb_c_prec_type_impl.f90 new file mode 100644 index 00000000..68cf95da --- /dev/null +++ b/prec/impl/psb_c_prec_type_impl.f90 @@ -0,0 +1,319 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_c_apply2_vect(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_c_prec_type, psb_protect_name => psb_c_apply2_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + character :: trans_ + complex(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_c_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call prec%prec%apply(cone,x,czero,y,desc_data,info,& + & trans=trans_,work=work_) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_apply2_vect + +subroutine psb_c_apply1_vect(prec,x,desc_data,info,trans,work) + use psb_base_mod + use psb_c_prec_type, psb_protect_name => psb_c_apply1_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + type(psb_c_vect_type) :: ww + character :: trans_ + complex(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_c_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call psb_geall(ww,desc_data,info) + if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) + if (info == 0) call prec%prec%apply(cone,x,czero,ww,desc_data,info,& + & trans=trans_,work=work_) + if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_apply1_vect + +subroutine psb_c_apply2v(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_c_prec_type, psb_protect_name => psb_c_apply2v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + + character :: trans_ + complex(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='psb_c_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(cone,x,czero,y,desc_data,info,trans_,work=work_) + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_apply2v + +subroutine psb_c_apply1v(prec,x,desc_data,info,trans) + use psb_base_mod + use psb_c_prec_type, psb_protect_name => psb_c_apply1v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + character :: trans_ + integer :: ictxt,np,me, err_act + complex(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='psb_c_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + + ictxt=desc_data%get_context() + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + call prec%prec%apply(cone,x,czero,ww,desc_data,info,& + & trans_,work=w1) + if(info /= psb_success_) goto 9999 + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_c_apply1v + diff --git a/prec/impl/psb_d_prec_type_impl.f90 b/prec/impl/psb_d_prec_type_impl.f90 new file mode 100644 index 00000000..dab79bcd --- /dev/null +++ b/prec/impl/psb_d_prec_type_impl.f90 @@ -0,0 +1,319 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_d_apply2_vect(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_d_prec_type, psb_protect_name => psb_d_apply2_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + character :: trans_ + real(psb_dpk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_d_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call prec%prec%apply(done,x,dzero,y,desc_data,info,& + & trans=trans_,work=work_) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_apply2_vect + +subroutine psb_d_apply1_vect(prec,x,desc_data,info,trans,work) + use psb_base_mod + use psb_d_prec_type, psb_protect_name => psb_d_apply1_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + type(psb_d_vect_type) :: ww + character :: trans_ + real(psb_dpk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_d_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call psb_geall(ww,desc_data,info) + if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) + if (info == 0) call prec%prec%apply(done,x,dzero,ww,desc_data,info,& + & trans=trans_,work=work_) + if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_apply1_vect + +subroutine psb_d_apply2v(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_d_prec_type, psb_protect_name => psb_d_apply2v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + + character :: trans_ + real(psb_dpk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='psb_d_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(done,x,dzero,y,desc_data,info,trans_,work=work_) + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_apply2v + +subroutine psb_d_apply1v(prec,x,desc_data,info,trans) + use psb_base_mod + use psb_d_prec_type, psb_protect_name => psb_d_apply1v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + character :: trans_ + integer :: ictxt,np,me, err_act + real(psb_dpk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='psb_d_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + + ictxt=desc_data%get_context() + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + call prec%prec%apply(done,x,dzero,ww,desc_data,info,& + & trans_,work=w1) + if(info /= psb_success_) goto 9999 + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_d_apply1v + diff --git a/prec/impl/psb_s_prec_type_impl.f90 b/prec/impl/psb_s_prec_type_impl.f90 new file mode 100644 index 00000000..e04bb1b7 --- /dev/null +++ b/prec/impl/psb_s_prec_type_impl.f90 @@ -0,0 +1,319 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_s_apply2_vect(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_s_prec_type, psb_protect_name => psb_s_apply2_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + character :: trans_ + real(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_s_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call prec%prec%apply(sone,x,szero,y,desc_data,info,& + & trans=trans_,work=work_) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_apply2_vect + +subroutine psb_s_apply1_vect(prec,x,desc_data,info,trans,work) + use psb_base_mod + use psb_s_prec_type, psb_protect_name => psb_s_apply1_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + type(psb_s_vect_type) :: ww + character :: trans_ + real(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_s_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call psb_geall(ww,desc_data,info) + if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) + if (info == 0) call prec%prec%apply(sone,x,szero,ww,desc_data,info,& + & trans=trans_,work=work_) + if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_apply1_vect + +subroutine psb_s_apply2v(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_s_prec_type, psb_protect_name => psb_s_apply2v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + + character :: trans_ + real(psb_spk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='psb_s_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(sone,x,szero,y,desc_data,info,trans_,work=work_) + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_apply2v + +subroutine psb_s_apply1v(prec,x,desc_data,info,trans) + use psb_base_mod + use psb_s_prec_type, psb_protect_name => psb_s_apply1v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + character :: trans_ + integer :: ictxt,np,me, err_act + real(psb_spk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='psb_s_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + + ictxt=desc_data%get_context() + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + call prec%prec%apply(sone,x,szero,ww,desc_data,info,& + & trans_,work=w1) + if(info /= psb_success_) goto 9999 + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_s_apply1v + diff --git a/prec/impl/psb_z_prec_type_impl.f90 b/prec/impl/psb_z_prec_type_impl.f90 new file mode 100644 index 00000000..887ba10a --- /dev/null +++ b/prec/impl/psb_z_prec_type_impl.f90 @@ -0,0 +1,319 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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_z_apply2_vect(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_z_prec_type, psb_protect_name => psb_z_apply2_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + character :: trans_ + complex(psb_dpk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_z_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call prec%prec%apply(zone,x,zzero,y,desc_data,info,& + & trans=trans_,work=work_) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_apply2_vect + +subroutine psb_z_apply1_vect(prec,x,desc_data,info,trans,work) + use psb_base_mod + use psb_z_prec_type, psb_protect_name => psb_z_apply1_vect + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + type(psb_z_vect_type) :: ww + character :: trans_ + complex(psb_dpk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name = 'psb_z_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + + call psb_geall(ww,desc_data,info) + if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) + if (info == 0) call prec%prec%apply(zone,x,zzero,ww,desc_data,info,& + & trans=trans_,work=work_) + if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info) + + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_apply1_vect + +subroutine psb_z_apply2v(prec,x,y,desc_data,info,trans,work) + use psb_base_mod + use psb_z_prec_type, psb_protect_name => psb_z_apply2v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + + character :: trans_ + complex(psb_dpk_), pointer :: work_(:) + integer :: ictxt,np,me,err_act + character(len=20) :: name + + name='psb_z_apply2v' + info = psb_success_ + call psb_erractionsave(err_act) + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (present(trans)) then + trans_=trans + else + trans_='N' + end if + + if (present(work)) then + work_ => work + else + allocate(work_(4*desc_data%get_local_cols()),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + call prec%prec%apply(zone,x,zzero,y,desc_data,info,trans_,work=work_) + if (present(work)) then + else + deallocate(work_,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_apply2v + +subroutine psb_z_apply1v(prec,x,desc_data,info,trans) + use psb_base_mod + use psb_z_prec_type, psb_protect_name => psb_z_apply1v + implicit none + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + + character :: trans_ + integer :: ictxt,np,me, err_act + complex(psb_dpk_), pointer :: WW(:), w1(:) + character(len=20) :: name + name='psb_z_apply1v' + info = psb_success_ + call psb_erractionsave(err_act) + + + ictxt=desc_data%get_context() + call psb_info(ictxt, me, np) + if (present(trans)) then + trans_=psb_toupper(trans) + else + trans_='N' + end if + + if (.not.allocated(prec%prec)) then + info = 1124 + call psb_errpush(info,name,a_err="preconditioner") + goto 9999 + end if + allocate(ww(size(x)),w1(size(x)),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + call prec%prec%apply(zone,x,zzero,ww,desc_data,info,& + & trans_,work=w1) + if(info /= psb_success_) goto 9999 + x(:) = ww(:) + deallocate(ww,W1,stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='DeAllocate') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_z_apply1v + diff --git a/prec/psb_c_base_prec_mod.f90 b/prec/psb_c_base_prec_mod.f90 index cd98e220..aab973c8 100644 --- a/prec/psb_c_base_prec_mod.f90 +++ b/prec/psb_c_base_prec_mod.f90 @@ -36,10 +36,11 @@ module psb_c_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& + use psb_base_mod, only : psb_spk_, psb_long_int_k_,& + & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_cspmat_type, psb_c_base_vect, psb_c_vect_type + & psb_c_base_sparse_mat, psb_cspmat_type, psb_c_csr_sparse_mat,& + & psb_c_base_vect_type, psb_c_vect_type use psb_prec_const_mod @@ -73,7 +74,7 @@ module psb_c_base_prec_mod contains subroutine psb_c_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_c_base_prec_type), intent(inout) :: prec complex(psb_spk_),intent(in) :: alpha, beta @@ -83,7 +84,7 @@ contains character(len=1), optional :: trans complex(psb_spk_),intent(inout), optional, target :: work(:) Integer :: err_act, nrow - character(len=20) :: name='d_base_prec_apply' + character(len=20) :: name='c_base_prec_apply' call psb_erractionsave(err_act) @@ -109,7 +110,7 @@ contains end subroutine psb_c_base_apply_vect subroutine psb_c_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_c_base_prec_type), intent(in) :: prec complex(psb_spk_),intent(in) :: alpha, beta @@ -145,10 +146,8 @@ contains end subroutine psb_c_base_apply subroutine psb_c_base_precinit(prec,info) - - use psb_base_mod Implicit None - + class(psb_c_base_prec_type),intent(inout) :: prec integer, intent(out) :: info Integer :: err_act, nrow @@ -177,8 +176,6 @@ contains end subroutine psb_c_base_precinit subroutine psb_c_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod Implicit None type(psb_cspmat_type), intent(in), target :: a @@ -215,8 +212,6 @@ contains end subroutine psb_c_base_precbld subroutine psb_c_base_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_c_base_prec_type),intent(inout) :: prec @@ -249,8 +244,6 @@ contains end subroutine psb_c_base_precseti subroutine psb_c_base_precsetr(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_c_base_prec_type),intent(inout) :: prec @@ -283,8 +276,6 @@ contains end subroutine psb_c_base_precsetr subroutine psb_c_base_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_c_base_prec_type),intent(inout) :: prec @@ -317,8 +308,6 @@ contains end subroutine psb_c_base_precsetc subroutine psb_c_base_precfree(prec,info) - - use psb_base_mod Implicit None class(psb_c_base_prec_type), intent(inout) :: prec @@ -352,8 +341,6 @@ contains subroutine psb_c_base_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_c_base_prec_type), intent(in) :: prec @@ -386,13 +373,12 @@ contains end subroutine psb_c_base_precdescr subroutine psb_c_base_precdump(prec,info,prefix,head) - use psb_base_mod implicit none class(psb_c_base_prec_type), intent(in) :: prec integer, intent(out) :: info character(len=*), intent(in), optional :: prefix,head Integer :: err_act, nrow - character(len=20) :: name='d_base_precdump' + character(len=20) :: name='c_base_precdump' call psb_erractionsave(err_act) @@ -418,7 +404,6 @@ contains end subroutine psb_c_base_precdump subroutine psb_c_base_set_ctxt(prec,ictxt) - use psb_base_mod implicit none class(psb_c_base_prec_type), intent(inout) :: prec integer, intent(in) :: ictxt @@ -428,7 +413,6 @@ contains end subroutine psb_c_base_set_ctxt function psb_c_base_sizeof(prec) result(val) - use psb_base_mod class(psb_c_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val @@ -437,7 +421,6 @@ contains end function psb_c_base_sizeof function psb_c_base_get_ctxt(prec) result(val) - use psb_base_mod class(psb_c_base_prec_type), intent(in) :: prec integer :: val diff --git a/prec/psb_c_prec_mod.f90 b/prec/psb_c_prec_mod.f90 index b5e1f2f7..40798f27 100644 --- a/prec/psb_c_prec_mod.f90 +++ b/prec/psb_c_prec_mod.f90 @@ -32,12 +32,13 @@ module psb_c_prec_mod use psb_c_prec_type + use psb_c_base_prec_mod interface psb_precbld subroutine psb_cprecbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod, only : psb_desc_type, psb_cspmat_type,& - & psb_c_base_sparse_mat, psb_spk_, psb_c_base_vect_type - use psb_prec_type, only : psb_cprec_type + import :: psb_desc_type, psb_cspmat_type,& + & psb_c_base_sparse_mat, psb_spk_, psb_c_base_vect_type, & + & psb_cprec_type implicit none type(psb_cspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a @@ -52,8 +53,7 @@ module psb_c_prec_mod interface psb_precinit subroutine psb_cprecinit(prec,ptype,info) - use psb_base_mod, only : psb_desc_type, psb_cspmat_type, psb_spk_ - use psb_prec_type, only : psb_cprec_type + import :: psb_desc_type, psb_cspmat_type, psb_spk_, psb_cprec_type implicit none type(psb_cprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype @@ -63,27 +63,25 @@ module psb_c_prec_mod interface psb_precset subroutine psb_cprecseti(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_cspmat_type, psb_spk_ - use psb_prec_type, only : psb_cprec_type + import :: psb_desc_type, psb_cspmat_type, psb_spk_, psb_cprec_type implicit none type(psb_cprec_type), intent(inout) :: prec integer :: what, val integer, intent(out) :: info end subroutine psb_cprecseti - subroutine psb_cprecsets(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_cspmat_type, psb_spk_ - use psb_prec_type, only : psb_cprec_type + subroutine psb_cprecsetr(prec,what,val,info) + import :: psb_desc_type, psb_cspmat_type, psb_spk_, psb_cprec_type implicit none type(psb_cprec_type), intent(inout) :: prec integer :: what real(psb_spk_) :: val integer, intent(out) :: info - end subroutine psb_cprecsets + end subroutine psb_cprecsetr end interface interface psb_ilu_fct subroutine psb_cilu_fct(a,l,u,d,info,blck) - use psb_base_mod, only : psb_desc_type, psb_cspmat_type, & + import :: psb_desc_type, psb_cspmat_type, & & psb_c_csr_sparse_mat, psb_spk_ integer, intent(out) :: info type(psb_cspmat_type),intent(in) :: a diff --git a/prec/psb_c_prec_type.f90 b/prec/psb_c_prec_type.f90 index f76c31d6..935147df 100644 --- a/prec/psb_c_prec_type.f90 +++ b/prec/psb_c_prec_type.f90 @@ -35,24 +35,18 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module psb_c_prec_type - ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_cspmat_type - use psb_prec_const_mod use psb_c_base_prec_mod type psb_cprec_type class(psb_c_base_prec_type), allocatable :: prec contains - procedure, pass(prec) :: c_apply1_vect - procedure, pass(prec) :: c_apply2_vect - procedure, pass(prec) :: c_apply2v - procedure, pass(prec) :: c_apply1v - generic, public :: apply => c_apply2v, c_apply1v,& - & c_apply1_vect, c_apply2_vect + procedure, pass(prec) :: psb_c_apply1_vect + procedure, pass(prec) :: psb_c_apply2_vect + procedure, pass(prec) :: psb_c_apply2v + procedure, pass(prec) :: psb_c_apply1v + generic, public :: apply => psb_c_apply2v, psb_c_apply1v,& + & psb_c_apply1_vect, psb_c_apply2_vect end type psb_cprec_type interface psb_precfree @@ -75,10 +69,58 @@ module psb_c_prec_type module procedure psb_cprec_sizeof end interface + interface psb_c_apply2_vect + subroutine psb_c_apply2_vect(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_apply2_vect + end interface psb_c_apply2_vect + + interface psb_c_apply1_vect + subroutine psb_c_apply1_vect(prec,x,desc_data,info,trans,work) + import :: psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(inout) :: prec + type(psb_c_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_apply1_vect + end interface psb_c_apply1_vect + + interface psb_c_apply2v + subroutine psb_c_apply2v(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_c_apply2v + end interface psb_c_apply2v + + interface psb_c_apply1v + subroutine psb_c_apply1v(prec,x,desc_data,info,trans) + import :: psb_desc_type, psb_cprec_type, psb_c_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_cprec_type), intent(in) :: prec + complex(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine psb_c_apply1v + end interface psb_c_apply1v + contains subroutine psb_cfile_prec_descr(p,iout) - use psb_base_mod type(psb_cprec_type), intent(in) :: p integer, intent(in), optional :: iout integer :: iout_,info @@ -99,7 +141,6 @@ contains end subroutine psb_cfile_prec_descr subroutine psb_c_prec_dump(prec,info,prefix,head) - use psb_base_mod implicit none type(psb_cprec_type), intent(in) :: prec integer, intent(out) :: info @@ -121,7 +162,6 @@ contains subroutine psb_c_precfree(p,info) - use psb_base_mod type(psb_cprec_type), intent(inout) :: p integer, intent(out) :: info integer :: me, err_act,i @@ -154,11 +194,9 @@ contains subroutine psb_nullify_cprec(p) type(psb_cprec_type), intent(inout) :: p - end subroutine psb_nullify_cprec function psb_cprec_sizeof(prec) result(val) - use psb_base_mod type(psb_cprec_type), intent(in) :: prec integer(psb_long_int_k_) :: val integer :: i @@ -170,282 +208,4 @@ contains end function psb_cprec_sizeof - subroutine c_apply2_vect(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_cprec_type), intent(inout) :: prec - type(psb_c_vect_type),intent(inout) :: x - type(psb_c_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - - character :: trans_ - complex(psb_spk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name = 'c_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call prec%prec%apply(cone,x,czero,y,desc_data,info,& - & trans=trans_,work=work_) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_apply2_vect - - subroutine c_apply1_vect(prec,x,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_cprec_type), intent(inout) :: prec - type(psb_c_vect_type),intent(inout) :: x - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - - type(psb_c_vect_type) :: ww - character :: trans_ - complex(psb_spk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name = 'c_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call psb_geall(ww,desc_data,info) - if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) - if (info == 0) call prec%prec%apply(cone,x,czero,ww,desc_data,info,& - & trans=trans_,work=work_) - if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_apply1_vect - - subroutine c_apply2v(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_cprec_type), intent(in) :: prec - complex(psb_spk_),intent(inout) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_spk_),intent(inout), optional, target :: work(:) - - character :: trans_ - complex(psb_spk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='c_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=trans - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - call prec%prec%apply(cone,x,czero,y,desc_data,info,trans_,work=work_) - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_apply2v - - subroutine c_apply1v(prec,x,desc_data,info,trans) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_cprec_type), intent(in) :: prec - complex(psb_spk_),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - - character :: trans_ - integer :: ictxt,np,me, err_act - complex(psb_spk_), pointer :: WW(:), w1(:) - character(len=20) :: name - name='c_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - call prec%prec%apply(cone,x,czero,ww,desc_data,info,& - & trans_,work=w1) - if(info /= psb_success_) goto 9999 - x(:) = ww(:) - deallocate(ww,W1,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine c_apply1v - end module psb_c_prec_type diff --git a/prec/psb_cprecset.f90 b/prec/psb_cprecset.f90 index d407c440..07a3a20b 100644 --- a/prec/psb_cprecset.f90 +++ b/prec/psb_cprecset.f90 @@ -54,10 +54,10 @@ subroutine psb_cprecseti(p,what,val,info) end subroutine psb_cprecseti -subroutine psb_cprecsets(p,what,val,info) +subroutine psb_cprecsetr(p,what,val,info) use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_cprecsets + use psb_prec_mod, psb_protect_name => psb_cprecsetr implicit none type(psb_cprec_type), intent(inout) :: p integer :: what @@ -77,4 +77,4 @@ subroutine psb_cprecsets(p,what,val,info) return -end subroutine psb_cprecsets +end subroutine psb_cprecsetr diff --git a/prec/psb_d_base_prec_mod.f90 b/prec/psb_d_base_prec_mod.f90 index d046d501..1957216b 100644 --- a/prec/psb_d_base_prec_mod.f90 +++ b/prec/psb_d_base_prec_mod.f90 @@ -36,12 +36,12 @@ module psb_d_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& + use psb_base_mod, only : psb_dpk_, psb_long_int_k_,& + & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_dspmat_type, psb_d_base_vect, psb_d_vect_type + & psb_d_base_sparse_mat, psb_dspmat_type, psb_d_csr_sparse_mat,& + & psb_d_base_vect_type, psb_d_vect_type - use psb_prec_const_mod type psb_d_base_prec_type @@ -64,7 +64,7 @@ module psb_d_base_prec_mod procedure, pass(prec) :: dump => psb_d_base_precdump procedure, pass(prec) :: get_nzeros => psb_d_base_get_nzeros end type psb_d_base_prec_type - + private :: psb_d_base_apply, psb_d_base_precbld, psb_d_base_precseti,& & psb_d_base_precsetr, psb_d_base_precsetc, psb_d_base_sizeof,& & psb_d_base_precinit, psb_d_base_precfree, psb_d_base_precdescr,& @@ -74,14 +74,14 @@ module psb_d_base_prec_mod contains subroutine psb_d_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data + implicit none + type(psb_desc_type),intent(in) :: desc_data class(psb_d_base_prec_type), intent(inout) :: prec - real(psb_dpk_),intent(in) :: alpha, beta + real(psb_dpk_),intent(in) :: alpha, beta type(psb_d_vect_type),intent(inout) :: x type(psb_d_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans + integer, intent(out) :: info + character(len=1), optional :: trans real(psb_dpk_),intent(inout), optional, target :: work(:) Integer :: err_act, nrow character(len=20) :: name='d_base_prec_apply' @@ -110,14 +110,14 @@ contains end subroutine psb_d_base_apply_vect subroutine psb_d_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data + implicit none + type(psb_desc_type),intent(in) :: desc_data class(psb_d_base_prec_type), intent(in) :: prec real(psb_dpk_),intent(in) :: alpha, beta real(psb_dpk_),intent(inout) :: x(:) real(psb_dpk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans + integer, intent(out) :: info + character(len=1), optional :: trans real(psb_dpk_),intent(inout), optional, target :: work(:) Integer :: err_act, nrow character(len=20) :: name='d_base_prec_apply' @@ -146,10 +146,8 @@ contains end subroutine psb_d_base_apply subroutine psb_d_base_precinit(prec,info) - - use psb_base_mod Implicit None - + class(psb_d_base_prec_type),intent(inout) :: prec integer, intent(out) :: info Integer :: err_act, nrow @@ -178,8 +176,6 @@ contains end subroutine psb_d_base_precinit subroutine psb_d_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod Implicit None type(psb_dspmat_type), intent(in), target :: a @@ -189,7 +185,7 @@ contains character, intent(in), optional :: upd character(len=*), intent(in), optional :: afmt class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_d_base_vect_type), intent(in), optional :: vmold Integer :: err_act, nrow character(len=20) :: name='d_base_precbld' @@ -216,8 +212,6 @@ contains end subroutine psb_d_base_precbld subroutine psb_d_base_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_d_base_prec_type),intent(inout) :: prec @@ -250,8 +244,6 @@ contains end subroutine psb_d_base_precseti subroutine psb_d_base_precsetr(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_d_base_prec_type),intent(inout) :: prec @@ -284,8 +276,6 @@ contains end subroutine psb_d_base_precsetr subroutine psb_d_base_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_d_base_prec_type),intent(inout) :: prec @@ -318,8 +308,6 @@ contains end subroutine psb_d_base_precsetc subroutine psb_d_base_precfree(prec,info) - - use psb_base_mod Implicit None class(psb_d_base_prec_type), intent(inout) :: prec @@ -353,8 +341,6 @@ contains subroutine psb_d_base_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_d_base_prec_type), intent(in) :: prec @@ -387,7 +373,6 @@ contains end subroutine psb_d_base_precdescr subroutine psb_d_base_precdump(prec,info,prefix,head) - use psb_base_mod implicit none class(psb_d_base_prec_type), intent(in) :: prec integer, intent(out) :: info @@ -419,7 +404,6 @@ contains end subroutine psb_d_base_precdump subroutine psb_d_base_set_ctxt(prec,ictxt) - use psb_base_mod implicit none class(psb_d_base_prec_type), intent(inout) :: prec integer, intent(in) :: ictxt @@ -429,7 +413,6 @@ contains end subroutine psb_d_base_set_ctxt function psb_d_base_sizeof(prec) result(val) - use psb_base_mod class(psb_d_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val @@ -438,7 +421,6 @@ contains end function psb_d_base_sizeof function psb_d_base_get_ctxt(prec) result(val) - use psb_base_mod class(psb_d_base_prec_type), intent(in) :: prec integer :: val @@ -454,5 +436,4 @@ contains end function psb_d_base_get_nzeros - end module psb_d_base_prec_mod diff --git a/prec/psb_d_prec_mod.f90 b/prec/psb_d_prec_mod.f90 index 66fc3398..83eb0b64 100644 --- a/prec/psb_d_prec_mod.f90 +++ b/prec/psb_d_prec_mod.f90 @@ -32,12 +32,13 @@ module psb_d_prec_mod use psb_d_prec_type + use psb_d_base_prec_mod interface psb_precbld subroutine psb_dprecbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod, only : psb_desc_type, psb_dspmat_type,& - & psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type - use psb_prec_type, only : psb_dprec_type + import :: psb_desc_type, psb_dspmat_type,& + & psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type, & + & psb_dprec_type implicit none type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a @@ -52,8 +53,7 @@ module psb_d_prec_mod interface psb_precinit subroutine psb_dprecinit(prec,ptype,info) - use psb_base_mod, only : psb_desc_type, psb_dpk_ - use psb_prec_type, only : psb_dprec_type + import :: psb_desc_type, psb_dspmat_type, psb_dpk_, psb_dprec_type implicit none type(psb_dprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype @@ -63,27 +63,25 @@ module psb_d_prec_mod interface psb_precset subroutine psb_dprecseti(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_dpk_ - use psb_prec_type, only : psb_dprec_type + import :: psb_desc_type, psb_dspmat_type, psb_dpk_, psb_dprec_type implicit none type(psb_dprec_type), intent(inout) :: prec integer :: what, val integer, intent(out) :: info end subroutine psb_dprecseti - subroutine psb_dprecsetd(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_dpk_ - use psb_prec_type, only : psb_dprec_type + subroutine psb_dprecsetr(prec,what,val,info) + import :: psb_desc_type, psb_dspmat_type, psb_dpk_, psb_dprec_type implicit none type(psb_dprec_type), intent(inout) :: prec integer :: what real(psb_dpk_) :: val integer, intent(out) :: info - end subroutine psb_dprecsetd + end subroutine psb_dprecsetr end interface interface psb_ilu_fct subroutine psb_dilu_fct(a,l,u,d,info,blck) - use psb_base_mod, only : psb_desc_type, psb_dspmat_type,& + import :: psb_desc_type, psb_dspmat_type, & & psb_d_csr_sparse_mat, psb_dpk_ integer, intent(out) :: info type(psb_dspmat_type),intent(in) :: a diff --git a/prec/psb_d_prec_type.f90 b/prec/psb_d_prec_type.f90 index bea39e37..f2cfacb4 100644 --- a/prec/psb_d_prec_type.f90 +++ b/prec/psb_d_prec_type.f90 @@ -35,25 +35,18 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module psb_d_prec_type - ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_dspmat_type - - use psb_prec_const_mod use psb_d_base_prec_mod - + type psb_dprec_type class(psb_d_base_prec_type), allocatable :: prec contains - procedure, pass(prec) :: d_apply1_vect - procedure, pass(prec) :: d_apply2_vect - procedure, pass(prec) :: d_apply2v - procedure, pass(prec) :: d_apply1v - generic, public :: apply => d_apply2v, d_apply1v,& - & d_apply1_vect, d_apply2_vect + procedure, pass(prec) :: psb_d_apply1_vect + procedure, pass(prec) :: psb_d_apply2_vect + procedure, pass(prec) :: psb_d_apply2v + procedure, pass(prec) :: psb_d_apply1v + generic, public :: apply => psb_d_apply2v, psb_d_apply1v,& + & psb_d_apply1_vect, psb_d_apply2_vect end type psb_dprec_type interface psb_precfree @@ -61,12 +54,11 @@ module psb_d_prec_type end interface interface psb_nullify_prec - module procedure psb_nullify_dprec + module procedure psb_nullify_cprec end interface - interface psb_precdescr - module procedure psb_file_prec_descr + module procedure psb_dfile_prec_descr end interface interface psb_precdump @@ -77,15 +69,61 @@ module psb_d_prec_type module procedure psb_dprec_sizeof end interface - + interface psb_d_apply2_vect + subroutine psb_d_apply2_vect(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_apply2_vect + end interface psb_d_apply2_vect + + interface psb_d_apply1_vect + subroutine psb_d_apply1_vect(prec,x,desc_data,info,trans,work) + import :: psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(inout) :: prec + type(psb_d_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_apply1_vect + end interface psb_d_apply1_vect + + interface psb_d_apply2v + subroutine psb_d_apply2v(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_d_apply2v + end interface psb_d_apply2v + + interface psb_d_apply1v + subroutine psb_d_apply1v(prec,x,desc_data,info,trans) + import :: psb_desc_type, psb_dprec_type, psb_d_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_dprec_type), intent(in) :: prec + real(psb_dpk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine psb_d_apply1v + end interface psb_d_apply1v + contains - - subroutine psb_file_prec_descr(p,iout) - use psb_base_mod + subroutine psb_dfile_prec_descr(p,iout) type(psb_dprec_type), intent(in) :: p integer, intent(in), optional :: iout - integer :: iout_, info + integer :: iout_,info character(len=20) :: name='prec_descr' if (present(iout)) then @@ -99,12 +137,10 @@ contains call psb_errpush(info,name,a_err="preconditioner") end if call p%prec%precdescr(iout) - - end subroutine psb_file_prec_descr - + + end subroutine psb_dfile_prec_descr subroutine psb_d_prec_dump(prec,info,prefix,head) - use psb_base_mod implicit none type(psb_dprec_type), intent(in) :: prec integer, intent(out) :: info @@ -126,7 +162,6 @@ contains subroutine psb_d_precfree(p,info) - use psb_base_mod type(psb_dprec_type), intent(inout) :: p integer, intent(out) :: info integer :: me, err_act,i @@ -154,307 +189,23 @@ contains return end if return - end subroutine psb_d_precfree - subroutine psb_nullify_dprec(p) + subroutine psb_nullify_cprec(p) type(psb_dprec_type), intent(inout) :: p - - end subroutine psb_nullify_dprec - + end subroutine psb_nullify_cprec function psb_dprec_sizeof(prec) result(val) - use psb_base_mod type(psb_dprec_type), intent(in) :: prec integer(psb_long_int_k_) :: val - integer :: i - val = 0 + integer :: i + val = 0 if (allocated(prec%prec)) then val = val + prec%prec%sizeof() end if - end function psb_dprec_sizeof - - - subroutine d_apply2_vect(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_dprec_type), intent(inout) :: prec - type(psb_d_vect_type),intent(inout) :: x - type(psb_d_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - - character :: trans_ - real(psb_dpk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='d_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call prec%prec%apply(done,x,dzero,y,desc_data,info,& - & trans=trans_,work=work_) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_apply2_vect - - - subroutine d_apply1_vect(prec,x,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_dprec_type), intent(inout) :: prec - type(psb_d_vect_type),intent(inout) :: x - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - type(psb_d_vect_type) :: ww - character :: trans_ - real(psb_dpk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='d_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call psb_geall(ww,desc_data,info) - if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) - if (info == 0) call prec%prec%apply(done,x,dzero,ww,desc_data,info,& - & trans=trans_,work=work_) - if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_apply1_vect - - subroutine d_apply2v(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_dprec_type), intent(in) :: prec - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_dpk_),intent(inout), optional, target :: work(:) - - character :: trans_ - real(psb_dpk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='d_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - call prec%prec%apply(done,x,dzero,y,desc_data,info,& - & trans=trans_,work=work_) - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_apply2v - - subroutine d_apply1v(prec,x,desc_data,info,trans) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_dprec_type), intent(in) :: prec - real(psb_dpk_),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - - character :: trans_ - integer :: ictxt,np,me, err_act - real(psb_dpk_), pointer :: WW(:), w1(:) - character(len=20) :: name - name='d_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - call prec%prec%apply(done,x,dzero,ww,desc_data,info,& - & trans=trans_,work=w1) - if(info /= psb_success_) goto 9999 - x(:) = ww(:) - deallocate(ww,W1,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine d_apply1v + end function psb_dprec_sizeof end module psb_d_prec_type diff --git a/prec/psb_dprecset.f90 b/prec/psb_dprecset.f90 index d1c407d4..51495a40 100644 --- a/prec/psb_dprecset.f90 +++ b/prec/psb_dprecset.f90 @@ -54,10 +54,10 @@ subroutine psb_dprecseti(p,what,val,info) end subroutine psb_dprecseti -subroutine psb_dprecsetd(p,what,val,info) +subroutine psb_dprecsetr(p,what,val,info) use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_dprecsetd + use psb_prec_mod, psb_protect_name => psb_dprecsetr implicit none type(psb_dprec_type), intent(inout) :: p integer :: what @@ -77,4 +77,4 @@ subroutine psb_dprecsetd(p,what,val,info) return -end subroutine psb_dprecsetd +end subroutine psb_dprecsetr diff --git a/prec/psb_s_base_prec_mod.f90 b/prec/psb_s_base_prec_mod.f90 index 339d9aa8..178ceccb 100644 --- a/prec/psb_s_base_prec_mod.f90 +++ b/prec/psb_s_base_prec_mod.f90 @@ -36,12 +36,12 @@ module psb_s_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& + use psb_base_mod, only : psb_spk_, psb_long_int_k_,& + & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_sspmat_type, psb_s_base_vect, psb_s_vect_type + & psb_s_base_sparse_mat, psb_sspmat_type, psb_s_csr_sparse_mat,& + & psb_s_base_vect_type, psb_s_vect_type - use psb_prec_const_mod type psb_s_base_prec_type @@ -74,17 +74,17 @@ module psb_s_base_prec_mod contains subroutine psb_s_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data + implicit none + type(psb_desc_type),intent(in) :: desc_data class(psb_s_base_prec_type), intent(inout) :: prec - real(psb_spk_),intent(in) :: alpha, beta + real(psb_spk_),intent(in) :: alpha, beta type(psb_s_vect_type),intent(inout) :: x type(psb_s_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans + integer, intent(out) :: info + character(len=1), optional :: trans real(psb_spk_),intent(inout), optional, target :: work(:) Integer :: err_act, nrow - character(len=20) :: name='d_base_prec_apply' + character(len=20) :: name='s_base_prec_apply' call psb_erractionsave(err_act) @@ -110,14 +110,14 @@ contains end subroutine psb_s_base_apply_vect subroutine psb_s_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data + implicit none + type(psb_desc_type),intent(in) :: desc_data class(psb_s_base_prec_type), intent(in) :: prec real(psb_spk_),intent(in) :: alpha, beta real(psb_spk_),intent(inout) :: x(:) real(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans + integer, intent(out) :: info + character(len=1), optional :: trans real(psb_spk_),intent(inout), optional, target :: work(:) Integer :: err_act, nrow character(len=20) :: name='s_base_prec_apply' @@ -146,10 +146,8 @@ contains end subroutine psb_s_base_apply subroutine psb_s_base_precinit(prec,info) - - use psb_base_mod Implicit None - + class(psb_s_base_prec_type),intent(inout) :: prec integer, intent(out) :: info Integer :: err_act, nrow @@ -178,8 +176,6 @@ contains end subroutine psb_s_base_precinit subroutine psb_s_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod Implicit None type(psb_sspmat_type), intent(in), target :: a @@ -216,8 +212,6 @@ contains end subroutine psb_s_base_precbld subroutine psb_s_base_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_s_base_prec_type),intent(inout) :: prec @@ -250,8 +244,6 @@ contains end subroutine psb_s_base_precseti subroutine psb_s_base_precsetr(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_s_base_prec_type),intent(inout) :: prec @@ -284,8 +276,6 @@ contains end subroutine psb_s_base_precsetr subroutine psb_s_base_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_s_base_prec_type),intent(inout) :: prec @@ -318,8 +308,6 @@ contains end subroutine psb_s_base_precsetc subroutine psb_s_base_precfree(prec,info) - - use psb_base_mod Implicit None class(psb_s_base_prec_type), intent(inout) :: prec @@ -353,8 +341,6 @@ contains subroutine psb_s_base_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_s_base_prec_type), intent(in) :: prec @@ -387,13 +373,12 @@ contains end subroutine psb_s_base_precdescr subroutine psb_s_base_precdump(prec,info,prefix,head) - use psb_base_mod implicit none class(psb_s_base_prec_type), intent(in) :: prec integer, intent(out) :: info character(len=*), intent(in), optional :: prefix,head Integer :: err_act, nrow - character(len=20) :: name='d_base_precdump' + character(len=20) :: name='s_base_precdump' call psb_erractionsave(err_act) @@ -419,7 +404,6 @@ contains end subroutine psb_s_base_precdump subroutine psb_s_base_set_ctxt(prec,ictxt) - use psb_base_mod implicit none class(psb_s_base_prec_type), intent(inout) :: prec integer, intent(in) :: ictxt @@ -429,7 +413,6 @@ contains end subroutine psb_s_base_set_ctxt function psb_s_base_sizeof(prec) result(val) - use psb_base_mod class(psb_s_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val @@ -438,7 +421,6 @@ contains end function psb_s_base_sizeof function psb_s_base_get_ctxt(prec) result(val) - use psb_base_mod class(psb_s_base_prec_type), intent(in) :: prec integer :: val diff --git a/prec/psb_s_prec_mod.f90 b/prec/psb_s_prec_mod.f90 index 3c94d2f9..a3fe0e39 100644 --- a/prec/psb_s_prec_mod.f90 +++ b/prec/psb_s_prec_mod.f90 @@ -32,12 +32,13 @@ module psb_s_prec_mod use psb_s_prec_type + use psb_s_base_prec_mod interface psb_precbld subroutine psb_sprecbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod, only : psb_desc_type, psb_sspmat_type,& - & psb_s_base_sparse_mat, psb_spk_, psb_s_base_vect_type - use psb_prec_type, only : psb_sprec_type + import :: psb_desc_type, psb_sspmat_type,& + & psb_s_base_sparse_mat, psb_spk_, psb_s_base_vect_type, & + & psb_sprec_type implicit none type(psb_sspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a @@ -47,14 +48,12 @@ module psb_s_prec_mod character(len=*), intent(in), optional :: afmt class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold - end subroutine psb_sprecbld end interface interface psb_precinit subroutine psb_sprecinit(prec,ptype,info) - use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_ - use psb_prec_type, only : psb_sprec_type + import :: psb_desc_type, psb_sspmat_type, psb_spk_, psb_sprec_type implicit none type(psb_sprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype @@ -64,27 +63,25 @@ module psb_s_prec_mod interface psb_precset subroutine psb_sprecseti(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_ - use psb_prec_type, only : psb_sprec_type + import :: psb_desc_type, psb_sspmat_type, psb_spk_, psb_sprec_type implicit none type(psb_sprec_type), intent(inout) :: prec integer :: what, val integer, intent(out) :: info end subroutine psb_sprecseti - subroutine psb_sprecsets(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_ - use psb_prec_type, only : psb_sprec_type + subroutine psb_sprecsetr(prec,what,val,info) + import :: psb_desc_type, psb_sspmat_type, psb_spk_, psb_sprec_type implicit none type(psb_sprec_type), intent(inout) :: prec integer :: what real(psb_spk_) :: val integer, intent(out) :: info - end subroutine psb_sprecsets + end subroutine psb_sprecsetr end interface interface psb_ilu_fct subroutine psb_silu_fct(a,l,u,d,info,blck) - use psb_base_mod, only : psb_desc_type, psb_sspmat_type,& + import :: psb_desc_type, psb_sspmat_type, & & psb_s_csr_sparse_mat, psb_spk_ integer, intent(out) :: info type(psb_sspmat_type),intent(in) :: a diff --git a/prec/psb_s_prec_type.f90 b/prec/psb_s_prec_type.f90 index a0818f25..931bee01 100644 --- a/prec/psb_s_prec_type.f90 +++ b/prec/psb_s_prec_type.f90 @@ -35,24 +35,18 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module psb_s_prec_type - ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_sspmat_type - use psb_prec_const_mod use psb_s_base_prec_mod type psb_sprec_type class(psb_s_base_prec_type), allocatable :: prec contains - procedure, pass(prec) :: s_apply1_vect - procedure, pass(prec) :: s_apply2_vect - procedure, pass(prec) :: s_apply2v - procedure, pass(prec) :: s_apply1v - generic, public :: apply => s_apply2v, s_apply1v,& - & s_apply1_vect, s_apply2_vect + procedure, pass(prec) :: psb_s_apply1_vect + procedure, pass(prec) :: psb_s_apply2_vect + procedure, pass(prec) :: psb_s_apply2v + procedure, pass(prec) :: psb_s_apply1v + generic, public :: apply => psb_s_apply2v, psb_s_apply1v,& + & psb_s_apply1_vect, psb_s_apply2_vect end type psb_sprec_type interface psb_precfree @@ -60,7 +54,7 @@ module psb_s_prec_type end interface interface psb_nullify_prec - module procedure psb_nullify_sprec + module procedure psb_nullify_cprec end interface interface psb_precdescr @@ -75,10 +69,58 @@ module psb_s_prec_type module procedure psb_sprec_sizeof end interface + interface psb_s_apply2_vect + subroutine psb_s_apply2_vect(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_apply2_vect + end interface psb_s_apply2_vect + + interface psb_s_apply1_vect + subroutine psb_s_apply1_vect(prec,x,desc_data,info,trans,work) + import :: psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(inout) :: prec + type(psb_s_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_apply1_vect + end interface psb_s_apply1_vect + + interface psb_s_apply2v + subroutine psb_s_apply2v(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine psb_s_apply2v + end interface psb_s_apply2v + + interface psb_s_apply1v + subroutine psb_s_apply1v(prec,x,desc_data,info,trans) + import :: psb_desc_type, psb_sprec_type, psb_s_vect_type, psb_spk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine psb_s_apply1v + end interface psb_s_apply1v + contains subroutine psb_sfile_prec_descr(p,iout) - use psb_base_mod type(psb_sprec_type), intent(in) :: p integer, intent(in), optional :: iout integer :: iout_,info @@ -99,7 +141,6 @@ contains end subroutine psb_sfile_prec_descr subroutine psb_s_prec_dump(prec,info,prefix,head) - use psb_base_mod implicit none type(psb_sprec_type), intent(in) :: prec integer, intent(out) :: info @@ -121,12 +162,11 @@ contains subroutine psb_s_precfree(p,info) - use psb_base_mod - type(psb_sprec_type), intent(inout) :: p - integer, intent(out) :: info - integer :: me, err_act,i - character(len=20) :: name - if(psb_get_errstatus() /= 0) return + type(psb_sprec_type), intent(inout) :: p + integer, intent(out) :: info + integer :: me, err_act,i + character(len=20) :: name + if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) @@ -151,304 +191,21 @@ contains return end subroutine psb_s_precfree - subroutine psb_nullify_sprec(p) + subroutine psb_nullify_cprec(p) type(psb_sprec_type), intent(inout) :: p - end subroutine psb_nullify_sprec + end subroutine psb_nullify_cprec function psb_sprec_sizeof(prec) result(val) - use psb_base_mod type(psb_sprec_type), intent(in) :: prec integer(psb_long_int_k_) :: val integer :: i val = 0 - if (allocated(prec%prec)) then val = val + prec%prec%sizeof() end if end function psb_sprec_sizeof - - - subroutine s_apply2_vect(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_sprec_type), intent(inout) :: prec - type(psb_s_vect_type),intent(inout) :: x - type(psb_s_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - - character :: trans_ - real(psb_spk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='s_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call prec%prec%apply(sone,x,szero,y,desc_data,info,& - & trans=trans_,work=work_) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_apply2_vect - - - subroutine s_apply1_vect(prec,x,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_sprec_type), intent(inout) :: prec - type(psb_s_vect_type),intent(inout) :: x - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - - type(psb_s_vect_type) :: ww - character :: trans_ - real(psb_spk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='s_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call psb_geall(ww,desc_data,info) - if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) - if (info == 0) call prec%prec%apply(sone,x,szero,ww,desc_data,info,& - & trans=trans_,work=work_) - if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_apply1_vect - - subroutine s_apply2v(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_sprec_type), intent(in) :: prec - real(psb_spk_),intent(inout) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - - character :: trans_ - real(psb_spk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='s_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=trans - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - call prec%prec%apply(sone,x,szero,y,desc_data,info,& - & trans=trans_,work=work_) - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_apply2v - - subroutine s_apply1v(prec,x,desc_data,info,trans) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_sprec_type), intent(in) :: prec - real(psb_spk_),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - - character :: trans_ - integer :: ictxt,np,me, err_act - real(psb_spk_), pointer :: WW(:), w1(:) - character(len=20) :: name - name='s_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - call prec%prec%apply(sone,x,szero,ww,desc_data,info,& - & trans=trans_,work=w1) - if(info /= psb_success_) goto 9999 - x(:) = ww(:) - deallocate(ww,W1,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine s_apply1v end module psb_s_prec_type diff --git a/prec/psb_sprecset.f90 b/prec/psb_sprecset.f90 index 06de2ade..f6fa6ed1 100644 --- a/prec/psb_sprecset.f90 +++ b/prec/psb_sprecset.f90 @@ -54,10 +54,9 @@ subroutine psb_sprecseti(p,what,val,info) end subroutine psb_sprecseti -subroutine psb_sprecsets(p,what,val,info) - +subroutine psb_sprecsetr(p,what,val,info) use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_sprecsets + use psb_prec_mod, psb_protect_name => psb_sprecsetr implicit none type(psb_sprec_type), intent(inout) :: p integer :: what @@ -77,4 +76,4 @@ subroutine psb_sprecsets(p,what,val,info) return -end subroutine psb_sprecsets +end subroutine psb_sprecsetr diff --git a/prec/psb_z_base_prec_mod.f90 b/prec/psb_z_base_prec_mod.f90 index 39193e27..2986ea4d 100644 --- a/prec/psb_z_base_prec_mod.f90 +++ b/prec/psb_z_base_prec_mod.f90 @@ -36,10 +36,11 @@ module psb_z_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& + use psb_base_mod, only : psb_dpk_, psb_long_int_k_,& + & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_zspmat_type, psb_z_base_vect, psb_z_vect_type + & psb_z_base_sparse_mat, psb_zspmat_type, psb_z_csr_sparse_mat,& + & psb_z_base_vect_type, psb_z_vect_type use psb_prec_const_mod @@ -73,7 +74,7 @@ module psb_z_base_prec_mod contains subroutine psb_z_base_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_z_base_prec_type), intent(inout) :: prec complex(psb_dpk_),intent(in) :: alpha, beta @@ -83,7 +84,7 @@ contains character(len=1), optional :: trans complex(psb_dpk_),intent(inout), optional, target :: work(:) Integer :: err_act, nrow - character(len=20) :: name='d_base_prec_apply' + character(len=20) :: name='z_base_prec_apply' call psb_erractionsave(err_act) @@ -109,7 +110,7 @@ contains end subroutine psb_z_base_apply_vect subroutine psb_z_base_apply(alpha,prec,x,beta,y,desc_data,info,trans,work) - use psb_base_mod + implicit none type(psb_desc_type),intent(in) :: desc_data class(psb_z_base_prec_type), intent(in) :: prec complex(psb_dpk_),intent(in) :: alpha, beta @@ -145,10 +146,8 @@ contains end subroutine psb_z_base_apply subroutine psb_z_base_precinit(prec,info) - - use psb_base_mod Implicit None - + class(psb_z_base_prec_type),intent(inout) :: prec integer, intent(out) :: info Integer :: err_act, nrow @@ -177,8 +176,6 @@ contains end subroutine psb_z_base_precinit subroutine psb_z_base_precbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - - use psb_base_mod Implicit None type(psb_zspmat_type), intent(in), target :: a @@ -215,8 +212,6 @@ contains end subroutine psb_z_base_precbld subroutine psb_z_base_precseti(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_z_base_prec_type),intent(inout) :: prec @@ -249,8 +244,6 @@ contains end subroutine psb_z_base_precseti subroutine psb_z_base_precsetr(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_z_base_prec_type),intent(inout) :: prec @@ -283,8 +276,6 @@ contains end subroutine psb_z_base_precsetr subroutine psb_z_base_precsetc(prec,what,val,info) - - use psb_base_mod Implicit None class(psb_z_base_prec_type),intent(inout) :: prec @@ -317,8 +308,6 @@ contains end subroutine psb_z_base_precsetc subroutine psb_z_base_precfree(prec,info) - - use psb_base_mod Implicit None class(psb_z_base_prec_type), intent(inout) :: prec @@ -352,8 +341,6 @@ contains subroutine psb_z_base_precdescr(prec,iout) - - use psb_base_mod Implicit None class(psb_z_base_prec_type), intent(in) :: prec @@ -386,13 +373,12 @@ contains end subroutine psb_z_base_precdescr subroutine psb_z_base_precdump(prec,info,prefix,head) - use psb_base_mod implicit none class(psb_z_base_prec_type), intent(in) :: prec integer, intent(out) :: info character(len=*), intent(in), optional :: prefix,head Integer :: err_act, nrow - character(len=20) :: name='d_base_precdump' + character(len=20) :: name='z_base_precdump' call psb_erractionsave(err_act) @@ -418,7 +404,6 @@ contains end subroutine psb_z_base_precdump subroutine psb_z_base_set_ctxt(prec,ictxt) - use psb_base_mod implicit none class(psb_z_base_prec_type), intent(inout) :: prec integer, intent(in) :: ictxt @@ -428,7 +413,6 @@ contains end subroutine psb_z_base_set_ctxt function psb_z_base_sizeof(prec) result(val) - use psb_base_mod class(psb_z_base_prec_type), intent(in) :: prec integer(psb_long_int_k_) :: val @@ -437,7 +421,6 @@ contains end function psb_z_base_sizeof function psb_z_base_get_ctxt(prec) result(val) - use psb_base_mod class(psb_z_base_prec_type), intent(in) :: prec integer :: val diff --git a/prec/psb_z_prec_mod.f90 b/prec/psb_z_prec_mod.f90 index c7828630..e6ec212d 100644 --- a/prec/psb_z_prec_mod.f90 +++ b/prec/psb_z_prec_mod.f90 @@ -32,12 +32,13 @@ module psb_z_prec_mod use psb_z_prec_type + use psb_z_base_prec_mod interface psb_precbld subroutine psb_zprecbld(a,desc_a,prec,info,upd,amold,afmt,vmold) - use psb_base_mod, only : psb_desc_type, psb_zspmat_type,& - & psb_z_base_sparse_mat, psb_dpk_, psb_z_base_vect_type - use psb_prec_type, only : psb_zprec_type + import :: psb_desc_type, psb_zspmat_type,& + & psb_z_base_sparse_mat, psb_dpk_, psb_z_base_vect_type, & + & psb_zprec_type implicit none type(psb_zspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a @@ -52,8 +53,7 @@ module psb_z_prec_mod interface psb_precinit subroutine psb_zprecinit(prec,ptype,info) - use psb_base_mod, only : psb_desc_type, psb_zspmat_type, psb_dpk_ - use psb_prec_type, only : psb_zprec_type + import :: psb_desc_type, psb_zspmat_type, psb_dpk_, psb_zprec_type implicit none type(psb_zprec_type), intent(inout) :: prec character(len=*), intent(in) :: ptype @@ -63,27 +63,25 @@ module psb_z_prec_mod interface psb_precset subroutine psb_zprecseti(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_zspmat_type, psb_dpk_ - use psb_prec_type, only : psb_zprec_type + import :: psb_desc_type, psb_zspmat_type, psb_dpk_, psb_zprec_type implicit none type(psb_zprec_type), intent(inout) :: prec integer :: what, val integer, intent(out) :: info end subroutine psb_zprecseti - subroutine psb_zprecsetd(prec,what,val,info) - use psb_base_mod, only : psb_desc_type, psb_zspmat_type, psb_dpk_ - use psb_prec_type, only : psb_zprec_type + subroutine psb_zprecsetr(prec,what,val,info) + import :: psb_desc_type, psb_zspmat_type, psb_dpk_, psb_zprec_type implicit none type(psb_zprec_type), intent(inout) :: prec integer :: what real(psb_dpk_) :: val integer, intent(out) :: info - end subroutine psb_zprecsetd + end subroutine psb_zprecsetr end interface interface psb_ilu_fct subroutine psb_zilu_fct(a,l,u,d,info,blck) - use psb_base_mod, only : psb_desc_type, psb_zspmat_type, & + import :: psb_desc_type, psb_zspmat_type, & & psb_z_csr_sparse_mat, psb_dpk_ integer, intent(out) :: info type(psb_zspmat_type),intent(in) :: a diff --git a/prec/psb_z_prec_type.f90 b/prec/psb_z_prec_type.f90 index cfb51995..de700591 100644 --- a/prec/psb_z_prec_type.f90 +++ b/prec/psb_z_prec_type.f90 @@ -35,24 +35,18 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module psb_z_prec_type - ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_long_int_k_,& - & psb_desc_type, psb_sizeof, psb_free, psb_cdfree,& - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus,& - & psb_zspmat_type - use psb_prec_const_mod use psb_z_base_prec_mod - + type psb_zprec_type class(psb_z_base_prec_type), allocatable :: prec contains - procedure, pass(prec) :: z_apply1_vect - procedure, pass(prec) :: z_apply2_vect - procedure, pass(prec) :: z_apply2v - procedure, pass(prec) :: z_apply1v - generic, public :: apply => z_apply2v, z_apply1v,& - & z_apply1_vect, z_apply2_vect + procedure, pass(prec) :: psb_z_apply1_vect + procedure, pass(prec) :: psb_z_apply2_vect + procedure, pass(prec) :: psb_z_apply2v + procedure, pass(prec) :: psb_z_apply1v + generic, public :: apply => psb_z_apply2v, psb_z_apply1v,& + & psb_z_apply1_vect, psb_z_apply2_vect end type psb_zprec_type interface psb_precfree @@ -60,7 +54,7 @@ module psb_z_prec_type end interface interface psb_nullify_prec - module procedure psb_nullify_zprec + module procedure psb_nullify_cprec end interface interface psb_precdescr @@ -75,10 +69,58 @@ module psb_z_prec_type module procedure psb_zprec_sizeof end interface + interface psb_z_apply2_vect + subroutine psb_z_apply2_vect(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_apply2_vect + end interface psb_z_apply2_vect + + interface psb_z_apply1_vect + subroutine psb_z_apply1_vect(prec,x,desc_data,info,trans,work) + import :: psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(inout) :: prec + type(psb_z_vect_type),intent(inout) :: x + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_apply1_vect + end interface psb_z_apply1_vect + + interface psb_z_apply2v + subroutine psb_z_apply2v(prec,x,y,desc_data,info,trans,work) + import :: psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + complex(psb_dpk_),intent(inout), optional, target :: work(:) + end subroutine psb_z_apply2v + end interface psb_z_apply2v + + interface psb_z_apply1v + subroutine psb_z_apply1v(prec,x,desc_data,info,trans) + import :: psb_desc_type, psb_zprec_type, psb_z_vect_type, psb_dpk_ + type(psb_desc_type),intent(in) :: desc_data + class(psb_zprec_type), intent(in) :: prec + complex(psb_dpk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine psb_z_apply1v + end interface psb_z_apply1v + contains subroutine psb_zfile_prec_descr(p,iout) - use psb_base_mod type(psb_zprec_type), intent(in) :: p integer, intent(in), optional :: iout integer :: iout_,info @@ -99,7 +141,6 @@ contains end subroutine psb_zfile_prec_descr subroutine psb_z_prec_dump(prec,info,prefix,head) - use psb_base_mod implicit none type(psb_zprec_type), intent(in) :: prec integer, intent(out) :: info @@ -121,7 +162,6 @@ contains subroutine psb_z_precfree(p,info) - use psb_base_mod type(psb_zprec_type), intent(inout) :: p integer, intent(out) :: info integer :: me, err_act,i @@ -151,13 +191,12 @@ contains return end subroutine psb_z_precfree - subroutine psb_nullify_zprec(p) + subroutine psb_nullify_cprec(p) type(psb_zprec_type), intent(inout) :: p - end subroutine psb_nullify_zprec + end subroutine psb_nullify_cprec function psb_zprec_sizeof(prec) result(val) - use psb_base_mod type(psb_zprec_type), intent(in) :: prec integer(psb_long_int_k_) :: val integer :: i @@ -169,281 +208,4 @@ contains end function psb_zprec_sizeof - subroutine z_apply2_vect(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_zprec_type), intent(inout) :: prec - type(psb_z_vect_type),intent(inout) :: x - type(psb_z_vect_type),intent(inout) :: y - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - - character :: trans_ - complex(psb_dpk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name = 'z_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call prec%prec%apply(zone,x,zzero,y,desc_data,info,& - & trans=trans_,work=work_) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_apply2_vect - - subroutine z_apply1_vect(prec,x,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_zprec_type), intent(inout) :: prec - type(psb_z_vect_type),intent(inout) :: x - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - - type(psb_z_vect_type) :: ww - character :: trans_ - complex(psb_dpk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name = 'z_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - - call psb_geall(ww,desc_data,info) - if (info == 0) call psb_geasb(ww,desc_data,info,mold=x%v) - if (info == 0) call prec%prec%apply(zone,x,zzero,ww,desc_data,info,& - & trans=trans_,work=work_) - if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info) - - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_apply1_vect - - subroutine z_apply2v(prec,x,y,desc_data,info,trans,work) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - complex(psb_dpk_),intent(inout), optional, target :: work(:) - - character :: trans_ - complex(psb_dpk_), pointer :: work_(:) - integer :: ictxt,np,me,err_act - character(len=20) :: name - - name='z_apply2v' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) - - if (present(trans)) then - trans_=trans - else - trans_='N' - end if - - if (present(work)) then - work_ => work - else - allocate(work_(4*desc_data%get_local_cols()),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - call prec%prec%apply(zone,x,zzero,y,desc_data,info,trans_,work=work_) - if (present(work)) then - else - deallocate(work_,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_apply2v - - subroutine z_apply1v(prec,x,desc_data,info,trans) - use psb_base_mod - type(psb_desc_type),intent(in) :: desc_data - class(psb_zprec_type), intent(in) :: prec - complex(psb_dpk_),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - - character :: trans_ - integer :: ictxt,np,me, err_act - complex(psb_dpk_), pointer :: WW(:), w1(:) - character(len=20) :: name - name='z_apply1v' - info = psb_success_ - call psb_erractionsave(err_act) - - - ictxt=desc_data%get_context() - call psb_info(ictxt, me, np) - if (present(trans)) then - trans_=psb_toupper(trans) - else - trans_='N' - end if - - if (.not.allocated(prec%prec)) then - info = 1124 - call psb_errpush(info,name,a_err="preconditioner") - goto 9999 - end if - allocate(ww(size(x)),w1(size(x)),stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - call prec%prec%apply(zone,x,zzero,ww,desc_data,info,trans_,work=w1) - if(info /= psb_success_) goto 9999 - x(:) = ww(:) - deallocate(ww,W1,stat=info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='DeAllocate') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine z_apply1v - end module psb_z_prec_type diff --git a/prec/psb_zprecset.f90 b/prec/psb_zprecset.f90 index 029b25d0..dfe6053a 100644 --- a/prec/psb_zprecset.f90 +++ b/prec/psb_zprecset.f90 @@ -54,10 +54,10 @@ subroutine psb_zprecseti(p,what,val,info) end subroutine psb_zprecseti -subroutine psb_zprecsetd(p,what,val,info) +subroutine psb_zprecsetr(p,what,val,info) use psb_base_mod - use psb_prec_mod, psb_protect_name => psb_zprecsetd + use psb_prec_mod, psb_protect_name => psb_zprecsetr implicit none type(psb_zprec_type), intent(inout) :: p integer :: what @@ -77,4 +77,4 @@ subroutine psb_zprecsetd(p,what,val,info) return -end subroutine psb_zprecsetd +end subroutine psb_zprecsetr