fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Fix NEST SELFP Schur ownership and option propagation

Browse Source
nested_matrix_type
jalmerol 2 days ago
parent 6004643a7b
commit 9e77b53c06
1 changed files with 62 additions and 41 deletions
Show Stats Download Patch File Download Diff File

103
prec/psb_d_nestedprec.f90
Unescape Escape View File

@ -91,9 +91,6 @@ module psb_d_nestedprec
class(psb_d_base_prec_type), allocatable :: pc class(psb_d_base_prec_type), allocatable :: pc
end type psb_d_nested_block_prec end type psb_d_nested_block_prec
type(psb_dspmat_type), pointer, save :: selfp_schur_mat => null()
type(psb_d_nested_block_prec), pointer, save :: selfp_schur_block => null()
type :: psb_d_nested_krylov_context type :: psb_d_nested_krylov_context
logical :: enabled logical :: enabled
character(len=16) :: method character(len=16) :: method
@ -115,6 +112,8 @@ module psb_d_nestedprec
integer(psb_ipk_) :: nfields integer(psb_ipk_) :: nfields
type(psb_d_nest_base_mat), pointer :: nest_op type(psb_d_nest_base_mat), pointer :: nest_op
type(psb_d_nested_block_prec), allocatable :: blocks(:) type(psb_d_nested_block_prec), allocatable :: blocks(:)
type(psb_dspmat_type), pointer :: selfp_schur_mat => null()
type(psb_d_nested_block_prec), pointer :: selfp_schur_block => null()
logical :: schur_selfp_built logical :: schur_selfp_built
character(len=16), allocatable :: field_block_ptype(:) character(len=16), allocatable :: field_block_ptype(:)
type(psb_d_nested_krylov_context), allocatable :: field_krylov(:) type(psb_d_nested_krylov_context), allocatable :: field_krylov(:)
@ -162,6 +161,11 @@ contains
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
info = psb_success_ info = psb_success_
if (allocated(prec%blocks) .or. associated(prec%selfp_schur_mat) .or. &
& associated(prec%selfp_schur_block)) then
call psb_d_nested_clear_built(prec, info)
if (info /= psb_success_) return
end if
prec%composition = psb_d_nested_add_ prec%composition = psb_d_nested_add_
prec%composition_name = 'ADDITIVE' prec%composition_name = 'ADDITIVE'
prec%default_block_ptype = 'DIAG' prec%default_block_ptype = 'DIAG'
@ -202,22 +206,22 @@ contains
deallocate(prec%blocks, stat=local_info) deallocate(prec%blocks, stat=local_info)
if (local_info /= 0 .and. info == psb_success_) info = local_info if (local_info /= 0 .and. info == psb_success_) info = local_info
end if end if
if (associated(selfp_schur_block)) then if (associated(prec%selfp_schur_block)) then
if (allocated(selfp_schur_block%pc)) then if (allocated(prec%selfp_schur_block%pc)) then
call selfp_schur_block%pc%free(local_info) call prec%selfp_schur_block%pc%free(local_info)
if (local_info /= psb_success_ .and. info == psb_success_) info = local_info if (local_info /= psb_success_ .and. info == psb_success_) info = local_info
deallocate(selfp_schur_block%pc, stat=local_info) deallocate(prec%selfp_schur_block%pc, stat=local_info)
if (local_info /= 0 .and. info == psb_success_) info = local_info if (local_info /= 0 .and. info == psb_success_) info = local_info
end if end if
deallocate(selfp_schur_block, stat=local_info) deallocate(prec%selfp_schur_block, stat=local_info)
if (local_info /= 0 .and. info == psb_success_) info = local_info if (local_info /= 0 .and. info == psb_success_) info = local_info
nullify(selfp_schur_block) nullify(prec%selfp_schur_block)
end if end if
if (associated(selfp_schur_mat)) then if (associated(prec%selfp_schur_mat)) then
call selfp_schur_mat%free() call prec%selfp_schur_mat%free()
deallocate(selfp_schur_mat, stat=local_info) deallocate(prec%selfp_schur_mat, stat=local_info)
if (local_info /= 0 .and. info == psb_success_) info = local_info if (local_info /= 0 .and. info == psb_success_) info = local_info
nullify(selfp_schur_mat) nullify(prec%selfp_schur_mat)
end if end if
prec%schur_selfp_built = .false. prec%schur_selfp_built = .false.
prec%nfields = 0 prec%nfields = 0
@ -1472,13 +1476,13 @@ contains
integer(psb_ipk_) :: k integer(psb_ipk_) :: k
info = psb_success_ info = psb_success_
if (.not. associated(selfp_schur_block)) return if (.not. associated(prec%selfp_schur_block)) return
if (.not. allocated(selfp_schur_block%pc)) return if (.not. allocated(prec%selfp_schur_block%pc)) return
if (allocated(prec%field_iopts)) then if (allocated(prec%field_iopts)) then
do k = 1, size(prec%field_iopts) do k = 1, size(prec%field_iopts)
if ((prec%field_iopts(k)%field == 0) .or. (prec%field_iopts(k)%field == 2)) then if ((prec%field_iopts(k)%field == 0) .or. (prec%field_iopts(k)%field == 2)) then
call selfp_schur_block%pc%precset(prec%field_iopts(k)%what, & call prec%selfp_schur_block%pc%precset(prec%field_iopts(k)%what, &
& prec%field_iopts(k)%val, info) & prec%field_iopts(k)%val, info)
if (info /= psb_success_) return if (info /= psb_success_) return
end if end if
@ -1488,7 +1492,7 @@ contains
if (allocated(prec%field_ropts)) then if (allocated(prec%field_ropts)) then
do k = 1, size(prec%field_ropts) do k = 1, size(prec%field_ropts)
if ((prec%field_ropts(k)%field == 0) .or. (prec%field_ropts(k)%field == 2)) then if ((prec%field_ropts(k)%field == 0) .or. (prec%field_ropts(k)%field == 2)) then
call selfp_schur_block%pc%precset(prec%field_ropts(k)%what, & call prec%selfp_schur_block%pc%precset(prec%field_ropts(k)%what, &
& prec%field_ropts(k)%val, info) & prec%field_ropts(k)%val, info)
if (info /= psb_success_) return if (info /= psb_success_) return
end if end if
@ -1498,7 +1502,7 @@ contains
if (allocated(prec%field_copts)) then if (allocated(prec%field_copts)) then
do k = 1, size(prec%field_copts) do k = 1, size(prec%field_copts)
if ((prec%field_copts(k)%field == 0) .or. (prec%field_copts(k)%field == 2)) then if ((prec%field_copts(k)%field == 0) .or. (prec%field_copts(k)%field == 2)) then
call selfp_schur_block%pc%precset(prec%field_copts(k)%what, & call prec%selfp_schur_block%pc%precset(prec%field_copts(k)%what, &
& trim(prec%field_copts(k)%val), info) & trim(prec%field_copts(k)%val), info)
if (info /= psb_success_) return if (info /= psb_success_) return
end if end if
@ -1559,23 +1563,23 @@ contains
return return
end if end if
if (associated(selfp_schur_mat)) then if (associated(prec%selfp_schur_mat)) then
call selfp_schur_mat%free() call prec%selfp_schur_mat%free()
deallocate(selfp_schur_mat, stat=info) deallocate(prec%selfp_schur_mat, stat=info)
nullify(selfp_schur_mat) nullify(prec%selfp_schur_mat)
if (info /= 0) then if (info /= 0) then
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
call psb_errpush(info, 'd_nested_build_selfp', a_err='Schur matrix reset') call psb_errpush(info, 'd_nested_build_selfp', a_err='Schur matrix reset')
goto 100 goto 100
end if end if
end if end if
allocate(selfp_schur_mat, stat=info) allocate(prec%selfp_schur_mat, stat=info)
if (info /= 0) then if (info /= 0) then
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
call psb_errpush(info, 'd_nested_build_selfp', a_err='Schur matrix') call psb_errpush(info, 'd_nested_build_selfp', a_err='Schur matrix')
goto 100 goto 100
end if end if
call psb_spall(selfp_schur_mat, desc2, info) call psb_spall(prec%selfp_schur_mat, desc2, info)
if (info /= psb_success_) goto 100 if (info /= psb_success_) goto 100
do i = 1, n_owned_2 do i = 1, n_owned_2
@ -1621,41 +1625,42 @@ contains
end do end do
if (n_insert > 0) then if (n_insert > 0) then
call psb_spins(n_insert, rows(1:n_insert), cols(1:n_insert), vals(1:n_insert), & call psb_spins(n_insert, rows(1:n_insert), cols(1:n_insert), vals(1:n_insert), &
& selfp_schur_mat, desc2, info) & prec%selfp_schur_mat, desc2, info)
if (info /= psb_success_) exit if (info /= psb_success_) exit
end if end if
end do end do
if (info /= psb_success_) goto 100 if (info /= psb_success_) goto 100
call psb_spasb(selfp_schur_mat, desc2, info, dupl=psb_dupl_add_) call psb_spasb(prec%selfp_schur_mat, desc2, info, dupl=psb_dupl_add_)
if (info /= psb_success_) goto 100 if (info /= psb_success_) goto 100
call selfp_schur_mat%cscnv(info, type='CSR') call prec%selfp_schur_mat%cscnv(info, type='CSR')
if (info /= psb_success_) goto 100 if (info /= psb_success_) goto 100
if (associated(selfp_schur_block)) then if (associated(prec%selfp_schur_block)) then
if (allocated(selfp_schur_block%pc)) then if (allocated(prec%selfp_schur_block%pc)) then
call selfp_schur_block%pc%free(info) call prec%selfp_schur_block%pc%free(info)
if (info /= psb_success_) return if (info /= psb_success_) return
deallocate(selfp_schur_block%pc, stat=info) deallocate(prec%selfp_schur_block%pc, stat=info)
if (info /= psb_success_) return if (info /= psb_success_) return
end if end if
deallocate(selfp_schur_block, stat=info) deallocate(prec%selfp_schur_block, stat=info)
if (info /= psb_success_) return if (info /= psb_success_) return
nullify(selfp_schur_block) nullify(prec%selfp_schur_block)
end if end if
allocate(selfp_schur_block, stat=info) allocate(prec%selfp_schur_block, stat=info)
if (info /= 0) then if (info /= 0) then
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
call psb_errpush(info, 'd_nested_build_selfp', a_err='Schur block') call psb_errpush(info, 'd_nested_build_selfp', a_err='Schur block')
goto 100 goto 100
end if end if
selfp_schur_block%ptype = 'BJAC' prec%selfp_schur_block%ptype = 'BJAC'
call psb_d_nested_alloc_block_pc(selfp_schur_block, info) call psb_d_nested_alloc_block_pc(prec%selfp_schur_block, info)
if (info /= psb_success_) goto 100 if (info /= psb_success_) goto 100
call selfp_schur_block%pc%precinit(info) call prec%selfp_schur_block%pc%precinit(info)
if (info /= psb_success_) goto 100 if (info /= psb_success_) goto 100
call psb_d_nested_replay_schur_options(prec, info)
if (info /= psb_success_) goto 100 if (info /= psb_success_) goto 100
call selfp_schur_block%pc%precbld(selfp_schur_mat, desc2, info, & call prec%selfp_schur_block%pc%precbld(prec%selfp_schur_mat, desc2, info, &
& amold=amold, vmold=vmold, imold=imold) & amold=amold, vmold=vmold, imold=imold)
if (info == psb_success_) prec%schur_selfp_built = .true. if (info == psb_success_) prec%schur_selfp_built = .true.
@ -1695,8 +1700,8 @@ contains
call psb_d_nested_field_solve(prec, 2, rhs, sol, info) call psb_d_nested_field_solve(prec, 2, rhs, sol, info)
return return
else if (prec%schur_solve == psb_d_nested_schur_selfp_) then else if (prec%schur_solve == psb_d_nested_schur_selfp_) then
if (.not. prec%schur_selfp_built .or. (.not. associated(selfp_schur_block)) .or. & if (.not. prec%schur_selfp_built .or. (.not. associated(prec%selfp_schur_block)) .or. &
& (.not. allocated(selfp_schur_block%pc))) then & (.not. allocated(prec%selfp_schur_block%pc))) then
info = psb_err_invalid_mat_state_ info = psb_err_invalid_mat_state_
call psb_errpush(info, 'd_nested_schur_solve', a_err='SELFP not built') call psb_errpush(info, 'd_nested_schur_solve', a_err='SELFP not built')
return return
@ -1715,7 +1720,7 @@ contains
return return
end if end if
sol(:) = dzero sol(:) = dzero
call selfp_schur_block%pc%apply(done, rhs, dzero, sol, desc2, info, & call prec%selfp_schur_block%pc%apply(done, rhs, dzero, sol, desc2, info, &
& trans='N', work=dz) & trans='N', work=dz)
deallocate(dz) deallocate(dz)
return return
@ -2335,6 +2340,22 @@ contains
if (info /= psb_success_) return if (info /= psb_success_) return
end do end do
end if end if
pout%schur_selfp_built = .false.
if (prec%schur_selfp_built .and. associated(prec%selfp_schur_mat) .and. &
& associated(prec%selfp_schur_block)) then
allocate(pout%selfp_schur_mat, stat=info)
if (info /= 0) return
call prec%selfp_schur_mat%clone(pout%selfp_schur_mat, info)
if (info /= psb_success_) return
allocate(pout%selfp_schur_block, stat=info)
if (info /= 0) return
pout%selfp_schur_block%ptype = prec%selfp_schur_block%ptype
if (allocated(prec%selfp_schur_block%pc)) then
call prec%selfp_schur_block%pc%clone(pout%selfp_schur_block%pc, info)
if (info /= psb_success_) return
end if
pout%schur_selfp_built = allocated(pout%selfp_schur_block%pc)
end if
end select end select
end subroutine psb_d_nested_clone end subroutine psb_d_nested_clone

Write Preview
Loading…
Cancel
Save