mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-16 02:49:03 +00:00
Merge branch 'unify_aggr_bld' into development
This commit is contained in:
Salvatore Filippone
@@ -39,6 +39,7 @@ module psb_c_realloc_mod
|
||||
! the size specified, possibly shortening it.
|
||||
!
|
||||
Interface psb_realloc
|
||||
module procedure psb_r_c_s
|
||||
module procedure psb_r_m_c_rk1
|
||||
module procedure psb_r_m_c_rk2
|
||||
module procedure psb_r_e_c_rk1
|
||||
@@ -56,7 +57,7 @@ module psb_c_realloc_mod
|
||||
end interface psb_move_alloc
|
||||
|
||||
Interface psb_safe_ab_cpy
|
||||
module procedure psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2
|
||||
module procedure psb_ab_cpy_c_s, psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2
|
||||
end Interface psb_safe_ab_cpy
|
||||
|
||||
Interface psb_safe_cpy
|
||||
@@ -82,6 +83,42 @@ module psb_c_realloc_mod
|
||||
|
||||
Contains
|
||||
|
||||
Subroutine psb_r_c_s(rrax,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
complex(psb_spk_), allocatable, intent(inout) :: rrax
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
! ...Local Variables
|
||||
integer(psb_ipk_) :: err_act,err
|
||||
character(len=20) :: name
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_r_c_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
|
||||
if (.not.allocated(rrax)) then
|
||||
Allocate(rrax,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
err=4025
|
||||
call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
|
||||
& a_err='complex(psb_spk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
info = err
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
End Subroutine psb_r_c_s
|
||||
|
||||
Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -687,6 +724,48 @@ Contains
|
||||
|
||||
|
||||
|
||||
subroutine psb_ab_cpy_c_s(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
complex(psb_spk_), allocatable, intent(in) :: vin
|
||||
complex(psb_spk_), allocatable, intent(out) :: vout
|
||||
integer(psb_ipk_) :: info
|
||||
! ...Local Variables
|
||||
|
||||
integer(psb_ipk_) :: isz,err_act,lb
|
||||
character(len=20) :: name, char_err
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_ab_cpy_c_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
if(psb_errstatus_fatal()) then
|
||||
info=psb_err_from_subroutine_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(vin)) then
|
||||
call psb_realloc(vout,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
char_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=char_err)
|
||||
goto 9999
|
||||
else
|
||||
vout = vin
|
||||
endif
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_ab_cpy_c_s
|
||||
|
||||
subroutine psb_ab_cpy_c_rk1(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
|
||||
@@ -39,6 +39,7 @@ module psb_d_realloc_mod
|
||||
! the size specified, possibly shortening it.
|
||||
!
|
||||
Interface psb_realloc
|
||||
module procedure psb_r_d_s
|
||||
module procedure psb_r_m_d_rk1
|
||||
module procedure psb_r_m_d_rk2
|
||||
module procedure psb_r_e_d_rk1
|
||||
@@ -56,7 +57,7 @@ module psb_d_realloc_mod
|
||||
end interface psb_move_alloc
|
||||
|
||||
Interface psb_safe_ab_cpy
|
||||
module procedure psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2
|
||||
module procedure psb_ab_cpy_d_s, psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2
|
||||
end Interface psb_safe_ab_cpy
|
||||
|
||||
Interface psb_safe_cpy
|
||||
@@ -82,6 +83,42 @@ module psb_d_realloc_mod
|
||||
|
||||
Contains
|
||||
|
||||
Subroutine psb_r_d_s(rrax,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
real(psb_dpk_), allocatable, intent(inout) :: rrax
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
! ...Local Variables
|
||||
integer(psb_ipk_) :: err_act,err
|
||||
character(len=20) :: name
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_r_d_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
|
||||
if (.not.allocated(rrax)) then
|
||||
Allocate(rrax,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
err=4025
|
||||
call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
|
||||
& a_err='real(psb_dpk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
info = err
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
End Subroutine psb_r_d_s
|
||||
|
||||
Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -687,6 +724,48 @@ Contains
|
||||
|
||||
|
||||
|
||||
subroutine psb_ab_cpy_d_s(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
real(psb_dpk_), allocatable, intent(in) :: vin
|
||||
real(psb_dpk_), allocatable, intent(out) :: vout
|
||||
integer(psb_ipk_) :: info
|
||||
! ...Local Variables
|
||||
|
||||
integer(psb_ipk_) :: isz,err_act,lb
|
||||
character(len=20) :: name, char_err
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_ab_cpy_d_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
if(psb_errstatus_fatal()) then
|
||||
info=psb_err_from_subroutine_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(vin)) then
|
||||
call psb_realloc(vout,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
char_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=char_err)
|
||||
goto 9999
|
||||
else
|
||||
vout = vin
|
||||
endif
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_ab_cpy_d_s
|
||||
|
||||
subroutine psb_ab_cpy_d_rk1(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
|
||||
@@ -39,6 +39,7 @@ module psb_e_realloc_mod
|
||||
! the size specified, possibly shortening it.
|
||||
!
|
||||
Interface psb_realloc
|
||||
module procedure psb_r_e_s
|
||||
module procedure psb_r_m_e_rk1
|
||||
module procedure psb_r_m_e_rk2
|
||||
module procedure psb_r_e_e_rk1
|
||||
@@ -56,7 +57,7 @@ module psb_e_realloc_mod
|
||||
end interface psb_move_alloc
|
||||
|
||||
Interface psb_safe_ab_cpy
|
||||
module procedure psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2
|
||||
module procedure psb_ab_cpy_e_s, psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2
|
||||
end Interface psb_safe_ab_cpy
|
||||
|
||||
Interface psb_safe_cpy
|
||||
@@ -82,6 +83,42 @@ module psb_e_realloc_mod
|
||||
|
||||
Contains
|
||||
|
||||
Subroutine psb_r_e_s(rrax,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
integer(psb_epk_), allocatable, intent(inout) :: rrax
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
! ...Local Variables
|
||||
integer(psb_ipk_) :: err_act,err
|
||||
character(len=20) :: name
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_r_e_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
|
||||
if (.not.allocated(rrax)) then
|
||||
Allocate(rrax,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
err=4025
|
||||
call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
|
||||
& a_err='integer(psb_epk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
info = err
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
End Subroutine psb_r_e_s
|
||||
|
||||
Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -687,6 +724,48 @@ Contains
|
||||
|
||||
|
||||
|
||||
subroutine psb_ab_cpy_e_s(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
integer(psb_epk_), allocatable, intent(in) :: vin
|
||||
integer(psb_epk_), allocatable, intent(out) :: vout
|
||||
integer(psb_ipk_) :: info
|
||||
! ...Local Variables
|
||||
|
||||
integer(psb_ipk_) :: isz,err_act,lb
|
||||
character(len=20) :: name, char_err
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_ab_cpy_e_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
if(psb_errstatus_fatal()) then
|
||||
info=psb_err_from_subroutine_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(vin)) then
|
||||
call psb_realloc(vout,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
char_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=char_err)
|
||||
goto 9999
|
||||
else
|
||||
vout = vin
|
||||
endif
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_ab_cpy_e_s
|
||||
|
||||
subroutine psb_ab_cpy_e_rk1(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
|
||||
@@ -39,6 +39,7 @@ module psb_i2_realloc_mod
|
||||
! the size specified, possibly shortening it.
|
||||
!
|
||||
Interface psb_realloc
|
||||
module procedure psb_r_i2_s
|
||||
module procedure psb_r_m_i2_rk1
|
||||
module procedure psb_r_m_i2_rk2
|
||||
module procedure psb_r_e_i2_rk1
|
||||
@@ -56,7 +57,7 @@ module psb_i2_realloc_mod
|
||||
end interface psb_move_alloc
|
||||
|
||||
Interface psb_safe_ab_cpy
|
||||
module procedure psb_ab_cpy_i2_rk1, psb_ab_cpy_i2_rk2
|
||||
module procedure psb_ab_cpy_i2_s, psb_ab_cpy_i2_rk1, psb_ab_cpy_i2_rk2
|
||||
end Interface psb_safe_ab_cpy
|
||||
|
||||
Interface psb_safe_cpy
|
||||
@@ -82,6 +83,42 @@ module psb_i2_realloc_mod
|
||||
|
||||
Contains
|
||||
|
||||
Subroutine psb_r_i2_s(rrax,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
integer(psb_i2pk_), allocatable, intent(inout) :: rrax
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
! ...Local Variables
|
||||
integer(psb_ipk_) :: err_act,err
|
||||
character(len=20) :: name
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_r_i2_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
|
||||
if (.not.allocated(rrax)) then
|
||||
Allocate(rrax,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
err=4025
|
||||
call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
|
||||
& a_err='integer(psb_i2pk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
info = err
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
End Subroutine psb_r_i2_s
|
||||
|
||||
Subroutine psb_r_m_i2_rk1(len,rrax,info,pad,lb)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -687,6 +724,48 @@ Contains
|
||||
|
||||
|
||||
|
||||
subroutine psb_ab_cpy_i2_s(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
integer(psb_i2pk_), allocatable, intent(in) :: vin
|
||||
integer(psb_i2pk_), allocatable, intent(out) :: vout
|
||||
integer(psb_ipk_) :: info
|
||||
! ...Local Variables
|
||||
|
||||
integer(psb_ipk_) :: isz,err_act,lb
|
||||
character(len=20) :: name, char_err
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_ab_cpy_i2_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
if(psb_errstatus_fatal()) then
|
||||
info=psb_err_from_subroutine_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(vin)) then
|
||||
call psb_realloc(vout,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
char_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=char_err)
|
||||
goto 9999
|
||||
else
|
||||
vout = vin
|
||||
endif
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_ab_cpy_i2_s
|
||||
|
||||
subroutine psb_ab_cpy_i2_rk1(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
|
||||
@@ -39,6 +39,7 @@ module psb_m_realloc_mod
|
||||
! the size specified, possibly shortening it.
|
||||
!
|
||||
Interface psb_realloc
|
||||
module procedure psb_r_m_s
|
||||
module procedure psb_r_m_m_rk1
|
||||
module procedure psb_r_m_m_rk2
|
||||
module procedure psb_r_e_m_rk1
|
||||
@@ -56,7 +57,7 @@ module psb_m_realloc_mod
|
||||
end interface psb_move_alloc
|
||||
|
||||
Interface psb_safe_ab_cpy
|
||||
module procedure psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2
|
||||
module procedure psb_ab_cpy_m_s, psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2
|
||||
end Interface psb_safe_ab_cpy
|
||||
|
||||
Interface psb_safe_cpy
|
||||
@@ -82,6 +83,42 @@ module psb_m_realloc_mod
|
||||
|
||||
Contains
|
||||
|
||||
Subroutine psb_r_m_s(rrax,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
integer(psb_mpk_), allocatable, intent(inout) :: rrax
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
! ...Local Variables
|
||||
integer(psb_ipk_) :: err_act,err
|
||||
character(len=20) :: name
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_r_m_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
|
||||
if (.not.allocated(rrax)) then
|
||||
Allocate(rrax,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
err=4025
|
||||
call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
|
||||
& a_err='integer(psb_mpk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
info = err
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
End Subroutine psb_r_m_s
|
||||
|
||||
Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -687,6 +724,48 @@ Contains
|
||||
|
||||
|
||||
|
||||
subroutine psb_ab_cpy_m_s(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
integer(psb_mpk_), allocatable, intent(in) :: vin
|
||||
integer(psb_mpk_), allocatable, intent(out) :: vout
|
||||
integer(psb_ipk_) :: info
|
||||
! ...Local Variables
|
||||
|
||||
integer(psb_ipk_) :: isz,err_act,lb
|
||||
character(len=20) :: name, char_err
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_ab_cpy_m_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
if(psb_errstatus_fatal()) then
|
||||
info=psb_err_from_subroutine_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(vin)) then
|
||||
call psb_realloc(vout,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
char_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=char_err)
|
||||
goto 9999
|
||||
else
|
||||
vout = vin
|
||||
endif
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_ab_cpy_m_s
|
||||
|
||||
subroutine psb_ab_cpy_m_rk1(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
|
||||
@@ -39,6 +39,7 @@ module psb_s_realloc_mod
|
||||
! the size specified, possibly shortening it.
|
||||
!
|
||||
Interface psb_realloc
|
||||
module procedure psb_r_s_s
|
||||
module procedure psb_r_m_s_rk1
|
||||
module procedure psb_r_m_s_rk2
|
||||
module procedure psb_r_e_s_rk1
|
||||
@@ -56,7 +57,7 @@ module psb_s_realloc_mod
|
||||
end interface psb_move_alloc
|
||||
|
||||
Interface psb_safe_ab_cpy
|
||||
module procedure psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2
|
||||
module procedure psb_ab_cpy_s_s, psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2
|
||||
end Interface psb_safe_ab_cpy
|
||||
|
||||
Interface psb_safe_cpy
|
||||
@@ -82,6 +83,42 @@ module psb_s_realloc_mod
|
||||
|
||||
Contains
|
||||
|
||||
Subroutine psb_r_s_s(rrax,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
real(psb_spk_), allocatable, intent(inout) :: rrax
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
! ...Local Variables
|
||||
integer(psb_ipk_) :: err_act,err
|
||||
character(len=20) :: name
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_r_s_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
|
||||
if (.not.allocated(rrax)) then
|
||||
Allocate(rrax,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
err=4025
|
||||
call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
|
||||
& a_err='real(psb_spk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
info = err
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
End Subroutine psb_r_s_s
|
||||
|
||||
Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -687,6 +724,48 @@ Contains
|
||||
|
||||
|
||||
|
||||
subroutine psb_ab_cpy_s_s(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
real(psb_spk_), allocatable, intent(in) :: vin
|
||||
real(psb_spk_), allocatable, intent(out) :: vout
|
||||
integer(psb_ipk_) :: info
|
||||
! ...Local Variables
|
||||
|
||||
integer(psb_ipk_) :: isz,err_act,lb
|
||||
character(len=20) :: name, char_err
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_ab_cpy_s_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
if(psb_errstatus_fatal()) then
|
||||
info=psb_err_from_subroutine_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(vin)) then
|
||||
call psb_realloc(vout,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
char_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=char_err)
|
||||
goto 9999
|
||||
else
|
||||
vout = vin
|
||||
endif
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_ab_cpy_s_s
|
||||
|
||||
subroutine psb_ab_cpy_s_rk1(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
|
||||
@@ -39,6 +39,7 @@ module psb_z_realloc_mod
|
||||
! the size specified, possibly shortening it.
|
||||
!
|
||||
Interface psb_realloc
|
||||
module procedure psb_r_z_s
|
||||
module procedure psb_r_m_z_rk1
|
||||
module procedure psb_r_m_z_rk2
|
||||
module procedure psb_r_e_z_rk1
|
||||
@@ -56,7 +57,7 @@ module psb_z_realloc_mod
|
||||
end interface psb_move_alloc
|
||||
|
||||
Interface psb_safe_ab_cpy
|
||||
module procedure psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2
|
||||
module procedure psb_ab_cpy_z_s, psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2
|
||||
end Interface psb_safe_ab_cpy
|
||||
|
||||
Interface psb_safe_cpy
|
||||
@@ -82,6 +83,42 @@ module psb_z_realloc_mod
|
||||
|
||||
Contains
|
||||
|
||||
Subroutine psb_r_z_s(rrax,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
complex(psb_dpk_), allocatable, intent(inout) :: rrax
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
! ...Local Variables
|
||||
integer(psb_ipk_) :: err_act,err
|
||||
character(len=20) :: name
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_r_z_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
|
||||
if (.not.allocated(rrax)) then
|
||||
Allocate(rrax,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
err=4025
|
||||
call psb_errpush(err,name, l_err=(/1_psb_lpk_/), &
|
||||
& a_err='complex(psb_dpk_)')
|
||||
goto 9999
|
||||
end if
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
info = err
|
||||
call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
End Subroutine psb_r_z_s
|
||||
|
||||
Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -687,6 +724,48 @@ Contains
|
||||
|
||||
|
||||
|
||||
subroutine psb_ab_cpy_z_s(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
! ...Subroutine Arguments
|
||||
complex(psb_dpk_), allocatable, intent(in) :: vin
|
||||
complex(psb_dpk_), allocatable, intent(out) :: vout
|
||||
integer(psb_ipk_) :: info
|
||||
! ...Local Variables
|
||||
|
||||
integer(psb_ipk_) :: isz,err_act,lb
|
||||
character(len=20) :: name, char_err
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
name='psb_ab_cpy_z_s'
|
||||
call psb_erractionsave(err_act)
|
||||
info=psb_success_
|
||||
if(psb_errstatus_fatal()) then
|
||||
info=psb_err_from_subroutine_
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (allocated(vin)) then
|
||||
call psb_realloc(vout,info)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
char_err='psb_realloc'
|
||||
call psb_errpush(info,name,a_err=char_err)
|
||||
goto 9999
|
||||
else
|
||||
vout = vin
|
||||
endif
|
||||
endif
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
end subroutine psb_ab_cpy_z_s
|
||||
|
||||
subroutine psb_ab_cpy_z_rk1(vin,vout,info)
|
||||
use psb_error_mod
|
||||
|
||||
|
||||
@@ -215,8 +215,8 @@ module psb_const_mod
|
||||
! Duplicate coefficients handling
|
||||
! These are usually set while calling spcnv as one of its
|
||||
! optional arugments.
|
||||
integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 0
|
||||
integer(psb_ipk_), parameter :: psb_dupl_add_ = 1
|
||||
integer(psb_ipk_), parameter :: psb_dupl_add_ = 0
|
||||
integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 1
|
||||
integer(psb_ipk_), parameter :: psb_dupl_err_ = 2
|
||||
integer(psb_ipk_), parameter :: psb_dupl_def_ = psb_dupl_add_
|
||||
! Matrix update mode
|
||||
|
||||
+1
-1
@@ -18,7 +18,7 @@ IMPLOBJS= psb_s_hbio_impl.o psb_d_hbio_impl.o \
|
||||
psb_s_mat_dist_impl.o psb_d_mat_dist_impl.o \
|
||||
psb_c_mat_dist_impl.o psb_z_mat_dist_impl.o \
|
||||
psb_s_renum_impl.o psb_d_renum_impl.o \
|
||||
psb_c_renum_impl.o psb_z_renum_impl.o
|
||||
psb_c_renum_impl.o psb_z_renum_impl.o psi_build_mtpart.o
|
||||
|
||||
MODOBJS=psb_util_mod.o $(BASEOBJS)
|
||||
COBJS=metis_int.o psb_amd_order.o
|
||||
|
||||
+22
-115
@@ -56,7 +56,7 @@
|
||||
module psb_metispart_mod
|
||||
use psb_base_mod, only : psb_sspmat_type, psb_cspmat_type,&
|
||||
& psb_dspmat_type, psb_zspmat_type, psb_err_unit, &
|
||||
& psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, &
|
||||
& psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_spk_,&
|
||||
& psb_s_csr_sparse_mat, psb_d_csr_sparse_mat, &
|
||||
& psb_c_csr_sparse_mat, psb_z_csr_sparse_mat
|
||||
public part_graph, build_mtpart, distr_mtpart,&
|
||||
@@ -65,18 +65,26 @@ module psb_metispart_mod
|
||||
integer(psb_ipk_), allocatable, save :: graph_vect(:)
|
||||
|
||||
interface build_mtpart
|
||||
module procedure build_mtpart,&
|
||||
& d_mat_build_mtpart, s_mat_build_mtpart,&
|
||||
& z_mat_build_mtpart, c_mat_build_mtpart, &
|
||||
& d_csr_build_mtpart, s_csr_build_mtpart,&
|
||||
& z_csr_build_mtpart, c_csr_build_mtpart
|
||||
|
||||
module procedure d_mat_build_mtpart, s_mat_build_mtpart,&
|
||||
& z_mat_build_mtpart, c_mat_build_mtpart
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine psi_build_mtpart(n,ja,irp,nparts,vect, weights)
|
||||
import :: psb_ipk_, psb_spk_
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n, nparts
|
||||
integer(psb_ipk_), intent(in) :: ja(:), irp(:)
|
||||
integer(psb_ipk_), allocatable, intent(inout) :: vect(:)
|
||||
real(psb_spk_),optional, intent(in) :: weights(:)
|
||||
|
||||
end subroutine psi_build_mtpart
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine part_graph(global_indx,n,np,pv,nv)
|
||||
implicit none
|
||||
implicit none
|
||||
integer(psb_lpk_), intent(in) :: global_indx, n
|
||||
integer(psb_ipk_), intent(in) :: np
|
||||
integer(psb_ipk_), intent(out) :: nv
|
||||
@@ -180,9 +188,9 @@ contains
|
||||
end if
|
||||
end if
|
||||
if (allocated(wgh_)) then
|
||||
call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_)
|
||||
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_)
|
||||
else
|
||||
call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts)
|
||||
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect)
|
||||
end if
|
||||
|
||||
end subroutine d_csr_build_mtpart
|
||||
@@ -219,9 +227,9 @@ contains
|
||||
end if
|
||||
end if
|
||||
if (allocated(wgh_)) then
|
||||
call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_)
|
||||
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_)
|
||||
else
|
||||
call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts)
|
||||
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect)
|
||||
end if
|
||||
|
||||
end subroutine z_csr_build_mtpart
|
||||
@@ -268,7 +276,7 @@ contains
|
||||
real(psb_spk_), optional :: weights(:)
|
||||
|
||||
|
||||
call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights)
|
||||
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights)
|
||||
|
||||
end subroutine c_csr_build_mtpart
|
||||
|
||||
@@ -280,111 +288,10 @@ contains
|
||||
real(psb_spk_), optional :: weights(:)
|
||||
|
||||
|
||||
call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights)
|
||||
call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights)
|
||||
|
||||
end subroutine s_csr_build_mtpart
|
||||
|
||||
subroutine build_mtpart(n,fida,ja,irp,nparts,weights)
|
||||
use psb_base_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: nparts
|
||||
integer(psb_ipk_) :: ja(:), irp(:)
|
||||
integer(psb_ipk_) :: n, i,numflag,nedc,wgflag
|
||||
character(len=5) :: fida
|
||||
integer(psb_ipk_), parameter :: nb=512
|
||||
real(psb_dpk_), parameter :: seed=12345.d0
|
||||
integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info
|
||||
real(psb_spk_),optional :: weights(:)
|
||||
integer(psb_ipk_) :: nl,nptl
|
||||
integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:)
|
||||
real(psb_spk_),allocatable :: wgh_(:)
|
||||
|
||||
#if defined(HAVE_METIS) && defined(IPK4)
|
||||
interface
|
||||
! subroutine METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
|
||||
! & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c)
|
||||
! use iso_c_binding
|
||||
! integer(c_int) :: n,wgflag,numflag,nparts,nedc
|
||||
! integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
! real(c_float) :: weights(*)
|
||||
! !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
|
||||
! !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
! end subroutine METIS_PartGraphKway
|
||||
|
||||
function METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
|
||||
& nparts,weights,part) bind(c,name="metis_PartGraphKway_C") result(res)
|
||||
use iso_c_binding
|
||||
integer(c_int) :: res
|
||||
integer(c_int) :: n,nparts
|
||||
integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),part(*)
|
||||
real(c_float) :: weights(*)
|
||||
!integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
|
||||
!integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
end function METIS_PartGraphKway
|
||||
end interface
|
||||
|
||||
call psb_realloc(n,graph_vect,info)
|
||||
if (info == psb_success_) allocate(gvl(n),wgh_(nparts),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',&
|
||||
& ' failure.'
|
||||
return
|
||||
endif
|
||||
if (nparts > 1) then
|
||||
if (psb_toupper(fida) == 'CSR') then
|
||||
iopt(1) = 0
|
||||
numflag = 1
|
||||
wgflag = 0
|
||||
|
||||
!!$ write(*,*) 'Before allocation',nparts
|
||||
|
||||
irpl=irp
|
||||
jal = ja
|
||||
nl = n
|
||||
nptl = nparts
|
||||
wgh_ = -1.0
|
||||
if(present(weights)) then
|
||||
if (size(weights) == nptl) then
|
||||
!!$ write(*,*) 'weights present',weights
|
||||
! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,&
|
||||
! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect)
|
||||
info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,weights,gvl)
|
||||
|
||||
else
|
||||
!!$ write(*,*) 'weights absent',wgh_
|
||||
info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,wgh_,gvl)
|
||||
end if
|
||||
else
|
||||
!!$ write(*,*) 'weights absent',wgh_
|
||||
info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,wgh_,gvl)
|
||||
endif
|
||||
!!$ write(*,*) 'after allocation',info
|
||||
|
||||
do i=1, n
|
||||
graph_vect(i) = gvl(i) - 1
|
||||
enddo
|
||||
else
|
||||
write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: matrix format ',&
|
||||
& ' failure. ', FIDA
|
||||
return
|
||||
endif
|
||||
else
|
||||
do i=1, n
|
||||
graph_vect(i) = 0
|
||||
enddo
|
||||
endif
|
||||
#else
|
||||
write(psb_err_unit,*) 'Warning: METIS was not configured at PSBLAS compile time !'
|
||||
#endif
|
||||
|
||||
return
|
||||
|
||||
end subroutine build_mtpart
|
||||
|
||||
!
|
||||
! WARNING: called IRET otherwise Intel compiler complains,
|
||||
! methinks it's a compiler bug, will need to report.
|
||||
|
||||
@@ -0,0 +1,95 @@
|
||||
|
||||
subroutine psi_build_mtpart(n,ja,irp,nparts,graph_vect,weights)
|
||||
use psb_base_mod
|
||||
use iso_c_binding
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(in) :: n, nparts
|
||||
integer(psb_ipk_), intent(in) :: ja(:), irp(:)
|
||||
integer(psb_ipk_), allocatable, intent(inout) :: graph_vect(:)
|
||||
real(psb_spk_),optional, intent(in) :: weights(:)
|
||||
! local variables
|
||||
integer(psb_ipk_) :: i,numflag, nedc,wgflag
|
||||
integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info
|
||||
integer(psb_ipk_) :: nl,nptl
|
||||
integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:)
|
||||
real(psb_spk_),allocatable :: wgh_(:)
|
||||
|
||||
#if defined(HAVE_METIS) && defined(IPK4)
|
||||
interface
|
||||
! subroutine METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
|
||||
! & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c)
|
||||
! use iso_c_binding
|
||||
! integer(c_int) :: n,wgflag,numflag,nparts,nedc
|
||||
! integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
! real(c_float) :: weights(*)
|
||||
! !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
|
||||
! !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
! end subroutine METIS_PartGraphKway
|
||||
|
||||
function METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,&
|
||||
& nparts,weights,part) bind(c,name="metis_PartGraphKway_C") result(res)
|
||||
use iso_c_binding
|
||||
integer(c_int) :: res
|
||||
integer(c_int) :: n,nparts
|
||||
integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),part(*)
|
||||
real(c_float) :: weights(*)
|
||||
!integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc
|
||||
!integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*)
|
||||
end function METIS_PartGraphKway
|
||||
end interface
|
||||
|
||||
call psb_realloc(n,graph_vect,info)
|
||||
if (info == psb_success_) allocate(gvl(n),wgh_(nparts),stat=info)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',&
|
||||
& ' failure.'
|
||||
return
|
||||
endif
|
||||
if (nparts > 1) then
|
||||
iopt(1) = 0
|
||||
numflag = 1
|
||||
wgflag = 0
|
||||
|
||||
!!$ write(*,*) 'Before allocation',nparts
|
||||
|
||||
irpl=irp
|
||||
jal = ja
|
||||
nl = n
|
||||
nptl = nparts
|
||||
wgh_ = -1.0
|
||||
if(present(weights)) then
|
||||
if (size(weights) == nptl) then
|
||||
!!$ write(*,*) 'weights present',weights
|
||||
! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,&
|
||||
! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect)
|
||||
info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,weights,gvl)
|
||||
|
||||
else
|
||||
!!$ write(*,*) 'weights absent',wgh_
|
||||
info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,wgh_,gvl)
|
||||
end if
|
||||
else
|
||||
!!$ write(*,*) 'weights absent',wgh_
|
||||
info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,&
|
||||
& nptl,wgh_,gvl)
|
||||
endif
|
||||
!!$ write(*,*) 'after allocation',info
|
||||
|
||||
do i=1, n
|
||||
graph_vect(i) = gvl(i) - 1
|
||||
enddo
|
||||
else
|
||||
do i=1, n
|
||||
graph_vect(i) = 0
|
||||
enddo
|
||||
endif
|
||||
#else
|
||||
write(psb_err_unit,*) 'Warning: METIS was not configured at PSBLAS compile time !'
|
||||
#endif
|
||||
|
||||
return
|
||||
|
||||
end subroutine psi_build_mtpart
|
||||
Reference in New Issue
Block a user