! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 ! Salvatore Filippone ! Alfredo Buttari ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: ! 1. Redistributions of source code must retain the above copyright ! notice, this list of conditions and the following disclaimer. ! 2. Redistributions in binary form must reproduce the above copyright ! notice, this list of conditions and the following disclaimer in the ! documentation and/or other materials provided with the distribution. ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific prior written permission. ! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS ! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. ! module psb_d_nestedprec use psb_base_mod, only : psb_ipk_, psb_epk_, psb_dpk_, psb_success_, & & psb_err_invalid_input_, psb_err_invalid_preca_, psb_err_invalid_mat_state_, & & psb_err_alloc_dealloc_, psb_err_transpose_not_n_unsupported_, & & psb_root_, psb_toupper, psb_info, psb_errpush, psb_halo, psb_gedot, & & done, dzero use psb_d_base_prec_mod use psb_d_nullprec, only : psb_d_null_prec_type use psb_d_diagprec, only : psb_d_diag_prec_type use psb_d_bjacprec, only : psb_d_bjac_prec_type use psb_d_nest_base_mat_mod, only : psb_d_nest_base_mat, psb_d_nest_get_n_fields, & & psb_d_nest_get_field_owned, psb_d_nest_get_block, psb_d_nest_get_field_desc, & & psb_d_nest_restrict_field, psb_d_nest_restrict_field_local, & & psb_d_nest_prolong_field, psb_d_nest_apply_block implicit none integer(psb_ipk_), parameter :: psb_d_nested_composition_ = 9101 integer(psb_ipk_), parameter :: psb_d_nested_block_solve_ = 9102 integer(psb_ipk_), parameter :: psb_d_nested_schur_solve_ = 9103 integer(psb_ipk_), parameter :: psb_d_nested_schur_maxit_ = 9104 integer(psb_ipk_), parameter :: psb_d_nested_schur_tol_ = 9105 integer(psb_ipk_), parameter :: psb_d_nested_inner_solve_ = 9106 integer(psb_ipk_), parameter :: psb_d_nested_inner_maxit_ = 9107 integer(psb_ipk_), parameter :: psb_d_nested_inner_tol_ = 9108 integer(psb_ipk_), parameter :: psb_d_nested_inner_itrace_ = 9109 integer(psb_ipk_), parameter :: psb_d_nested_inner_istop_ = 9110 integer(psb_ipk_), parameter, private :: psb_d_nested_diag_ = 1 integer(psb_ipk_), parameter, private :: psb_d_nested_add_ = 2 integer(psb_ipk_), parameter, private :: psb_d_nested_mult_ = 3 integer(psb_ipk_), parameter, private :: psb_d_nested_symm_ = 4 integer(psb_ipk_), parameter, private :: psb_d_nested_schur_lower_ = 5 integer(psb_ipk_), parameter, private :: psb_d_nested_schur_upper_ = 6 integer(psb_ipk_), parameter, private :: psb_d_nested_schur_full_ = 7 integer(psb_ipk_), parameter, private :: psb_d_nested_schur_a22_ = 1 integer(psb_ipk_), parameter, private :: psb_d_nested_schur_mf_ = 2 type :: psb_d_nested_iopt integer(psb_ipk_) :: field integer(psb_ipk_) :: what integer(psb_ipk_) :: val end type psb_d_nested_iopt type :: psb_d_nested_ropt integer(psb_ipk_) :: field integer(psb_ipk_) :: what real(psb_dpk_) :: val end type psb_d_nested_ropt type :: psb_d_nested_copt integer(psb_ipk_) :: field integer(psb_ipk_) :: what character(len=64) :: val end type psb_d_nested_copt type :: psb_d_nested_block_prec character(len=16) :: ptype class(psb_d_base_prec_type), allocatable :: pc end type psb_d_nested_block_prec type :: psb_d_nested_krylov_context logical :: enabled character(len=16) :: method integer(psb_ipk_) :: itmax integer(psb_ipk_) :: itrace integer(psb_ipk_) :: istop real(psb_dpk_) :: tol end type psb_d_nested_krylov_context type, extends(psb_d_base_prec_type) :: psb_d_nested_prec_type integer(psb_ipk_) :: composition character(len=32) :: composition_name character(len=16) :: default_block_ptype integer(psb_ipk_) :: schur_solve character(len=32) :: schur_solve_name integer(psb_ipk_) :: schur_maxit real(psb_dpk_) :: schur_tol type(psb_d_nested_krylov_context) :: default_krylov integer(psb_ipk_) :: nfields type(psb_d_nest_base_mat), pointer :: nest_op type(psb_d_nested_block_prec), allocatable :: blocks(:) character(len=16), allocatable :: field_block_ptype(:) type(psb_d_nested_krylov_context), allocatable :: field_krylov(:) type(psb_d_nested_iopt), allocatable :: field_iopts(:) type(psb_d_nested_ropt), allocatable :: field_ropts(:) type(psb_d_nested_copt), allocatable :: field_copts(:) contains procedure, pass(prec) :: d_apply_v => psb_d_nested_apply_vect procedure, pass(prec) :: d_apply => psb_d_nested_apply procedure, pass(prec) :: precbld => psb_d_nested_precbld procedure, pass(prec) :: precinit => psb_d_nested_precinit procedure, pass(prec) :: precseti => psb_d_nested_precseti procedure, pass(prec) :: precsetr => psb_d_nested_precsetr procedure, pass(prec) :: precsetc => psb_d_nested_precsetc procedure, pass(prec) :: precdescr => psb_d_nested_precdescr procedure, pass(prec) :: dump => psb_d_nested_dump procedure, pass(prec) :: clone => psb_d_nested_clone procedure, pass(prec) :: free => psb_d_nested_precfree procedure, pass(prec) :: sizeof => psb_d_nested_sizeof procedure, pass(prec) :: get_nzeros => psb_d_nested_get_nzeros end type psb_d_nested_prec_type private :: psb_d_nested_apply_vect, psb_d_nested_apply, psb_d_nested_precbld, & & psb_d_nested_precinit, psb_d_nested_precfree, psb_d_nested_precdescr, & & psb_d_nested_dump, psb_d_nested_clone, psb_d_nested_sizeof, & & psb_d_nested_get_nzeros, psb_d_nested_precseti, & & psb_d_nested_precsetr, psb_d_nested_precsetc, & & psb_d_nested_clear_built, psb_d_nested_valid_block_solve, & & psb_d_nested_get_field_block_ptype, psb_d_nested_field_solve, & & psb_d_nested_apply_schur, psb_d_nested_replay_field_options, & & psb_d_nested_append_iopt, psb_d_nested_append_ropt, & & psb_d_nested_append_copt, psb_d_nested_schur_action, & & psb_d_nested_schur_solve, psb_d_nested_get_field_krylov, & & psb_d_nested_inner_solve, psb_d_nested_inner_cg, psb_d_nested_inner_bicgstab, & & psb_d_nested_field_matvec, psb_d_nested_ensure_krylov_field contains ! Reset nested preconditioner options and detach any previous field state. subroutine psb_d_nested_precinit(prec, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info info = psb_success_ prec%composition = psb_d_nested_add_ prec%composition_name = 'ADDITIVE' prec%default_block_ptype = 'DIAG' prec%schur_solve = psb_d_nested_schur_a22_ prec%schur_solve_name = 'A22' prec%schur_maxit = 4 prec%schur_tol = 0.0_psb_dpk_ prec%default_krylov%enabled = .false. prec%default_krylov%method = 'CG' prec%default_krylov%itmax = 20 prec%default_krylov%itrace = -1 prec%default_krylov%istop = 2 prec%default_krylov%tol = 1.0e-6_psb_dpk_ prec%nfields = 0 prec%nest_op => null() if (allocated(prec%field_block_ptype)) deallocate(prec%field_block_ptype) if (allocated(prec%field_krylov)) deallocate(prec%field_krylov) if (allocated(prec%field_iopts)) deallocate(prec%field_iopts) if (allocated(prec%field_ropts)) deallocate(prec%field_ropts) if (allocated(prec%field_copts)) deallocate(prec%field_copts) end subroutine psb_d_nested_precinit ! Release built field preconditioners while preserving user configuration. subroutine psb_d_nested_clear_built(prec, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, local_info info = psb_success_ if (allocated(prec%blocks)) then do i = 1, size(prec%blocks) if (allocated(prec%blocks(i)%pc)) then call prec%blocks(i)%pc%free(local_info) deallocate(prec%blocks(i)%pc, stat=local_info) end if end do deallocate(prec%blocks, stat=local_info) if (local_info /= 0 .and. info == psb_success_) info = local_info end if prec%nfields = 0 prec%nest_op => null() end subroutine psb_d_nested_clear_built ! Fully release nested preconditioner storage and pending configuration. subroutine psb_d_nested_precfree(prec, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: local_info call psb_d_nested_clear_built(prec, info) if (allocated(prec%field_block_ptype)) then deallocate(prec%field_block_ptype, stat=local_info) if (local_info /= 0 .and. info == psb_success_) info = local_info end if if (allocated(prec%field_krylov)) then deallocate(prec%field_krylov, stat=local_info) if (local_info /= 0 .and. info == psb_success_) info = local_info end if if (allocated(prec%field_iopts)) deallocate(prec%field_iopts, stat=local_info) if (allocated(prec%field_ropts)) deallocate(prec%field_ropts, stat=local_info) if (allocated(prec%field_copts)) deallocate(prec%field_copts, stat=local_info) end subroutine psb_d_nested_precfree ! Set integer-valued nested options or record integer field-block options. subroutine psb_d_nested_precseti(prec, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: what, val integer(psb_ipk_), intent(out) :: info info = psb_success_ select case (what) case (psb_d_nested_schur_maxit_) prec%schur_maxit = max(0, val) case (psb_d_nested_inner_maxit_, psb_d_nested_inner_itrace_, & & psb_d_nested_inner_istop_) call psb_d_nested_set_field_krylov_i(prec, 0, what, val, info) case default call psb_d_nested_append_iopt(prec, 0, what, val, info) end select end subroutine psb_d_nested_precseti ! Set real-valued nested options or record real field-block options. subroutine psb_d_nested_precsetr(prec, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info info = psb_success_ select case (what) case (psb_d_nested_schur_tol_) prec%schur_tol = max(dzero, val) case (psb_d_nested_inner_tol_) call psb_d_nested_set_field_krylov_r(prec, 0, what, val, info) case default call psb_d_nested_append_ropt(prec, 0, what, val, info) end select end subroutine psb_d_nested_precsetr ! Set character-valued nested options or record character field-block options. subroutine psb_d_nested_precsetc(prec, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=64) :: opt info = psb_success_ opt = psb_toupper(trim(val)) select case (what) case (psb_d_nested_composition_) select case (trim(opt)) case ('DIAGONAL','DIAG') prec%composition = psb_d_nested_diag_ prec%composition_name = 'DIAGONAL' case ('ADDITIVE','ADD') prec%composition = psb_d_nested_add_ prec%composition_name = 'ADDITIVE' case ('MULTIPLICATIVE','MULT') prec%composition = psb_d_nested_mult_ prec%composition_name = 'MULTIPLICATIVE' case ('SYMMETRIC_MULTIPLICATIVE','SYMMETRIC','SYM_MULT','SYMM') prec%composition = psb_d_nested_symm_ prec%composition_name = 'SYMMETRIC_MULTIPLICATIVE' case ('SCHUR_LOWER','LOWER_SCHUR') prec%composition = psb_d_nested_schur_lower_ prec%composition_name = 'SCHUR_LOWER' case ('SCHUR_UPPER','UPPER_SCHUR') prec%composition = psb_d_nested_schur_upper_ prec%composition_name = 'SCHUR_UPPER' case ('SCHUR','SCHUR_FULL','FULL_SCHUR') prec%composition = psb_d_nested_schur_full_ prec%composition_name = 'SCHUR_FULL' case default info = psb_err_invalid_input_ end select case (psb_d_nested_block_solve_) if (psb_d_nested_valid_block_solve(opt)) then prec%default_block_ptype = trim(opt) else info = psb_err_invalid_preca_ end if case (psb_d_nested_schur_solve_) select case (trim(opt)) case ('A22','A_22','FIELD','FIELD_BLOCK') prec%schur_solve = psb_d_nested_schur_a22_ prec%schur_solve_name = 'A22' case ('MATRIX_FREE','MATFREE','MF','SELF') prec%schur_solve = psb_d_nested_schur_mf_ prec%schur_solve_name = 'MATRIX_FREE' case default info = psb_err_invalid_input_ end select case (psb_d_nested_inner_solve_) call psb_d_nested_set_field_krylov_c(prec, 0, what, trim(opt), info) case default call psb_d_nested_append_copt(prec, 0, what, trim(val), info) end select end subroutine psb_d_nested_precsetc ! Build one field preconditioner for each diagonal block of a nested matrix. subroutine psb_d_nested_precbld(a, desc_a, prec, info, amold, vmold, imold) type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: amold class(psb_d_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold integer(psb_ipk_) :: i, nfields type(psb_dspmat_type), pointer :: block_ptr type(psb_desc_type), pointer :: field_desc character(len=24) :: name info = psb_success_ name = 'd_nested_precbld' call prec%set_ctxt(desc_a%get_ctxt()) call psb_d_nested_clear_built(prec, info) if (info /= psb_success_) return call prec%set_ctxt(desc_a%get_ctxt()) if (.not. allocated(a%a)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, name, a_err='matrix storage not allocated') return end if select type (ap => a%a) type is (psb_d_nest_base_mat) prec%nest_op => ap class default info = psb_err_invalid_input_ call psb_errpush(info, name, a_err='NEST preconditioner requires NEST matrix') return end select nfields = psb_d_nest_get_n_fields(prec%nest_op) if (nfields <= 0) then info = psb_err_invalid_mat_state_ call psb_errpush(info, name, a_err='nested matrix has no fields') return end if prec%nfields = nfields allocate(prec%blocks(nfields), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name, a_err='blocks') return end if do i = 1, nfields field_desc => psb_d_nest_get_field_desc(prec%nest_op, i) if (.not. associated(field_desc)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, name, a_err='missing field descriptor') return end if block_ptr => psb_d_nest_get_block(prec%nest_op, i, i) if (associated(block_ptr)) then prec%blocks(i)%ptype = psb_d_nested_get_field_block_ptype(prec, i) else prec%blocks(i)%ptype = 'NONE' end if call psb_d_nested_alloc_block_pc(prec%blocks(i), info) if (info /= psb_success_) return call prec%blocks(i)%pc%precinit(info) if (info /= psb_success_) return call psb_d_nested_replay_field_options(prec, i, info) if (info /= psb_success_) return if (associated(block_ptr)) then call prec%blocks(i)%pc%precbld(block_ptr, field_desc, info, & & amold=amold, vmold=vmold, imold=imold) else call prec%blocks(i)%pc%set_ctxt(field_desc%get_ctxt()) end if if (info /= psb_success_) return end do end subroutine psb_d_nested_precbld ! Allocate the concrete PSBLAS preconditioner requested for one field block. subroutine psb_d_nested_alloc_block_pc(block, info) type(psb_d_nested_block_prec), intent(inout) :: block integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(block%pc)) then call block%pc%free(info) if (info == psb_success_) deallocate(block%pc, stat=info) if (info /= psb_success_) return end if select case (psb_toupper(trim(block%ptype))) case ('NONE','NOPREC') allocate(psb_d_null_prec_type :: block%pc, stat=info) case ('DIAG') allocate(psb_d_diag_prec_type :: block%pc, stat=info) case ('BJAC') allocate(psb_d_bjac_prec_type :: block%pc, stat=info) case default info = psb_err_invalid_preca_ end select end subroutine psb_d_nested_alloc_block_pc logical function psb_d_nested_valid_block_solve(ptype) result(valid) character(len=*), intent(in) :: ptype character(len=32) :: opt opt = psb_toupper(trim(ptype)) select case (trim(opt)) case ('NONE','NOPREC','DIAG','BJAC') valid = .true. case default valid = .false. end select end function psb_d_nested_valid_block_solve function psb_d_nested_get_field_block_ptype(prec, field) result(ptype) class(psb_d_nested_prec_type), intent(in) :: prec integer(psb_ipk_), intent(in) :: field character(len=16) :: ptype ptype = prec%default_block_ptype if (allocated(prec%field_block_ptype)) then if (field <= size(prec%field_block_ptype)) then if (len_trim(prec%field_block_ptype(field)) > 0) & & ptype = prec%field_block_ptype(field) end if end if end function psb_d_nested_get_field_block_ptype ! Store a per-field block preconditioner type override. subroutine psb_d_nested_set_block_solve_field(prec, field, ptype, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field character(len=*), intent(in) :: ptype integer(psb_ipk_), intent(out) :: info character(len=16), allocatable :: tmp(:) character(len=32) :: opt integer(psb_ipk_) :: old_size info = psb_success_ opt = psb_toupper(trim(ptype)) if (field <= 0) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_block_solve_field', a_err='field index') return end if if (.not. psb_d_nested_valid_block_solve(opt)) then info = psb_err_invalid_preca_ call psb_errpush(info, 'd_nested_set_block_solve_field', a_err='block solve') return end if old_size = 0 if (allocated(prec%field_block_ptype)) old_size = size(prec%field_block_ptype) if (field > old_size) then allocate(tmp(field), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_set_block_solve_field', a_err='field block options') return end if tmp(:) = '' if (old_size > 0) tmp(1:old_size) = prec%field_block_ptype(1:old_size) call move_alloc(tmp, prec%field_block_ptype) end if prec%field_block_ptype(field) = trim(opt) end subroutine psb_d_nested_set_block_solve_field subroutine psb_d_nested_ensure_krylov_field(prec, field, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field integer(psb_ipk_), intent(out) :: info type(psb_d_nested_krylov_context), allocatable :: tmp(:) integer(psb_ipk_) :: old_size info = psb_success_ if (field <= 0) return old_size = 0 if (allocated(prec%field_krylov)) old_size = size(prec%field_krylov) if (field > old_size) then allocate(tmp(field), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_ensure_krylov_field', a_err='field krylov options') return end if tmp(:) = prec%default_krylov if (old_size > 0) tmp(1:old_size) = prec%field_krylov(1:old_size) call move_alloc(tmp, prec%field_krylov) end if end subroutine psb_d_nested_ensure_krylov_field subroutine psb_d_nested_set_field_krylov_c(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=32) :: opt info = psb_success_ opt = psb_toupper(trim(val)) if (field < 0) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_krylov_c', a_err='field index') return end if if (what /= psb_d_nested_inner_solve_) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_krylov_c', a_err='inner option') return end if select case (trim(opt)) case ('NONE','NO','OFF','FALSE') if (field == 0) then prec%default_krylov%enabled = .false. else call psb_d_nested_ensure_krylov_field(prec, field, info) if (info == psb_success_) prec%field_krylov(field)%enabled = .false. end if case ('CG','BICGSTAB','BICGstab','BiCGSTAB') if (field == 0) then prec%default_krylov%enabled = .true. prec%default_krylov%method = trim(opt) else call psb_d_nested_ensure_krylov_field(prec, field, info) if (info == psb_success_) then prec%field_krylov(field)%enabled = .true. prec%field_krylov(field)%method = trim(opt) end if end if case default info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_krylov_c', a_err='inner method') end select end subroutine psb_d_nested_set_field_krylov_c subroutine psb_d_nested_set_field_krylov_i(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what, val integer(psb_ipk_), intent(out) :: info info = psb_success_ if (field < 0) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_krylov_i', a_err='field index') return end if if (field > 0) then call psb_d_nested_ensure_krylov_field(prec, field, info) if (info /= psb_success_) return end if select case (what) case (psb_d_nested_inner_maxit_) if (field == 0) then prec%default_krylov%itmax = max(1, val) else prec%field_krylov(field)%itmax = max(1, val) end if case (psb_d_nested_inner_itrace_) if (field == 0) then prec%default_krylov%itrace = val else prec%field_krylov(field)%itrace = val end if case (psb_d_nested_inner_istop_) if (field == 0) then prec%default_krylov%istop = val else prec%field_krylov(field)%istop = val end if case default info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_krylov_i', a_err='inner option') end select end subroutine psb_d_nested_set_field_krylov_i subroutine psb_d_nested_set_field_krylov_r(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info info = psb_success_ if (field < 0) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_krylov_r', a_err='field index') return end if if (what /= psb_d_nested_inner_tol_) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_krylov_r', a_err='inner option') return end if if (field == 0) then prec%default_krylov%tol = max(dzero, val) else call psb_d_nested_ensure_krylov_field(prec, field, info) if (info == psb_success_) prec%field_krylov(field)%tol = max(dzero, val) end if end subroutine psb_d_nested_set_field_krylov_r function psb_d_nested_get_field_krylov(prec, field) result(ctx) class(psb_d_nested_prec_type), intent(in) :: prec integer(psb_ipk_), intent(in) :: field type(psb_d_nested_krylov_context) :: ctx ctx = prec%default_krylov if (allocated(prec%field_krylov)) then if (field <= size(prec%field_krylov)) ctx = prec%field_krylov(field) end if end function psb_d_nested_get_field_krylov ! Append a pending integer option for all fields or one selected field. subroutine psb_d_nested_append_iopt(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what, val integer(psb_ipk_), intent(out) :: info type(psb_d_nested_iopt), allocatable :: tmp(:) integer(psb_ipk_) :: n info = psb_success_ n = 0 if (allocated(prec%field_iopts)) n = size(prec%field_iopts) allocate(tmp(n+1), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_append_iopt', a_err='field integer options') return end if if (n > 0) tmp(1:n) = prec%field_iopts(1:n) tmp(n+1)%field = field tmp(n+1)%what = what tmp(n+1)%val = val call move_alloc(tmp, prec%field_iopts) end subroutine psb_d_nested_append_iopt ! Append a pending real option for all fields or one selected field. subroutine psb_d_nested_append_ropt(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info type(psb_d_nested_ropt), allocatable :: tmp(:) integer(psb_ipk_) :: n info = psb_success_ n = 0 if (allocated(prec%field_ropts)) n = size(prec%field_ropts) allocate(tmp(n+1), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_append_ropt', a_err='field real options') return end if if (n > 0) tmp(1:n) = prec%field_ropts(1:n) tmp(n+1)%field = field tmp(n+1)%what = what tmp(n+1)%val = val call move_alloc(tmp, prec%field_ropts) end subroutine psb_d_nested_append_ropt ! Append a pending character option for all fields or one selected field. subroutine psb_d_nested_append_copt(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info type(psb_d_nested_copt), allocatable :: tmp(:) integer(psb_ipk_) :: n info = psb_success_ n = 0 if (allocated(prec%field_copts)) n = size(prec%field_copts) allocate(tmp(n+1), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_append_copt', a_err='field character options') return end if if (n > 0) tmp(1:n) = prec%field_copts(1:n) tmp(n+1)%field = field tmp(n+1)%what = what tmp(n+1)%val = trim(val) call move_alloc(tmp, prec%field_copts) end subroutine psb_d_nested_append_copt ! Record an integer option to replay on a field block preconditioner. subroutine psb_d_nested_set_field_precseti(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what, val integer(psb_ipk_), intent(out) :: info info = psb_success_ if (field < 0) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_precseti', a_err='field index') return end if call psb_d_nested_append_iopt(prec, field, what, val, info) end subroutine psb_d_nested_set_field_precseti ! Record a real option to replay on a field block preconditioner. subroutine psb_d_nested_set_field_precsetr(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info info = psb_success_ if (field < 0) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_precsetr', a_err='field index') return end if call psb_d_nested_append_ropt(prec, field, what, val, info) end subroutine psb_d_nested_set_field_precsetr ! Record a character option to replay on a field block preconditioner. subroutine psb_d_nested_set_field_precsetc(prec, field, what, val, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field, what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info info = psb_success_ if (field < 0) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_set_field_precsetc', a_err='field index') return end if call psb_d_nested_append_copt(prec, field, what, val, info) end subroutine psb_d_nested_set_field_precsetc ! Apply stored field-specific options to a built field block preconditioner. subroutine psb_d_nested_replay_field_options(prec, field, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: k info = psb_success_ if (.not. allocated(prec%blocks(field)%pc)) return if (allocated(prec%field_iopts)) then do k = 1, size(prec%field_iopts) if ((prec%field_iopts(k)%field == 0) .or. (prec%field_iopts(k)%field == field)) then call prec%blocks(field)%pc%precset(prec%field_iopts(k)%what, & & prec%field_iopts(k)%val, info) if (info /= psb_success_) return end if end do end if if (allocated(prec%field_ropts)) then do k = 1, size(prec%field_ropts) if ((prec%field_ropts(k)%field == 0) .or. (prec%field_ropts(k)%field == field)) then call prec%blocks(field)%pc%precset(prec%field_ropts(k)%what, & & prec%field_ropts(k)%val, info) if (info /= psb_success_) return end if end do end if if (allocated(prec%field_copts)) then do k = 1, size(prec%field_copts) if ((prec%field_copts(k)%field == 0) .or. (prec%field_copts(k)%field == field)) then call prec%blocks(field)%pc%precset(prec%field_copts(k)%what, & & trim(prec%field_copts(k)%val), info) if (info /= psb_success_) return end if end do end if end subroutine psb_d_nested_replay_field_options ! Apply the nested preconditioner to PSBLAS vector objects. subroutine psb_d_nested_apply_vect(alpha, prec, x, beta, y, desc_data, info, trans) type(psb_desc_type), intent(in) :: desc_data class(psb_d_nested_prec_type), intent(inout) :: prec type(psb_d_vect_type), intent(inout) :: x real(psb_dpk_), intent(in) :: alpha, beta type(psb_d_vect_type), intent(inout) :: y integer(psb_ipk_), intent(out) :: info character(len=1), optional :: trans real(psb_dpk_), allocatable :: xbuf(:), ybuf(:) integer(psb_ipk_) :: ncol info = psb_success_ ncol = desc_data%get_local_cols() xbuf = x%get_vect(ncol) allocate(ybuf(max(y%get_nrows(), ncol)), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ return end if ybuf(:) = dzero call psb_d_nested_apply(alpha, prec, xbuf, beta, ybuf, desc_data, info, trans) if (info == psb_success_) call y%set(ybuf(1:y%get_nrows())) deallocate(ybuf) end subroutine psb_d_nested_apply_vect ! Apply the selected nested composition to raw array vectors. subroutine psb_d_nested_apply(alpha, prec, x, beta, y, desc_data, info, trans, work) type(psb_desc_type), intent(in) :: desc_data class(psb_d_nested_prec_type), intent(inout) :: prec real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(in) :: alpha, beta real(psb_dpk_), intent(inout) :: y(:) integer(psb_ipk_), intent(out) :: info character(len=1), optional :: trans real(psb_dpk_), intent(inout), optional, target :: work(:) real(psb_dpk_), allocatable :: z(:) integer(psb_ipk_) :: nrow, ncol character :: trans_ character(len=24) :: name info = psb_success_ name = 'd_nested_apply' trans_ = 'N' if (present(trans)) trans_ = psb_toupper(trans) if (.not. associated(prec%nest_op) .or. .not. allocated(prec%blocks)) then info = 1124 call psb_errpush(info, name, a_err='nested preconditioner') return end if nrow = desc_data%get_local_rows() ncol = desc_data%get_local_cols() if (size(x) < nrow .or. size(y) < nrow) then info = psb_err_invalid_input_ call psb_errpush(info, name, a_err='vector too small') return end if allocate(z(max(nrow,ncol)), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name, a_err='work vector') return end if z(:) = dzero if (trans_ /= 'N') then info = psb_err_transpose_not_n_unsupported_ call psb_errpush(info, name) else select case (prec%composition) case (psb_d_nested_diag_, psb_d_nested_add_) call psb_d_nested_add_apply(prec, x, z, desc_data, info) case (psb_d_nested_mult_) call psb_d_nested_sweep(prec, x, z, desc_data, 1, prec%nfields, 1, info) case (psb_d_nested_symm_) call psb_d_nested_sweep(prec, x, z, desc_data, 1, prec%nfields, 1, info) if (info == psb_success_) & & call psb_d_nested_sweep(prec, x, z, desc_data, prec%nfields, 1, -1, info) case (psb_d_nested_schur_lower_, psb_d_nested_schur_upper_, psb_d_nested_schur_full_) call psb_d_nested_apply_schur(prec, x, z, desc_data, info) case default info = psb_err_invalid_input_ call psb_errpush(info, name, a_err='unknown composition') end select end if if (info /= psb_success_) then deallocate(z) return end if if (beta == dzero) then y(1:nrow) = alpha * z(1:nrow) else y(1:nrow) = alpha * z(1:nrow) + beta * y(1:nrow) end if deallocate(z) end subroutine psb_d_nested_apply ! Apply the additive or diagonal field-split composition. subroutine psb_d_nested_add_apply(prec, x, z, desc_data, info) class(psb_d_nested_prec_type), intent(inout) :: prec real(psb_dpk_), intent(in) :: x(:) real(psb_dpk_), intent(inout) :: z(:) type(psb_desc_type), intent(in) :: desc_data integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, n_owned, n_col_field real(psb_dpk_), allocatable :: rhs(:), sol(:), wrk(:) type(psb_desc_type), pointer :: field_desc info = psb_success_ z(:) = dzero do i = 1, prec%nfields n_owned = psb_d_nest_get_field_owned(prec%nest_op, i) field_desc => psb_d_nest_get_field_desc(prec%nest_op, i) if (.not. associated(field_desc)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_add_apply', a_err='missing field descriptor') return end if n_col_field = field_desc%get_local_cols() allocate(rhs(n_col_field), sol(n_col_field), wrk(n_col_field), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_add_apply', a_err='field vectors') return end if rhs(:) = dzero sol(:) = dzero call psb_d_nest_restrict_field(prec%nest_op, i, x, rhs, info) if (info == psb_success_) then call prec%blocks(i)%pc%apply(done, rhs, dzero, sol, field_desc, info, trans='N', work=wrk) end if if (info == psb_success_) then call psb_d_nest_prolong_field(prec%nest_op, i, sol, z, info) end if deallocate(rhs, sol, wrk) if (info /= psb_success_) return end do end subroutine psb_d_nested_add_apply ! Apply one forward or backward multiplicative field sweep. subroutine psb_d_nested_sweep(prec, x, z, desc_data, first, last, step, info) class(psb_d_nested_prec_type), intent(inout) :: prec real(psb_dpk_), intent(in) :: x(:) real(psb_dpk_), intent(inout) :: z(:) type(psb_desc_type), intent(in) :: desc_data integer(psb_ipk_), intent(in) :: first, last, step integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i, j, n_owned, n_col_i, n_col_j real(psb_dpk_), allocatable :: rhs(:), sol(:), z_field(:), wrk(:) type(psb_desc_type), pointer :: field_desc_i, field_desc_j type(psb_dspmat_type), pointer :: block_ptr info = psb_success_ call psb_halo(z, desc_data, info) if (info /= psb_success_) return i = first do n_owned = psb_d_nest_get_field_owned(prec%nest_op, i) field_desc_i => psb_d_nest_get_field_desc(prec%nest_op, i) if (.not. associated(field_desc_i)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_sweep', a_err='missing row field descriptor') return end if n_col_i = field_desc_i%get_local_cols() allocate(rhs(n_col_i), sol(n_col_i), wrk(n_col_i), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_sweep', a_err='field vectors') return end if rhs(:) = dzero sol(:) = dzero call psb_d_nest_restrict_field(prec%nest_op, i, x, rhs, info) if (info /= psb_success_) then deallocate(rhs, sol, wrk) return end if do j = 1, prec%nfields if (j == i) cycle block_ptr => psb_d_nest_get_block(prec%nest_op, i, j) if (.not. associated(block_ptr)) cycle field_desc_j => psb_d_nest_get_field_desc(prec%nest_op, j) if (.not. associated(field_desc_j)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_sweep', a_err='missing column field descriptor') deallocate(rhs, sol, wrk) return end if n_col_j = field_desc_j%get_local_cols() allocate(z_field(n_col_j), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_sweep', a_err='offdiag field vector') deallocate(rhs, sol, wrk) return end if z_field(:) = dzero call psb_d_nest_restrict_field_local(prec%nest_op, j, z, z_field, info) if (info == psb_success_) then call psb_d_nest_apply_block(prec%nest_op, i, j, -done, z_field, done, rhs, info) end if deallocate(z_field) if (info /= psb_success_) then deallocate(rhs, sol, wrk) return end if end do call prec%blocks(i)%pc%apply(done, rhs, dzero, sol, field_desc_i, info, trans='N', work=wrk) if (info == psb_success_) then call psb_d_nest_prolong_field(prec%nest_op, i, sol, z, info) end if deallocate(rhs, sol, wrk) if (info /= psb_success_) return call psb_halo(z, desc_data, info) if (info /= psb_success_) return if (i == last) exit i = i + step end do end subroutine psb_d_nested_sweep ! Apply one field block preconditioner to a field-local right-hand side. subroutine psb_d_nested_field_solve(prec, field, rhs, sol, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field real(psb_dpk_), intent(inout) :: rhs(:) real(psb_dpk_), intent(inout) :: sol(:) integer(psb_ipk_), intent(out) :: info real(psb_dpk_), allocatable :: wrk(:) type(psb_desc_type), pointer :: field_desc type(psb_d_nested_krylov_context) :: kctx integer(psb_ipk_) :: n_col_field info = psb_success_ field_desc => psb_d_nest_get_field_desc(prec%nest_op, field) if (.not. associated(field_desc)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_field_solve', a_err='missing field descriptor') return end if n_col_field = field_desc%get_local_cols() kctx = prec%default_krylov if (allocated(prec%field_krylov)) then if (field <= size(prec%field_krylov)) kctx = prec%field_krylov(field) end if if (kctx%enabled) then call psb_d_nested_inner_solve(prec, field, kctx, rhs, sol, info) return end if allocate(wrk(n_col_field), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_field_solve', a_err='work vector') return end if sol(:) = dzero call prec%blocks(field)%pc%apply(done, rhs, dzero, sol, field_desc, info, trans='N', work=wrk) deallocate(wrk) end subroutine psb_d_nested_field_solve subroutine psb_d_nested_field_matvec(prec, field, x, y, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), intent(inout) :: y(:) integer(psb_ipk_), intent(out) :: info real(psb_dpk_), allocatable :: xh(:) type(psb_desc_type), pointer :: field_desc type(psb_dspmat_type), pointer :: block_ptr integer(psb_ipk_) :: n_col_field info = psb_success_ field_desc => psb_d_nest_get_field_desc(prec%nest_op, field) block_ptr => psb_d_nest_get_block(prec%nest_op, field, field) if (.not. associated(field_desc)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_field_matvec', a_err='missing field descriptor') return end if if (.not. associated(block_ptr)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_field_matvec', a_err='missing diagonal block') return end if n_col_field = field_desc%get_local_cols() allocate(xh(n_col_field), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_field_matvec', a_err='work vector') return end if xh(:) = dzero xh(1:min(size(x), n_col_field)) = x(1:min(size(x), n_col_field)) call psb_halo(xh, field_desc, info) if (info == psb_success_) then y(:) = dzero call psb_d_nest_apply_block(prec%nest_op, field, field, done, xh, dzero, y, info) end if deallocate(xh) end subroutine psb_d_nested_field_matvec subroutine psb_d_nested_inner_solve(prec, field, kctx, rhs, sol, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field type(psb_d_nested_krylov_context), intent(in) :: kctx real(psb_dpk_), intent(inout) :: rhs(:) real(psb_dpk_), intent(inout) :: sol(:) integer(psb_ipk_), intent(out) :: info select case (psb_toupper(trim(kctx%method))) case ('CG') call psb_d_nested_inner_cg(prec, field, kctx, rhs, sol, info) case ('BICGSTAB') call psb_d_nested_inner_bicgstab(prec, field, kctx, rhs, sol, info) case default info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_inner_solve', a_err='inner Krylov method') end select end subroutine psb_d_nested_inner_solve subroutine psb_d_nested_inner_cg(prec, field, kctx, rhs, sol, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field type(psb_d_nested_krylov_context), intent(in) :: kctx real(psb_dpk_), intent(inout) :: rhs(:) real(psb_dpk_), intent(inout) :: sol(:) integer(psb_ipk_), intent(out) :: info real(psb_dpk_), allocatable :: r(:), z(:), p(:), q(:), wrk(:) type(psb_desc_type), pointer :: field_desc integer(psb_ipk_) :: n_col_field, k real(psb_dpk_) :: bnorm, rnorm, rz, rz_new, denom, alpha, beta info = psb_success_ field_desc => psb_d_nest_get_field_desc(prec%nest_op, field) if (.not. associated(field_desc)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_inner_cg', a_err='missing field descriptor') return end if n_col_field = field_desc%get_local_cols() allocate(r(n_col_field), z(n_col_field), p(n_col_field), q(n_col_field), & & wrk(n_col_field), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_inner_cg', a_err='inner work vectors') return end if sol(:) = dzero r(:) = rhs(:) bnorm = sqrt(max(dzero, psb_gedot(rhs, rhs, field_desc, info))) if (info /= psb_success_) goto 100 if (bnorm == dzero) goto 100 z(:) = dzero call prec%blocks(field)%pc%apply(done, r, dzero, z, field_desc, info, trans='N', work=wrk) if (info /= psb_success_) goto 100 p(:) = z(:) rz = psb_gedot(r, z, field_desc, info) if (info /= psb_success_) goto 100 do k = 1, max(1, kctx%itmax) q(:) = dzero call psb_d_nested_field_matvec(prec, field, p, q, info) if (info /= psb_success_) exit denom = psb_gedot(p, q, field_desc, info) if (info /= psb_success_) exit if (abs(denom) <= epsilon(done)) exit alpha = rz / denom sol(:) = sol(:) + alpha * p(:) r(:) = r(:) - alpha * q(:) rnorm = sqrt(max(dzero, psb_gedot(r, r, field_desc, info))) if (info /= psb_success_) exit if (rnorm <= kctx%tol * bnorm) exit z(:) = dzero call prec%blocks(field)%pc%apply(done, r, dzero, z, field_desc, info, trans='N', work=wrk) if (info /= psb_success_) exit rz_new = psb_gedot(r, z, field_desc, info) if (info /= psb_success_) exit if (abs(rz) <= epsilon(done)) exit beta = rz_new / rz p(:) = z(:) + beta * p(:) rz = rz_new end do 100 continue deallocate(r, z, p, q, wrk) end subroutine psb_d_nested_inner_cg subroutine psb_d_nested_inner_bicgstab(prec, field, kctx, rhs, sol, info) class(psb_d_nested_prec_type), intent(inout) :: prec integer(psb_ipk_), intent(in) :: field type(psb_d_nested_krylov_context), intent(in) :: kctx real(psb_dpk_), intent(inout) :: rhs(:) real(psb_dpk_), intent(inout) :: sol(:) integer(psb_ipk_), intent(out) :: info real(psb_dpk_), allocatable :: r(:), r0(:), p(:), v(:), s(:), t(:), ph(:), sh(:), wrk(:) type(psb_desc_type), pointer :: field_desc integer(psb_ipk_) :: n_col_field, k real(psb_dpk_) :: bnorm, rnorm, rho, rho_old, alpha, beta, omega, denom info = psb_success_ field_desc => psb_d_nest_get_field_desc(prec%nest_op, field) if (.not. associated(field_desc)) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_inner_bicgstab', a_err='missing field descriptor') return end if n_col_field = field_desc%get_local_cols() allocate(r(n_col_field), r0(n_col_field), p(n_col_field), v(n_col_field), & & s(n_col_field), t(n_col_field), ph(n_col_field), sh(n_col_field), & & wrk(n_col_field), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_inner_bicgstab', a_err='inner work vectors') return end if sol(:) = dzero r(:) = rhs(:) r0(:) = r(:) p(:) = dzero v(:) = dzero rho_old = done alpha = done omega = done bnorm = sqrt(max(dzero, psb_gedot(rhs, rhs, field_desc, info))) if (info /= psb_success_) goto 100 if (bnorm == dzero) goto 100 do k = 1, max(1, kctx%itmax) rho = psb_gedot(r0, r, field_desc, info) if (info /= psb_success_) exit if (abs(rho) <= epsilon(done)) exit if (k == 1) then p(:) = r(:) else if (abs(omega) <= epsilon(done)) exit beta = (rho / rho_old) * (alpha / omega) p(:) = r(:) + beta * (p(:) - omega * v(:)) end if ph(:) = dzero call prec%blocks(field)%pc%apply(done, p, dzero, ph, field_desc, info, trans='N', work=wrk) if (info /= psb_success_) exit v(:) = dzero call psb_d_nested_field_matvec(prec, field, ph, v, info) if (info /= psb_success_) exit denom = psb_gedot(r0, v, field_desc, info) if (info /= psb_success_) exit if (abs(denom) <= epsilon(done)) exit alpha = rho / denom s(:) = r(:) - alpha * v(:) rnorm = sqrt(max(dzero, psb_gedot(s, s, field_desc, info))) if (info /= psb_success_) exit if (rnorm <= kctx%tol * bnorm) then sol(:) = sol(:) + alpha * ph(:) exit end if sh(:) = dzero call prec%blocks(field)%pc%apply(done, s, dzero, sh, field_desc, info, trans='N', work=wrk) if (info /= psb_success_) exit t(:) = dzero call psb_d_nested_field_matvec(prec, field, sh, t, info) if (info /= psb_success_) exit denom = psb_gedot(t, t, field_desc, info) if (info /= psb_success_) exit if (abs(denom) <= epsilon(done)) exit omega = psb_gedot(t, s, field_desc, info) / denom if (info /= psb_success_) exit sol(:) = sol(:) + alpha * ph(:) + omega * sh(:) r(:) = s(:) - omega * t(:) rnorm = sqrt(max(dzero, psb_gedot(r, r, field_desc, info))) if (info /= psb_success_) exit if (rnorm <= kctx%tol * bnorm) exit rho_old = rho end do 100 continue deallocate(r, r0, p, v, s, t, ph, sh, wrk) end subroutine psb_d_nested_inner_bicgstab ! Apply the matrix-free Schur action Sx on the second field. subroutine psb_d_nested_schur_action(prec, x2, y2, gwork, desc_data, info) class(psb_d_nested_prec_type), intent(inout) :: prec real(psb_dpk_), intent(inout) :: x2(:) real(psb_dpk_), intent(inout) :: y2(:) real(psb_dpk_), intent(inout) :: gwork(:) type(psb_desc_type), intent(in) :: desc_data integer(psb_ipk_), intent(out) :: info real(psb_dpk_), allocatable :: x2h(:), t1(:), w1(:), w1h(:), t2(:) type(psb_desc_type), pointer :: desc1, desc2 type(psb_dspmat_type), pointer :: block12, block21, block22 integer(psb_ipk_) :: n_col_1, n_col_2 info = psb_success_ desc1 => psb_d_nest_get_field_desc(prec%nest_op, 1) desc2 => psb_d_nest_get_field_desc(prec%nest_op, 2) if ((.not. associated(desc1)) .or. (.not. associated(desc2))) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_schur_action', a_err='missing field descriptor') return end if n_col_1 = desc1%get_local_cols() n_col_2 = desc2%get_local_cols() allocate(x2h(n_col_2), t1(n_col_1), w1(n_col_1), w1h(n_col_1), & & t2(n_col_2), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_schur_action', a_err='field vectors') return end if x2h(:) = dzero t1(:) = dzero w1(:) = dzero w1h(:) = dzero t2(:) = dzero y2(:) = dzero gwork(:) = dzero call psb_d_nest_prolong_field(prec%nest_op, 2, x2, gwork, info) if (info /= psb_success_) goto 100 call psb_halo(gwork, desc_data, info) if (info /= psb_success_) goto 100 call psb_d_nest_restrict_field_local(prec%nest_op, 2, gwork, x2h, info) if (info /= psb_success_) goto 100 block22 => psb_d_nest_get_block(prec%nest_op, 2, 2) if (associated(block22)) then call psb_d_nest_apply_block(prec%nest_op, 2, 2, done, x2h, dzero, y2, info) if (info /= psb_success_) goto 100 end if block12 => psb_d_nest_get_block(prec%nest_op, 1, 2) block21 => psb_d_nest_get_block(prec%nest_op, 2, 1) if (associated(block12) .and. associated(block21)) then call psb_d_nest_apply_block(prec%nest_op, 1, 2, done, x2h, dzero, t1, info) if (info /= psb_success_) goto 100 call psb_d_nested_field_solve(prec, 1, t1, w1, info) if (info /= psb_success_) goto 100 gwork(:) = dzero call psb_d_nest_prolong_field(prec%nest_op, 1, w1, gwork, info) if (info /= psb_success_) goto 100 call psb_halo(gwork, desc_data, info) if (info /= psb_success_) goto 100 call psb_d_nest_restrict_field_local(prec%nest_op, 1, gwork, w1h, info) if (info /= psb_success_) goto 100 call psb_d_nest_apply_block(prec%nest_op, 2, 1, done, w1h, dzero, t2, info) if (info /= psb_success_) goto 100 y2(:) = y2(:) - t2(:) end if 100 continue deallocate(x2h, t1, w1, w1h, t2) end subroutine psb_d_nested_schur_action ! Approximately solve the Schur block using A22 or the matrix-free Schur action. subroutine psb_d_nested_schur_solve(prec, rhs, sol, gwork, desc_data, info) class(psb_d_nested_prec_type), intent(inout) :: prec real(psb_dpk_), intent(inout) :: rhs(:) real(psb_dpk_), intent(inout) :: sol(:) real(psb_dpk_), intent(inout) :: gwork(:) type(psb_desc_type), intent(in) :: desc_data integer(psb_ipk_), intent(out) :: info real(psb_dpk_), allocatable :: sx(:), res(:), dz(:) integer(psb_ipk_) :: k, maxit, n_owned real(psb_dpk_) :: rnrm info = psb_success_ if (prec%schur_solve == psb_d_nested_schur_a22_) then call psb_d_nested_field_solve(prec, 2, rhs, sol, info) return end if allocate(sx(size(rhs)), res(size(rhs)), dz(size(rhs)), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_schur_solve', a_err='Schur work vectors') return end if sol(:) = dzero maxit = max(1, prec%schur_maxit) n_owned = psb_d_nest_get_field_owned(prec%nest_op, 2) do k = 1, maxit sx(:) = dzero call psb_d_nested_schur_action(prec, sol, sx, gwork, desc_data, info) if (info /= psb_success_) exit res(:) = rhs(:) - sx(:) if (prec%schur_tol > dzero) then rnrm = sqrt(sum(res(1:n_owned) * res(1:n_owned))) if (rnrm <= prec%schur_tol) exit end if call psb_d_nested_field_solve(prec, 2, res, dz, info) if (info /= psb_success_) exit sol(:) = sol(:) + dz(:) end do deallocate(sx, res, dz) end subroutine psb_d_nested_schur_solve ! Apply the two-field lower, upper, or full Schur-style composition. subroutine psb_d_nested_apply_schur(prec, x, z, desc_data, info) class(psb_d_nested_prec_type), intent(inout) :: prec real(psb_dpk_), intent(in) :: x(:) real(psb_dpk_), intent(inout) :: z(:) type(psb_desc_type), intent(in) :: desc_data integer(psb_ipk_), intent(out) :: info real(psb_dpk_), allocatable :: b1(:), b2(:), x1(:), x2(:), t1(:), t2(:), c1(:), gwork(:) type(psb_desc_type), pointer :: desc1, desc2 type(psb_dspmat_type), pointer :: block12, block21 integer(psb_ipk_) :: n_col_1, n_col_2 info = psb_success_ z(:) = dzero if (prec%nfields /= 2) then info = psb_err_invalid_input_ call psb_errpush(info, 'd_nested_apply_schur', a_err='Schur composition requires two fields') return end if desc1 => psb_d_nest_get_field_desc(prec%nest_op, 1) desc2 => psb_d_nest_get_field_desc(prec%nest_op, 2) if ((.not. associated(desc1)) .or. (.not. associated(desc2))) then info = psb_err_invalid_mat_state_ call psb_errpush(info, 'd_nested_apply_schur', a_err='missing field descriptor') return end if n_col_1 = desc1%get_local_cols() n_col_2 = desc2%get_local_cols() allocate(b1(n_col_1), b2(n_col_2), x1(n_col_1), x2(n_col_2), & & t1(n_col_1), t2(n_col_2), c1(n_col_1), gwork(size(z)), stat=info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, 'd_nested_apply_schur', a_err='field vectors') return end if b1(:) = dzero b2(:) = dzero x1(:) = dzero x2(:) = dzero t1(:) = dzero t2(:) = dzero c1(:) = dzero gwork(:) = dzero call psb_d_nest_restrict_field(prec%nest_op, 1, x, b1, info) if (info /= psb_success_) goto 100 call psb_d_nest_restrict_field(prec%nest_op, 2, x, b2, info) if (info /= psb_success_) goto 100 block12 => psb_d_nest_get_block(prec%nest_op, 1, 2) block21 => psb_d_nest_get_block(prec%nest_op, 2, 1) select case (prec%composition) case (psb_d_nested_schur_lower_, psb_d_nested_schur_full_) call psb_d_nested_field_solve(prec, 1, b1, x1, info) if (info /= psb_success_) goto 100 call psb_d_nest_prolong_field(prec%nest_op, 1, x1, z, info) if (info /= psb_success_) goto 100 call psb_halo(z, desc_data, info) if (info /= psb_success_) goto 100 call psb_d_nest_restrict_field_local(prec%nest_op, 1, z, x1, info) if (info /= psb_success_) goto 100 t2(:) = b2(:) if (associated(block21)) then call psb_d_nest_apply_block(prec%nest_op, 2, 1, -done, x1, done, t2, info) if (info /= psb_success_) goto 100 end if call psb_d_nested_schur_solve(prec, t2, x2, gwork, desc_data, info) if (info /= psb_success_) goto 100 call psb_d_nest_prolong_field(prec%nest_op, 2, x2, z, info) if (info /= psb_success_) goto 100 if (prec%composition == psb_d_nested_schur_full_) then call psb_halo(z, desc_data, info) if (info /= psb_success_) goto 100 call psb_d_nest_restrict_field_local(prec%nest_op, 2, z, x2, info) if (info /= psb_success_) goto 100 t1(:) = dzero if (associated(block12)) then call psb_d_nest_apply_block(prec%nest_op, 1, 2, done, x2, dzero, t1, info) if (info /= psb_success_) goto 100 end if call psb_d_nested_field_solve(prec, 1, t1, c1, info) if (info /= psb_success_) goto 100 x1(:) = x1(:) - c1(:) call psb_d_nest_prolong_field(prec%nest_op, 1, x1, z, info) if (info /= psb_success_) goto 100 end if case (psb_d_nested_schur_upper_) call psb_d_nested_schur_solve(prec, b2, x2, gwork, desc_data, info) if (info /= psb_success_) goto 100 call psb_d_nest_prolong_field(prec%nest_op, 2, x2, z, info) if (info /= psb_success_) goto 100 call psb_halo(z, desc_data, info) if (info /= psb_success_) goto 100 call psb_d_nest_restrict_field_local(prec%nest_op, 2, z, x2, info) if (info /= psb_success_) goto 100 t1(:) = b1(:) if (associated(block12)) then call psb_d_nest_apply_block(prec%nest_op, 1, 2, -done, x2, done, t1, info) if (info /= psb_success_) goto 100 end if call psb_d_nested_field_solve(prec, 1, t1, x1, info) if (info /= psb_success_) goto 100 call psb_d_nest_prolong_field(prec%nest_op, 1, x1, z, info) if (info /= psb_success_) goto 100 end select call psb_halo(z, desc_data, info) 100 continue deallocate(b1, b2, x1, x2, t1, t2, c1, gwork) end subroutine psb_d_nested_apply_schur ! Print a short description of the nested preconditioner configuration. subroutine psb_d_nested_precdescr(prec, iout, root, verbosity, prefix) class(psb_d_nested_prec_type), intent(in) :: prec integer(psb_ipk_), intent(in), optional :: iout integer(psb_ipk_), intent(in), optional :: root integer(psb_ipk_), intent(in), optional :: verbosity character(len=*), intent(in), optional :: prefix integer(psb_ipk_) :: iout_, root_, verbosity_, iam, np character(len=1024) :: prefix_ iout_ = 6 if (present(iout)) iout_ = iout root_ = psb_root_ if (present(root)) root_ = root verbosity_ = 0 if (present(verbosity)) verbosity_ = verbosity prefix_ = '' if (present(prefix)) prefix_ = prefix if (verbosity_ < 0) return call psb_info(prec%ctxt, iam, np) if (root_ == -1) root_ = iam if (iam == root_) then write(iout_,*) trim(prefix_), ' ', trim(prec%desc_prefix()), & & ' Nested block preconditioner: ', trim(prec%composition_name), & & ', block solve: ', trim(prec%default_block_ptype) if (prec%default_krylov%enabled) & & write(iout_,*) trim(prefix_), ' default inner Krylov: ', & & trim(prec%default_krylov%method), ' maxit=', prec%default_krylov%itmax, & & ' tol=', prec%default_krylov%tol end if end subroutine psb_d_nested_precdescr ! Provide a placeholder dump hook for the nested preconditioner. subroutine psb_d_nested_dump(prec, info, prefix, head) class(psb_d_nested_prec_type), intent(in) :: prec integer(psb_ipk_), intent(out) :: info character(len=*), intent(in), optional :: prefix, head info = psb_success_ end subroutine psb_d_nested_dump function psb_d_nested_sizeof(prec) result(val) class(psb_d_nested_prec_type), intent(in) :: prec integer(psb_epk_) :: val integer(psb_ipk_) :: i val = 0_psb_epk_ if (allocated(prec%blocks)) then do i = 1, size(prec%blocks) if (allocated(prec%blocks(i)%pc)) val = val + prec%blocks(i)%pc%sizeof() end do end if end function psb_d_nested_sizeof function psb_d_nested_get_nzeros(prec) result(val) class(psb_d_nested_prec_type), intent(in) :: prec integer(psb_epk_) :: val integer(psb_ipk_) :: i val = 0_psb_epk_ if (allocated(prec%blocks)) then do i = 1, size(prec%blocks) if (allocated(prec%blocks(i)%pc)) val = val + prec%blocks(i)%pc%get_nzeros() end do end if end function psb_d_nested_get_nzeros ! Clone nested preconditioner configuration and any built field blocks. subroutine psb_d_nested_clone(prec, precout, info) class(psb_d_nested_prec_type), intent(inout) :: prec class(psb_d_base_prec_type), allocatable, intent(inout) :: precout integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: i info = psb_success_ if (allocated(precout)) then call precout%free(info) if (info == psb_success_) deallocate(precout, stat=info) if (info /= psb_success_) return end if allocate(psb_d_nested_prec_type :: precout, stat=info) if (info /= 0) return select type (pout => precout) type is (psb_d_nested_prec_type) call pout%set_ctxt(prec%get_ctxt()) pout%composition = prec%composition pout%composition_name = prec%composition_name pout%default_block_ptype = prec%default_block_ptype pout%schur_solve = prec%schur_solve pout%schur_solve_name = prec%schur_solve_name pout%schur_maxit = prec%schur_maxit pout%schur_tol = prec%schur_tol pout%default_krylov = prec%default_krylov pout%nfields = prec%nfields pout%nest_op => prec%nest_op if (allocated(prec%field_block_ptype)) then allocate(pout%field_block_ptype(size(prec%field_block_ptype)), stat=info) if (info /= 0) return pout%field_block_ptype(:) = prec%field_block_ptype(:) end if if (allocated(prec%field_krylov)) then allocate(pout%field_krylov(size(prec%field_krylov)), stat=info) if (info /= 0) return pout%field_krylov(:) = prec%field_krylov(:) end if if (allocated(prec%field_iopts)) then allocate(pout%field_iopts(size(prec%field_iopts)), stat=info) if (info /= 0) return pout%field_iopts(:) = prec%field_iopts(:) end if if (allocated(prec%field_ropts)) then allocate(pout%field_ropts(size(prec%field_ropts)), stat=info) if (info /= 0) return pout%field_ropts(:) = prec%field_ropts(:) end if if (allocated(prec%field_copts)) then allocate(pout%field_copts(size(prec%field_copts)), stat=info) if (info /= 0) return pout%field_copts(:) = prec%field_copts(:) end if if (allocated(prec%blocks)) then allocate(pout%blocks(size(prec%blocks)), stat=info) if (info /= 0) return do i = 1, size(prec%blocks) pout%blocks(i)%ptype = prec%blocks(i)%ptype if (allocated(prec%blocks(i)%pc)) & & call prec%blocks(i)%pc%clone(pout%blocks(i)%pc, info) if (info /= psb_success_) return end do end if end select end subroutine psb_d_nested_clone end module psb_d_nestedprec