mld2p4-2:

mlprec/impl/mld_cmlprec_bld.f90
 mlprec/impl/mld_dmlprec_bld.f90
 mlprec/impl/mld_smlprec_bld.f90
 mlprec/impl/mld_zmlprec_bld.f90
 mlprec/mld_c_onelev_mod.f90
 mlprec/mld_c_prec_type.f90
 mlprec/mld_d_onelev_mod.f90
 mlprec/mld_d_prec_type.f90
 mlprec/mld_s_onelev_mod.f90
 mlprec/mld_s_prec_type.f90
 mlprec/mld_z_onelev_mod.f90
 mlprec/mld_z_prec_type.f90
 tests/pdegen/runs/ppde.inp

Take out mld_move_alloc, transform it into method(s).
stopcriterion
Salvatore Filippone 9 years ago
parent 5224097818
commit 81a3e58358

@ -293,7 +293,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
! First do a move_alloc.
! This handles the AC, DESC_AC and MAP fields
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
& call current%item%move_alloc(p%precv(i),info)
! Now set the smoother/solver parts.
if (info == psb_success_) then
if (i ==1) then
@ -422,13 +422,13 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
do i=1,newsz-1
call mld_move_alloc(p%precv(i),t_prec%precv(i),info)
call p%precv(i)%move_alloc(t_prec%precv(i),info)
end do
call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info)
call p%precv(iszv)%move_alloc(t_prec%precv(newsz),info)
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call mld_move_alloc(t_prec,p,info)
call t_prec%move_alloc(p,info)
! Ignore errors from transfer
info = psb_success_
!

@ -293,7 +293,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
! First do a move_alloc.
! This handles the AC, DESC_AC and MAP fields
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
& call current%item%move_alloc(p%precv(i),info)
! Now set the smoother/solver parts.
if (info == psb_success_) then
if (i ==1) then
@ -422,13 +422,13 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
do i=1,newsz-1
call mld_move_alloc(p%precv(i),t_prec%precv(i),info)
call p%precv(i)%move_alloc(t_prec%precv(i),info)
end do
call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info)
call p%precv(iszv)%move_alloc(t_prec%precv(newsz),info)
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call mld_move_alloc(t_prec,p,info)
call t_prec%move_alloc(p,info)
! Ignore errors from transfer
info = psb_success_
!

@ -293,7 +293,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold)
! First do a move_alloc.
! This handles the AC, DESC_AC and MAP fields
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
& call current%item%move_alloc(p%precv(i),info)
! Now set the smoother/solver parts.
if (info == psb_success_) then
if (i ==1) then
@ -422,13 +422,13 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
do i=1,newsz-1
call mld_move_alloc(p%precv(i),t_prec%precv(i),info)
call p%precv(i)%move_alloc(t_prec%precv(i),info)
end do
call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info)
call p%precv(iszv)%move_alloc(t_prec%precv(newsz),info)
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call mld_move_alloc(t_prec,p,info)
call t_prec%move_alloc(p,info)
! Ignore errors from transfer
info = psb_success_
!

@ -293,7 +293,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
! First do a move_alloc.
! This handles the AC, DESC_AC and MAP fields
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
& call current%item%move_alloc(p%precv(i),info)
! Now set the smoother/solver parts.
if (info == psb_success_) then
if (i ==1) then
@ -422,13 +422,13 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold)
goto 9999
endif
do i=1,newsz-1
call mld_move_alloc(p%precv(i),t_prec%precv(i),info)
call p%precv(i)%move_alloc(t_prec%precv(i),info)
end do
call mld_move_alloc(p%precv(iszv),t_prec%precv(newsz),info)
call p%precv(iszv)%move_alloc(t_prec%precv(newsz),info)
do i=newsz+1, iszv
call p%precv(i)%free(info)
end do
call mld_move_alloc(t_prec,p,info)
call t_prec%move_alloc(p,info)
! Ignore errors from transfer
info = psb_success_
!

