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

Fixes for MUMPS used as local solver. Better interface for choosing

Browse Source 
same.
stopcriterion
Salvatore Filippone 6 years ago
parent acfe6c0295
commit ab387a1343
13 changed files with 641 additions and 541 deletions
Show Stats Download Patch File Download Diff File

21
mlprec/impl/solver/mld_c_mumps_solver_apply.F90
Unescape Escape View File

@ -82,6 +82,11 @@ subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
n_row = desc_data%get_local_rows() n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols() n_col = desc_data%get_local_cols()
! Running in local mode?
if (sv%ipar(1) == mld_local_solver_ ) then
gx = x
else if (sv%ipar(1) == mld_global_solver_ ) then
if (n_col <= size(work)) then if (n_col <= size(work)) then
ww = work(1:n_col) ww = work(1:n_col)
else else
@ -101,6 +106,13 @@ subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
end if end if
call psb_gather(gx, x, desc_data, info, root=0) call psb_gather(gx, x, desc_data, info, root=0)
else
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if
select case(trans_) select case(trans_)
case('N') case('N')
sv%id%icntl(9) = 1 sv%id%icntl(9) = 1
@ -120,11 +132,14 @@ subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
sv%id%icntl(4)=-1 sv%id%icntl(4)=-1
sv%id%job = 3 sv%id%job = 3
call cmumps(sv%id) call cmumps(sv%id)
if (sv%ipar(1) == mld_local_solver_ ) then
call psb_geaxpby(alpha,gx,beta,y,desc_data,info)
else
call psb_scatter(gx, ww, desc_data, info, root=0) call psb_scatter(gx, ww, desc_data, info, root=0)
if (info == psb_success_) then if (info == psb_success_) then
call psb_geaxpby(alpha,ww,beta,y,desc_data,info) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
end if end if
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,& call psb_errpush(psb_err_internal_error_,&
@ -132,9 +147,7 @@ subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
endif endif
if (nglob > size(work)) then if (allocated(ww)) deallocate(ww)
deallocate(ww)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

46
mlprec/impl/solver/mld_c_mumps_solver_bld.F90
Unescape Escape View File

@ -60,7 +60,7 @@
type(psb_c_coo_sparse_mat), target :: acoo type(psb_c_coo_sparse_mat), target :: acoo
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc
integer(psb_ipk_) :: ifrst, ibcheck integer(psb_ipk_) :: ifrst, ibcheck
integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, iam, me, i, err_act, debug_unit, debug_level
character(len=20) :: name='c_mumps_solver_bld', ch_err character(len=20) :: name='c_mumps_solver_bld', ch_err
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
@ -71,20 +71,26 @@
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
if (sv%ipar(1) < 0 ) then if (sv%ipar(1) == mld_local_solver_ ) then
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/me/)) call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/iam/))
call psb_get_mpicomm(ictxt1, icomm) call psb_get_mpicomm(ictxt1, icomm)
allocate(sv%local_ictxt,stat=info) allocate(sv%local_ictxt,stat=info)
sv%local_ictxt = ictxt1 sv%local_ictxt = ictxt1
write(*,*)'mumps_bld: +++++>',icomm,ictxt1 write(*,*)'mumps_bld: +++++>',icomm,sv%local_ictxt
call psb_info(ictxt1, me, np) call psb_info(ictxt1, me, np)
npr = np npr = np
else else if (sv%ipar(1) == mld_global_solver_ ) then
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
write(*,*)'mumps_bld: +++++>',icomm,ictxt write(*,*)'mumps_bld: +++++>',icomm,ictxt
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
me = iam
npr = np npr = np
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if end if
npc = 1 npc = 1
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -98,7 +104,7 @@
allocate(sv%id,stat=info) allocate(sv%id,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_dealloc_ info=psb_err_alloc_dealloc_
call psb_errpush(info,name,a_err='mld_cmumps_default') call psb_errpush(info,name,a_err='mld_dmumps_default')
goto 9999 goto 9999
end if end if
end if end if
@ -108,10 +114,13 @@
sv%id%job = -1 sv%id%job = -1
sv%id%par = 1 sv%id%par = 1
call cmumps(sv%id) call cmumps(sv%id)
!WARNING: CALLING cMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX !WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX
if (allocated(sv%icntl)) then if (allocated(sv%icntl)) then
do i=1,mld_mumps_icntl_size do i=1,mld_mumps_icntl_size
if (allocated(sv%icntl(i)%item)) sv%id%icntl(i) = sv%icntl(i)%item if (allocated(sv%icntl(i)%item)) then
!write(0,*) 'MUMPS_BLD: setting entry ',i,' to ', sv%icntl(i)%item
sv%id%icntl(i) = sv%icntl(i)%item
end if
end do end do
end if end if
if (allocated(sv%rcntl)) then if (allocated(sv%rcntl)) then
@ -122,13 +131,14 @@
sv%id%icntl(3)=sv%ipar(2) sv%id%icntl(3)=sv%ipar(2)
nglob = desc_a%get_global_rows() nglob = desc_a%get_global_rows()
if (sv%ipar(1) < 0) then if (sv%ipar(1) == mld_local_solver_ ) then
nglobrec=desc_a%get_local_rows() nglobrec=desc_a%get_local_rows()
call a%csclip(c,info,jmax=a%get_nrows()) call a%csclip(c,info,jmax=a%get_nrows())
call c%cp_to(acoo) call c%cp_to(acoo)
nglob = c%get_nrows() nglob = c%get_nrows()
if (nglobrec /= nglob) then if (nglobrec /= nglob) then
write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. A zero-overlap is used instead' write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. '
write(*,*)'A zero-overlap is used instead'
end if end if
else else
call a%cp_to(acoo) call a%cp_to(acoo)
@ -136,7 +146,7 @@
nztota = acoo%get_nzeros() nztota = acoo%get_nzeros()
! switch to global numbering ! switch to global numbering
if (sv%ipar(1) >= 0 ) then if (sv%ipar(1) == mld_global_solver_ ) then
call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I')
call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I')
end if end if
@ -155,13 +165,13 @@
sv%id%nz = acoo%get_nzeros() sv%id%nz = acoo%get_nzeros()
sv%id%job = 4 sv%id%job = 4
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
write(*,*)'calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc write(*,*)iam, ' calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc
call cmumps(sv%id) call dmumps(sv%id)
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
info = sv%id%infog(1) info = sv%id%infog(1)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mld_cmumps_fact ' ch_err='mld_dmumps_fact '
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -173,7 +183,7 @@
sv%built=.true. sv%built=.true.
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) iam,' ',trim(name),' end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -188,5 +198,5 @@
#else #else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif #endif
end subroutine c_mumps_solver_bld end subroutine c_mumps_solver_bld

