diff --git a/mlprec/mld_c_mumps_solver.F90 b/mlprec/mld_c_mumps_solver.F90 index 0f5c339e..7fea8477 100644 --- a/mlprec/mld_c_mumps_solver.F90 +++ b/mlprec/mld_c_mumps_solver.F90 @@ -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,7 +179,59 @@ module mld_c_mumps_solver contains - subroutine c_mumps_solver_free(sv,info) + 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 @@ -184,10 +239,11 @@ contains 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_free' + character(len=20) :: name='c_mumps_solver_clear_data' - call psb_erractionsave(err_act) + info = 0 #if defined(HAVE_MUMPS_) + call psb_erractionsave(err_act) if (allocated(sv%id)) then if (sv%built) then sv%id%job = -2 @@ -195,14 +251,11 @@ contains info = sv%id%infog(1) if (info /= psb_success_) goto 9999 end if - deallocate(sv%id, sv%icntl, sv%rcntl) + 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 - 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_erractionrestore(err_act) @@ -216,298 +269,328 @@ contains end if return #endif - end subroutine c_mumps_solver_free - -#if defined(HAVE_FINAL) - subroutine c_mumps_solver_finalize(sv) + end subroutine c_mumps_solver_clear_data + subroutine c_mumps_solver_free(sv,info) + use psb_base_mod, only : psb_exit Implicit None ! Arguments - type(mld_c_mumps_solver_type), intent(inout) :: sv - integer(psb_ipk_) :: info + 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_finalize' + character(len=20) :: name='c_mumps_solver_free' - call sv%free(info) + info = 0 +#if defined(HAVE_MUMPS_) + 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 + call psb_error() + return + end if return +#endif + end subroutine c_mumps_solver_free + +#if defined(HAVE_FINAL) +subroutine c_mumps_solver_finalize(sv) + + 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' + + call sv%free(info) + + 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 diff --git a/mlprec/mld_d_mumps_solver.F90 b/mlprec/mld_d_mumps_solver.F90 index 8c081a85..62097154 100644 --- a/mlprec/mld_d_mumps_solver.F90 +++ b/mlprec/mld_d_mumps_solver.F90 @@ -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,7 +179,59 @@ module mld_d_mumps_solver contains - subroutine d_mumps_solver_free(sv,info) + 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 @@ -184,10 +239,11 @@ contains 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_free' + character(len=20) :: name='d_mumps_solver_clear_data' - call psb_erractionsave(err_act) + info = 0 #if defined(HAVE_MUMPS_) + call psb_erractionsave(err_act) if (allocated(sv%id)) then if (sv%built) then sv%id%job = -2 @@ -195,14 +251,11 @@ contains info = sv%id%infog(1) if (info /= psb_success_) goto 9999 end if - deallocate(sv%id, sv%icntl, sv%rcntl) + 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 - 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_erractionrestore(err_act) @@ -216,298 +269,328 @@ contains end if return #endif - end subroutine d_mumps_solver_free - -#if defined(HAVE_FINAL) - subroutine d_mumps_solver_finalize(sv) + end subroutine d_mumps_solver_clear_data + subroutine d_mumps_solver_free(sv,info) + use psb_base_mod, only : psb_exit Implicit None ! Arguments - type(mld_d_mumps_solver_type), intent(inout) :: sv - integer(psb_ipk_) :: info + 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_finalize' + character(len=20) :: name='d_mumps_solver_free' - call sv%free(info) + info = 0 +#if defined(HAVE_MUMPS_) + 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 + call psb_error() + return + end if return +#endif + end subroutine d_mumps_solver_free + +#if defined(HAVE_FINAL) +subroutine d_mumps_solver_finalize(sv) + + 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' + + call sv%free(info) + + 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 diff --git a/mlprec/mld_s_mumps_solver.F90 b/mlprec/mld_s_mumps_solver.F90 index 38fbc353..51b09abb 100644 --- a/mlprec/mld_s_mumps_solver.F90 +++ b/mlprec/mld_s_mumps_solver.F90 @@ -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,7 +179,59 @@ module mld_s_mumps_solver contains - subroutine s_mumps_solver_free(sv,info) + 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 @@ -184,10 +239,11 @@ contains 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_free' + character(len=20) :: name='s_mumps_solver_clear_data' - call psb_erractionsave(err_act) + info = 0 #if defined(HAVE_MUMPS_) + call psb_erractionsave(err_act) if (allocated(sv%id)) then if (sv%built) then sv%id%job = -2 @@ -195,14 +251,11 @@ contains info = sv%id%infog(1) if (info /= psb_success_) goto 9999 end if - deallocate(sv%id, sv%icntl, sv%rcntl) + 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 - 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_erractionrestore(err_act) @@ -216,298 +269,328 @@ contains end if return #endif - end subroutine s_mumps_solver_free - -#if defined(HAVE_FINAL) - subroutine s_mumps_solver_finalize(sv) + end subroutine s_mumps_solver_clear_data + subroutine s_mumps_solver_free(sv,info) + use psb_base_mod, only : psb_exit Implicit None ! Arguments - type(mld_s_mumps_solver_type), intent(inout) :: sv - integer(psb_ipk_) :: info + 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_finalize' + character(len=20) :: name='s_mumps_solver_free' - call sv%free(info) + info = 0 +#if defined(HAVE_MUMPS_) + 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 + call psb_error() + return + end if return +#endif + end subroutine s_mumps_solver_free + +#if defined(HAVE_FINAL) +subroutine s_mumps_solver_finalize(sv) + + 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' + + call sv%free(info) + + 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 diff --git a/mlprec/mld_z_mumps_solver.F90 b/mlprec/mld_z_mumps_solver.F90 index d5ce2fd5..af71fa2f 100644 --- a/mlprec/mld_z_mumps_solver.F90 +++ b/mlprec/mld_z_mumps_solver.F90 @@ -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,7 +179,59 @@ module mld_z_mumps_solver contains - subroutine z_mumps_solver_free(sv,info) + 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 @@ -184,10 +239,11 @@ contains 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_free' + character(len=20) :: name='z_mumps_solver_clear_data' - call psb_erractionsave(err_act) + info = 0 #if defined(HAVE_MUMPS_) + call psb_erractionsave(err_act) if (allocated(sv%id)) then if (sv%built) then sv%id%job = -2 @@ -195,14 +251,11 @@ contains info = sv%id%infog(1) if (info /= psb_success_) goto 9999 end if - deallocate(sv%id, sv%icntl, sv%rcntl) + 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 - 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_erractionrestore(err_act) @@ -216,298 +269,328 @@ contains end if return #endif - end subroutine z_mumps_solver_free - -#if defined(HAVE_FINAL) - subroutine z_mumps_solver_finalize(sv) + end subroutine z_mumps_solver_clear_data + subroutine z_mumps_solver_free(sv,info) + use psb_base_mod, only : psb_exit Implicit None ! Arguments - type(mld_z_mumps_solver_type), intent(inout) :: sv - integer(psb_ipk_) :: info + 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_finalize' + character(len=20) :: name='z_mumps_solver_free' - call sv%free(info) + info = 0 +#if defined(HAVE_MUMPS_) + 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 + call psb_error() + return + end if return +#endif + end subroutine z_mumps_solver_free + +#if defined(HAVE_FINAL) +subroutine z_mumps_solver_finalize(sv) + + 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' + + call sv%free(info) + + 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