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

psblas3:

Browse Source 
prec/Makefile
 prec/impl
 prec/impl/Makefile
 prec/impl/psb_c_prec_type_impl.f90
 prec/impl/psb_d_prec_type_impl.f90
 prec/impl/psb_s_prec_type_impl.f90
 prec/impl/psb_z_prec_type_impl.f90
 prec/psb_c_base_prec_mod.f90
 prec/psb_c_prec_mod.f90
 prec/psb_c_prec_type.f90
 prec/psb_cprecset.f90
 prec/psb_d_base_prec_mod.f90
 prec/psb_d_prec_mod.f90
 prec/psb_d_prec_type.f90
 prec/psb_dprecset.f90
 prec/psb_s_base_prec_mod.f90
 prec/psb_s_prec_mod.f90
 prec/psb_s_prec_type.f90
 prec/psb_sprecset.f90
 prec/psb_z_base_prec_mod.f90
 prec/psb_z_prec_mod.f90
 prec/psb_z_prec_type.f90
 prec/psb_zprecset.f90

Start decoupling interface/impl for PSB preconditioners.
Use IMPORT in interface definitions as much as possible.
This commit is contained in:
Salvatore Filippone
2012-01-03 11:53:02 +00:00
parent c8a5934771
commit 572e9e6b66
22 changed files with 1656 additions and 1399 deletions
Download Patch File Download Diff File Expand all files Collapse all files
prec/Makefile
+4 -2
View File
@@ -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)
prec/impl/Makefile
+30
View File
@@ -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)
prec/impl/psb_c_prec_type_impl.f90
+319
View File
@@ -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
prec/impl/psb_d_prec_type_impl.f90
+319
View File
@@ -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
prec/impl/psb_s_prec_type_impl.f90
+319
View File
@@ -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
prec/impl/psb_z_prec_type_impl.f90
+319
View File
@@ -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
prec/psb_c_base_prec_mod.f90
+9 -26
View File
@@ -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
prec/psb_c_prec_mod.f90
+10 -12
View File
@@ -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
prec/psb_c_prec_type.f90
+55 -295
View File
@@ -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
prec/psb_cprecset.f90
+3 -3
View File
@@ -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
prec/psb_d_base_prec_mod.f90
+16 -35
View File
@@ -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
prec/psb_d_prec_mod.f90
+10 -12
View File
@@ -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
prec/psb_d_prec_type.f90
+67 -316
View File
@@ -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 module psb_d_prec_type
prec/psb_dprecset.f90
+3 -3
View File
@@ -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
prec/psb_s_base_prec_mod.f90
+16 -34
View File
@@ -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
prec/psb_s_prec_mod.f90
+10 -13
View File
@@ -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
prec/psb_s_prec_type.f90
+63 -306
View File
@@ -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
prec/psb_sprecset.f90
+3 -4
View File
@@ -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
prec/psb_z_base_prec_mod.f90
+9 -26
View File
@@ -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
prec/psb_z_prec_mod.f90
+10 -12
View File
@@ -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
prec/psb_z_prec_type.f90
+59 -297
View File
@@ -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
prec/psb_zprecset.f90
+3 -3
View File
@@ -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