21
mlprec/impl/solver/mld_d_mumps_solver_apply.F90
Unescape Escape View File

@ -82,6 +82,11 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
n_row = desc_data%get_local_rows() n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols() n_col = desc_data%get_local_cols()
! Running in local mode?
if (sv%ipar(1) == mld_local_solver_ ) then
gx = x
else if (sv%ipar(1) == mld_global_solver_ ) then
if (n_col <= size(work)) then if (n_col <= size(work)) then
ww = work(1:n_col) ww = work(1:n_col)
else else
@ -101,6 +106,13 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
end if end if
call psb_gather(gx, x, desc_data, info, root=0) call psb_gather(gx, x, desc_data, info, root=0)
else
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if
select case(trans_) select case(trans_)
case('N') case('N')
sv%id%icntl(9) = 1 sv%id%icntl(9) = 1
@ -120,11 +132,14 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
sv%id%icntl(4)=-1 sv%id%icntl(4)=-1
sv%id%job = 3 sv%id%job = 3
call dmumps(sv%id) call dmumps(sv%id)
if (sv%ipar(1) == mld_local_solver_ ) then
call psb_geaxpby(alpha,gx,beta,y,desc_data,info)
else
call psb_scatter(gx, ww, desc_data, info, root=0) call psb_scatter(gx, ww, desc_data, info, root=0)
if (info == psb_success_) then if (info == psb_success_) then
call psb_geaxpby(alpha,ww,beta,y,desc_data,info) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
end if end if
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,& call psb_errpush(psb_err_internal_error_,&
@ -132,9 +147,7 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
endif endif
if (nglob > size(work)) then if (allocated(ww)) deallocate(ww)
deallocate(ww)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

38
mlprec/impl/solver/mld_d_mumps_solver_bld.F90
Unescape Escape View File

@ -60,7 +60,7 @@
type(psb_d_coo_sparse_mat), target :: acoo type(psb_d_coo_sparse_mat), target :: acoo
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc
integer(psb_ipk_) :: ifrst, ibcheck integer(psb_ipk_) :: ifrst, ibcheck
integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, iam, me, i, err_act, debug_unit, debug_level
character(len=20) :: name='d_mumps_solver_bld', ch_err character(len=20) :: name='d_mumps_solver_bld', ch_err
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
@ -71,20 +71,26 @@
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
if (sv%ipar(1) < 0 ) then if (sv%ipar(1) == mld_local_solver_ ) then
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/me/)) call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/iam/))
call psb_get_mpicomm(ictxt1, icomm) call psb_get_mpicomm(ictxt1, icomm)
allocate(sv%local_ictxt,stat=info) allocate(sv%local_ictxt,stat=info)
sv%local_ictxt = ictxt1 sv%local_ictxt = ictxt1
write(*,*)'mumps_bld: +++++>',icomm,ictxt1 write(*,*)'mumps_bld: +++++>',icomm,sv%local_ictxt
call psb_info(ictxt1, me, np) call psb_info(ictxt1, me, np)
npr = np npr = np
else else if (sv%ipar(1) == mld_global_solver_ ) then
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
write(*,*)'mumps_bld: +++++>',icomm,ictxt write(*,*)'mumps_bld: +++++>',icomm,ictxt
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
me = iam
npr = np npr = np
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if end if
npc = 1 npc = 1
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -111,7 +117,10 @@
!WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX !WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX
if (allocated(sv%icntl)) then if (allocated(sv%icntl)) then
do i=1,mld_mumps_icntl_size do i=1,mld_mumps_icntl_size
if (allocated(sv%icntl(i)%item)) sv%id%icntl(i) = sv%icntl(i)%item if (allocated(sv%icntl(i)%item)) then
!write(0,*) 'MUMPS_BLD: setting entry ',i,' to ', sv%icntl(i)%item
sv%id%icntl(i) = sv%icntl(i)%item
end if
end do end do
end if end if
if (allocated(sv%rcntl)) then if (allocated(sv%rcntl)) then
@ -122,13 +131,14 @@
sv%id%icntl(3)=sv%ipar(2) sv%id%icntl(3)=sv%ipar(2)
nglob = desc_a%get_global_rows() nglob = desc_a%get_global_rows()
if (sv%ipar(1) < 0) then if (sv%ipar(1) == mld_local_solver_ ) then
nglobrec=desc_a%get_local_rows() nglobrec=desc_a%get_local_rows()
call a%csclip(c,info,jmax=a%get_nrows()) call a%csclip(c,info,jmax=a%get_nrows())
call c%cp_to(acoo) call c%cp_to(acoo)
nglob = c%get_nrows() nglob = c%get_nrows()
if (nglobrec /= nglob) then if (nglobrec /= nglob) then
write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. A zero-overlap is used instead' write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. '
write(*,*)'A zero-overlap is used instead'
end if end if
else else
call a%cp_to(acoo) call a%cp_to(acoo)
@ -136,7 +146,7 @@
nztota = acoo%get_nzeros() nztota = acoo%get_nzeros()
! switch to global numbering ! switch to global numbering
if (sv%ipar(1) >= 0 ) then if (sv%ipar(1) == mld_global_solver_ ) then
call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I')
call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I')
end if end if
@ -155,7 +165,7 @@
sv%id%nz = acoo%get_nzeros() sv%id%nz = acoo%get_nzeros()
sv%id%job = 4 sv%id%job = 4
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
write(*,*)'calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc write(*,*)iam, ' calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc
call dmumps(sv%id) call dmumps(sv%id)
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
info = sv%id%infog(1) info = sv%id%infog(1)
@ -173,7 +183,7 @@
sv%built=.true. sv%built=.true.
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) iam,' ',trim(name),' end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -188,5 +198,5 @@
#else #else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif #endif
end subroutine d_mumps_solver_bld end subroutine d_mumps_solver_bld