@ -152,6 +152,7 @@ module mld_c_onelev_mod
procedure, pass(lv) :: sizeof => c_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros
procedure, nopass :: stringval => mld_stringval
procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc
end type mld_c_onelev_type
type mld_c_onelev_node
@ -161,7 +162,7 @@ module mld_c_onelev_mod
private :: c_base_onelev_default, c_base_onelev_sizeof, &
& c_base_onelev_nullify, c_base_onelev_get_nzeros, &
& c_base_onelev_clone
& c_base_onelev_clone, c_base_onelev_move_alloc
@ -351,10 +352,6 @@ module mld_c_onelev_mod
end subroutine mld_c_base_onelev_dump
end interface
interface mld_move_alloc
module procedure mld_c_onelev_move_alloc
end interface
contains
!
! Function returning the size of the mld_prec_type data structure
@ -484,30 +481,30 @@ contains
end subroutine c_base_onelev_clone
subroutine mld_c_onelev_move_alloc(a, b,info)
subroutine c_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
type(mld_c_onelev_type), target, intent(inout) :: a, b
class(mld_c_onelev_type), target, intent(inout) :: lv, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
b%parms = a%parms
if (associated(a%sm2,a%sm2a)) then
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%parms = lv%parms
if (associated(lv%sm2,lv%sm2a)) then
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm2a
else
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm
end if
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
end subroutine mld_c_onelev_move_alloc
end subroutine c_base_onelev_move_alloc
end module mld_c_onelev_mod

