diff --git a/mlprec/impl/smoother/mld_c_as_smoother_clone.f90 b/mlprec/impl/smoother/mld_c_as_smoother_clone.f90 index 63882558..65daf8a4 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_c_as_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_c_as_smoother_type), intent(inout) :: sm - class(mld_c_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_c_as_smoother_type), intent(inout) :: sm + class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,11 +54,17 @@ subroutine mld_c_as_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_c_as_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_c_as_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_c_as_smoother_type) smo%novr = sm%novr @@ -68,6 +74,10 @@ subroutine mld_c_as_smoother_clone(sm,smout,info) call sm%nd%clone(smo%nd,info) if (info == psb_success_) & & call sm%desc_data%clone(smo%desc_data,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if class default info = psb_err_internal_error_ diff --git a/mlprec/impl/smoother/mld_c_base_smoother_clone.f90 b/mlprec/impl/smoother/mld_c_base_smoother_clone.f90 index 8d478bfb..6a6b7715 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_clone.f90 @@ -42,8 +42,8 @@ subroutine mld_c_base_smoother_clone(sm,smout,info) use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_clone Implicit None ! Arguments - class(mld_c_base_smoother_type), intent(inout) :: sm - class(mld_c_base_smoother_type), allocatable, intent(out) :: smout + class(mld_c_base_smoother_type), intent(inout) :: sm + class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_clone' diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_clone.f90 index 62a45077..c82aeaef 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_c_jac_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_c_jac_smoother_type), intent(inout) :: sm - class(mld_c_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_c_jac_smoother_type), intent(inout) :: sm + class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,16 +54,26 @@ subroutine mld_c_jac_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_c_jac_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_c_jac_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_c_jac_smoother_type) smo%nnz_nd_tot = sm%nnz_nd_tot call sm%nd%clone(smo%nd,info) - + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + class default info = psb_err_internal_error_ end select diff --git a/mlprec/impl/smoother/mld_d_as_smoother_clone.f90 b/mlprec/impl/smoother/mld_d_as_smoother_clone.f90 index f06564a7..f4f2fc42 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_d_as_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_d_as_smoother_type), intent(inout) :: sm - class(mld_d_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_d_as_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,11 +54,17 @@ subroutine mld_d_as_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_d_as_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_d_as_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_d_as_smoother_type) smo%novr = sm%novr @@ -68,6 +74,10 @@ subroutine mld_d_as_smoother_clone(sm,smout,info) call sm%nd%clone(smo%nd,info) if (info == psb_success_) & & call sm%desc_data%clone(smo%desc_data,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if class default info = psb_err_internal_error_ diff --git a/mlprec/impl/smoother/mld_d_base_smoother_clone.f90 b/mlprec/impl/smoother/mld_d_base_smoother_clone.f90 index b8b76439..3c6c98cd 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_clone.f90 @@ -42,8 +42,8 @@ subroutine mld_d_base_smoother_clone(sm,smout,info) use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_clone Implicit None ! Arguments - class(mld_d_base_smoother_type), intent(inout) :: sm - class(mld_d_base_smoother_type), allocatable, intent(out) :: smout + class(mld_d_base_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_clone' diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_clone.f90 index d87ccdd4..2288325d 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_d_jac_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_d_jac_smoother_type), intent(inout) :: sm - class(mld_d_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_d_jac_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,16 +54,26 @@ subroutine mld_d_jac_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_d_jac_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_d_jac_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_d_jac_smoother_type) smo%nnz_nd_tot = sm%nnz_nd_tot call sm%nd%clone(smo%nd,info) - + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + class default info = psb_err_internal_error_ end select diff --git a/mlprec/impl/smoother/mld_s_as_smoother_clone.f90 b/mlprec/impl/smoother/mld_s_as_smoother_clone.f90 index c26d4d07..3da6f2a5 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_s_as_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_s_as_smoother_type), intent(inout) :: sm - class(mld_s_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_s_as_smoother_type), intent(inout) :: sm + class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,11 +54,17 @@ subroutine mld_s_as_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_s_as_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_s_as_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_s_as_smoother_type) smo%novr = sm%novr @@ -68,6 +74,10 @@ subroutine mld_s_as_smoother_clone(sm,smout,info) call sm%nd%clone(smo%nd,info) if (info == psb_success_) & & call sm%desc_data%clone(smo%desc_data,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if class default info = psb_err_internal_error_ diff --git a/mlprec/impl/smoother/mld_s_base_smoother_clone.f90 b/mlprec/impl/smoother/mld_s_base_smoother_clone.f90 index 3e5ba785..66e3a68c 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_clone.f90 @@ -42,8 +42,8 @@ subroutine mld_s_base_smoother_clone(sm,smout,info) use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_clone Implicit None ! Arguments - class(mld_s_base_smoother_type), intent(inout) :: sm - class(mld_s_base_smoother_type), allocatable, intent(out) :: smout + class(mld_s_base_smoother_type), intent(inout) :: sm + class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_clone' diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_clone.f90 index 617d8cbc..a4e1a381 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_s_jac_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_s_jac_smoother_type), intent(inout) :: sm - class(mld_s_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_s_jac_smoother_type), intent(inout) :: sm + class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,16 +54,26 @@ subroutine mld_s_jac_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_s_jac_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_s_jac_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_s_jac_smoother_type) smo%nnz_nd_tot = sm%nnz_nd_tot call sm%nd%clone(smo%nd,info) - + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + class default info = psb_err_internal_error_ end select diff --git a/mlprec/impl/smoother/mld_z_as_smoother_clone.f90 b/mlprec/impl/smoother/mld_z_as_smoother_clone.f90 index a1a69e00..9885208d 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_z_as_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_z_as_smoother_type), intent(inout) :: sm - class(mld_z_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_z_as_smoother_type), intent(inout) :: sm + class(mld_z_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,11 +54,17 @@ subroutine mld_z_as_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_z_as_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_z_as_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_z_as_smoother_type) smo%novr = sm%novr @@ -68,6 +74,10 @@ subroutine mld_z_as_smoother_clone(sm,smout,info) call sm%nd%clone(smo%nd,info) if (info == psb_success_) & & call sm%desc_data%clone(smo%desc_data,info) + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if class default info = psb_err_internal_error_ diff --git a/mlprec/impl/smoother/mld_z_base_smoother_clone.f90 b/mlprec/impl/smoother/mld_z_base_smoother_clone.f90 index b669e14a..5d20b823 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_clone.f90 @@ -42,8 +42,8 @@ subroutine mld_z_base_smoother_clone(sm,smout,info) use mld_z_base_smoother_mod, mld_protect_name => mld_z_base_smoother_clone Implicit None ! Arguments - class(mld_z_base_smoother_type), intent(inout) :: sm - class(mld_z_base_smoother_type), allocatable, intent(out) :: smout + class(mld_z_base_smoother_type), intent(inout) :: sm + class(mld_z_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_clone' diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_clone.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_clone.f90 index 2ad3c2a0..7468582c 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_clone.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_clone.f90 @@ -44,9 +44,9 @@ subroutine mld_z_jac_smoother_clone(sm,smout,info) Implicit None ! Arguments - class(mld_z_jac_smoother_type), intent(inout) :: sm - class(mld_z_base_smoother_type), allocatable, intent(out) :: smout - integer(psb_ipk_), intent(out) :: info + class(mld_z_jac_smoother_type), intent(inout) :: sm + class(mld_z_base_smoother_type), allocatable, intent(inout) :: smout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act @@ -54,16 +54,26 @@ subroutine mld_z_jac_smoother_clone(sm,smout,info) info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_z_jac_smoother_type :: smout, stat=info) + if (allocated(smout)) then + call smout%free(info) + if (info == psb_success_) deallocate(smout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_z_jac_smoother_type :: smout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(smo => smout) type is (mld_z_jac_smoother_type) smo%nnz_nd_tot = sm%nnz_nd_tot call sm%nd%clone(smo%nd,info) - + if ((info==psb_success_).and.(allocated(sm%sv))) then + allocate(smout%sv,mold=sm%sv,stat=info) + if (info == psb_success_) call sm%sv%clone(smo%sv,info) + end if + class default info = psb_err_internal_error_ end select diff --git a/mlprec/impl/solver/mld_c_base_solver_clone.f90 b/mlprec/impl/solver/mld_c_base_solver_clone.f90 index e9a6d8f4..4e015a85 100644 --- a/mlprec/impl/solver/mld_c_base_solver_clone.f90 +++ b/mlprec/impl/solver/mld_c_base_solver_clone.f90 @@ -42,9 +42,9 @@ subroutine mld_c_base_solver_clone(sv,svout,info) use mld_c_base_solver_mod, mld_protect_name => mld_c_base_solver_clone Implicit None ! Arguments - class(mld_c_base_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_base_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_solver_clone' diff --git a/mlprec/impl/solver/mld_c_diag_solver_clone.f90 b/mlprec/impl/solver/mld_c_diag_solver_clone.f90 index 8161c8d6..3f7a6af2 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_c_diag_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_c_diag_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_diag_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_c_diag_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_c_diag_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_c_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) diff --git a/mlprec/impl/solver/mld_c_id_solver_clone.f90 b/mlprec/impl/solver/mld_c_id_solver_clone.f90 index e6823b1e..d88b8c98 100644 --- a/mlprec/impl/solver/mld_c_id_solver_clone.f90 +++ b/mlprec/impl/solver/mld_c_id_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_c_id_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_c_id_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_id_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_c_id_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_c_id_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_c_id_solver_type) ! Nothing to be done. diff --git a/mlprec/impl/solver/mld_c_ilu_solver_clone.f90 b/mlprec/impl/solver/mld_c_ilu_solver_clone.f90 index d64dcb13..14661fbb 100644 --- a/mlprec/impl/solver/mld_c_ilu_solver_clone.f90 +++ b/mlprec/impl/solver/mld_c_ilu_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_c_ilu_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_c_ilu_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_ilu_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - - allocate(mld_c_ilu_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_c_ilu_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(svo => svout) type is (mld_c_ilu_solver_type) svo%fact_type = sv%fact_type diff --git a/mlprec/impl/solver/mld_d_base_solver_clone.f90 b/mlprec/impl/solver/mld_d_base_solver_clone.f90 index 213e96f0..d41f1766 100644 --- a/mlprec/impl/solver/mld_d_base_solver_clone.f90 +++ b/mlprec/impl/solver/mld_d_base_solver_clone.f90 @@ -42,9 +42,9 @@ subroutine mld_d_base_solver_clone(sv,svout,info) use mld_d_base_solver_mod, mld_protect_name => mld_d_base_solver_clone Implicit None ! Arguments - class(mld_d_base_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_base_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_solver_clone' diff --git a/mlprec/impl/solver/mld_d_diag_solver_clone.f90 b/mlprec/impl/solver/mld_d_diag_solver_clone.f90 index c026fbb9..c75e04a8 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_d_diag_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_d_diag_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_diag_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_d_diag_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_d_diag_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_d_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) diff --git a/mlprec/impl/solver/mld_d_id_solver_clone.f90 b/mlprec/impl/solver/mld_d_id_solver_clone.f90 index 5f4ae281..6e55027f 100644 --- a/mlprec/impl/solver/mld_d_id_solver_clone.f90 +++ b/mlprec/impl/solver/mld_d_id_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_d_id_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_d_id_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_id_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_d_id_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_d_id_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_d_id_solver_type) ! Nothing to be done. diff --git a/mlprec/impl/solver/mld_d_ilu_solver_clone.f90 b/mlprec/impl/solver/mld_d_ilu_solver_clone.f90 index c1323a0f..b37a9fd1 100644 --- a/mlprec/impl/solver/mld_d_ilu_solver_clone.f90 +++ b/mlprec/impl/solver/mld_d_ilu_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_d_ilu_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_d_ilu_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_ilu_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - - allocate(mld_d_ilu_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_d_ilu_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(svo => svout) type is (mld_d_ilu_solver_type) svo%fact_type = sv%fact_type diff --git a/mlprec/impl/solver/mld_s_base_solver_clone.f90 b/mlprec/impl/solver/mld_s_base_solver_clone.f90 index cc5c2445..863b7257 100644 --- a/mlprec/impl/solver/mld_s_base_solver_clone.f90 +++ b/mlprec/impl/solver/mld_s_base_solver_clone.f90 @@ -42,9 +42,9 @@ subroutine mld_s_base_solver_clone(sv,svout,info) use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_clone Implicit None ! Arguments - class(mld_s_base_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_base_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_solver_clone' diff --git a/mlprec/impl/solver/mld_s_diag_solver_clone.f90 b/mlprec/impl/solver/mld_s_diag_solver_clone.f90 index 7c181826..4d653324 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_s_diag_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_s_diag_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_diag_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_s_diag_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_s_diag_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_s_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) diff --git a/mlprec/impl/solver/mld_s_id_solver_clone.f90 b/mlprec/impl/solver/mld_s_id_solver_clone.f90 index 9776d791..5eb6c73b 100644 --- a/mlprec/impl/solver/mld_s_id_solver_clone.f90 +++ b/mlprec/impl/solver/mld_s_id_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_s_id_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_s_id_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_id_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_s_id_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_s_id_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_s_id_solver_type) ! Nothing to be done. diff --git a/mlprec/impl/solver/mld_s_ilu_solver_clone.f90 b/mlprec/impl/solver/mld_s_ilu_solver_clone.f90 index d2fad046..19f32433 100644 --- a/mlprec/impl/solver/mld_s_ilu_solver_clone.f90 +++ b/mlprec/impl/solver/mld_s_ilu_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_s_ilu_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_s_ilu_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_ilu_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - - allocate(mld_s_ilu_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_s_ilu_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(svo => svout) type is (mld_s_ilu_solver_type) svo%fact_type = sv%fact_type diff --git a/mlprec/impl/solver/mld_z_base_solver_clone.f90 b/mlprec/impl/solver/mld_z_base_solver_clone.f90 index ca0050b6..6ac0047d 100644 --- a/mlprec/impl/solver/mld_z_base_solver_clone.f90 +++ b/mlprec/impl/solver/mld_z_base_solver_clone.f90 @@ -42,9 +42,9 @@ subroutine mld_z_base_solver_clone(sv,svout,info) use mld_z_base_solver_mod, mld_protect_name => mld_z_base_solver_clone Implicit None ! Arguments - class(mld_z_base_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_base_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_solver_clone' diff --git a/mlprec/impl/solver/mld_z_diag_solver_clone.f90 b/mlprec/impl/solver/mld_z_diag_solver_clone.f90 index d1e1266b..d4c75e93 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_clone.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_z_diag_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_z_diag_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_diag_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_z_diag_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_z_diag_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_z_diag_solver_type) call psb_safe_ab_cpy(sv%d,svo%d,info) diff --git a/mlprec/impl/solver/mld_z_id_solver_clone.f90 b/mlprec/impl/solver/mld_z_id_solver_clone.f90 index 6612196a..d6f0b27b 100644 --- a/mlprec/impl/solver/mld_z_id_solver_clone.f90 +++ b/mlprec/impl/solver/mld_z_id_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_z_id_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_z_id_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_id_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - allocate(mld_z_id_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_z_id_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if - + select type(svo => svout) type is (mld_z_id_solver_type) ! Nothing to be done. diff --git a/mlprec/impl/solver/mld_z_ilu_solver_clone.f90 b/mlprec/impl/solver/mld_z_ilu_solver_clone.f90 index 0fb44681..e8681446 100644 --- a/mlprec/impl/solver/mld_z_ilu_solver_clone.f90 +++ b/mlprec/impl/solver/mld_z_ilu_solver_clone.f90 @@ -44,21 +44,26 @@ subroutine mld_z_ilu_solver_clone(sv,svout,info) Implicit None ! Arguments - class(mld_z_ilu_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_ilu_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: err_act info=psb_success_ call psb_erractionsave(err_act) - - allocate(mld_z_ilu_solver_type :: svout, stat=info) + if (allocated(svout)) then + call svout%free(info) + if (info == psb_success_) deallocate(svout, stat=info) + end if + if (info == psb_success_) & + & allocate(mld_z_ilu_solver_type :: svout, stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ goto 9999 end if + select type(svo => svout) type is (mld_z_ilu_solver_type) svo%fact_type = sv%fact_type diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 5bc99dc9..2a02043f 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -79,10 +79,10 @@ module mld_base_prec_type ! ! Version numbers ! - character(len=*), parameter :: mld_version_string_ = "2.0.0" - integer(psb_ipk_), parameter :: mld_version_major_ = 2 - integer(psb_ipk_), parameter :: mld_version_minor_ = 0 - integer(psb_ipk_), parameter :: mld_patchlevel_ = 0 + character(len=*), parameter :: mld_version_string_ = "2.0.0" + integer(psb_ipk_), parameter :: mld_version_major_ = 2 + integer(psb_ipk_), parameter :: mld_version_minor_ = 0 + integer(psb_ipk_), parameter :: mld_patchlevel_ = 0 type mld_aux_onelev_map_type diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index 991887eb..d3af5c68 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -70,11 +70,13 @@ module mld_c_as_smoother procedure, pass(sm) :: sizeof => c_as_smoother_sizeof procedure, pass(sm) :: default => c_as_smoother_default procedure, pass(sm) :: get_nzeros => c_as_smoother_get_nzeros + procedure, nopass :: get_fmt => c_as_smoother_get_fmt end type mld_c_as_smoother_type private :: c_as_smoother_descr, c_as_smoother_sizeof, & - & c_as_smoother_default, c_as_smoother_get_nzeros + & c_as_smoother_default, c_as_smoother_get_nzeros, & + & c_as_smoother_get_fmt character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -243,8 +245,8 @@ module mld_c_as_smoother subroutine mld_c_as_smoother_clone(sm,smout,info) import :: mld_c_as_smoother_type, psb_spk_, & & mld_c_base_smoother_type, psb_ipk_ - class(mld_c_as_smoother_type), intent(inout) :: sm - class(mld_c_base_smoother_type), intent(out) :: smout + class(mld_c_as_smoother_type), intent(inout) :: sm + class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_c_as_smoother_clone end interface @@ -352,4 +354,11 @@ contains return end subroutine c_as_smoother_descr + function c_as_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Schwarz smoother" + end function c_as_smoother_get_fmt + end module mld_c_as_smoother diff --git a/mlprec/mld_c_base_smoother_mod.f90 b/mlprec/mld_c_base_smoother_mod.f90 index 0fb3e09e..c1ac1d12 100644 --- a/mlprec/mld_c_base_smoother_mod.f90 +++ b/mlprec/mld_c_base_smoother_mod.f90 @@ -112,10 +112,11 @@ module mld_c_base_smoother_mod procedure, pass(sm) :: sizeof => c_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => c_base_smoother_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => c_base_smoother_get_fmt end type mld_c_base_smoother_type - private :: c_base_smoother_sizeof, & + private :: c_base_smoother_sizeof, c_base_smoother_get_fmt, & & c_base_smoother_default, c_base_smoother_get_nzeros @@ -304,8 +305,8 @@ module mld_c_base_smoother_mod Implicit None ! Arguments - class(mld_c_base_smoother_type), intent(inout) :: sm - class(mld_c_base_smoother_type), allocatable, intent(out) :: smout + class(mld_c_base_smoother_type), intent(inout) :: sm + class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_c_base_smoother_clone end interface @@ -357,5 +358,11 @@ contains return end subroutine c_base_smoother_default + function c_base_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base smoother" + end function c_base_smoother_get_fmt end module mld_c_base_smoother_mod diff --git a/mlprec/mld_c_base_solver_mod.f90 b/mlprec/mld_c_base_solver_mod.f90 index d647b5ed..0a4b7eac 100644 --- a/mlprec/mld_c_base_solver_mod.f90 +++ b/mlprec/mld_c_base_solver_mod.f90 @@ -104,10 +104,11 @@ module mld_c_base_solver_mod procedure, pass(sv) :: sizeof => c_base_solver_sizeof procedure, pass(sv) :: get_nzeros => c_base_solver_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => c_base_solver_get_fmt end type mld_c_base_solver_type private :: c_base_solver_sizeof, c_base_solver_default,& - & c_base_solver_get_nzeros + & c_base_solver_get_nzeros, c_base_solver_get_fmt interface @@ -318,9 +319,9 @@ module mld_c_base_solver_mod Implicit None ! Arguments - class(mld_c_base_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_base_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_c_base_solver_clone end interface @@ -360,4 +361,12 @@ contains return end subroutine c_base_solver_default + function c_base_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base solver" + end function c_base_solver_get_fmt + + end module mld_c_base_solver_mod diff --git a/mlprec/mld_c_diag_solver.f90 b/mlprec/mld_c_diag_solver.f90 index 943da415..1b5642a7 100644 --- a/mlprec/mld_c_diag_solver.f90 +++ b/mlprec/mld_c_diag_solver.f90 @@ -59,11 +59,13 @@ module mld_c_diag_solver procedure, pass(sv) :: descr => c_diag_solver_descr procedure, pass(sv) :: sizeof => c_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => c_diag_solver_get_nzeros + procedure, nopass :: get_fmt => c_diag_solver_get_fmt end type mld_c_diag_solver_type private :: c_diag_solver_free, c_diag_solver_descr, & - & c_diag_solver_sizeof, c_diag_solver_get_nzeros + & c_diag_solver_sizeof, c_diag_solver_get_nzeros, & + & c_diag_solver_get_fmt interface @@ -122,9 +124,9 @@ module mld_c_diag_solver Implicit None ! Arguments - class(mld_c_diag_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_diag_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_c_diag_solver_clone end interface @@ -221,4 +223,12 @@ contains return end function c_diag_solver_get_nzeros + function c_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Diag solver" + end function c_diag_solver_get_fmt + + end module mld_c_diag_solver diff --git a/mlprec/mld_c_id_solver.f90 b/mlprec/mld_c_id_solver.f90 index 64ee0d76..bed3af3c 100644 --- a/mlprec/mld_c_id_solver.f90 +++ b/mlprec/mld_c_id_solver.f90 @@ -55,11 +55,12 @@ module mld_c_id_solver procedure, pass(sv) :: apply_a => mld_c_id_solver_apply procedure, pass(sv) :: free => c_id_solver_free procedure, pass(sv) :: descr => c_id_solver_descr + procedure, nopass :: get_fmt => c_id_solver_get_fmt end type mld_c_id_solver_type private :: c_id_solver_bld, & - & c_id_solver_free, & + & c_id_solver_free, c_id_solver_get_fmt, & & c_id_solver_descr interface @@ -102,9 +103,9 @@ module mld_c_id_solver Implicit None ! Arguments - class(mld_c_id_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_id_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_c_id_solver_clone end interface @@ -178,4 +179,12 @@ contains end subroutine c_id_solver_descr + function c_id_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Identity solver" + end function c_id_solver_get_fmt + + end module mld_c_id_solver diff --git a/mlprec/mld_c_ilu_solver.f90 b/mlprec/mld_c_ilu_solver.f90 index 796fd5b2..9b0c2908 100644 --- a/mlprec/mld_c_ilu_solver.f90 +++ b/mlprec/mld_c_ilu_solver.f90 @@ -71,6 +71,7 @@ module mld_c_ilu_solver procedure, pass(sv) :: default => c_ilu_solver_default procedure, pass(sv) :: sizeof => c_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => c_ilu_solver_get_nzeros + procedure, nopass :: get_fmt => c_ilu_solver_get_fmt end type mld_c_ilu_solver_type @@ -79,7 +80,8 @@ module mld_c_ilu_solver & c_ilu_solver_setc, c_ilu_solver_setr,& & c_ilu_solver_descr, c_ilu_solver_sizeof, & & c_ilu_solver_default, c_ilu_solver_dmp, & - & c_ilu_solver_apply_vect, c_ilu_solver_get_nzeros + & c_ilu_solver_apply_vect, c_ilu_solver_get_nzeros, & + & c_ilu_solver_get_fmt character(len=15), parameter, private :: & @@ -162,9 +164,9 @@ module mld_c_ilu_solver Implicit None ! Arguments - class(mld_c_ilu_solver_type), intent(inout) :: sv - class(mld_c_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_c_ilu_solver_type), intent(inout) :: sv + class(mld_c_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_c_ilu_solver_clone end interface @@ -556,4 +558,11 @@ contains return end function c_ilu_solver_sizeof + function c_ilu_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "ILU solver" + end function c_ilu_solver_get_fmt + end module mld_c_ilu_solver diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index 410f3656..67e572b5 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -62,11 +62,13 @@ module mld_c_jac_smoother procedure, pass(sm) :: descr => c_jac_smoother_descr procedure, pass(sm) :: sizeof => c_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => c_jac_smoother_get_nzeros + procedure, nopass :: get_fmt => c_jac_smoother_get_fmt end type mld_c_jac_smoother_type private :: c_jac_smoother_free, c_jac_smoother_descr, & - & c_jac_smoother_sizeof, c_jac_smoother_get_nzeros + & c_jac_smoother_sizeof, c_jac_smoother_get_nzeros, & + & c_jac_smoother_get_fmt interface @@ -120,8 +122,8 @@ module mld_c_jac_smoother subroutine mld_c_jac_smoother_clone(sm,smout,info) import :: mld_c_jac_smoother_type, psb_spk_, & & mld_c_base_smoother_type, psb_ipk_ - class(mld_c_jac_smoother_type), intent(inout) :: sm - class(mld_c_base_smoother_type), intent(out) :: smout + class(mld_c_jac_smoother_type), intent(inout) :: sm + class(mld_c_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_c_jac_smoother_clone end interface @@ -247,4 +249,11 @@ contains return end function c_jac_smoother_get_nzeros + function c_jac_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi smoother" + end function c_jac_smoother_get_fmt + end module mld_c_jac_smoother diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index 1051d85f..74b498b0 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -385,11 +385,18 @@ contains ! Arguments class(mld_c_onelev_type), target, intent(inout) :: lv - class(mld_c_onelev_type), intent(out) :: lvout + class(mld_c_onelev_type), intent(inout) :: lvout integer(psb_ipk_), intent(out) :: info - if (allocated(lv%sm)) & - & call lv%sm%clone(lvout%sm,info) + info = psb_success_ + if (allocated(lv%sm)) then + call lv%sm%clone(lvout%sm,info) + else + if (allocated(lvout%sm)) then + call lvout%sm%free(info) + if (info==psb_success_) deallocate(lvout%sm,stat=info) + end if + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 90cff70d..57ba740e 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -728,36 +728,53 @@ contains implicit none class(mld_cprec_type), intent(inout) :: prec - class(mld_cprec_type), target, intent(out) :: precout - integer(psb_ipk_), intent(out) :: info + class(psb_cprec_type), intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + call mld_c_inner_clone(prec,precout,info) + + end subroutine mld_c_clone + + subroutine mld_c_inner_clone(prec,precout,info) + + implicit none + class(mld_cprec_type), intent(inout) :: prec + class(psb_cprec_type), target, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info ! Local vars integer(psb_ipk_) :: i, j, il1, ln, lname, lev integer(psb_ipk_) :: icontxt,iam, np info = psb_success_ - precout%ictxt = prec%ictxt - precout%coarse_aggr_size = prec%coarse_aggr_size - precout%op_complexity = prec%op_complexity - if (allocated(prec%precv)) then - ln = size(prec%precv) - allocate(precout%precv(ln),stat=info) - if (info /= psb_success_) goto 9999 - if (ln > 1) then - call prec%precv(1)%clone(precout%precv(1),info) - end if - do lev=2, ln - if (info /= psb_success_) exit - call prec%precv(lev)%clone(precout%precv(lev),info) - if (info == psb_success_) then - precout%precv(lev)%base_a => precout%precv(lev)%ac - precout%precv(lev)%base_desc => precout%precv(lev)%desc_ac - precout%precv(lev)%map%p_desc_X => precout%precv(lev-1)%base_desc - precout%precv(lev)%map%p_desc_Y => precout%precv(lev)%base_desc + select type(pout => precout) + class is (mld_cprec_type) + pout%ictxt = prec%ictxt + pout%coarse_aggr_size = prec%coarse_aggr_size + pout%op_complexity = prec%op_complexity + if (allocated(prec%precv)) then + ln = size(prec%precv) + allocate(pout%precv(ln),stat=info) + if (info /= psb_success_) goto 9999 + if (ln >= 1) then + call prec%precv(1)%clone(pout%precv(1),info) end if - end do - end if + do lev=2, ln + if (info /= psb_success_) exit + call prec%precv(lev)%clone(pout%precv(lev),info) + if (info == psb_success_) then + pout%precv(lev)%base_a => pout%precv(lev)%ac + pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac + pout%precv(lev)%map%p_desc_X => pout%precv(lev-1)%base_desc + pout%precv(lev)%map%p_desc_Y => pout%precv(lev)%base_desc + end if + end do + end if + class default + write(0,*) 'Error: wrong out type' + info = psb_err_invalid_input_ + end select 9999 continue - end subroutine mld_c_clone + end subroutine mld_c_inner_clone subroutine mld_cprec_move_alloc(a, b,info) use psb_base_mod diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index bf0b5d00..f46c2d5a 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -70,11 +70,13 @@ module mld_d_as_smoother procedure, pass(sm) :: sizeof => d_as_smoother_sizeof procedure, pass(sm) :: default => d_as_smoother_default procedure, pass(sm) :: get_nzeros => d_as_smoother_get_nzeros + procedure, nopass :: get_fmt => d_as_smoother_get_fmt end type mld_d_as_smoother_type private :: d_as_smoother_descr, d_as_smoother_sizeof, & - & d_as_smoother_default, d_as_smoother_get_nzeros + & d_as_smoother_default, d_as_smoother_get_nzeros, & + & d_as_smoother_get_fmt character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -243,8 +245,8 @@ module mld_d_as_smoother subroutine mld_d_as_smoother_clone(sm,smout,info) import :: mld_d_as_smoother_type, psb_dpk_, & & mld_d_base_smoother_type, psb_ipk_ - class(mld_d_as_smoother_type), intent(inout) :: sm - class(mld_d_base_smoother_type), intent(out) :: smout + class(mld_d_as_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_d_as_smoother_clone end interface @@ -352,4 +354,11 @@ contains return end subroutine d_as_smoother_descr + function d_as_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Schwarz smoother" + end function d_as_smoother_get_fmt + end module mld_d_as_smoother diff --git a/mlprec/mld_d_base_smoother_mod.f90 b/mlprec/mld_d_base_smoother_mod.f90 index 6f7cc194..7da85ede 100644 --- a/mlprec/mld_d_base_smoother_mod.f90 +++ b/mlprec/mld_d_base_smoother_mod.f90 @@ -112,10 +112,11 @@ module mld_d_base_smoother_mod procedure, pass(sm) :: sizeof => d_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => d_base_smoother_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => d_base_smoother_get_fmt end type mld_d_base_smoother_type - private :: d_base_smoother_sizeof, & + private :: d_base_smoother_sizeof, d_base_smoother_get_fmt, & & d_base_smoother_default, d_base_smoother_get_nzeros @@ -304,8 +305,8 @@ module mld_d_base_smoother_mod Implicit None ! Arguments - class(mld_d_base_smoother_type), intent(inout) :: sm - class(mld_d_base_smoother_type), allocatable, intent(out) :: smout + class(mld_d_base_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_d_base_smoother_clone end interface @@ -357,5 +358,11 @@ contains return end subroutine d_base_smoother_default + function d_base_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base smoother" + end function d_base_smoother_get_fmt end module mld_d_base_smoother_mod diff --git a/mlprec/mld_d_base_solver_mod.f90 b/mlprec/mld_d_base_solver_mod.f90 index ec2c5fc1..65aafbe3 100644 --- a/mlprec/mld_d_base_solver_mod.f90 +++ b/mlprec/mld_d_base_solver_mod.f90 @@ -104,10 +104,11 @@ module mld_d_base_solver_mod procedure, pass(sv) :: sizeof => d_base_solver_sizeof procedure, pass(sv) :: get_nzeros => d_base_solver_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => d_base_solver_get_fmt end type mld_d_base_solver_type private :: d_base_solver_sizeof, d_base_solver_default,& - & d_base_solver_get_nzeros + & d_base_solver_get_nzeros, d_base_solver_get_fmt interface @@ -318,9 +319,9 @@ module mld_d_base_solver_mod Implicit None ! Arguments - class(mld_d_base_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_base_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_d_base_solver_clone end interface @@ -360,4 +361,12 @@ contains return end subroutine d_base_solver_default + function d_base_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base solver" + end function d_base_solver_get_fmt + + end module mld_d_base_solver_mod diff --git a/mlprec/mld_d_diag_solver.f90 b/mlprec/mld_d_diag_solver.f90 index 4eb1d7b5..fea35161 100644 --- a/mlprec/mld_d_diag_solver.f90 +++ b/mlprec/mld_d_diag_solver.f90 @@ -59,11 +59,13 @@ module mld_d_diag_solver procedure, pass(sv) :: descr => d_diag_solver_descr procedure, pass(sv) :: sizeof => d_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => d_diag_solver_get_nzeros + procedure, nopass :: get_fmt => d_diag_solver_get_fmt end type mld_d_diag_solver_type private :: d_diag_solver_free, d_diag_solver_descr, & - & d_diag_solver_sizeof, d_diag_solver_get_nzeros + & d_diag_solver_sizeof, d_diag_solver_get_nzeros, & + & d_diag_solver_get_fmt interface @@ -122,9 +124,9 @@ module mld_d_diag_solver Implicit None ! Arguments - class(mld_d_diag_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_diag_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_d_diag_solver_clone end interface @@ -221,4 +223,12 @@ contains return end function d_diag_solver_get_nzeros + function d_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Diag solver" + end function d_diag_solver_get_fmt + + end module mld_d_diag_solver diff --git a/mlprec/mld_d_id_solver.f90 b/mlprec/mld_d_id_solver.f90 index 3140042b..0fc069c5 100644 --- a/mlprec/mld_d_id_solver.f90 +++ b/mlprec/mld_d_id_solver.f90 @@ -55,11 +55,12 @@ module mld_d_id_solver procedure, pass(sv) :: apply_a => mld_d_id_solver_apply procedure, pass(sv) :: free => d_id_solver_free procedure, pass(sv) :: descr => d_id_solver_descr + procedure, nopass :: get_fmt => d_id_solver_get_fmt end type mld_d_id_solver_type private :: d_id_solver_bld, & - & d_id_solver_free, & + & d_id_solver_free, d_id_solver_get_fmt, & & d_id_solver_descr interface @@ -102,9 +103,9 @@ module mld_d_id_solver Implicit None ! Arguments - class(mld_d_id_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_id_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_d_id_solver_clone end interface @@ -178,4 +179,12 @@ contains end subroutine d_id_solver_descr + function d_id_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Identity solver" + end function d_id_solver_get_fmt + + end module mld_d_id_solver diff --git a/mlprec/mld_d_ilu_solver.f90 b/mlprec/mld_d_ilu_solver.f90 index f9b391d9..adf8ed11 100644 --- a/mlprec/mld_d_ilu_solver.f90 +++ b/mlprec/mld_d_ilu_solver.f90 @@ -71,6 +71,7 @@ module mld_d_ilu_solver procedure, pass(sv) :: default => d_ilu_solver_default procedure, pass(sv) :: sizeof => d_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => d_ilu_solver_get_nzeros + procedure, nopass :: get_fmt => d_ilu_solver_get_fmt end type mld_d_ilu_solver_type @@ -79,7 +80,8 @@ module mld_d_ilu_solver & d_ilu_solver_setc, d_ilu_solver_setr,& & d_ilu_solver_descr, d_ilu_solver_sizeof, & & d_ilu_solver_default, d_ilu_solver_dmp, & - & d_ilu_solver_apply_vect, d_ilu_solver_get_nzeros + & d_ilu_solver_apply_vect, d_ilu_solver_get_nzeros, & + & d_ilu_solver_get_fmt character(len=15), parameter, private :: & @@ -162,9 +164,9 @@ module mld_d_ilu_solver Implicit None ! Arguments - class(mld_d_ilu_solver_type), intent(inout) :: sv - class(mld_d_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_d_ilu_solver_type), intent(inout) :: sv + class(mld_d_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_d_ilu_solver_clone end interface @@ -556,4 +558,11 @@ contains return end function d_ilu_solver_sizeof + function d_ilu_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "ILU solver" + end function d_ilu_solver_get_fmt + end module mld_d_ilu_solver diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index 357e89c6..3192d71f 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -62,11 +62,13 @@ module mld_d_jac_smoother procedure, pass(sm) :: descr => d_jac_smoother_descr procedure, pass(sm) :: sizeof => d_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => d_jac_smoother_get_nzeros + procedure, nopass :: get_fmt => d_jac_smoother_get_fmt end type mld_d_jac_smoother_type private :: d_jac_smoother_free, d_jac_smoother_descr, & - & d_jac_smoother_sizeof, d_jac_smoother_get_nzeros + & d_jac_smoother_sizeof, d_jac_smoother_get_nzeros, & + & d_jac_smoother_get_fmt interface @@ -120,8 +122,8 @@ module mld_d_jac_smoother subroutine mld_d_jac_smoother_clone(sm,smout,info) import :: mld_d_jac_smoother_type, psb_dpk_, & & mld_d_base_smoother_type, psb_ipk_ - class(mld_d_jac_smoother_type), intent(inout) :: sm - class(mld_d_base_smoother_type), intent(out) :: smout + class(mld_d_jac_smoother_type), intent(inout) :: sm + class(mld_d_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_d_jac_smoother_clone end interface @@ -247,4 +249,11 @@ contains return end function d_jac_smoother_get_nzeros + function d_jac_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi smoother" + end function d_jac_smoother_get_fmt + end module mld_d_jac_smoother diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 88e101bf..0d60249d 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -385,11 +385,18 @@ contains ! Arguments class(mld_d_onelev_type), target, intent(inout) :: lv - class(mld_d_onelev_type), intent(out) :: lvout + class(mld_d_onelev_type), intent(inout) :: lvout integer(psb_ipk_), intent(out) :: info - if (allocated(lv%sm)) & - & call lv%sm%clone(lvout%sm,info) + info = psb_success_ + if (allocated(lv%sm)) then + call lv%sm%clone(lvout%sm,info) + else + if (allocated(lvout%sm)) then + call lvout%sm%free(info) + if (info==psb_success_) deallocate(lvout%sm,stat=info) + end if + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index e5d670c7..eb55979e 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -728,36 +728,53 @@ contains implicit none class(mld_dprec_type), intent(inout) :: prec - class(mld_dprec_type), target, intent(out) :: precout - integer(psb_ipk_), intent(out) :: info + class(psb_dprec_type), intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + call mld_d_inner_clone(prec,precout,info) + + end subroutine mld_d_clone + + subroutine mld_d_inner_clone(prec,precout,info) + + implicit none + class(mld_dprec_type), intent(inout) :: prec + class(psb_dprec_type), target, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info ! Local vars integer(psb_ipk_) :: i, j, il1, ln, lname, lev integer(psb_ipk_) :: icontxt,iam, np info = psb_success_ - precout%ictxt = prec%ictxt - precout%coarse_aggr_size = prec%coarse_aggr_size - precout%op_complexity = prec%op_complexity - if (allocated(prec%precv)) then - ln = size(prec%precv) - allocate(precout%precv(ln),stat=info) - if (info /= psb_success_) goto 9999 - if (ln > 1) then - call prec%precv(1)%clone(precout%precv(1),info) - end if - do lev=2, ln - if (info /= psb_success_) exit - call prec%precv(lev)%clone(precout%precv(lev),info) - if (info == psb_success_) then - precout%precv(lev)%base_a => precout%precv(lev)%ac - precout%precv(lev)%base_desc => precout%precv(lev)%desc_ac - precout%precv(lev)%map%p_desc_X => precout%precv(lev-1)%base_desc - precout%precv(lev)%map%p_desc_Y => precout%precv(lev)%base_desc + select type(pout => precout) + class is (mld_dprec_type) + pout%ictxt = prec%ictxt + pout%coarse_aggr_size = prec%coarse_aggr_size + pout%op_complexity = prec%op_complexity + if (allocated(prec%precv)) then + ln = size(prec%precv) + allocate(pout%precv(ln),stat=info) + if (info /= psb_success_) goto 9999 + if (ln >= 1) then + call prec%precv(1)%clone(pout%precv(1),info) end if - end do - end if + do lev=2, ln + if (info /= psb_success_) exit + call prec%precv(lev)%clone(pout%precv(lev),info) + if (info == psb_success_) then + pout%precv(lev)%base_a => pout%precv(lev)%ac + pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac + pout%precv(lev)%map%p_desc_X => pout%precv(lev-1)%base_desc + pout%precv(lev)%map%p_desc_Y => pout%precv(lev)%base_desc + end if + end do + end if + class default + write(0,*) 'Error: wrong out type' + info = psb_err_invalid_input_ + end select 9999 continue - end subroutine mld_d_clone + end subroutine mld_d_inner_clone subroutine mld_dprec_move_alloc(a, b,info) use psb_base_mod diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index 4d2d84ed..436f0f90 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -70,11 +70,13 @@ module mld_s_as_smoother procedure, pass(sm) :: sizeof => s_as_smoother_sizeof procedure, pass(sm) :: default => s_as_smoother_default procedure, pass(sm) :: get_nzeros => s_as_smoother_get_nzeros + procedure, nopass :: get_fmt => s_as_smoother_get_fmt end type mld_s_as_smoother_type private :: s_as_smoother_descr, s_as_smoother_sizeof, & - & s_as_smoother_default, s_as_smoother_get_nzeros + & s_as_smoother_default, s_as_smoother_get_nzeros, & + & s_as_smoother_get_fmt character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -243,8 +245,8 @@ module mld_s_as_smoother subroutine mld_s_as_smoother_clone(sm,smout,info) import :: mld_s_as_smoother_type, psb_spk_, & & mld_s_base_smoother_type, psb_ipk_ - class(mld_s_as_smoother_type), intent(inout) :: sm - class(mld_s_base_smoother_type), intent(out) :: smout + class(mld_s_as_smoother_type), intent(inout) :: sm + class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_s_as_smoother_clone end interface @@ -352,4 +354,11 @@ contains return end subroutine s_as_smoother_descr + function s_as_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Schwarz smoother" + end function s_as_smoother_get_fmt + end module mld_s_as_smoother diff --git a/mlprec/mld_s_base_smoother_mod.f90 b/mlprec/mld_s_base_smoother_mod.f90 index 55525617..66fc16df 100644 --- a/mlprec/mld_s_base_smoother_mod.f90 +++ b/mlprec/mld_s_base_smoother_mod.f90 @@ -112,10 +112,11 @@ module mld_s_base_smoother_mod procedure, pass(sm) :: sizeof => s_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => s_base_smoother_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => s_base_smoother_get_fmt end type mld_s_base_smoother_type - private :: s_base_smoother_sizeof, & + private :: s_base_smoother_sizeof, s_base_smoother_get_fmt, & & s_base_smoother_default, s_base_smoother_get_nzeros @@ -304,8 +305,8 @@ module mld_s_base_smoother_mod Implicit None ! Arguments - class(mld_s_base_smoother_type), intent(inout) :: sm - class(mld_s_base_smoother_type), allocatable, intent(out) :: smout + class(mld_s_base_smoother_type), intent(inout) :: sm + class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_s_base_smoother_clone end interface @@ -357,5 +358,11 @@ contains return end subroutine s_base_smoother_default + function s_base_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base smoother" + end function s_base_smoother_get_fmt end module mld_s_base_smoother_mod diff --git a/mlprec/mld_s_base_solver_mod.f90 b/mlprec/mld_s_base_solver_mod.f90 index f9f871f4..d58089d8 100644 --- a/mlprec/mld_s_base_solver_mod.f90 +++ b/mlprec/mld_s_base_solver_mod.f90 @@ -104,10 +104,11 @@ module mld_s_base_solver_mod procedure, pass(sv) :: sizeof => s_base_solver_sizeof procedure, pass(sv) :: get_nzeros => s_base_solver_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => s_base_solver_get_fmt end type mld_s_base_solver_type private :: s_base_solver_sizeof, s_base_solver_default,& - & s_base_solver_get_nzeros + & s_base_solver_get_nzeros, s_base_solver_get_fmt interface @@ -318,9 +319,9 @@ module mld_s_base_solver_mod Implicit None ! Arguments - class(mld_s_base_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_base_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_s_base_solver_clone end interface @@ -360,4 +361,12 @@ contains return end subroutine s_base_solver_default + function s_base_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base solver" + end function s_base_solver_get_fmt + + end module mld_s_base_solver_mod diff --git a/mlprec/mld_s_diag_solver.f90 b/mlprec/mld_s_diag_solver.f90 index 10bea87d..16372ae4 100644 --- a/mlprec/mld_s_diag_solver.f90 +++ b/mlprec/mld_s_diag_solver.f90 @@ -59,11 +59,13 @@ module mld_s_diag_solver procedure, pass(sv) :: descr => s_diag_solver_descr procedure, pass(sv) :: sizeof => s_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => s_diag_solver_get_nzeros + procedure, nopass :: get_fmt => s_diag_solver_get_fmt end type mld_s_diag_solver_type private :: s_diag_solver_free, s_diag_solver_descr, & - & s_diag_solver_sizeof, s_diag_solver_get_nzeros + & s_diag_solver_sizeof, s_diag_solver_get_nzeros, & + & s_diag_solver_get_fmt interface @@ -122,9 +124,9 @@ module mld_s_diag_solver Implicit None ! Arguments - class(mld_s_diag_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_diag_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_s_diag_solver_clone end interface @@ -221,4 +223,12 @@ contains return end function s_diag_solver_get_nzeros + function s_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Diag solver" + end function s_diag_solver_get_fmt + + end module mld_s_diag_solver diff --git a/mlprec/mld_s_id_solver.f90 b/mlprec/mld_s_id_solver.f90 index 8c0b2097..e69ecc25 100644 --- a/mlprec/mld_s_id_solver.f90 +++ b/mlprec/mld_s_id_solver.f90 @@ -55,11 +55,12 @@ module mld_s_id_solver procedure, pass(sv) :: apply_a => mld_s_id_solver_apply procedure, pass(sv) :: free => s_id_solver_free procedure, pass(sv) :: descr => s_id_solver_descr + procedure, nopass :: get_fmt => s_id_solver_get_fmt end type mld_s_id_solver_type private :: s_id_solver_bld, & - & s_id_solver_free, & + & s_id_solver_free, s_id_solver_get_fmt, & & s_id_solver_descr interface @@ -102,9 +103,9 @@ module mld_s_id_solver Implicit None ! Arguments - class(mld_s_id_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_id_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_s_id_solver_clone end interface @@ -178,4 +179,12 @@ contains end subroutine s_id_solver_descr + function s_id_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Identity solver" + end function s_id_solver_get_fmt + + end module mld_s_id_solver diff --git a/mlprec/mld_s_ilu_solver.f90 b/mlprec/mld_s_ilu_solver.f90 index 46cc8572..5233f2b0 100644 --- a/mlprec/mld_s_ilu_solver.f90 +++ b/mlprec/mld_s_ilu_solver.f90 @@ -71,6 +71,7 @@ module mld_s_ilu_solver procedure, pass(sv) :: default => s_ilu_solver_default procedure, pass(sv) :: sizeof => s_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => s_ilu_solver_get_nzeros + procedure, nopass :: get_fmt => s_ilu_solver_get_fmt end type mld_s_ilu_solver_type @@ -79,7 +80,8 @@ module mld_s_ilu_solver & s_ilu_solver_setc, s_ilu_solver_setr,& & s_ilu_solver_descr, s_ilu_solver_sizeof, & & s_ilu_solver_default, s_ilu_solver_dmp, & - & s_ilu_solver_apply_vect, s_ilu_solver_get_nzeros + & s_ilu_solver_apply_vect, s_ilu_solver_get_nzeros, & + & s_ilu_solver_get_fmt character(len=15), parameter, private :: & @@ -162,9 +164,9 @@ module mld_s_ilu_solver Implicit None ! Arguments - class(mld_s_ilu_solver_type), intent(inout) :: sv - class(mld_s_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_s_ilu_solver_type), intent(inout) :: sv + class(mld_s_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_s_ilu_solver_clone end interface @@ -556,4 +558,11 @@ contains return end function s_ilu_solver_sizeof + function s_ilu_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "ILU solver" + end function s_ilu_solver_get_fmt + end module mld_s_ilu_solver diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index 5a95d422..1fa7f094 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -62,11 +62,13 @@ module mld_s_jac_smoother procedure, pass(sm) :: descr => s_jac_smoother_descr procedure, pass(sm) :: sizeof => s_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => s_jac_smoother_get_nzeros + procedure, nopass :: get_fmt => s_jac_smoother_get_fmt end type mld_s_jac_smoother_type private :: s_jac_smoother_free, s_jac_smoother_descr, & - & s_jac_smoother_sizeof, s_jac_smoother_get_nzeros + & s_jac_smoother_sizeof, s_jac_smoother_get_nzeros, & + & s_jac_smoother_get_fmt interface @@ -120,8 +122,8 @@ module mld_s_jac_smoother subroutine mld_s_jac_smoother_clone(sm,smout,info) import :: mld_s_jac_smoother_type, psb_spk_, & & mld_s_base_smoother_type, psb_ipk_ - class(mld_s_jac_smoother_type), intent(inout) :: sm - class(mld_s_base_smoother_type), intent(out) :: smout + class(mld_s_jac_smoother_type), intent(inout) :: sm + class(mld_s_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_s_jac_smoother_clone end interface @@ -247,4 +249,11 @@ contains return end function s_jac_smoother_get_nzeros + function s_jac_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi smoother" + end function s_jac_smoother_get_fmt + end module mld_s_jac_smoother diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index a161393f..e73530a7 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -385,11 +385,18 @@ contains ! Arguments class(mld_s_onelev_type), target, intent(inout) :: lv - class(mld_s_onelev_type), intent(out) :: lvout + class(mld_s_onelev_type), intent(inout) :: lvout integer(psb_ipk_), intent(out) :: info - if (allocated(lv%sm)) & - & call lv%sm%clone(lvout%sm,info) + info = psb_success_ + if (allocated(lv%sm)) then + call lv%sm%clone(lvout%sm,info) + else + if (allocated(lvout%sm)) then + call lvout%sm%free(info) + if (info==psb_success_) deallocate(lvout%sm,stat=info) + end if + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 78709141..65bb7c97 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -728,36 +728,53 @@ contains implicit none class(mld_sprec_type), intent(inout) :: prec - class(mld_sprec_type), target, intent(out) :: precout - integer(psb_ipk_), intent(out) :: info + class(psb_sprec_type), intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + call mld_s_inner_clone(prec,precout,info) + + end subroutine mld_s_clone + + subroutine mld_s_inner_clone(prec,precout,info) + + implicit none + class(mld_sprec_type), intent(inout) :: prec + class(psb_sprec_type), target, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info ! Local vars integer(psb_ipk_) :: i, j, il1, ln, lname, lev integer(psb_ipk_) :: icontxt,iam, np info = psb_success_ - precout%ictxt = prec%ictxt - precout%coarse_aggr_size = prec%coarse_aggr_size - precout%op_complexity = prec%op_complexity - if (allocated(prec%precv)) then - ln = size(prec%precv) - allocate(precout%precv(ln),stat=info) - if (info /= psb_success_) goto 9999 - if (ln > 1) then - call prec%precv(1)%clone(precout%precv(1),info) - end if - do lev=2, ln - if (info /= psb_success_) exit - call prec%precv(lev)%clone(precout%precv(lev),info) - if (info == psb_success_) then - precout%precv(lev)%base_a => precout%precv(lev)%ac - precout%precv(lev)%base_desc => precout%precv(lev)%desc_ac - precout%precv(lev)%map%p_desc_X => precout%precv(lev-1)%base_desc - precout%precv(lev)%map%p_desc_Y => precout%precv(lev)%base_desc + select type(pout => precout) + class is (mld_sprec_type) + pout%ictxt = prec%ictxt + pout%coarse_aggr_size = prec%coarse_aggr_size + pout%op_complexity = prec%op_complexity + if (allocated(prec%precv)) then + ln = size(prec%precv) + allocate(pout%precv(ln),stat=info) + if (info /= psb_success_) goto 9999 + if (ln >= 1) then + call prec%precv(1)%clone(pout%precv(1),info) end if - end do - end if + do lev=2, ln + if (info /= psb_success_) exit + call prec%precv(lev)%clone(pout%precv(lev),info) + if (info == psb_success_) then + pout%precv(lev)%base_a => pout%precv(lev)%ac + pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac + pout%precv(lev)%map%p_desc_X => pout%precv(lev-1)%base_desc + pout%precv(lev)%map%p_desc_Y => pout%precv(lev)%base_desc + end if + end do + end if + class default + write(0,*) 'Error: wrong out type' + info = psb_err_invalid_input_ + end select 9999 continue - end subroutine mld_s_clone + end subroutine mld_s_inner_clone subroutine mld_sprec_move_alloc(a, b,info) use psb_base_mod diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index 5d081ff1..717b4042 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -70,11 +70,13 @@ module mld_z_as_smoother procedure, pass(sm) :: sizeof => z_as_smoother_sizeof procedure, pass(sm) :: default => z_as_smoother_default procedure, pass(sm) :: get_nzeros => z_as_smoother_get_nzeros + procedure, nopass :: get_fmt => z_as_smoother_get_fmt end type mld_z_as_smoother_type private :: z_as_smoother_descr, z_as_smoother_sizeof, & - & z_as_smoother_default, z_as_smoother_get_nzeros + & z_as_smoother_default, z_as_smoother_get_nzeros, & + & z_as_smoother_get_fmt character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -243,8 +245,8 @@ module mld_z_as_smoother subroutine mld_z_as_smoother_clone(sm,smout,info) import :: mld_z_as_smoother_type, psb_dpk_, & & mld_z_base_smoother_type, psb_ipk_ - class(mld_z_as_smoother_type), intent(inout) :: sm - class(mld_z_base_smoother_type), intent(out) :: smout + class(mld_z_as_smoother_type), intent(inout) :: sm + class(mld_z_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_z_as_smoother_clone end interface @@ -352,4 +354,11 @@ contains return end subroutine z_as_smoother_descr + function z_as_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Schwarz smoother" + end function z_as_smoother_get_fmt + end module mld_z_as_smoother diff --git a/mlprec/mld_z_base_smoother_mod.f90 b/mlprec/mld_z_base_smoother_mod.f90 index 882f68b5..a5c0a3df 100644 --- a/mlprec/mld_z_base_smoother_mod.f90 +++ b/mlprec/mld_z_base_smoother_mod.f90 @@ -112,10 +112,11 @@ module mld_z_base_smoother_mod procedure, pass(sm) :: sizeof => z_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => z_base_smoother_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => z_base_smoother_get_fmt end type mld_z_base_smoother_type - private :: z_base_smoother_sizeof, & + private :: z_base_smoother_sizeof, z_base_smoother_get_fmt, & & z_base_smoother_default, z_base_smoother_get_nzeros @@ -304,8 +305,8 @@ module mld_z_base_smoother_mod Implicit None ! Arguments - class(mld_z_base_smoother_type), intent(inout) :: sm - class(mld_z_base_smoother_type), allocatable, intent(out) :: smout + class(mld_z_base_smoother_type), intent(inout) :: sm + class(mld_z_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_z_base_smoother_clone end interface @@ -357,5 +358,11 @@ contains return end subroutine z_base_smoother_default + function z_base_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base smoother" + end function z_base_smoother_get_fmt end module mld_z_base_smoother_mod diff --git a/mlprec/mld_z_base_solver_mod.f90 b/mlprec/mld_z_base_solver_mod.f90 index 4791306b..2de72c50 100644 --- a/mlprec/mld_z_base_solver_mod.f90 +++ b/mlprec/mld_z_base_solver_mod.f90 @@ -104,10 +104,11 @@ module mld_z_base_solver_mod procedure, pass(sv) :: sizeof => z_base_solver_sizeof procedure, pass(sv) :: get_nzeros => z_base_solver_get_nzeros procedure, nopass :: stringval => mld_stringval + procedure, nopass :: get_fmt => z_base_solver_get_fmt end type mld_z_base_solver_type private :: z_base_solver_sizeof, z_base_solver_default,& - & z_base_solver_get_nzeros + & z_base_solver_get_nzeros, z_base_solver_get_fmt interface @@ -318,9 +319,9 @@ module mld_z_base_solver_mod Implicit None ! Arguments - class(mld_z_base_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_base_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_z_base_solver_clone end interface @@ -360,4 +361,12 @@ contains return end subroutine z_base_solver_default + function z_base_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Base solver" + end function z_base_solver_get_fmt + + end module mld_z_base_solver_mod diff --git a/mlprec/mld_z_diag_solver.f90 b/mlprec/mld_z_diag_solver.f90 index 5701b44b..4184e99a 100644 --- a/mlprec/mld_z_diag_solver.f90 +++ b/mlprec/mld_z_diag_solver.f90 @@ -59,11 +59,13 @@ module mld_z_diag_solver procedure, pass(sv) :: descr => z_diag_solver_descr procedure, pass(sv) :: sizeof => z_diag_solver_sizeof procedure, pass(sv) :: get_nzeros => z_diag_solver_get_nzeros + procedure, nopass :: get_fmt => z_diag_solver_get_fmt end type mld_z_diag_solver_type private :: z_diag_solver_free, z_diag_solver_descr, & - & z_diag_solver_sizeof, z_diag_solver_get_nzeros + & z_diag_solver_sizeof, z_diag_solver_get_nzeros, & + & z_diag_solver_get_fmt interface @@ -122,9 +124,9 @@ module mld_z_diag_solver Implicit None ! Arguments - class(mld_z_diag_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_diag_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_z_diag_solver_clone end interface @@ -221,4 +223,12 @@ contains return end function z_diag_solver_get_nzeros + function z_diag_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Diag solver" + end function z_diag_solver_get_fmt + + end module mld_z_diag_solver diff --git a/mlprec/mld_z_id_solver.f90 b/mlprec/mld_z_id_solver.f90 index 1604e99e..53c81a29 100644 --- a/mlprec/mld_z_id_solver.f90 +++ b/mlprec/mld_z_id_solver.f90 @@ -55,11 +55,12 @@ module mld_z_id_solver procedure, pass(sv) :: apply_a => mld_z_id_solver_apply procedure, pass(sv) :: free => z_id_solver_free procedure, pass(sv) :: descr => z_id_solver_descr + procedure, nopass :: get_fmt => z_id_solver_get_fmt end type mld_z_id_solver_type private :: z_id_solver_bld, & - & z_id_solver_free, & + & z_id_solver_free, z_id_solver_get_fmt, & & z_id_solver_descr interface @@ -102,9 +103,9 @@ module mld_z_id_solver Implicit None ! Arguments - class(mld_z_id_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_id_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_z_id_solver_clone end interface @@ -178,4 +179,12 @@ contains end subroutine z_id_solver_descr + function z_id_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Identity solver" + end function z_id_solver_get_fmt + + end module mld_z_id_solver diff --git a/mlprec/mld_z_ilu_solver.f90 b/mlprec/mld_z_ilu_solver.f90 index 74e5789a..d4288e15 100644 --- a/mlprec/mld_z_ilu_solver.f90 +++ b/mlprec/mld_z_ilu_solver.f90 @@ -71,6 +71,7 @@ module mld_z_ilu_solver procedure, pass(sv) :: default => z_ilu_solver_default procedure, pass(sv) :: sizeof => z_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => z_ilu_solver_get_nzeros + procedure, nopass :: get_fmt => z_ilu_solver_get_fmt end type mld_z_ilu_solver_type @@ -79,7 +80,8 @@ module mld_z_ilu_solver & z_ilu_solver_setc, z_ilu_solver_setr,& & z_ilu_solver_descr, z_ilu_solver_sizeof, & & z_ilu_solver_default, z_ilu_solver_dmp, & - & z_ilu_solver_apply_vect, z_ilu_solver_get_nzeros + & z_ilu_solver_apply_vect, z_ilu_solver_get_nzeros, & + & z_ilu_solver_get_fmt character(len=15), parameter, private :: & @@ -162,9 +164,9 @@ module mld_z_ilu_solver Implicit None ! Arguments - class(mld_z_ilu_solver_type), intent(inout) :: sv - class(mld_z_base_solver_type), allocatable, intent(out) :: svout - integer(psb_ipk_), intent(out) :: info + class(mld_z_ilu_solver_type), intent(inout) :: sv + class(mld_z_base_solver_type), allocatable, intent(inout) :: svout + integer(psb_ipk_), intent(out) :: info end subroutine mld_z_ilu_solver_clone end interface @@ -556,4 +558,11 @@ contains return end function z_ilu_solver_sizeof + function z_ilu_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "ILU solver" + end function z_ilu_solver_get_fmt + end module mld_z_ilu_solver diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index 5d62897b..500c8aec 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -62,11 +62,13 @@ module mld_z_jac_smoother procedure, pass(sm) :: descr => z_jac_smoother_descr procedure, pass(sm) :: sizeof => z_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => z_jac_smoother_get_nzeros + procedure, nopass :: get_fmt => z_jac_smoother_get_fmt end type mld_z_jac_smoother_type private :: z_jac_smoother_free, z_jac_smoother_descr, & - & z_jac_smoother_sizeof, z_jac_smoother_get_nzeros + & z_jac_smoother_sizeof, z_jac_smoother_get_nzeros, & + & z_jac_smoother_get_fmt interface @@ -120,8 +122,8 @@ module mld_z_jac_smoother subroutine mld_z_jac_smoother_clone(sm,smout,info) import :: mld_z_jac_smoother_type, psb_dpk_, & & mld_z_base_smoother_type, psb_ipk_ - class(mld_z_jac_smoother_type), intent(inout) :: sm - class(mld_z_base_smoother_type), intent(out) :: smout + class(mld_z_jac_smoother_type), intent(inout) :: sm + class(mld_z_base_smoother_type), allocatable, intent(inout) :: smout integer(psb_ipk_), intent(out) :: info end subroutine mld_z_jac_smoother_clone end interface @@ -247,4 +249,11 @@ contains return end function z_jac_smoother_get_nzeros + function z_jac_smoother_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Jacobi smoother" + end function z_jac_smoother_get_fmt + end module mld_z_jac_smoother diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 1da4d1d7..756effda 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -385,11 +385,18 @@ contains ! Arguments class(mld_z_onelev_type), target, intent(inout) :: lv - class(mld_z_onelev_type), intent(out) :: lvout + class(mld_z_onelev_type), intent(inout) :: lvout integer(psb_ipk_), intent(out) :: info - if (allocated(lv%sm)) & - & call lv%sm%clone(lvout%sm,info) + info = psb_success_ + if (allocated(lv%sm)) then + call lv%sm%clone(lvout%sm,info) + else + if (allocated(lvout%sm)) then + call lvout%sm%free(info) + if (info==psb_success_) deallocate(lvout%sm,stat=info) + end if + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index 58160c94..1211f91c 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -728,36 +728,53 @@ contains implicit none class(mld_zprec_type), intent(inout) :: prec - class(mld_zprec_type), target, intent(out) :: precout - integer(psb_ipk_), intent(out) :: info + class(psb_zprec_type), intent(out) :: precout + integer(psb_ipk_), intent(out) :: info + + call mld_z_inner_clone(prec,precout,info) + + end subroutine mld_z_clone + + subroutine mld_z_inner_clone(prec,precout,info) + + implicit none + class(mld_zprec_type), intent(inout) :: prec + class(psb_zprec_type), target, intent(out) :: precout + integer(psb_ipk_), intent(out) :: info ! Local vars integer(psb_ipk_) :: i, j, il1, ln, lname, lev integer(psb_ipk_) :: icontxt,iam, np info = psb_success_ - precout%ictxt = prec%ictxt - precout%coarse_aggr_size = prec%coarse_aggr_size - precout%op_complexity = prec%op_complexity - if (allocated(prec%precv)) then - ln = size(prec%precv) - allocate(precout%precv(ln),stat=info) - if (info /= psb_success_) goto 9999 - if (ln > 1) then - call prec%precv(1)%clone(precout%precv(1),info) - end if - do lev=2, ln - if (info /= psb_success_) exit - call prec%precv(lev)%clone(precout%precv(lev),info) - if (info == psb_success_) then - precout%precv(lev)%base_a => precout%precv(lev)%ac - precout%precv(lev)%base_desc => precout%precv(lev)%desc_ac - precout%precv(lev)%map%p_desc_X => precout%precv(lev-1)%base_desc - precout%precv(lev)%map%p_desc_Y => precout%precv(lev)%base_desc + select type(pout => precout) + class is (mld_zprec_type) + pout%ictxt = prec%ictxt + pout%coarse_aggr_size = prec%coarse_aggr_size + pout%op_complexity = prec%op_complexity + if (allocated(prec%precv)) then + ln = size(prec%precv) + allocate(pout%precv(ln),stat=info) + if (info /= psb_success_) goto 9999 + if (ln >= 1) then + call prec%precv(1)%clone(pout%precv(1),info) end if - end do - end if + do lev=2, ln + if (info /= psb_success_) exit + call prec%precv(lev)%clone(pout%precv(lev),info) + if (info == psb_success_) then + pout%precv(lev)%base_a => pout%precv(lev)%ac + pout%precv(lev)%base_desc => pout%precv(lev)%desc_ac + pout%precv(lev)%map%p_desc_X => pout%precv(lev-1)%base_desc + pout%precv(lev)%map%p_desc_Y => pout%precv(lev)%base_desc + end if + end do + end if + class default + write(0,*) 'Error: wrong out type' + info = psb_err_invalid_input_ + end select 9999 continue - end subroutine mld_z_clone + end subroutine mld_z_inner_clone subroutine mld_zprec_move_alloc(a, b,info) use psb_base_mod