mirror of
https://github.com/sfilippone/amg4psblas.git
synced 2026-10-06 22:55:12 +00:00
Methods clear_data and clone_settings for MUMPS solver
This commit is contained in:
Salvatore Filippone
+310
-227
@@ -88,6 +88,8 @@ module mld_c_mumps_solver
|
||||
procedure, pass(sv) :: build => c_mumps_solver_bld
|
||||
procedure, pass(sv) :: apply_a => c_mumps_solver_apply
|
||||
procedure, pass(sv) :: apply_v => c_mumps_solver_apply_vect
|
||||
procedure, pass(sv) :: clone_settings => c_mumps_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => c_mumps_solver_clear_data
|
||||
procedure, pass(sv) :: free => c_mumps_solver_free
|
||||
procedure, pass(sv) :: descr => c_mumps_solver_descr
|
||||
procedure, pass(sv) :: sizeof => c_mumps_solver_sizeof
|
||||
@@ -108,8 +110,9 @@ module mld_c_mumps_solver
|
||||
& c_mumps_solver_free, c_mumps_solver_descr, &
|
||||
& c_mumps_solver_sizeof, c_mumps_solver_apply_vect,&
|
||||
& c_mumps_solver_cseti, c_mumps_solver_csetr, &
|
||||
& c_mumps_solver_csetc, &
|
||||
& c_mumps_solver_csetc, c_mumps_solver_clear_data, &
|
||||
& c_mumps_solver_default, c_mumps_solver_get_fmt, &
|
||||
& c_mumps_solver_clone_settings, &
|
||||
& c_mumps_solver_get_id, c_mumps_solver_is_global
|
||||
#if defined(HAVE_FINAL)
|
||||
private :: c_mumps_solver_finalize
|
||||
@@ -176,6 +179,98 @@ module mld_c_mumps_solver
|
||||
|
||||
contains
|
||||
|
||||
subroutine c_mumps_solver_clone_settings(sv,svout,info)
|
||||
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
class(mld_c_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: k,err_act
|
||||
character(len=20) :: name='c_mumps_solver_clone_settings'
|
||||
|
||||
info = 0
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select type(svout)
|
||||
class is(mld_c_mumps_solver_type)
|
||||
svout%ipar(:) = sv%ipar(:)
|
||||
svout%built = .false.
|
||||
if (allocated(svout%icntl)) deallocate(svout%icntl,stat=info)
|
||||
if (info == 0) allocate(svout%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_icntl_size
|
||||
call psb_safe_ab_cpy(sv%icntl(k)%item,svout%icntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (allocated(svout%rcntl)) deallocate(svout%rcntl,stat=info)
|
||||
if (info == 0) allocate(svout%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_rcntl_size
|
||||
call psb_safe_ab_cpy(sv%rcntl(k)%item,svout%rcntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
#endif
|
||||
end subroutine c_mumps_solver_clone_settings
|
||||
|
||||
subroutine c_mumps_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_clear_data'
|
||||
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call psb_erractionsave(err_act)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call cmumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, stat=info)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
#endif
|
||||
end subroutine c_mumps_solver_clear_data
|
||||
|
||||
subroutine c_mumps_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
@@ -186,28 +281,16 @@ contains
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call cmumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, sv%icntl, sv%rcntl)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
if (allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if (allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionsave(err_act)
|
||||
call sv%clear_data(info)
|
||||
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if ((info == 0).and.allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
@@ -219,295 +302,295 @@ contains
|
||||
end subroutine c_mumps_solver_free
|
||||
|
||||
#if defined(HAVE_FINAL)
|
||||
subroutine c_mumps_solver_finalize(sv)
|
||||
subroutine c_mumps_solver_finalize(sv)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_finalize'
|
||||
! Arguments
|
||||
type(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_finalize'
|
||||
|
||||
call sv%free(info)
|
||||
call sv%free(info)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine c_mumps_solver_finalize
|
||||
end subroutine c_mumps_solver_finalize
|
||||
#endif
|
||||
|
||||
subroutine c_mumps_solver_descr(sv,info,iout,coarse)
|
||||
subroutine c_mumps_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine c_mumps_solver_descr
|
||||
end if
|
||||
return
|
||||
end subroutine c_mumps_solver_descr
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!! WARNING: OTHER PARAMETERS OF MUMPS COULD BE ADDED. !!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
subroutine c_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
subroutine c_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_csetc'
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine c_mumps_solver_csetc
|
||||
end if
|
||||
return
|
||||
end subroutine c_mumps_solver_csetc
|
||||
|
||||
|
||||
subroutine c_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
subroutine c_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_cseti'
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine c_mumps_solver_cseti
|
||||
end if
|
||||
return
|
||||
end subroutine c_mumps_solver_cseti
|
||||
|
||||
subroutine c_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
subroutine c_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_csetr'
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_mumps_solver_csetr'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine c_mumps_solver_csetr
|
||||
end if
|
||||
return
|
||||
end subroutine c_mumps_solver_csetr
|
||||
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine c_mumps_solver_default(sv)
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine c_mumps_solver_default(sv)
|
||||
|
||||
Implicit none
|
||||
Implicit none
|
||||
|
||||
!Argument
|
||||
class(mld_c_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='c_mumps_default'
|
||||
!Argument
|
||||
class(mld_c_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='c_mumps_default'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_cmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_cmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_cmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_cmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_cmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_cmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
|
||||
#endif
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine c_mumps_solver_default
|
||||
end subroutine c_mumps_solver_default
|
||||
|
||||
function c_mumps_solver_sizeof(sv) result(val)
|
||||
function c_mumps_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_c_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
#if defined(HAVE_MUMPS_)
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
#else
|
||||
val = 0
|
||||
val = 0
|
||||
#endif
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function c_mumps_solver_sizeof
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function c_mumps_solver_sizeof
|
||||
|
||||
function c_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
function c_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "MUMPS solver"
|
||||
end function c_mumps_solver_get_fmt
|
||||
val = "MUMPS solver"
|
||||
end function c_mumps_solver_get_fmt
|
||||
|
||||
function c_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
function c_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = mld_mumps_
|
||||
end function c_mumps_solver_get_id
|
||||
val = mld_mumps_
|
||||
end function c_mumps_solver_get_id
|
||||
|
||||
|
||||
function c_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_c_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
function c_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_c_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function c_mumps_solver_is_global
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function c_mumps_solver_is_global
|
||||
|
||||
end module mld_c_mumps_solver
|
||||
|
||||
|
||||
+310
-227
@@ -88,6 +88,8 @@ module mld_d_mumps_solver
|
||||
procedure, pass(sv) :: build => d_mumps_solver_bld
|
||||
procedure, pass(sv) :: apply_a => d_mumps_solver_apply
|
||||
procedure, pass(sv) :: apply_v => d_mumps_solver_apply_vect
|
||||
procedure, pass(sv) :: clone_settings => d_mumps_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => d_mumps_solver_clear_data
|
||||
procedure, pass(sv) :: free => d_mumps_solver_free
|
||||
procedure, pass(sv) :: descr => d_mumps_solver_descr
|
||||
procedure, pass(sv) :: sizeof => d_mumps_solver_sizeof
|
||||
@@ -108,8 +110,9 @@ module mld_d_mumps_solver
|
||||
& d_mumps_solver_free, d_mumps_solver_descr, &
|
||||
& d_mumps_solver_sizeof, d_mumps_solver_apply_vect,&
|
||||
& d_mumps_solver_cseti, d_mumps_solver_csetr, &
|
||||
& d_mumps_solver_csetc, &
|
||||
& d_mumps_solver_csetc, d_mumps_solver_clear_data, &
|
||||
& d_mumps_solver_default, d_mumps_solver_get_fmt, &
|
||||
& d_mumps_solver_clone_settings, &
|
||||
& d_mumps_solver_get_id, d_mumps_solver_is_global
|
||||
#if defined(HAVE_FINAL)
|
||||
private :: d_mumps_solver_finalize
|
||||
@@ -176,6 +179,98 @@ module mld_d_mumps_solver
|
||||
|
||||
contains
|
||||
|
||||
subroutine d_mumps_solver_clone_settings(sv,svout,info)
|
||||
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
class(mld_d_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: k,err_act
|
||||
character(len=20) :: name='d_mumps_solver_clone_settings'
|
||||
|
||||
info = 0
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select type(svout)
|
||||
class is(mld_d_mumps_solver_type)
|
||||
svout%ipar(:) = sv%ipar(:)
|
||||
svout%built = .false.
|
||||
if (allocated(svout%icntl)) deallocate(svout%icntl,stat=info)
|
||||
if (info == 0) allocate(svout%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_icntl_size
|
||||
call psb_safe_ab_cpy(sv%icntl(k)%item,svout%icntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (allocated(svout%rcntl)) deallocate(svout%rcntl,stat=info)
|
||||
if (info == 0) allocate(svout%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_rcntl_size
|
||||
call psb_safe_ab_cpy(sv%rcntl(k)%item,svout%rcntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
#endif
|
||||
end subroutine d_mumps_solver_clone_settings
|
||||
|
||||
subroutine d_mumps_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_clear_data'
|
||||
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call psb_erractionsave(err_act)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call dmumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, stat=info)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
#endif
|
||||
end subroutine d_mumps_solver_clear_data
|
||||
|
||||
subroutine d_mumps_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
@@ -186,28 +281,16 @@ contains
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call dmumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, sv%icntl, sv%rcntl)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
if (allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if (allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionsave(err_act)
|
||||
call sv%clear_data(info)
|
||||
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if ((info == 0).and.allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
@@ -219,295 +302,295 @@ contains
|
||||
end subroutine d_mumps_solver_free
|
||||
|
||||
#if defined(HAVE_FINAL)
|
||||
subroutine d_mumps_solver_finalize(sv)
|
||||
subroutine d_mumps_solver_finalize(sv)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_finalize'
|
||||
! Arguments
|
||||
type(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_finalize'
|
||||
|
||||
call sv%free(info)
|
||||
call sv%free(info)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine d_mumps_solver_finalize
|
||||
end subroutine d_mumps_solver_finalize
|
||||
#endif
|
||||
|
||||
subroutine d_mumps_solver_descr(sv,info,iout,coarse)
|
||||
subroutine d_mumps_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine d_mumps_solver_descr
|
||||
end if
|
||||
return
|
||||
end subroutine d_mumps_solver_descr
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!! WARNING: OTHER PARAMETERS OF MUMPS COULD BE ADDED. !!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
subroutine d_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
subroutine d_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_csetc'
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine d_mumps_solver_csetc
|
||||
end if
|
||||
return
|
||||
end subroutine d_mumps_solver_csetc
|
||||
|
||||
|
||||
subroutine d_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
subroutine d_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_cseti'
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine d_mumps_solver_cseti
|
||||
end if
|
||||
return
|
||||
end subroutine d_mumps_solver_cseti
|
||||
|
||||
subroutine d_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
subroutine d_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_csetr'
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_mumps_solver_csetr'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine d_mumps_solver_csetr
|
||||
end if
|
||||
return
|
||||
end subroutine d_mumps_solver_csetr
|
||||
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine d_mumps_solver_default(sv)
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine d_mumps_solver_default(sv)
|
||||
|
||||
Implicit none
|
||||
Implicit none
|
||||
|
||||
!Argument
|
||||
class(mld_d_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='d_mumps_default'
|
||||
!Argument
|
||||
class(mld_d_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='d_mumps_default'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_dmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_dmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_dmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_dmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_dmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_dmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
|
||||
#endif
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine d_mumps_solver_default
|
||||
end subroutine d_mumps_solver_default
|
||||
|
||||
function d_mumps_solver_sizeof(sv) result(val)
|
||||
function d_mumps_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_d_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
#if defined(HAVE_MUMPS_)
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
#else
|
||||
val = 0
|
||||
val = 0
|
||||
#endif
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function d_mumps_solver_sizeof
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function d_mumps_solver_sizeof
|
||||
|
||||
function d_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
function d_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "MUMPS solver"
|
||||
end function d_mumps_solver_get_fmt
|
||||
val = "MUMPS solver"
|
||||
end function d_mumps_solver_get_fmt
|
||||
|
||||
function d_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
function d_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = mld_mumps_
|
||||
end function d_mumps_solver_get_id
|
||||
val = mld_mumps_
|
||||
end function d_mumps_solver_get_id
|
||||
|
||||
|
||||
function d_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_d_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
function d_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_d_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function d_mumps_solver_is_global
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function d_mumps_solver_is_global
|
||||
|
||||
end module mld_d_mumps_solver
|
||||
|
||||
|
||||
+310
-227
@@ -88,6 +88,8 @@ module mld_s_mumps_solver
|
||||
procedure, pass(sv) :: build => s_mumps_solver_bld
|
||||
procedure, pass(sv) :: apply_a => s_mumps_solver_apply
|
||||
procedure, pass(sv) :: apply_v => s_mumps_solver_apply_vect
|
||||
procedure, pass(sv) :: clone_settings => s_mumps_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => s_mumps_solver_clear_data
|
||||
procedure, pass(sv) :: free => s_mumps_solver_free
|
||||
procedure, pass(sv) :: descr => s_mumps_solver_descr
|
||||
procedure, pass(sv) :: sizeof => s_mumps_solver_sizeof
|
||||
@@ -108,8 +110,9 @@ module mld_s_mumps_solver
|
||||
& s_mumps_solver_free, s_mumps_solver_descr, &
|
||||
& s_mumps_solver_sizeof, s_mumps_solver_apply_vect,&
|
||||
& s_mumps_solver_cseti, s_mumps_solver_csetr, &
|
||||
& s_mumps_solver_csetc, &
|
||||
& s_mumps_solver_csetc, s_mumps_solver_clear_data, &
|
||||
& s_mumps_solver_default, s_mumps_solver_get_fmt, &
|
||||
& s_mumps_solver_clone_settings, &
|
||||
& s_mumps_solver_get_id, s_mumps_solver_is_global
|
||||
#if defined(HAVE_FINAL)
|
||||
private :: s_mumps_solver_finalize
|
||||
@@ -176,6 +179,98 @@ module mld_s_mumps_solver
|
||||
|
||||
contains
|
||||
|
||||
subroutine s_mumps_solver_clone_settings(sv,svout,info)
|
||||
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
class(mld_s_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: k,err_act
|
||||
character(len=20) :: name='s_mumps_solver_clone_settings'
|
||||
|
||||
info = 0
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select type(svout)
|
||||
class is(mld_s_mumps_solver_type)
|
||||
svout%ipar(:) = sv%ipar(:)
|
||||
svout%built = .false.
|
||||
if (allocated(svout%icntl)) deallocate(svout%icntl,stat=info)
|
||||
if (info == 0) allocate(svout%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_icntl_size
|
||||
call psb_safe_ab_cpy(sv%icntl(k)%item,svout%icntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (allocated(svout%rcntl)) deallocate(svout%rcntl,stat=info)
|
||||
if (info == 0) allocate(svout%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_rcntl_size
|
||||
call psb_safe_ab_cpy(sv%rcntl(k)%item,svout%rcntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
#endif
|
||||
end subroutine s_mumps_solver_clone_settings
|
||||
|
||||
subroutine s_mumps_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_clear_data'
|
||||
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call psb_erractionsave(err_act)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call smumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, stat=info)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
#endif
|
||||
end subroutine s_mumps_solver_clear_data
|
||||
|
||||
subroutine s_mumps_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
@@ -186,28 +281,16 @@ contains
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call smumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, sv%icntl, sv%rcntl)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
if (allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if (allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionsave(err_act)
|
||||
call sv%clear_data(info)
|
||||
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if ((info == 0).and.allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
@@ -219,295 +302,295 @@ contains
|
||||
end subroutine s_mumps_solver_free
|
||||
|
||||
#if defined(HAVE_FINAL)
|
||||
subroutine s_mumps_solver_finalize(sv)
|
||||
subroutine s_mumps_solver_finalize(sv)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_finalize'
|
||||
! Arguments
|
||||
type(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_finalize'
|
||||
|
||||
call sv%free(info)
|
||||
call sv%free(info)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine s_mumps_solver_finalize
|
||||
end subroutine s_mumps_solver_finalize
|
||||
#endif
|
||||
|
||||
subroutine s_mumps_solver_descr(sv,info,iout,coarse)
|
||||
subroutine s_mumps_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine s_mumps_solver_descr
|
||||
end if
|
||||
return
|
||||
end subroutine s_mumps_solver_descr
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!! WARNING: OTHER PARAMETERS OF MUMPS COULD BE ADDED. !!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
subroutine s_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
subroutine s_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_csetc'
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine s_mumps_solver_csetc
|
||||
end if
|
||||
return
|
||||
end subroutine s_mumps_solver_csetc
|
||||
|
||||
|
||||
subroutine s_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
subroutine s_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_cseti'
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine s_mumps_solver_cseti
|
||||
end if
|
||||
return
|
||||
end subroutine s_mumps_solver_cseti
|
||||
|
||||
subroutine s_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
subroutine s_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_csetr'
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_mumps_solver_csetr'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine s_mumps_solver_csetr
|
||||
end if
|
||||
return
|
||||
end subroutine s_mumps_solver_csetr
|
||||
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine s_mumps_solver_default(sv)
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine s_mumps_solver_default(sv)
|
||||
|
||||
Implicit none
|
||||
Implicit none
|
||||
|
||||
!Argument
|
||||
class(mld_s_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='s_mumps_default'
|
||||
!Argument
|
||||
class(mld_s_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='s_mumps_default'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_smumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_smumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_smumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_smumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_smumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_smumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
|
||||
#endif
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine s_mumps_solver_default
|
||||
end subroutine s_mumps_solver_default
|
||||
|
||||
function s_mumps_solver_sizeof(sv) result(val)
|
||||
function s_mumps_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_s_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
#if defined(HAVE_MUMPS_)
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
#else
|
||||
val = 0
|
||||
val = 0
|
||||
#endif
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function s_mumps_solver_sizeof
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function s_mumps_solver_sizeof
|
||||
|
||||
function s_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
function s_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "MUMPS solver"
|
||||
end function s_mumps_solver_get_fmt
|
||||
val = "MUMPS solver"
|
||||
end function s_mumps_solver_get_fmt
|
||||
|
||||
function s_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
function s_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = mld_mumps_
|
||||
end function s_mumps_solver_get_id
|
||||
val = mld_mumps_
|
||||
end function s_mumps_solver_get_id
|
||||
|
||||
|
||||
function s_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_s_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
function s_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_s_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function s_mumps_solver_is_global
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function s_mumps_solver_is_global
|
||||
|
||||
end module mld_s_mumps_solver
|
||||
|
||||
|
||||
+310
-227
@@ -88,6 +88,8 @@ module mld_z_mumps_solver
|
||||
procedure, pass(sv) :: build => z_mumps_solver_bld
|
||||
procedure, pass(sv) :: apply_a => z_mumps_solver_apply
|
||||
procedure, pass(sv) :: apply_v => z_mumps_solver_apply_vect
|
||||
procedure, pass(sv) :: clone_settings => z_mumps_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => z_mumps_solver_clear_data
|
||||
procedure, pass(sv) :: free => z_mumps_solver_free
|
||||
procedure, pass(sv) :: descr => z_mumps_solver_descr
|
||||
procedure, pass(sv) :: sizeof => z_mumps_solver_sizeof
|
||||
@@ -108,8 +110,9 @@ module mld_z_mumps_solver
|
||||
& z_mumps_solver_free, z_mumps_solver_descr, &
|
||||
& z_mumps_solver_sizeof, z_mumps_solver_apply_vect,&
|
||||
& z_mumps_solver_cseti, z_mumps_solver_csetr, &
|
||||
& z_mumps_solver_csetc, &
|
||||
& z_mumps_solver_csetc, z_mumps_solver_clear_data, &
|
||||
& z_mumps_solver_default, z_mumps_solver_get_fmt, &
|
||||
& z_mumps_solver_clone_settings, &
|
||||
& z_mumps_solver_get_id, z_mumps_solver_is_global
|
||||
#if defined(HAVE_FINAL)
|
||||
private :: z_mumps_solver_finalize
|
||||
@@ -176,6 +179,98 @@ module mld_z_mumps_solver
|
||||
|
||||
contains
|
||||
|
||||
subroutine z_mumps_solver_clone_settings(sv,svout,info)
|
||||
|
||||
use psb_base_mod
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
class(mld_z_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: k,err_act
|
||||
character(len=20) :: name='z_mumps_solver_clone_settings'
|
||||
|
||||
info = 0
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select type(svout)
|
||||
class is(mld_z_mumps_solver_type)
|
||||
svout%ipar(:) = sv%ipar(:)
|
||||
svout%built = .false.
|
||||
if (allocated(svout%icntl)) deallocate(svout%icntl,stat=info)
|
||||
if (info == 0) allocate(svout%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_icntl_size
|
||||
call psb_safe_ab_cpy(sv%icntl(k)%item,svout%icntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
if (allocated(svout%rcntl)) deallocate(svout%rcntl,stat=info)
|
||||
if (info == 0) allocate(svout%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info == 0) then
|
||||
do k=1,mld_mumps_rcntl_size
|
||||
call psb_safe_ab_cpy(sv%rcntl(k)%item,svout%rcntl(k)%item,info)
|
||||
end do
|
||||
end if
|
||||
|
||||
class default
|
||||
info = psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
#endif
|
||||
end subroutine z_mumps_solver_clone_settings
|
||||
|
||||
subroutine z_mumps_solver_clear_data(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_clear_data'
|
||||
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
call psb_erractionsave(err_act)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call zmumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, stat=info)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
#endif
|
||||
end subroutine z_mumps_solver_clear_data
|
||||
|
||||
subroutine z_mumps_solver_free(sv,info)
|
||||
use psb_base_mod, only : psb_exit
|
||||
Implicit None
|
||||
@@ -186,28 +281,16 @@ contains
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = 0
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (allocated(sv%id)) then
|
||||
if (sv%built) then
|
||||
sv%id%job = -2
|
||||
call zmumps(sv%id)
|
||||
info = sv%id%infog(1)
|
||||
if (info /= psb_success_) goto 9999
|
||||
end if
|
||||
deallocate(sv%id, sv%icntl, sv%rcntl)
|
||||
if (allocated(sv%local_ictxt)) then
|
||||
call psb_exit(sv%local_ictxt,close=.false.)
|
||||
deallocate(sv%local_ictxt,stat=info)
|
||||
end if
|
||||
if (allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if (allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
sv%built=.false.
|
||||
end if
|
||||
call psb_erractionsave(err_act)
|
||||
call sv%clear_data(info)
|
||||
if ((info == 0).and.allocated(sv%icntl)) deallocate(sv%icntl,stat=info)
|
||||
if ((info == 0).and.allocated(sv%rcntl)) deallocate(sv%rcntl,stat=info)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
@@ -219,295 +302,295 @@ contains
|
||||
end subroutine z_mumps_solver_free
|
||||
|
||||
#if defined(HAVE_FINAL)
|
||||
subroutine z_mumps_solver_finalize(sv)
|
||||
subroutine z_mumps_solver_finalize(sv)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
type(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_finalize'
|
||||
! Arguments
|
||||
type(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
Integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_finalize'
|
||||
|
||||
call sv%free(info)
|
||||
call sv%free(info)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
end subroutine z_mumps_solver_finalize
|
||||
end subroutine z_mumps_solver_finalize
|
||||
#endif
|
||||
|
||||
subroutine z_mumps_solver_descr(sv,info,iout,coarse)
|
||||
subroutine z_mumps_solver_descr(sv,info,iout,coarse)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
integer(psb_ipk_) :: ictxt, me, np
|
||||
character(len=20), parameter :: name='mld_z_mumps_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
write(iout_,*) ' MUMPS Solver. '
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine z_mumps_solver_descr
|
||||
end if
|
||||
return
|
||||
end subroutine z_mumps_solver_descr
|
||||
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!! WARNING: OTHER PARAMETERS OF MUMPS COULD BE ADDED. !!
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
subroutine z_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
subroutine z_mumps_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_csetc'
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
|
||||
select case(psb_toupper(trim(what)))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = sv%stringval(psb_toupper(trim(val)))
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine z_mumps_solver_csetc
|
||||
end if
|
||||
return
|
||||
end subroutine z_mumps_solver_csetc
|
||||
|
||||
|
||||
subroutine z_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
subroutine z_mumps_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_cseti'
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_LOC_GLOB')
|
||||
sv%ipar(1) = val
|
||||
case('MUMPS_PRINT_ERR')
|
||||
sv%ipar(2) = val
|
||||
case('MUMPS_SYM')
|
||||
sv%ipar(3) = val
|
||||
case('MUMPS_IPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%icntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine z_mumps_solver_cseti
|
||||
end if
|
||||
return
|
||||
end subroutine z_mumps_solver_cseti
|
||||
|
||||
subroutine z_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
subroutine z_mumps_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_csetr'
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_mumps_solver_csetr'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
select case(psb_toupper(what))
|
||||
#if defined(HAVE_MUMPS_)
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
case('MUMPS_RPAR_ENTRY')
|
||||
if(present(idx)) then
|
||||
! Note: this will allocate %item
|
||||
sv%rcntl(idx)%item = val
|
||||
end if
|
||||
#endif
|
||||
case default
|
||||
call sv%mld_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
case default
|
||||
call sv%mld_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end subroutine z_mumps_solver_csetr
|
||||
end if
|
||||
return
|
||||
end subroutine z_mumps_solver_csetr
|
||||
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine z_mumps_solver_default(sv)
|
||||
!!NOTE: BY DEFAULT BLR is activated with a dropping parameter to 1d-4 !!
|
||||
subroutine z_mumps_solver_default(sv)
|
||||
|
||||
Implicit none
|
||||
Implicit none
|
||||
|
||||
!Argument
|
||||
class(mld_z_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='z_mumps_default'
|
||||
!Argument
|
||||
class(mld_z_mumps_solver_type),intent(inout) :: sv
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_ipk_) :: err_act,ictx,icomm
|
||||
character(len=20) :: name='z_mumps_default'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
#if defined(HAVE_MUMPS_)
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_zmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
if (.not.allocated(sv%id)) then
|
||||
allocate(sv%id,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_zmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_zmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
sv%built=.false.
|
||||
end if
|
||||
if (.not.allocated(sv%icntl)) then
|
||||
allocate(sv%icntl(mld_mumps_icntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_zmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_zmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (.not.allocated(sv%rcntl)) then
|
||||
allocate(sv%rcntl(mld_mumps_rcntl_size),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name,a_err='mld_zmumps_default')
|
||||
goto 9999
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
end if
|
||||
! INSTANTIATION OF sv%id needed to set parmater but mpi communicator needed
|
||||
! sv%id%job = -1
|
||||
! sv%id%par=1
|
||||
! call dmumps(sv%id)
|
||||
sv%ipar = 0
|
||||
sv%ipar(1) = mld_global_solver_
|
||||
!sv%ipar(10)=6
|
||||
!sv%ipar(11)=0
|
||||
!sv%ipar(12)=6
|
||||
|
||||
#endif
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
call psb_erractionrestore(err_act)
|
||||
if (err_act == psb_act_abort_) then
|
||||
call psb_error()
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine z_mumps_solver_default
|
||||
end subroutine z_mumps_solver_default
|
||||
|
||||
function z_mumps_solver_sizeof(sv) result(val)
|
||||
function z_mumps_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
implicit none
|
||||
! Arguments
|
||||
class(mld_z_mumps_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer :: i
|
||||
#if defined(HAVE_MUMPS_)
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
val = (sv%id%INFOG(22)+sv%id%INFOG(32))*1d+6
|
||||
#else
|
||||
val = 0
|
||||
val = 0
|
||||
#endif
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function z_mumps_solver_sizeof
|
||||
! val = 2*psb_sizeof_ip + psb_sizeof_dp
|
||||
! val = val + sv%symbsize
|
||||
! val = val + sv%numsize
|
||||
return
|
||||
end function z_mumps_solver_sizeof
|
||||
|
||||
function z_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
function z_mumps_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "MUMPS solver"
|
||||
end function z_mumps_solver_get_fmt
|
||||
val = "MUMPS solver"
|
||||
end function z_mumps_solver_get_fmt
|
||||
|
||||
function z_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
function z_mumps_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = mld_mumps_
|
||||
end function z_mumps_solver_get_id
|
||||
val = mld_mumps_
|
||||
end function z_mumps_solver_get_id
|
||||
|
||||
|
||||
function z_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_z_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
function z_mumps_solver_is_global(sv) result(val)
|
||||
implicit none
|
||||
class(mld_z_mumps_solver_type), intent(in) :: sv
|
||||
logical :: val
|
||||
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function z_mumps_solver_is_global
|
||||
val = (sv%ipar(1) == mld_global_solver_ )
|
||||
end function z_mumps_solver_is_global
|
||||
|
||||
end module mld_z_mumps_solver
|
||||
|
||||
|
||||
Reference in New Issue
Block a user