@ -108,10 +108,11 @@ module mld_c_prec_type
& cseti, csetc, csetr, setsm, setsv
procedure, pass(prec) :: get_smoother => mld_c_get_smootherp
procedure, pass(prec) :: get_solver => mld_c_get_solverp
procedure, pass(prec) :: move_alloc => c_prec_move_alloc
end type mld_cprec_type
private :: mld_c_dump, mld_c_get_compl, mld_c_cmp_compl,&
& mld_c_get_nzeros
& mld_c_get_nzeros, c_prec_move_alloc
!
@ -255,11 +256,6 @@ module mld_c_prec_type
end subroutine mld_ccprecsetc
end interface
interface mld_move_alloc
module procedure mld_cprec_move_alloc
end interface
contains
!
! Function returning a pointer to the smoother
@ -812,31 +808,36 @@ contains
9999 continue
end subroutine mld_c_inner_clone
subroutine mld_cprec_move_alloc(a, b,info)
subroutine c_prec_move_alloc(prec, b,info)
use psb_base_mod
implicit none
type(mld_cprec_type), intent(inout) :: a
type(mld_cprec_type), intent(inout), target :: b
class(mld_cprec_type), intent(inout) :: prec
class(mld_cprec_type), intent(inout), target :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
if (same_type_as(prec,b)) then
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call b%free(info)
if (info /= psb_success_) then
!?????
!!$ return
endif
end if
call move_alloc(prec%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
else
write(0,*) 'Warning: PREC%move_alloc onto different type?'
info = psb_err_internal_error_
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_cprec_move_alloc
end subroutine c_prec_move_alloc
end module mld_c_prec_type

@ -152,6 +152,7 @@ module mld_d_onelev_mod
procedure, pass(lv) :: sizeof => d_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros
procedure, nopass :: stringval => mld_stringval
procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc
end type mld_d_onelev_type
type mld_d_onelev_node
@ -161,7 +162,7 @@ module mld_d_onelev_mod
private :: d_base_onelev_default, d_base_onelev_sizeof, &
& d_base_onelev_nullify, d_base_onelev_get_nzeros, &
& d_base_onelev_clone
& d_base_onelev_clone, d_base_onelev_move_alloc
@ -351,10 +352,6 @@ module mld_d_onelev_mod
end subroutine mld_d_base_onelev_dump
end interface
interface mld_move_alloc
module procedure mld_d_onelev_move_alloc
end interface
contains
!
! Function returning the size of the mld_prec_type data structure
@ -484,30 +481,30 @@ contains
end subroutine d_base_onelev_clone
subroutine mld_d_onelev_move_alloc(a, b,info)
subroutine d_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
type(mld_d_onelev_type), target, intent(inout) :: a, b
class(mld_d_onelev_type), target, intent(inout) :: lv, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
b%parms = a%parms
if (associated(a%sm2,a%sm2a)) then
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%parms = lv%parms
if (associated(lv%sm2,lv%sm2a)) then
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm2a
else
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm
end if
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
end subroutine mld_d_onelev_move_alloc
end subroutine d_base_onelev_move_alloc
end module mld_d_onelev_mod

@ -108,10 +108,11 @@ module mld_d_prec_type
& cseti, csetc, csetr, setsm, setsv
procedure, pass(prec) :: get_smoother => mld_d_get_smootherp
procedure, pass(prec) :: get_solver => mld_d_get_solverp
procedure, pass(prec) :: move_alloc => d_prec_move_alloc
end type mld_dprec_type
private :: mld_d_dump, mld_d_get_compl, mld_d_cmp_compl,&
& mld_d_get_nzeros
& mld_d_get_nzeros, d_prec_move_alloc
!
@ -255,11 +256,6 @@ module mld_d_prec_type
end subroutine mld_dcprecsetc
end interface
interface mld_move_alloc
module procedure mld_dprec_move_alloc
end interface
contains
!
! Function returning a pointer to the smoother
@ -812,31 +808,36 @@ contains
9999 continue
end subroutine mld_d_inner_clone
subroutine mld_dprec_move_alloc(a, b,info)
subroutine d_prec_move_alloc(prec, b,info)
use psb_base_mod
implicit none
type(mld_dprec_type), intent(inout) :: a
type(mld_dprec_type), intent(inout), target :: b
class(mld_dprec_type), intent(inout) :: prec
class(mld_dprec_type), intent(inout), target :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
if (same_type_as(prec,b)) then
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call b%free(info)
if (info /= psb_success_) then
!?????
!!$ return
endif
end if
call move_alloc(prec%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
else
write(0,*) 'Warning: PREC%move_alloc onto different type?'
info = psb_err_internal_error_
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_dprec_move_alloc
end subroutine d_prec_move_alloc
end module mld_d_prec_type

@ -152,6 +152,7 @@ module mld_s_onelev_mod
procedure, pass(lv) :: sizeof => s_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros
procedure, nopass :: stringval => mld_stringval
procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc
end type mld_s_onelev_type
type mld_s_onelev_node
@ -161,7 +162,7 @@ module mld_s_onelev_mod
private :: s_base_onelev_default, s_base_onelev_sizeof, &
& s_base_onelev_nullify, s_base_onelev_get_nzeros, &
& s_base_onelev_clone
& s_base_onelev_clone, s_base_onelev_move_alloc
@ -351,10 +352,6 @@ module mld_s_onelev_mod
end subroutine mld_s_base_onelev_dump
end interface
interface mld_move_alloc
module procedure mld_s_onelev_move_alloc
end interface
contains
!
! Function returning the size of the mld_prec_type data structure
@ -484,30 +481,30 @@ contains
end subroutine s_base_onelev_clone
subroutine mld_s_onelev_move_alloc(a, b,info)
subroutine s_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
type(mld_s_onelev_type), target, intent(inout) :: a, b
class(mld_s_onelev_type), target, intent(inout) :: lv, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
b%parms = a%parms
if (associated(a%sm2,a%sm2a)) then
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%parms = lv%parms
if (associated(lv%sm2,lv%sm2a)) then
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm2a
else
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm
end if
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
end subroutine mld_s_onelev_move_alloc
end subroutine s_base_onelev_move_alloc
end module mld_s_onelev_mod

@ -108,10 +108,11 @@ module mld_s_prec_type
& cseti, csetc, csetr, setsm, setsv
procedure, pass(prec) :: get_smoother => mld_s_get_smootherp
procedure, pass(prec) :: get_solver => mld_s_get_solverp
procedure, pass(prec) :: move_alloc => s_prec_move_alloc
end type mld_sprec_type
private :: mld_s_dump, mld_s_get_compl, mld_s_cmp_compl,&
& mld_s_get_nzeros
& mld_s_get_nzeros, s_prec_move_alloc
!
@ -255,11 +256,6 @@ module mld_s_prec_type
end subroutine mld_scprecsetc
end interface
interface mld_move_alloc
module procedure mld_sprec_move_alloc
end interface
contains
!
! Function returning a pointer to the smoother
@ -812,31 +808,36 @@ contains
9999 continue
end subroutine mld_s_inner_clone
subroutine mld_sprec_move_alloc(a, b,info)
subroutine s_prec_move_alloc(prec, b,info)
use psb_base_mod
implicit none
type(mld_sprec_type), intent(inout) :: a
type(mld_sprec_type), intent(inout), target :: b
class(mld_sprec_type), intent(inout) :: prec
class(mld_sprec_type), intent(inout), target :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
if (same_type_as(prec,b)) then
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call b%free(info)
if (info /= psb_success_) then
!?????
!!$ return
endif
end if
call move_alloc(prec%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
else
write(0,*) 'Warning: PREC%move_alloc onto different type?'
info = psb_err_internal_error_
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_sprec_move_alloc
end subroutine s_prec_move_alloc
end module mld_s_prec_type

@ -152,6 +152,7 @@ module mld_z_onelev_mod
procedure, pass(lv) :: sizeof => z_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros
procedure, nopass :: stringval => mld_stringval
procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc
end type mld_z_onelev_type
type mld_z_onelev_node
@ -161,7 +162,7 @@ module mld_z_onelev_mod
private :: z_base_onelev_default, z_base_onelev_sizeof, &
& z_base_onelev_nullify, z_base_onelev_get_nzeros, &
& z_base_onelev_clone
& z_base_onelev_clone, z_base_onelev_move_alloc
@ -351,10 +352,6 @@ module mld_z_onelev_mod
end subroutine mld_z_base_onelev_dump
end interface
interface mld_move_alloc
module procedure mld_z_onelev_move_alloc
end interface
contains
!
! Function returning the size of the mld_prec_type data structure
@ -484,30 +481,30 @@ contains
end subroutine z_base_onelev_clone
subroutine mld_z_onelev_move_alloc(a, b,info)
subroutine z_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
type(mld_z_onelev_type), target, intent(inout) :: a, b
class(mld_z_onelev_type), target, intent(inout) :: lv, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
b%parms = a%parms
if (associated(a%sm2,a%sm2a)) then
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
b%parms = lv%parms
if (associated(lv%sm2,lv%sm2a)) then
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm2a
else
call move_alloc(a%sm,b%sm)
call move_alloc(a%sm2a,b%sm2a)
call move_alloc(lv%sm,b%sm)
call move_alloc(lv%sm2a,b%sm2a)
b%sm2 =>b%sm
end if
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
if (info == psb_success_) call psb_move_alloc(lv%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(lv%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(lv%map,b%map,info)
b%base_a => lv%base_a
b%base_desc => lv%base_desc
end subroutine mld_z_onelev_move_alloc
end subroutine z_base_onelev_move_alloc
end module mld_z_onelev_mod

@ -108,10 +108,11 @@ module mld_z_prec_type
& cseti, csetc, csetr, setsm, setsv
procedure, pass(prec) :: get_smoother => mld_z_get_smootherp
procedure, pass(prec) :: get_solver => mld_z_get_solverp
procedure, pass(prec) :: move_alloc => z_prec_move_alloc
end type mld_zprec_type
private :: mld_z_dump, mld_z_get_compl, mld_z_cmp_compl,&
& mld_z_get_nzeros
& mld_z_get_nzeros, z_prec_move_alloc
!
@ -255,11 +256,6 @@ module mld_z_prec_type
end subroutine mld_zcprecsetc
end interface
interface mld_move_alloc
module procedure mld_zprec_move_alloc
end interface
contains
!
! Function returning a pointer to the smoother
@ -812,31 +808,36 @@ contains
9999 continue
end subroutine mld_z_inner_clone
subroutine mld_zprec_move_alloc(a, b,info)
subroutine z_prec_move_alloc(prec, b,info)
use psb_base_mod
implicit none
type(mld_zprec_type), intent(inout) :: a
type(mld_zprec_type), intent(inout), target :: b
class(mld_zprec_type), intent(inout) :: prec
class(mld_zprec_type), intent(inout), target :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
if (same_type_as(prec,b)) then
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call b%free(info)
if (info /= psb_success_) then
!?????
!!$ return
endif
end if
call move_alloc(prec%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
else
write(0,*) 'Warning: PREC%move_alloc onto different type?'
info = psb_err_internal_error_
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_zprec_move_alloc
end subroutine z_prec_move_alloc
end module mld_z_prec_type

@ -19,7 +19,7 @@ GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU GS M
BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML
2 ! Number of levels in a multilevel preconditioner
SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY
DEC ! Type of aggregation DEC SYMDEC GLB
SYMDEC ! Type of aggregation DEC SYMDEC
NATURAL ! Ordering of aggregation NATURAL DEGREE
MULT ! Type of multilevel correction: ADD MULT
TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD)

Loading…
Cancel
Save