21
mlprec/impl/solver/mld_s_mumps_solver_apply.F90
Unescape Escape View File

@ -82,6 +82,11 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
n_row = desc_data%get_local_rows() n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols() n_col = desc_data%get_local_cols()
! Running in local mode?
if (sv%ipar(1) == mld_local_solver_ ) then
gx = x
else if (sv%ipar(1) == mld_global_solver_ ) then
if (n_col <= size(work)) then if (n_col <= size(work)) then
ww = work(1:n_col) ww = work(1:n_col)
else else
@ -101,6 +106,13 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
end if end if
call psb_gather(gx, x, desc_data, info, root=0) call psb_gather(gx, x, desc_data, info, root=0)
else
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if
select case(trans_) select case(trans_)
case('N') case('N')
sv%id%icntl(9) = 1 sv%id%icntl(9) = 1
@ -120,11 +132,14 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
sv%id%icntl(4)=-1 sv%id%icntl(4)=-1
sv%id%job = 3 sv%id%job = 3
call smumps(sv%id) call smumps(sv%id)
if (sv%ipar(1) == mld_local_solver_ ) then
call psb_geaxpby(alpha,gx,beta,y,desc_data,info)
else
call psb_scatter(gx, ww, desc_data, info, root=0) call psb_scatter(gx, ww, desc_data, info, root=0)
if (info == psb_success_) then if (info == psb_success_) then
call psb_geaxpby(alpha,ww,beta,y,desc_data,info) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
end if end if
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,& call psb_errpush(psb_err_internal_error_,&
@ -132,9 +147,7 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
endif endif
if (nglob > size(work)) then if (allocated(ww)) deallocate(ww)
deallocate(ww)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

46
mlprec/impl/solver/mld_s_mumps_solver_bld.F90
Unescape Escape View File

@ -60,7 +60,7 @@
type(psb_s_coo_sparse_mat), target :: acoo type(psb_s_coo_sparse_mat), target :: acoo
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc
integer(psb_ipk_) :: ifrst, ibcheck integer(psb_ipk_) :: ifrst, ibcheck
integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, iam, me, i, err_act, debug_unit, debug_level
character(len=20) :: name='s_mumps_solver_bld', ch_err character(len=20) :: name='s_mumps_solver_bld', ch_err
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
@ -71,20 +71,26 @@
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
if (sv%ipar(1) < 0 ) then if (sv%ipar(1) == mld_local_solver_ ) then
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/me/)) call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/iam/))
call psb_get_mpicomm(ictxt1, icomm) call psb_get_mpicomm(ictxt1, icomm)
allocate(sv%local_ictxt,stat=info) allocate(sv%local_ictxt,stat=info)
sv%local_ictxt = ictxt1 sv%local_ictxt = ictxt1
write(*,*)'mumps_bld: +++++>',icomm,ictxt1 write(*,*)'mumps_bld: +++++>',icomm,sv%local_ictxt
call psb_info(ictxt1, me, np) call psb_info(ictxt1, me, np)
npr = np npr = np
else else if (sv%ipar(1) == mld_global_solver_ ) then
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
write(*,*)'mumps_bld: +++++>',icomm,ictxt write(*,*)'mumps_bld: +++++>',icomm,ictxt
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
me = iam
npr = np npr = np
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if end if
npc = 1 npc = 1
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -98,7 +104,7 @@
allocate(sv%id,stat=info) allocate(sv%id,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_dealloc_ info=psb_err_alloc_dealloc_
call psb_errpush(info,name,a_err='mld_smumps_default') call psb_errpush(info,name,a_err='mld_dmumps_default')
goto 9999 goto 9999
end if end if
end if end if
@ -108,10 +114,13 @@
sv%id%job = -1 sv%id%job = -1
sv%id%par = 1 sv%id%par = 1
call smumps(sv%id) call smumps(sv%id)
!WARNING: CALLING sMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX !WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX
if (allocated(sv%icntl)) then if (allocated(sv%icntl)) then
do i=1,mld_mumps_icntl_size do i=1,mld_mumps_icntl_size
if (allocated(sv%icntl(i)%item)) sv%id%icntl(i) = sv%icntl(i)%item if (allocated(sv%icntl(i)%item)) then
!write(0,*) 'MUMPS_BLD: setting entry ',i,' to ', sv%icntl(i)%item
sv%id%icntl(i) = sv%icntl(i)%item
end if
end do end do
end if end if
if (allocated(sv%rcntl)) then if (allocated(sv%rcntl)) then
@ -122,13 +131,14 @@
sv%id%icntl(3)=sv%ipar(2) sv%id%icntl(3)=sv%ipar(2)
nglob = desc_a%get_global_rows() nglob = desc_a%get_global_rows()
if (sv%ipar(1) < 0) then if (sv%ipar(1) == mld_local_solver_ ) then
nglobrec=desc_a%get_local_rows() nglobrec=desc_a%get_local_rows()
call a%csclip(c,info,jmax=a%get_nrows()) call a%csclip(c,info,jmax=a%get_nrows())
call c%cp_to(acoo) call c%cp_to(acoo)
nglob = c%get_nrows() nglob = c%get_nrows()
if (nglobrec /= nglob) then if (nglobrec /= nglob) then
write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. A zero-overlap is used instead' write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. '
write(*,*)'A zero-overlap is used instead'
end if end if
else else
call a%cp_to(acoo) call a%cp_to(acoo)
@ -136,7 +146,7 @@
nztota = acoo%get_nzeros() nztota = acoo%get_nzeros()
! switch to global numbering ! switch to global numbering
if (sv%ipar(1) >= 0 ) then if (sv%ipar(1) == mld_global_solver_ ) then
call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I')
call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I')
end if end if
@ -155,13 +165,13 @@
sv%id%nz = acoo%get_nzeros() sv%id%nz = acoo%get_nzeros()
sv%id%job = 4 sv%id%job = 4
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
write(*,*)'calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc write(*,*)iam, ' calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc
call smumps(sv%id) call dmumps(sv%id)
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
info = sv%id%infog(1) info = sv%id%infog(1)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mld_smumps_fact ' ch_err='mld_dmumps_fact '
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -173,7 +183,7 @@
sv%built=.true. sv%built=.true.
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) iam,' ',trim(name),' end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -188,5 +198,5 @@
#else #else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif #endif
end subroutine s_mumps_solver_bld end subroutine s_mumps_solver_bld

