From b508c9ad856f3cbd55768036577ae6dbbc960c13 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 31 Mar 2013 20:57:16 +0000 Subject: [PATCH] psblas3: base/modules/psb_c_vect_mod.F90 base/modules/psb_d_vect_mod.F90 base/modules/psb_i_vect_mod.F90 base/modules/psb_s_vect_mod.F90 base/modules/psb_z_vect_mod.F90 prec/psb_c_base_prec_mod.f90 prec/psb_c_bjacprec.f90 prec/psb_c_diagprec.f90 prec/psb_c_nullprec.f90 prec/psb_d_base_prec_mod.f90 prec/psb_d_bjacprec.f90 prec/psb_d_diagprec.f90 prec/psb_d_nullprec.f90 prec/psb_s_base_prec_mod.f90 prec/psb_s_bjacprec.f90 prec/psb_s_diagprec.f90 prec/psb_s_nullprec.f90 prec/psb_z_base_prec_mod.f90 prec/psb_z_bjacprec.f90 prec/psb_z_diagprec.f90 prec/psb_z_nullprec.f90 Clone method in base_prec --- base/modules/psb_c_vect_mod.F90 | 4 +- base/modules/psb_d_vect_mod.F90 | 4 +- base/modules/psb_i_vect_mod.F90 | 4 +- base/modules/psb_s_vect_mod.F90 | 4 +- base/modules/psb_z_vect_mod.F90 | 4 +- prec/psb_c_base_prec_mod.f90 | 13 ++++ prec/psb_c_bjacprec.f90 | 106 ++++++++++++++++---------------- prec/psb_c_diagprec.f90 | 59 ++++++++++++++++-- prec/psb_c_nullprec.f90 | 43 +++++++++++++ prec/psb_d_base_prec_mod.f90 | 13 ++++ prec/psb_d_bjacprec.f90 | 106 ++++++++++++++++---------------- prec/psb_d_diagprec.f90 | 59 ++++++++++++++++-- prec/psb_d_nullprec.f90 | 43 +++++++++++++ prec/psb_s_base_prec_mod.f90 | 13 ++++ prec/psb_s_bjacprec.f90 | 106 ++++++++++++++++---------------- prec/psb_s_diagprec.f90 | 59 ++++++++++++++++-- prec/psb_s_nullprec.f90 | 43 +++++++++++++ prec/psb_z_base_prec_mod.f90 | 13 ++++ prec/psb_z_bjacprec.f90 | 106 ++++++++++++++++---------------- prec/psb_z_diagprec.f90 | 59 ++++++++++++++++-- prec/psb_z_nullprec.f90 | 43 +++++++++++++ 21 files changed, 663 insertions(+), 241 deletions(-) diff --git a/base/modules/psb_c_vect_mod.F90 b/base/modules/psb_c_vect_mod.F90 index 1bc27f8b..b3e6256a 100644 --- a/base/modules/psb_c_vect_mod.F90 +++ b/base/modules/psb_c_vect_mod.F90 @@ -95,11 +95,13 @@ module psb_c_vect_mod contains - subroutine c_vect_clone(x,y) + subroutine c_vect_clone(x,y,info) implicit none class(psb_c_vect_type), intent(inout) :: x class(psb_c_vect_type), intent(out) :: y + integer(psb_ipk_), intent(out) :: info + info = psb_success_ if (allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if diff --git a/base/modules/psb_d_vect_mod.F90 b/base/modules/psb_d_vect_mod.F90 index 81daba60..4392c364 100644 --- a/base/modules/psb_d_vect_mod.F90 +++ b/base/modules/psb_d_vect_mod.F90 @@ -95,11 +95,13 @@ module psb_d_vect_mod contains - subroutine d_vect_clone(x,y) + subroutine d_vect_clone(x,y,info) implicit none class(psb_d_vect_type), intent(inout) :: x class(psb_d_vect_type), intent(out) :: y + integer(psb_ipk_), intent(out) :: info + info = psb_success_ if (allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if diff --git a/base/modules/psb_i_vect_mod.F90 b/base/modules/psb_i_vect_mod.F90 index 4b08fb12..d04a6ff2 100644 --- a/base/modules/psb_i_vect_mod.F90 +++ b/base/modules/psb_i_vect_mod.F90 @@ -95,11 +95,13 @@ module psb_i_vect_mod contains - subroutine i_vect_clone(x,y) + subroutine i_vect_clone(x,y,info) implicit none class(psb_i_vect_type), intent(inout) :: x class(psb_i_vect_type), intent(out) :: y + integer(psb_ipk_), intent(out) :: info + info = psb_success_ if (allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if diff --git a/base/modules/psb_s_vect_mod.F90 b/base/modules/psb_s_vect_mod.F90 index 7688e503..b935662c 100644 --- a/base/modules/psb_s_vect_mod.F90 +++ b/base/modules/psb_s_vect_mod.F90 @@ -95,11 +95,13 @@ module psb_s_vect_mod contains - subroutine s_vect_clone(x,y) + subroutine s_vect_clone(x,y,info) implicit none class(psb_s_vect_type), intent(inout) :: x class(psb_s_vect_type), intent(out) :: y + integer(psb_ipk_), intent(out) :: info + info = psb_success_ if (allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if diff --git a/base/modules/psb_z_vect_mod.F90 b/base/modules/psb_z_vect_mod.F90 index ac2fb0dc..c754824c 100644 --- a/base/modules/psb_z_vect_mod.F90 +++ b/base/modules/psb_z_vect_mod.F90 @@ -95,11 +95,13 @@ module psb_z_vect_mod contains - subroutine z_vect_clone(x,y) + subroutine z_vect_clone(x,y,info) implicit none class(psb_z_vect_type), intent(inout) :: x class(psb_z_vect_type), intent(out) :: y + integer(psb_ipk_), intent(out) :: info + info = psb_success_ if (allocated(x%v)) then call y%bld(x%get_vect(),mold=x%v) end if diff --git a/prec/psb_c_base_prec_mod.f90 b/prec/psb_c_base_prec_mod.f90 index ce3e3051..6409fb4a 100644 --- a/prec/psb_c_base_prec_mod.f90 +++ b/prec/psb_c_base_prec_mod.f90 @@ -64,6 +64,7 @@ module psb_c_base_prec_mod procedure(psb_c_base_precfree), pass(prec), deferred :: precfree procedure(psb_c_base_precdescr), pass(prec), deferred :: precdescr procedure(psb_c_base_precdump), pass(prec), deferred :: dump + procedure(psb_c_base_precclone), pass(prec), deferred :: clone end type psb_c_base_prec_type private :: psb_c_base_set_ctxt, psb_c_base_get_ctxt, & @@ -179,6 +180,18 @@ module psb_c_base_prec_mod end subroutine psb_c_base_precdump end interface + + abstract interface + subroutine psb_c_base_precclone(prec,precout,info) + import psb_ipk_, psb_spk_, psb_desc_type, psb_c_vect_type, & + & psb_c_base_vect_type, psb_cspmat_type, psb_c_base_prec_type,& + & psb_c_base_sparse_mat + implicit none + class(psb_c_base_prec_type), intent(inout) :: prec + class(psb_c_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_precclone + end interface contains diff --git a/prec/psb_c_bjacprec.f90 b/prec/psb_c_bjacprec.f90 index 8454015c..a1612aa6 100644 --- a/prec/psb_c_bjacprec.f90 +++ b/prec/psb_c_bjacprec.f90 @@ -43,11 +43,12 @@ module psb_c_bjacprec procedure, pass(prec) :: precbld => psb_c_bjac_precbld procedure, pass(prec) :: precinit => psb_c_bjac_precinit procedure, pass(prec) :: precseti => psb_c_bjac_precseti - procedure, pass(prec) :: precsetr => psb_c_bjac_precsetr - procedure, pass(prec) :: precsetc => psb_c_bjac_precsetc +!!$ procedure, pass(prec) :: precsetr => psb_c_bjac_precsetr +!!$ procedure, pass(prec) :: precsetc => psb_c_bjac_precsetc procedure, pass(prec) :: precfree => psb_c_bjac_precfree procedure, pass(prec) :: precdescr => psb_c_bjac_precdescr procedure, pass(prec) :: dump => psb_c_bjac_dump + procedure, pass(prec) :: clone => psb_c_bjac_clone procedure, pass(prec) :: sizeof => psb_c_bjac_sizeof procedure, pass(prec) :: get_nzeros => psb_c_bjac_get_nzeros end type psb_c_bjac_prec_type @@ -210,48 +211,33 @@ contains end function psb_c_bjac_get_nzeros - subroutine psb_c_bjac_precsetr(prec,what,val,info) + subroutine psb_c_bjac_precfree(prec,info) Implicit None - class(psb_c_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_bjac_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - 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_bjac_precsetr - - subroutine psb_c_bjac_precsetc(prec,what,val,info) - - Implicit None + class(psb_c_bjac_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info - class(psb_c_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='c_bjac_precset' + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='c_bjac_precfree' call psb_erractionsave(err_act) info = psb_success_ + if (allocated(prec%av)) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + end if + if (allocated(prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv,stat=info) + end if + if (allocated(prec%iprcparm)) then + deallocate(prec%iprcparm,stat=info) + end if call psb_erractionrestore(err_act) return @@ -262,35 +248,49 @@ contains return end if return - end subroutine psb_c_bjac_precsetc - subroutine psb_c_bjac_precfree(prec,info) + end subroutine psb_c_bjac_precfree + + subroutine psb_c_bjac_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod Implicit None class(psb_c_bjac_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info + class(psb_c_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, i - character(len=20) :: name='c_bjac_precfree' + character(len=20) :: name='c_bjac_clone' call psb_erractionsave(err_act) info = psb_success_ - if (allocated(prec%av)) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - end if + allocate(psb_c_bjac_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_c_bjac_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%av)) then + allocate(pout%av(size(prec%av)),stat=info) + do i=1,size(prec%av) + if (info /= psb_success_) exit + call prec%av(i)%clone(pout%av(i),info) + enddo + if (info /= psb_success_) goto 9999 + end if + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 - if (allocated(prec%dv)) then - call prec%dv%free(info) - if (info == 0) deallocate(prec%dv,stat=info) - end if - if (allocated(prec%iprcparm)) then - deallocate(prec%iprcparm,stat=info) - end if call psb_erractionrestore(err_act) return @@ -302,6 +302,6 @@ contains end if return - end subroutine psb_c_bjac_precfree + end subroutine psb_c_bjac_clone end module psb_c_bjacprec diff --git a/prec/psb_c_diagprec.f90 b/prec/psb_c_diagprec.f90 index 051c630a..9e7d061f 100644 --- a/prec/psb_c_diagprec.f90 +++ b/prec/psb_c_diagprec.f90 @@ -39,12 +39,13 @@ module psb_c_diagprec contains procedure, pass(prec) :: c_apply_v => psb_c_diag_apply_vect procedure, pass(prec) :: c_apply => psb_c_diag_apply - procedure, pass(prec) :: precbld => psb_c_diag_precbld - procedure, pass(prec) :: precinit => psb_c_diag_precinit - procedure, pass(prec) :: precfree => psb_c_diag_precfree - procedure, pass(prec) :: precdescr => psb_c_diag_precdescr - procedure, pass(prec) :: sizeof => psb_c_diag_sizeof - procedure, pass(prec) :: dump => psb_c_diag_dump + procedure, pass(prec) :: precbld => psb_c_diag_precbld + procedure, pass(prec) :: precinit => psb_c_diag_precinit + procedure, pass(prec) :: precfree => psb_c_diag_precfree + procedure, pass(prec) :: precdescr => psb_c_diag_precdescr + procedure, pass(prec) :: sizeof => psb_c_diag_sizeof + procedure, pass(prec) :: dump => psb_c_diag_dump + procedure, pass(prec) :: clone => psb_c_diag_clone procedure, pass(prec) :: get_nzeros => psb_c_diag_get_nzeros end type psb_c_diag_prec_type @@ -225,4 +226,50 @@ contains end function psb_c_diag_get_nzeros + subroutine psb_c_diag_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod + + Implicit None + + class(psb_c_diag_prec_type), intent(inout) :: prec + class(psb_c_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='c_diag_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_c_diag_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_c_diag_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + if (info == 0) call psb_safe_ab_cpy(prec%d,pout%d,info) + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_diag_clone + + end module psb_c_diagprec diff --git a/prec/psb_c_nullprec.f90 b/prec/psb_c_nullprec.f90 index e60c0547..2a657b28 100644 --- a/prec/psb_c_nullprec.f90 +++ b/prec/psb_c_nullprec.f90 @@ -43,6 +43,7 @@ module psb_c_nullprec procedure, pass(prec) :: precdescr => psb_c_null_precdescr procedure, pass(prec) :: sizeof => psb_c_null_sizeof procedure, pass(prec) :: dump => psb_c_null_dump + procedure, pass(prec) :: clone => psb_c_null_clone end type psb_c_null_prec_type private :: psb_c_null_precbld, psb_c_null_sizeof,& @@ -258,4 +259,46 @@ contains return end function psb_c_null_sizeof + + subroutine psb_c_null_clone(prec,precout,info) + use psb_const_mod + use psb_error_mod + + Implicit None + + class(psb_c_null_prec_type), intent(inout) :: prec + class(psb_c_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='c_null_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_c_null_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_c_null_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_null_clone + + end module psb_c_nullprec diff --git a/prec/psb_d_base_prec_mod.f90 b/prec/psb_d_base_prec_mod.f90 index bfb83d74..90090e5f 100644 --- a/prec/psb_d_base_prec_mod.f90 +++ b/prec/psb_d_base_prec_mod.f90 @@ -64,6 +64,7 @@ module psb_d_base_prec_mod procedure(psb_d_base_precfree), pass(prec), deferred :: precfree procedure(psb_d_base_precdescr), pass(prec), deferred :: precdescr procedure(psb_d_base_precdump), pass(prec), deferred :: dump + procedure(psb_d_base_precclone), pass(prec), deferred :: clone end type psb_d_base_prec_type private :: psb_d_base_set_ctxt, psb_d_base_get_ctxt, & @@ -179,6 +180,18 @@ module psb_d_base_prec_mod end subroutine psb_d_base_precdump end interface + + abstract interface + subroutine psb_d_base_precclone(prec,precout,info) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_d_vect_type, & + & psb_d_base_vect_type, psb_dspmat_type, psb_d_base_prec_type,& + & psb_d_base_sparse_mat + implicit none + class(psb_d_base_prec_type), intent(inout) :: prec + class(psb_d_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_precclone + end interface contains diff --git a/prec/psb_d_bjacprec.f90 b/prec/psb_d_bjacprec.f90 index 359c9459..71f6dee6 100644 --- a/prec/psb_d_bjacprec.f90 +++ b/prec/psb_d_bjacprec.f90 @@ -43,11 +43,12 @@ module psb_d_bjacprec procedure, pass(prec) :: precbld => psb_d_bjac_precbld procedure, pass(prec) :: precinit => psb_d_bjac_precinit procedure, pass(prec) :: precseti => psb_d_bjac_precseti - procedure, pass(prec) :: precsetr => psb_d_bjac_precsetr - procedure, pass(prec) :: precsetc => psb_d_bjac_precsetc +!!$ procedure, pass(prec) :: precsetr => psb_d_bjac_precsetr +!!$ procedure, pass(prec) :: precsetc => psb_d_bjac_precsetc procedure, pass(prec) :: precfree => psb_d_bjac_precfree procedure, pass(prec) :: precdescr => psb_d_bjac_precdescr procedure, pass(prec) :: dump => psb_d_bjac_dump + procedure, pass(prec) :: clone => psb_d_bjac_clone procedure, pass(prec) :: sizeof => psb_d_bjac_sizeof procedure, pass(prec) :: get_nzeros => psb_d_bjac_get_nzeros end type psb_d_bjac_prec_type @@ -210,48 +211,33 @@ contains end function psb_d_bjac_get_nzeros - subroutine psb_d_bjac_precsetr(prec,what,val,info) + subroutine psb_d_bjac_precfree(prec,info) Implicit None - class(psb_d_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_bjac_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - 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_bjac_precsetr - - subroutine psb_d_bjac_precsetc(prec,what,val,info) - - Implicit None + class(psb_d_bjac_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info - class(psb_d_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='d_bjac_precset' + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='d_bjac_precfree' call psb_erractionsave(err_act) info = psb_success_ + if (allocated(prec%av)) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + end if + if (allocated(prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv,stat=info) + end if + if (allocated(prec%iprcparm)) then + deallocate(prec%iprcparm,stat=info) + end if call psb_erractionrestore(err_act) return @@ -262,35 +248,49 @@ contains return end if return - end subroutine psb_d_bjac_precsetc - subroutine psb_d_bjac_precfree(prec,info) + end subroutine psb_d_bjac_precfree + + subroutine psb_d_bjac_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod Implicit None class(psb_d_bjac_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info + class(psb_d_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, i - character(len=20) :: name='d_bjac_precfree' + character(len=20) :: name='d_bjac_clone' call psb_erractionsave(err_act) info = psb_success_ - if (allocated(prec%av)) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - end if + allocate(psb_d_bjac_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_d_bjac_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%av)) then + allocate(pout%av(size(prec%av)),stat=info) + do i=1,size(prec%av) + if (info /= psb_success_) exit + call prec%av(i)%clone(pout%av(i),info) + enddo + if (info /= psb_success_) goto 9999 + end if + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 - if (allocated(prec%dv)) then - call prec%dv%free(info) - if (info == 0) deallocate(prec%dv,stat=info) - end if - if (allocated(prec%iprcparm)) then - deallocate(prec%iprcparm,stat=info) - end if call psb_erractionrestore(err_act) return @@ -302,6 +302,6 @@ contains end if return - end subroutine psb_d_bjac_precfree + end subroutine psb_d_bjac_clone end module psb_d_bjacprec diff --git a/prec/psb_d_diagprec.f90 b/prec/psb_d_diagprec.f90 index cdc3e0e4..d164a6c6 100644 --- a/prec/psb_d_diagprec.f90 +++ b/prec/psb_d_diagprec.f90 @@ -39,12 +39,13 @@ module psb_d_diagprec contains procedure, pass(prec) :: d_apply_v => psb_d_diag_apply_vect procedure, pass(prec) :: d_apply => psb_d_diag_apply - procedure, pass(prec) :: precbld => psb_d_diag_precbld - procedure, pass(prec) :: precinit => psb_d_diag_precinit - procedure, pass(prec) :: precfree => psb_d_diag_precfree - procedure, pass(prec) :: precdescr => psb_d_diag_precdescr - procedure, pass(prec) :: sizeof => psb_d_diag_sizeof - procedure, pass(prec) :: dump => psb_d_diag_dump + procedure, pass(prec) :: precbld => psb_d_diag_precbld + procedure, pass(prec) :: precinit => psb_d_diag_precinit + procedure, pass(prec) :: precfree => psb_d_diag_precfree + procedure, pass(prec) :: precdescr => psb_d_diag_precdescr + procedure, pass(prec) :: sizeof => psb_d_diag_sizeof + procedure, pass(prec) :: dump => psb_d_diag_dump + procedure, pass(prec) :: clone => psb_d_diag_clone procedure, pass(prec) :: get_nzeros => psb_d_diag_get_nzeros end type psb_d_diag_prec_type @@ -225,4 +226,50 @@ contains end function psb_d_diag_get_nzeros + subroutine psb_d_diag_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod + + Implicit None + + class(psb_d_diag_prec_type), intent(inout) :: prec + class(psb_d_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='d_diag_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_d_diag_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_d_diag_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + if (info == 0) call psb_safe_ab_cpy(prec%d,pout%d,info) + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_diag_clone + + end module psb_d_diagprec diff --git a/prec/psb_d_nullprec.f90 b/prec/psb_d_nullprec.f90 index 31bb7b68..de8eaf23 100644 --- a/prec/psb_d_nullprec.f90 +++ b/prec/psb_d_nullprec.f90 @@ -43,6 +43,7 @@ module psb_d_nullprec procedure, pass(prec) :: precdescr => psb_d_null_precdescr procedure, pass(prec) :: sizeof => psb_d_null_sizeof procedure, pass(prec) :: dump => psb_d_null_dump + procedure, pass(prec) :: clone => psb_d_null_clone end type psb_d_null_prec_type private :: psb_d_null_precbld, psb_d_null_sizeof,& @@ -258,4 +259,46 @@ contains return end function psb_d_null_sizeof + + subroutine psb_d_null_clone(prec,precout,info) + use psb_const_mod + use psb_error_mod + + Implicit None + + class(psb_d_null_prec_type), intent(inout) :: prec + class(psb_d_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='d_null_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_d_null_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_d_null_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_null_clone + + end module psb_d_nullprec diff --git a/prec/psb_s_base_prec_mod.f90 b/prec/psb_s_base_prec_mod.f90 index d478e50b..ab8b83c3 100644 --- a/prec/psb_s_base_prec_mod.f90 +++ b/prec/psb_s_base_prec_mod.f90 @@ -64,6 +64,7 @@ module psb_s_base_prec_mod procedure(psb_s_base_precfree), pass(prec), deferred :: precfree procedure(psb_s_base_precdescr), pass(prec), deferred :: precdescr procedure(psb_s_base_precdump), pass(prec), deferred :: dump + procedure(psb_s_base_precclone), pass(prec), deferred :: clone end type psb_s_base_prec_type private :: psb_s_base_set_ctxt, psb_s_base_get_ctxt, & @@ -179,6 +180,18 @@ module psb_s_base_prec_mod end subroutine psb_s_base_precdump end interface + + abstract interface + subroutine psb_s_base_precclone(prec,precout,info) + import psb_ipk_, psb_spk_, psb_desc_type, psb_s_vect_type, & + & psb_s_base_vect_type, psb_sspmat_type, psb_s_base_prec_type,& + & psb_s_base_sparse_mat + implicit none + class(psb_s_base_prec_type), intent(inout) :: prec + class(psb_s_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_precclone + end interface contains diff --git a/prec/psb_s_bjacprec.f90 b/prec/psb_s_bjacprec.f90 index 358ab247..7c8e5905 100644 --- a/prec/psb_s_bjacprec.f90 +++ b/prec/psb_s_bjacprec.f90 @@ -43,11 +43,12 @@ module psb_s_bjacprec procedure, pass(prec) :: precbld => psb_s_bjac_precbld procedure, pass(prec) :: precinit => psb_s_bjac_precinit procedure, pass(prec) :: precseti => psb_s_bjac_precseti - procedure, pass(prec) :: precsetr => psb_s_bjac_precsetr - procedure, pass(prec) :: precsetc => psb_s_bjac_precsetc +!!$ procedure, pass(prec) :: precsetr => psb_s_bjac_precsetr +!!$ procedure, pass(prec) :: precsetc => psb_s_bjac_precsetc procedure, pass(prec) :: precfree => psb_s_bjac_precfree procedure, pass(prec) :: precdescr => psb_s_bjac_precdescr procedure, pass(prec) :: dump => psb_s_bjac_dump + procedure, pass(prec) :: clone => psb_s_bjac_clone procedure, pass(prec) :: sizeof => psb_s_bjac_sizeof procedure, pass(prec) :: get_nzeros => psb_s_bjac_get_nzeros end type psb_s_bjac_prec_type @@ -210,48 +211,33 @@ contains end function psb_s_bjac_get_nzeros - subroutine psb_s_bjac_precsetr(prec,what,val,info) + subroutine psb_s_bjac_precfree(prec,info) Implicit None - class(psb_s_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_spk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_bjac_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - 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_bjac_precsetr - - subroutine psb_s_bjac_precsetc(prec,what,val,info) - - Implicit None + class(psb_s_bjac_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info - class(psb_s_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='s_bjac_precset' + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='s_bjac_precfree' call psb_erractionsave(err_act) info = psb_success_ + if (allocated(prec%av)) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + end if + if (allocated(prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv,stat=info) + end if + if (allocated(prec%iprcparm)) then + deallocate(prec%iprcparm,stat=info) + end if call psb_erractionrestore(err_act) return @@ -262,35 +248,49 @@ contains return end if return - end subroutine psb_s_bjac_precsetc - subroutine psb_s_bjac_precfree(prec,info) + end subroutine psb_s_bjac_precfree + + subroutine psb_s_bjac_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod Implicit None class(psb_s_bjac_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info + class(psb_s_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, i - character(len=20) :: name='s_bjac_precfree' + character(len=20) :: name='s_bjac_clone' call psb_erractionsave(err_act) info = psb_success_ - if (allocated(prec%av)) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - end if + allocate(psb_s_bjac_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_s_bjac_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%av)) then + allocate(pout%av(size(prec%av)),stat=info) + do i=1,size(prec%av) + if (info /= psb_success_) exit + call prec%av(i)%clone(pout%av(i),info) + enddo + if (info /= psb_success_) goto 9999 + end if + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 - if (allocated(prec%dv)) then - call prec%dv%free(info) - if (info == 0) deallocate(prec%dv,stat=info) - end if - if (allocated(prec%iprcparm)) then - deallocate(prec%iprcparm,stat=info) - end if call psb_erractionrestore(err_act) return @@ -302,6 +302,6 @@ contains end if return - end subroutine psb_s_bjac_precfree + end subroutine psb_s_bjac_clone end module psb_s_bjacprec diff --git a/prec/psb_s_diagprec.f90 b/prec/psb_s_diagprec.f90 index 36c62190..d966ab64 100644 --- a/prec/psb_s_diagprec.f90 +++ b/prec/psb_s_diagprec.f90 @@ -39,12 +39,13 @@ module psb_s_diagprec contains procedure, pass(prec) :: s_apply_v => psb_s_diag_apply_vect procedure, pass(prec) :: s_apply => psb_s_diag_apply - procedure, pass(prec) :: precbld => psb_s_diag_precbld - procedure, pass(prec) :: precinit => psb_s_diag_precinit - procedure, pass(prec) :: precfree => psb_s_diag_precfree - procedure, pass(prec) :: precdescr => psb_s_diag_precdescr - procedure, pass(prec) :: sizeof => psb_s_diag_sizeof - procedure, pass(prec) :: dump => psb_s_diag_dump + procedure, pass(prec) :: precbld => psb_s_diag_precbld + procedure, pass(prec) :: precinit => psb_s_diag_precinit + procedure, pass(prec) :: precfree => psb_s_diag_precfree + procedure, pass(prec) :: precdescr => psb_s_diag_precdescr + procedure, pass(prec) :: sizeof => psb_s_diag_sizeof + procedure, pass(prec) :: dump => psb_s_diag_dump + procedure, pass(prec) :: clone => psb_s_diag_clone procedure, pass(prec) :: get_nzeros => psb_s_diag_get_nzeros end type psb_s_diag_prec_type @@ -225,4 +226,50 @@ contains end function psb_s_diag_get_nzeros + subroutine psb_s_diag_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod + + Implicit None + + class(psb_s_diag_prec_type), intent(inout) :: prec + class(psb_s_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='s_diag_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_s_diag_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_s_diag_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + if (info == 0) call psb_safe_ab_cpy(prec%d,pout%d,info) + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_diag_clone + + end module psb_s_diagprec diff --git a/prec/psb_s_nullprec.f90 b/prec/psb_s_nullprec.f90 index 60519337..fe62bf24 100644 --- a/prec/psb_s_nullprec.f90 +++ b/prec/psb_s_nullprec.f90 @@ -43,6 +43,7 @@ module psb_s_nullprec procedure, pass(prec) :: precdescr => psb_s_null_precdescr procedure, pass(prec) :: sizeof => psb_s_null_sizeof procedure, pass(prec) :: dump => psb_s_null_dump + procedure, pass(prec) :: clone => psb_s_null_clone end type psb_s_null_prec_type private :: psb_s_null_precbld, psb_s_null_sizeof,& @@ -258,4 +259,46 @@ contains return end function psb_s_null_sizeof + + subroutine psb_s_null_clone(prec,precout,info) + use psb_const_mod + use psb_error_mod + + Implicit None + + class(psb_s_null_prec_type), intent(inout) :: prec + class(psb_s_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='s_null_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_s_null_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_s_null_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_null_clone + + end module psb_s_nullprec diff --git a/prec/psb_z_base_prec_mod.f90 b/prec/psb_z_base_prec_mod.f90 index 88f585d6..df3c712e 100644 --- a/prec/psb_z_base_prec_mod.f90 +++ b/prec/psb_z_base_prec_mod.f90 @@ -64,6 +64,7 @@ module psb_z_base_prec_mod procedure(psb_z_base_precfree), pass(prec), deferred :: precfree procedure(psb_z_base_precdescr), pass(prec), deferred :: precdescr procedure(psb_z_base_precdump), pass(prec), deferred :: dump + procedure(psb_z_base_precclone), pass(prec), deferred :: clone end type psb_z_base_prec_type private :: psb_z_base_set_ctxt, psb_z_base_get_ctxt, & @@ -179,6 +180,18 @@ module psb_z_base_prec_mod end subroutine psb_z_base_precdump end interface + + abstract interface + subroutine psb_z_base_precclone(prec,precout,info) + import psb_ipk_, psb_dpk_, psb_desc_type, psb_z_vect_type, & + & psb_z_base_vect_type, psb_zspmat_type, psb_z_base_prec_type,& + & psb_z_base_sparse_mat + implicit none + class(psb_z_base_prec_type), intent(inout) :: prec + class(psb_z_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_precclone + end interface contains diff --git a/prec/psb_z_bjacprec.f90 b/prec/psb_z_bjacprec.f90 index 3541e48c..af9cfadf 100644 --- a/prec/psb_z_bjacprec.f90 +++ b/prec/psb_z_bjacprec.f90 @@ -43,11 +43,12 @@ module psb_z_bjacprec procedure, pass(prec) :: precbld => psb_z_bjac_precbld procedure, pass(prec) :: precinit => psb_z_bjac_precinit procedure, pass(prec) :: precseti => psb_z_bjac_precseti - procedure, pass(prec) :: precsetr => psb_z_bjac_precsetr - procedure, pass(prec) :: precsetc => psb_z_bjac_precsetc +!!$ procedure, pass(prec) :: precsetr => psb_z_bjac_precsetr +!!$ procedure, pass(prec) :: precsetc => psb_z_bjac_precsetc procedure, pass(prec) :: precfree => psb_z_bjac_precfree procedure, pass(prec) :: precdescr => psb_z_bjac_precdescr procedure, pass(prec) :: dump => psb_z_bjac_dump + procedure, pass(prec) :: clone => psb_z_bjac_clone procedure, pass(prec) :: sizeof => psb_z_bjac_sizeof procedure, pass(prec) :: get_nzeros => psb_z_bjac_get_nzeros end type psb_z_bjac_prec_type @@ -210,48 +211,33 @@ contains end function psb_z_bjac_get_nzeros - subroutine psb_z_bjac_precsetr(prec,what,val,info) + subroutine psb_z_bjac_precfree(prec,info) Implicit None - class(psb_z_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_bjac_precset' - - call psb_erractionsave(err_act) - - info = psb_success_ - - 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_bjac_precsetr - - subroutine psb_z_bjac_precsetc(prec,what,val,info) - - Implicit None + class(psb_z_bjac_prec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info - class(psb_z_bjac_prec_type),intent(inout) :: prec - integer(psb_ipk_), intent(in) :: what - character(len=*), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nrow - character(len=20) :: name='z_bjac_precset' + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='z_bjac_precfree' call psb_erractionsave(err_act) info = psb_success_ + if (allocated(prec%av)) then + do i=1,size(prec%av) + call prec%av(i)%free() + enddo + deallocate(prec%av,stat=info) + end if + if (allocated(prec%dv)) then + call prec%dv%free(info) + if (info == 0) deallocate(prec%dv,stat=info) + end if + if (allocated(prec%iprcparm)) then + deallocate(prec%iprcparm,stat=info) + end if call psb_erractionrestore(err_act) return @@ -262,35 +248,49 @@ contains return end if return - end subroutine psb_z_bjac_precsetc - subroutine psb_z_bjac_precfree(prec,info) + end subroutine psb_z_bjac_precfree + + subroutine psb_z_bjac_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod Implicit None class(psb_z_bjac_prec_type), intent(inout) :: prec - integer(psb_ipk_), intent(out) :: info + class(psb_z_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, i - character(len=20) :: name='z_bjac_precfree' + character(len=20) :: name='z_bjac_clone' call psb_erractionsave(err_act) info = psb_success_ - if (allocated(prec%av)) then - do i=1,size(prec%av) - call prec%av(i)%free() - enddo - deallocate(prec%av,stat=info) - end if + allocate(psb_z_bjac_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_z_bjac_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%av)) then + allocate(pout%av(size(prec%av)),stat=info) + do i=1,size(prec%av) + if (info /= psb_success_) exit + call prec%av(i)%clone(pout%av(i),info) + enddo + if (info /= psb_success_) goto 9999 + end if + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 - if (allocated(prec%dv)) then - call prec%dv%free(info) - if (info == 0) deallocate(prec%dv,stat=info) - end if - if (allocated(prec%iprcparm)) then - deallocate(prec%iprcparm,stat=info) - end if call psb_erractionrestore(err_act) return @@ -302,6 +302,6 @@ contains end if return - end subroutine psb_z_bjac_precfree + end subroutine psb_z_bjac_clone end module psb_z_bjacprec diff --git a/prec/psb_z_diagprec.f90 b/prec/psb_z_diagprec.f90 index a2938ff3..7b16ec09 100644 --- a/prec/psb_z_diagprec.f90 +++ b/prec/psb_z_diagprec.f90 @@ -39,12 +39,13 @@ module psb_z_diagprec contains procedure, pass(prec) :: z_apply_v => psb_z_diag_apply_vect procedure, pass(prec) :: z_apply => psb_z_diag_apply - procedure, pass(prec) :: precbld => psb_z_diag_precbld - procedure, pass(prec) :: precinit => psb_z_diag_precinit - procedure, pass(prec) :: precfree => psb_z_diag_precfree - procedure, pass(prec) :: precdescr => psb_z_diag_precdescr - procedure, pass(prec) :: sizeof => psb_z_diag_sizeof - procedure, pass(prec) :: dump => psb_z_diag_dump + procedure, pass(prec) :: precbld => psb_z_diag_precbld + procedure, pass(prec) :: precinit => psb_z_diag_precinit + procedure, pass(prec) :: precfree => psb_z_diag_precfree + procedure, pass(prec) :: precdescr => psb_z_diag_precdescr + procedure, pass(prec) :: sizeof => psb_z_diag_sizeof + procedure, pass(prec) :: dump => psb_z_diag_dump + procedure, pass(prec) :: clone => psb_z_diag_clone procedure, pass(prec) :: get_nzeros => psb_z_diag_get_nzeros end type psb_z_diag_prec_type @@ -225,4 +226,50 @@ contains end function psb_z_diag_get_nzeros + subroutine psb_z_diag_clone(prec,precout,info) + use psb_error_mod + use psb_realloc_mod + + Implicit None + + class(psb_z_diag_prec_type), intent(inout) :: prec + class(psb_z_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='z_diag_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_z_diag_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_z_diag_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + if (allocated(prec%dv)) then + allocate(pout%dv,stat=info) + if (info == 0) call prec%dv%clone(pout%dv,info) + end if + if (info == 0) call psb_safe_ab_cpy(prec%d,pout%d,info) + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_diag_clone + + end module psb_z_diagprec diff --git a/prec/psb_z_nullprec.f90 b/prec/psb_z_nullprec.f90 index e7137057..8036d721 100644 --- a/prec/psb_z_nullprec.f90 +++ b/prec/psb_z_nullprec.f90 @@ -43,6 +43,7 @@ module psb_z_nullprec procedure, pass(prec) :: precdescr => psb_z_null_precdescr procedure, pass(prec) :: sizeof => psb_z_null_sizeof procedure, pass(prec) :: dump => psb_z_null_dump + procedure, pass(prec) :: clone => psb_z_null_clone end type psb_z_null_prec_type private :: psb_z_null_precbld, psb_z_null_sizeof,& @@ -258,4 +259,46 @@ contains return end function psb_z_null_sizeof + + subroutine psb_z_null_clone(prec,precout,info) + use psb_const_mod + use psb_error_mod + + Implicit None + + class(psb_z_null_prec_type), intent(inout) :: prec + class(psb_z_base_prec_type), allocatable, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act, i + character(len=20) :: name='z_null_clone' + + call psb_erractionsave(err_act) + + info = psb_success_ + allocate(psb_z_null_prec_type :: precout, stat=info) + if (info /= 0) goto 9999 + select type(pout => precout) + type is (psb_z_null_prec_type) + call pout%set_ctxt(prec%get_ctxt()) + + class default + info = psb_err_internal_error_ + end select + if (info /= 0) goto 9999 + + 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_null_clone + + end module psb_z_nullprec