21
mlprec/impl/solver/mld_z_mumps_solver_apply.F90
Unescape Escape View File

@ -82,6 +82,11 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
n_row = desc_data%get_local_rows() n_row = desc_data%get_local_rows()
n_col = desc_data%get_local_cols() n_col = desc_data%get_local_cols()
! Running in local mode?
if (sv%ipar(1) == mld_local_solver_ ) then
gx = x
else if (sv%ipar(1) == mld_global_solver_ ) then
if (n_col <= size(work)) then if (n_col <= size(work)) then
ww = work(1:n_col) ww = work(1:n_col)
else else
@ -101,6 +106,13 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
end if end if
call psb_gather(gx, x, desc_data, info, root=0) call psb_gather(gx, x, desc_data, info, root=0)
else
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if
select case(trans_) select case(trans_)
case('N') case('N')
sv%id%icntl(9) = 1 sv%id%icntl(9) = 1
@ -120,11 +132,14 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
sv%id%icntl(4)=-1 sv%id%icntl(4)=-1
sv%id%job = 3 sv%id%job = 3
call zmumps(sv%id) call zmumps(sv%id)
if (sv%ipar(1) == mld_local_solver_ ) then
call psb_geaxpby(alpha,gx,beta,y,desc_data,info)
else
call psb_scatter(gx, ww, desc_data, info, root=0) call psb_scatter(gx, ww, desc_data, info, root=0)
if (info == psb_success_) then if (info == psb_success_) then
call psb_geaxpby(alpha,ww,beta,y,desc_data,info) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
end if end if
end if
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,& call psb_errpush(psb_err_internal_error_,&
@ -132,9 +147,7 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,&
goto 9999 goto 9999
endif endif
if (nglob > size(work)) then if (allocated(ww)) deallocate(ww)
deallocate(ww)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

46
mlprec/impl/solver/mld_z_mumps_solver_bld.F90
Unescape Escape View File

@ -60,7 +60,7 @@
type(psb_z_coo_sparse_mat), target :: acoo type(psb_z_coo_sparse_mat), target :: acoo
integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc
integer(psb_ipk_) :: ifrst, ibcheck integer(psb_ipk_) :: ifrst, ibcheck
integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, iam, me, i, err_act, debug_unit, debug_level
character(len=20) :: name='z_mumps_solver_bld', ch_err character(len=20) :: name='z_mumps_solver_bld', ch_err
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
@ -71,20 +71,26 @@
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
if (sv%ipar(1) < 0 ) then if (sv%ipar(1) == mld_local_solver_ ) then
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/me/)) call psb_init(ictxt1,np=1,basectxt=ictxt,ids=(/iam/))
call psb_get_mpicomm(ictxt1, icomm) call psb_get_mpicomm(ictxt1, icomm)
allocate(sv%local_ictxt,stat=info) allocate(sv%local_ictxt,stat=info)
sv%local_ictxt = ictxt1 sv%local_ictxt = ictxt1
write(*,*)'mumps_bld: +++++>',icomm,ictxt1 write(*,*)'mumps_bld: +++++>',icomm,sv%local_ictxt
call psb_info(ictxt1, me, np) call psb_info(ictxt1, me, np)
npr = np npr = np
else else if (sv%ipar(1) == mld_global_solver_ ) then
call psb_get_mpicomm(ictxt,icomm) call psb_get_mpicomm(ictxt,icomm)
write(*,*)'mumps_bld: +++++>',icomm,ictxt write(*,*)'mumps_bld: +++++>',icomm,ictxt
call psb_info(ictxt, me, np) call psb_info(ictxt, iam, np)
me = iam
npr = np npr = np
else
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid local/global solver in MUMPS')
goto 9999
end if end if
npc = 1 npc = 1
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -98,7 +104,7 @@
allocate(sv%id,stat=info) allocate(sv%id,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_dealloc_ info=psb_err_alloc_dealloc_
call psb_errpush(info,name,a_err='mld_zmumps_default') call psb_errpush(info,name,a_err='mld_dmumps_default')
goto 9999 goto 9999
end if end if
end if end if
@ -108,10 +114,13 @@
sv%id%job = -1 sv%id%job = -1
sv%id%par = 1 sv%id%par = 1
call zmumps(sv%id) call zmumps(sv%id)
!WARNING: CALLING zMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX !WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX
if (allocated(sv%icntl)) then if (allocated(sv%icntl)) then
do i=1,mld_mumps_icntl_size do i=1,mld_mumps_icntl_size
if (allocated(sv%icntl(i)%item)) sv%id%icntl(i) = sv%icntl(i)%item if (allocated(sv%icntl(i)%item)) then
!write(0,*) 'MUMPS_BLD: setting entry ',i,' to ', sv%icntl(i)%item
sv%id%icntl(i) = sv%icntl(i)%item
end if
end do end do
end if end if
if (allocated(sv%rcntl)) then if (allocated(sv%rcntl)) then
@ -122,13 +131,14 @@
sv%id%icntl(3)=sv%ipar(2) sv%id%icntl(3)=sv%ipar(2)
nglob = desc_a%get_global_rows() nglob = desc_a%get_global_rows()
if (sv%ipar(1) < 0) then if (sv%ipar(1) == mld_local_solver_ ) then
nglobrec=desc_a%get_local_rows() nglobrec=desc_a%get_local_rows()
call a%csclip(c,info,jmax=a%get_nrows()) call a%csclip(c,info,jmax=a%get_nrows())
call c%cp_to(acoo) call c%cp_to(acoo)
nglob = c%get_nrows() nglob = c%get_nrows()
if (nglobrec /= nglob) then if (nglobrec /= nglob) then
write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. A zero-overlap is used instead' write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. '
write(*,*)'A zero-overlap is used instead'
end if end if
else else
call a%cp_to(acoo) call a%cp_to(acoo)
@ -136,7 +146,7 @@
nztota = acoo%get_nzeros() nztota = acoo%get_nzeros()
! switch to global numbering ! switch to global numbering
if (sv%ipar(1) >= 0 ) then if (sv%ipar(1) == mld_global_solver_ ) then
call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I')
call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I')
end if end if
@ -155,13 +165,13 @@
sv%id%nz = acoo%get_nzeros() sv%id%nz = acoo%get_nzeros()
sv%id%job = 4 sv%id%job = 4
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
write(*,*)'calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc write(*,*)iam, ' calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc
call zmumps(sv%id) call dmumps(sv%id)
!call psb_barrier(ictxt) !call psb_barrier(ictxt)
info = sv%id%infog(1) info = sv%id%infog(1)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mld_zmumps_fact ' ch_err='mld_dmumps_fact '
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -173,7 +183,7 @@
sv%built=.true. sv%built=.true.
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end' & write(debug_unit,*) iam,' ',trim(name),' end'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -188,5 +198,5 @@
#else #else
write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile "
#endif #endif
end subroutine z_mumps_solver_bld end subroutine z_mumps_solver_bld

14
mlprec/mld_base_prec_type.F90
Unescape Escape View File

@ -286,15 +286,15 @@ module mld_base_prec_type
integer(psb_ipk_), parameter :: mld_coarse_iluthrs_ = 4 integer(psb_ipk_), parameter :: mld_coarse_iluthrs_ = 4
integer(psb_ipk_), parameter :: mld_solver_eps_ = 6 integer(psb_ipk_), parameter :: mld_solver_eps_ = 6
integer(psb_ipk_), parameter :: mld_rfpsz_ = 8 integer(psb_ipk_), parameter :: mld_rfpsz_ = 8
!
! Is the current solver local or global
!
integer(psb_ipk_), parameter :: mld_local_solver_ = 0
integer(psb_ipk_), parameter :: mld_global_solver_ = 1
! !
! Entries for mumps ! Entries for mumps
! !
!parameter controling the sequential/parallel building of MUMPS
integer(psb_ipk_), parameter :: mld_as_sequential_ = 40
!parameter regulating the error printing of MUMPS
integer(psb_ipk_), parameter :: mld_mumps_print_err_ = 41
! Size of the control vectors ! Size of the control vectors
integer, parameter :: mld_mumps_icntl_size=40 integer, parameter :: mld_mumps_icntl_size=40
integer, parameter :: mld_mumps_rcntl_size=15 integer, parameter :: mld_mumps_rcntl_size=15
@ -483,6 +483,10 @@ contains
val = mld_no_filter_mat_ val = mld_no_filter_mat_
case('OUTER_SWEEPS') case('OUTER_SWEEPS')
val = mld_outer_sweeps_ val = mld_outer_sweeps_
case('LOCAL_SOLVER')
val = mld_local_solver_
case('GLOBAL_SOLVER')
val = mld_global_solver_
case default case default
val = -1 val = -1
end select end select

5
mlprec/mld_c_mumps_solver.F90
Unescape Escape View File

@ -291,7 +291,7 @@ contains
select case(psb_toupper(what)) select case(psb_toupper(what))
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
case('MUMPS_AS_SEQUENTIAL') case('MUMPS_SOLVER_LOC_GLOB')
sv%ipar(1)=val sv%ipar(1)=val
case('MUMPS_PRINT_ERR') case('MUMPS_PRINT_ERR')
sv%ipar(2)=val sv%ipar(2)=val
@ -401,7 +401,8 @@ contains
! sv%id%job = -1 ! sv%id%job = -1
! sv%id%par=1 ! sv%id%par=1
! call dmumps(sv%id) ! call dmumps(sv%id)
sv%ipar(1)=2 sv%ipar = 0
sv%ipar(1) = mld_global_solver_
!sv%ipar(10)=6 !sv%ipar(10)=6
!sv%ipar(11)=0 !sv%ipar(11)=0
!sv%ipar(12)=6 !sv%ipar(12)=6

5
mlprec/mld_d_mumps_solver.F90
Unescape Escape View File

@ -291,7 +291,7 @@ contains
select case(psb_toupper(what)) select case(psb_toupper(what))
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
case('MUMPS_AS_SEQUENTIAL') case('MUMPS_SOLVER_LOC_GLOB')
sv%ipar(1)=val sv%ipar(1)=val
case('MUMPS_PRINT_ERR') case('MUMPS_PRINT_ERR')
sv%ipar(2)=val sv%ipar(2)=val
@ -401,7 +401,8 @@ contains
! sv%id%job = -1 ! sv%id%job = -1
! sv%id%par=1 ! sv%id%par=1
! call dmumps(sv%id) ! call dmumps(sv%id)
sv%ipar(1)=2 sv%ipar = 0
sv%ipar(1) = mld_global_solver_
!sv%ipar(10)=6 !sv%ipar(10)=6
!sv%ipar(11)=0 !sv%ipar(11)=0
!sv%ipar(12)=6 !sv%ipar(12)=6

5
mlprec/mld_s_mumps_solver.F90
Unescape Escape View File

@ -291,7 +291,7 @@ contains
select case(psb_toupper(what)) select case(psb_toupper(what))
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
case('MUMPS_AS_SEQUENTIAL') case('MUMPS_SOLVER_LOC_GLOB')
sv%ipar(1)=val sv%ipar(1)=val
case('MUMPS_PRINT_ERR') case('MUMPS_PRINT_ERR')
sv%ipar(2)=val sv%ipar(2)=val
@ -401,7 +401,8 @@ contains
! sv%id%job = -1 ! sv%id%job = -1
! sv%id%par=1 ! sv%id%par=1
! call dmumps(sv%id) ! call dmumps(sv%id)
sv%ipar(1)=2 sv%ipar = 0
sv%ipar(1) = mld_global_solver_
!sv%ipar(10)=6 !sv%ipar(10)=6
!sv%ipar(11)=0 !sv%ipar(11)=0
!sv%ipar(12)=6 !sv%ipar(12)=6

5
mlprec/mld_z_mumps_solver.F90
Unescape Escape View File

@ -291,7 +291,7 @@ contains
select case(psb_toupper(what)) select case(psb_toupper(what))
#if defined(HAVE_MUMPS_) #if defined(HAVE_MUMPS_)
case('MUMPS_AS_SEQUENTIAL') case('MUMPS_SOLVER_LOC_GLOB')
sv%ipar(1)=val sv%ipar(1)=val
case('MUMPS_PRINT_ERR') case('MUMPS_PRINT_ERR')
sv%ipar(2)=val sv%ipar(2)=val
@ -401,7 +401,8 @@ contains
! sv%id%job = -1 ! sv%id%job = -1
! sv%id%par=1 ! sv%id%par=1
! call dmumps(sv%id) ! call dmumps(sv%id)
sv%ipar(1)=2 sv%ipar = 0
sv%ipar(1) = mld_global_solver_
!sv%ipar(10)=6 !sv%ipar(10)=6
!sv%ipar(11)=0 !sv%ipar(11)=0
!sv%ipar(12)=6 !sv%ipar(12)=6

Write Preview
Loading…
Cancel
Save