fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-18 11:52:11 +00:00
Code Issues Packages Projects Releases Wiki Activity

Changed realloc and blacs_env IFDEFs. In realloc we now IFDEF on

Browse Source 
MOVE_ALLOC.
Changed descriptor_type to allow for an implementation avoiding
GLOB_TO_LOC of size M for very large M.
This commit is contained in:
Salvatore Filippone
2006-11-28 13:54:23 +00:00
parent 02d7800a6c
commit 53193622ef
11 changed files with 739 additions and 165 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/modules/blacs_env.F90
+5 -5
View File
@@ -1,11 +1,11 @@
subroutine psb_set_coher(ictxt,isvch)
integer :: ictxt, isvch
! Ensure global coherence for convergence checks.
#ifdef NORMAL
#ifdef NETLIB_BLACS
Call blacs_get(ictxt,16,isvch)
Call blacs_set(ictxt,16,1)
#endif
#ifdef HAVE_ESSL
#ifdef ESSL_BLACS
! Do nothing: ESSL does coherence by default,
! and does not handle req=16
#endif
@@ -13,10 +13,10 @@ end subroutine psb_set_coher
subroutine psb_restore_coher(ictxt,isvch)
integer :: ictxt, isvch
! Ensure global coherence for convergence checks.
#ifdef NORMAL
#ifdef NETLIB_BLACS
Call blacs_set(ictxt,16,isvch)
#endif
#ifdef HAVE_ESSL
#ifdef ESSL_BLACS
! Do nothing: ESSL does coherence by default,
! and does not handle req=16
#endif
@@ -31,7 +31,7 @@ subroutine psb_get_rank(rank,ictxt,id)
rank = blacs_pnum(ictxt,id,0)
end subroutine psb_get_rank
#ifdef HAVE_ESSL
#ifdef ESSL_BLACS
!
! Need these, as they are not in the ESSL implementation
! of the BLACS.
src/modules/psb_check_mod.f90
+63 -63
View File
@@ -335,88 +335,88 @@ contains
call psb_erractionsave(err_act)
if (m < 0) then
info=10
int_err(1) = 1
int_err(2) = m
info=10
int_err(1) = 1
int_err(2) = m
else if (n < 0) then
info=10
int_err(1) = 3
int_err(2) = n
info=10
int_err(1) = 3
int_err(2) = n
else if ((ia < 1) .and. (m /= 0)) then
info=20
int_err(1) = 4
int_err(2) = ia
info=20
int_err(1) = 4
int_err(2) = ia
else if ((ja < 1) .and. (n /= 0)) then
info=20
int_err(1) = 5
int_err(2) = ja
info=20
int_err(1) = 5
int_err(2) = ja
else if (psb_cd_get_local_cols(desc_dec) < 0) then
info=40
int_err(1) = 6
int_err(2) = psb_n_col_
int_err(3) = psb_cd_get_local_cols(desc_dec)
info=40
int_err(1) = 6
int_err(2) = psb_n_col_
int_err(3) = psb_cd_get_local_cols(desc_dec)
else if (psb_cd_get_local_rows(desc_dec) < 0) then
info=40
int_err(1) = 6
int_err(2) = psb_n_row_
int_err(3) = psb_cd_get_local_rows(desc_dec)
info=40
int_err(1) = 6
int_err(2) = psb_n_row_
int_err(3) = psb_cd_get_local_rows(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < m) then
info=60
int_err(1) = 1
int_err(2) = m
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
info=60
int_err(1) = 1
int_err(2) = m
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < m) then
info=60
int_err(1) = 2
int_err(2) = n
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
info=60
int_err(1) = 2
int_err(2) = n
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < ia) then
info=60
int_err(1) = 3
int_err(2) = ia
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
info=60
int_err(1) = 3
int_err(2) = ia
int_err(3) = 5
int_err(4) = psb_m_
int_err(5) = psb_cd_get_global_rows(desc_dec)
else if (psb_cd_get_global_cols(desc_dec) < ja) then
info=60
int_err(1) = 4
int_err(2) = ja
int_err(3) = 5
int_err(4) = psb_n_
int_err(5) = psb_cd_get_global_cols(desc_dec)
info=60
int_err(1) = 4
int_err(2) = ja
int_err(3) = 5
int_err(4) = psb_n_
int_err(5) = psb_cd_get_global_cols(desc_dec)
else if (psb_cd_get_global_rows(desc_dec) < (ia+m-1)) then
info=80
int_err(1) = 1
int_err(2) = m
int_err(3) = 3
int_err(4) = ia
info=80
int_err(1) = 1
int_err(2) = m
int_err(3) = 3
int_err(4) = ia
else if (psb_cd_get_global_cols(desc_dec) < (ja+n-1)) then
info=80
int_err(1) = 2
int_err(2) = n
int_err(3) = 4
int_err(4) = ja
info=80
int_err(1) = 2
int_err(2) = n
int_err(3) = 4
int_err(4) = ja
end if
if (info /= 0) then
call psb_errpush(info,name,i_err=int_err)
goto 9999
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
! Compute local indices for submatrix starting
! at global indices ix and jx
if(present(iia).and.present(jja)) then
if (psb_cd_get_local_rows(desc_dec) > 0) then
iia=1
jja=1
else
iia=psb_cd_get_local_rows(desc_dec)+1
jja=psb_cd_get_local_cols(desc_dec)+1
end if
if (psb_cd_get_local_rows(desc_dec) > 0) then
iia=1
jja=1
else
iia=psb_cd_get_local_rows(desc_dec)+1
jja=psb_cd_get_local_cols(desc_dec)+1
end if
end if
call psb_erractionrestore(err_act)
src/modules/psb_const_mod.f90
+5
View File
@@ -71,6 +71,11 @@ module psb_const_mod
integer, parameter :: psb_desc_repl_=3199
integer, parameter :: psb_desc_upd_=psb_desc_bld_+1
integer, parameter :: psb_desc_upd_asb_=psb_desc_upd_+1
integer, parameter :: psb_desc_large_asb_=psb_desc_upd_asb_+1
integer, parameter :: psb_desc_large_bld_=psb_desc_large_asb_+1
integer, parameter :: nbits=14
integer, parameter :: hashsize=2**nbits, hashmask=hashsize-1
integer, parameter :: psb_default_large_threshold=4*1024*1024 ! to be reviewed
integer, parameter :: psb_hpnt_nentries_=7
!
src/modules/psb_desc_type.f90
+48 -6
View File
@@ -58,14 +58,32 @@ module psb_descriptor_type
! contain for each global element the corresponding local index,
! if exist.
integer, allocatable :: glob_to_loc (:)
integer, allocatable :: hashv(:), glb_lc(:,:), ptree(:)
! local renumbering induced by sparse matrix storage.
integer, allocatable :: lprm(:)
! index space in case it is not just the contiguous range 1:n
integer, allocatable :: idx_space(:)
end type psb_desc_type
integer, private, save :: cd_large_threshold=psb_default_large_threshold
contains
subroutine psb_cd_set_large_threshold(ith)
integer, intent(in) :: ith
if (ith > 0) then
cd_large_threshold = ith
end if
end subroutine psb_cd_set_large_threshold
integer function psb_cd_get_large_threshold()
psb_cd_get_large_threshold = cd_large_threshold
end function psb_cd_get_large_threshold
subroutine psb_nullify_desc(desc)
type(psb_desc_type), intent(inout) :: desc
@@ -76,6 +94,7 @@ contains
end subroutine psb_nullify_desc
logical function psb_is_ok_desc(desc)
type(psb_desc_type), intent(in) :: desc
psb_is_ok_desc = psb_is_ok_dec(psb_cd_get_dectype(desc))
@@ -89,6 +108,13 @@ contains
end function psb_is_bld_desc
logical function psb_is_large_desc(desc)
type(psb_desc_type), intent(in) :: desc
psb_is_large_desc = psb_is_large_dec(psb_cd_get_dectype(desc))
end function psb_is_large_desc
logical function psb_is_upd_desc(desc)
type(psb_desc_type), intent(in) :: desc
@@ -115,15 +141,16 @@ contains
integer :: dectype
psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.&
& (dectype == psb_desc_upd_).or.(dectype== psb_desc_upd_asb_).or.&
& (dectype== psb_desc_repl_))
&(dectype == psb_desc_upd_).or.(dectype== psb_desc_upd_asb_).or.&
&(dectype == psb_desc_large_asb_).or.(dectype == psb_desc_large_bld_).or.&
&(dectype== psb_desc_repl_))
end function psb_is_ok_dec
logical function psb_is_bld_dec(dectype)
integer :: dectype
psb_is_bld_dec = (dectype == psb_desc_bld_)
psb_is_bld_dec = (dectype == psb_desc_bld_)&
& .or.(dectype == psb_desc_large_bld_)
end function psb_is_bld_dec
logical function psb_is_upd_dec(dectype)
@@ -143,13 +170,13 @@ contains
logical function psb_is_asb_dec(dectype)
integer :: dectype
psb_is_asb_dec = (dectype == psb_desc_asb_).or.&
psb_is_asb_dec = (dectype == psb_desc_asb_)&
& .or.(dectype == psb_desc_large_asb_).or.&
& (dectype== psb_desc_repl_)
end function psb_is_asb_dec
integer function psb_cd_get_local_rows(desc)
type(psb_desc_type), intent(in) :: desc
@@ -185,5 +212,20 @@ contains
psb_cd_get_dectype = desc%matrix_data(psb_dec_type_)
end function psb_cd_get_dectype
integer function psb_cd_get_mpic(desc)
type(psb_desc_type), intent(in) :: desc
psb_cd_get_mpic = desc%matrix_data(psb_mpi_c_)
end function psb_cd_get_mpic
logical function psb_is_large_dec(dectype)
integer :: dectype
psb_is_large_dec = (dectype == psb_desc_large_asb_)&
& .or.(dectype == psb_desc_large_bld_)
end function psb_is_large_dec
end module psb_descriptor_type
src/modules/psb_penv_mod.f90
-1
View File
@@ -142,7 +142,6 @@ module psb_penv_mod
end interface
contains
src/modules/psb_prec_mod.f90
+51
View File
@@ -150,4 +150,55 @@ module psb_prec_mod
end subroutine psb_zprc_aply1
end interface
interface psb_baseprc_bld
subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
Use psb_spmat_type
use psb_descriptor_type
use psb_prec_type
type(psb_dspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_dbaseprc_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine psb_dbaseprc_bld
subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
Use psb_spmat_type
use psb_descriptor_type
use psb_prec_type
type(psb_zspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_zbaseprc_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
end subroutine psb_zbaseprc_bld
end interface
interface psb_mlprc_bld
subroutine psb_dmlprc_bld(a,desc_a,p,info)
use psb_serial_mod
use psb_descriptor_type
use psb_prec_type
use psb_const_mod
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_dbaseprc_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine psb_dmlprc_bld
subroutine psb_zmlprc_bld(a,desc_a,p,info)
use psb_serial_mod
use psb_descriptor_type
use psb_prec_type
use psb_const_mod
implicit none
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_zbaseprc_type), intent(inout),target :: p
integer, intent(out) :: info
end subroutine psb_zmlprc_bld
end interface
end module psb_prec_mod
src/modules/psb_prec_type.f90
+5 -3
View File
@@ -683,9 +683,11 @@ contains
enddo
deallocate(p%av,stat=info)
end if
! Do we really need the two below? Probably not.
! call psb_cdfree(p%desc_data,info)
! call psb_cdfree(p%desc_ac,info)
if (allocated(p%desc_data%matrix_data)) &
& call psb_cdfree(p%desc_data,info)
if (allocated(p%desc_ac%matrix_data)) &
& call psb_cdfree(p%desc_ac,info)
if (allocated(p%dprcparm)) then
deallocate(p%dprcparm,stat=info)
src/modules/psb_realloc_mod.f90 → src/modules/psb_realloc_mod.F90
+380 -80
View File
@@ -46,8 +46,11 @@ module psb_realloc_mod
interface psb_transfer
module procedure psb_dtransfer1d
module procedure psb_dtransfer2d
module procedure psb_itransfer1d
module procedure psb_itransfer2d
module procedure psb_ztransfer1d
module procedure psb_ztransfer2d
end interface
Interface psb_safe_cpy
@@ -55,6 +58,10 @@ module psb_realloc_mod
& psb_dcpy1d, psb_dcpy2d, psb_zcpy1d, psb_zcpy2d
end Interface
Interface psb_check_size
module procedure psb_icksz1d, psb_dcksz1d, psb_zcksz1d
end Interface
interface psb_size
module procedure psb_isize1d, psb_isize2d,&
& psb_dsize1d, psb_dsize2d,&
@@ -400,6 +407,7 @@ Contains
psb_zsize1d = size(vin)
end if
end function psb_zsize1d
function psb_zsize2d(vin,dim)
integer :: psb_zsize2d
complex(kind(1.d0)), allocatable, intent(in) :: vin(:,:)
@@ -417,7 +425,157 @@ Contains
end function psb_zsize2d
Subroutine psb_dreallocate1i(len,rrax,info,pad)
Subroutine psb_icksz1d(len,v,info,pad)
use psb_error_mod
! ...Subroutine Arguments
Integer,Intent(in) :: len
Integer,allocatable, intent(inout) :: v(:)
integer :: info
integer, optional, intent(in) :: pad
! ...Local Variables
character(len=20) :: name
logical, parameter :: debug=.false.
integer :: isz, err_act
name='psb_check_size'
call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return
info=0
If (len > psb_size(v)) Then
isz = max((3*psb_size(v))/2,(len+1))
if (present(pad)) then
call psb_realloc(isz,v,info,pad=pad)
else
call psb_realloc(isz,v,info)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
end if
End If
end If
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
else
call psb_error()
end if
return
End Subroutine psb_icksz1d
Subroutine psb_dcksz1d(len,v,info,pad)
use psb_error_mod
! ...Subroutine Arguments
Integer,Intent(in) :: len
real(kind(1.d0)),allocatable, intent(inout) :: v(:)
integer :: info
real(kind(1.d0)), optional, intent(in) :: pad
! ...Local Variables
character(len=20) :: name
logical, parameter :: debug=.false.
integer :: isz, err_act
name='psb_check_size'
call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return
info=0
If (len > psb_size(v)) Then
isz = max((3*psb_size(v))/2,(len+1))
if (present(pad)) then
call psb_realloc(isz,v,info,pad=pad)
else
call psb_realloc(isz,v,info)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
end if
End If
end If
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
else
call psb_error()
end if
return
End Subroutine psb_dcksz1d
Subroutine psb_zcksz1d(len,v,info,pad)
use psb_error_mod
! ...Subroutine Arguments
Integer,Intent(in) :: len
complex(kind(1.d0)),allocatable, intent(inout) :: v(:)
integer :: info
complex(kind(1.d0)), optional, intent(in) :: pad
! ...Local Variables
character(len=20) :: name
logical, parameter :: debug=.false.
integer :: isz, err_act
name='psb_check_size'
call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return
info=0
If (len > psb_size(v)) Then
isz = max((3*psb_size(v))/2,(len+1))
if (present(pad)) then
call psb_realloc(isz,v,info,pad=pad)
else
call psb_realloc(isz,v,info)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_realloc')
goto 9999
end if
End If
end If
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
else
call psb_error()
end if
return
End Subroutine psb_zcksz1d
Subroutine psb_dreallocate1i(len,rrax,info,pad,lb)
use psb_error_mod
! ...Subroutine Arguments
@@ -425,9 +583,10 @@ Contains
Integer,allocatable, intent(inout) :: rrax(:)
integer :: info
integer, optional, intent(in) :: pad
integer, optional, intent(in) :: lb
! ...Local Variables
Integer,allocatable :: tmp(:)
Integer :: dim, err_act, err,i
Integer :: dim, err_act, err,i,lb_
character(len=20) :: name
logical, parameter :: debug=.false.
@@ -437,23 +596,29 @@ Contains
if(psb_get_errstatus().ne.0) return
info=0
if (debug) write(0,*) 'reallocate I',len
if (present(lb)) then
lb_ = lb
else
lb_ = 1
endif
if (allocated(rrax)) then
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
Allocate(tmp(lb_:len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
goto 9999
end if
tmp(1:min(len,dim))=rrax(1:min(len,dim))
call move_alloc(tmp,rrax)
call psb_transfer(tmp,rrax,info)
end if
else
dim = 0
allocate(rrax(len),stat=info)
allocate(rrax(lb_:len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
@@ -481,7 +646,7 @@ Contains
End Subroutine psb_dreallocate1i
Subroutine psb_dreallocate1d(len,rrax,info,pad)
Subroutine psb_dreallocate1d(len,rrax,info,pad,lb)
use psb_error_mod
! ...Subroutine Arguments
@@ -489,10 +654,11 @@ Contains
Real(kind(1.d0)),allocatable, intent(inout) :: rrax(:)
integer :: info
real(kind(1.d0)), optional, intent(in) :: pad
integer, optional, intent(in) :: lb
! ...Local Variables
Real(kind(1.d0)),allocatable :: tmp(:)
Integer :: dim,err_act,err,i, m
Integer :: dim,err_act,err,i, m, lb_
character(len=20) :: name
logical, parameter :: debug=.false.
@@ -501,11 +667,17 @@ Contains
info = 0
if (debug) write(0,*) 'reallocate D',len
if (present(lb)) then
lb_ = lb
else
lb_ = 1
endif
if (allocated(rrax)) then
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
Allocate(tmp(lb_:len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
@@ -514,12 +686,12 @@ Contains
m = min(dim,len)
tmp(1:m) = rrax(1:m)
call move_alloc(tmp,rrax)
call psb_transfer(tmp,rrax,info)
End If
else
dim = 0
Allocate(rrax(len),stat=info)
Allocate(rrax(lb_:len),stat=info)
if (info /= 0) then
err=4000
call psb_errpush(err,name)
@@ -578,7 +750,7 @@ Contains
m = min(dim,len)
tmp(1:m) = rrax(1:m)
call move_alloc(tmp,rrax)
call psb_transfer(tmp,rrax,info)
End If
else
@@ -642,7 +814,7 @@ Contains
m = min(dim,len1)
tmp(1:m,1:min(len2,dim2)) = rrax(1:m,1:min(len2,dim2))
call move_alloc(tmp,rrax)
call psb_transfer(tmp,rrax,info)
End If
else
@@ -708,7 +880,7 @@ Contains
m = min(dim,len1)
tmp(1:m,1:min(len2,dim2)) = rrax(1:m,1:min(len2,dim2))
call move_alloc(tmp,rrax)
call psb_transfer(tmp,rrax,info)
End If
else
@@ -771,7 +943,7 @@ Contains
m = min(dim,len1)
tmp(1:m,1:min(len2,dim2)) = rrax(1:m,1:min(len2,dim2))
call move_alloc(tmp,rrax)
call psb_transfer(tmp,rrax,info)
End If
else
@@ -945,98 +1117,226 @@ Contains
return
End Subroutine psb_dreallocate2i1z
Subroutine psb_dtransfer1d(vin,vout,info)
use psb_error_mod
real(kind(1.d0)), allocatable, intent(inout) :: vin(:),vout(:)
integer, intent(out) :: info
!
! To be reimplemented with MOVE_ALLOC
!
info = 0
call move_alloc(vin,vout)
!!$
!!$ if (.not.allocated(vin) ) then
!!$ if (allocated(vout)) then
!!$ deallocate(vout,stat=info)
!!$ end if
!!$ else if (allocated(vin)) then
!!$ if (.not.allocated(vout)) then
!!$ allocate(vout(size(vin)),stat=info)
!!$ if (info /= 0) return
!!$ else
!!$ if (size(vout) /= size(vin)) then
!!$ deallocate(vout,stat=info)
!!$ if (info /= 0) return
!!$ allocate(vout(size(vin)),stat=info)
!!$ if (info /= 0) return
!!$ end if
!!$ end if
!!$ vout = vin
!!$ deallocate(vin,stat=info)
!!$ end if
#ifdef HAVE_MOVE_ALLOC
if (allocated(vin)) then
call move_alloc(vin,vout)
else if (allocated(vout)) then
write(0,*) 'transfer: Clearing output'
deallocate(vout)
end if
#else
if (.not.allocated(vin) ) then
if (allocated(vout)) then
deallocate(vout,stat=info)
end if
else if (allocated(vin)) then
if (.not.allocated(vout)) then
allocate(vout(size(vin)),stat=info)
if (info /= 0) return
else
if (size(vout) /= size(vin)) then
deallocate(vout,stat=info)
if (info /= 0) return
allocate(vout(size(vin)),stat=info)
if (info /= 0) return
end if
end if
vout = vin
deallocate(vin,stat=info)
end if
#endif
end Subroutine psb_dtransfer1d
Subroutine psb_dtransfer2d(vin,vout,info)
use psb_error_mod
real(kind(1.d0)), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer, intent(out) :: info
!
!
info = 0
#ifdef HAVE_MOVE_ALLOC
if (allocated(vin)) then
call move_alloc(vin,vout)
else if (allocated(vout)) then
deallocate(vout)
end if
#else
if (.not.allocated(vin) ) then
if (allocated(vout)) then
deallocate(vout,stat=info)
end if
else if (allocated(vin)) then
if (.not.allocated(vout)) then
allocate(vout(size(vin,1),size(vin,2)),stat=info)
if (info /= 0) return
else
if (size(vout) /= size(vin)) then
deallocate(vout,stat=info)
if (info /= 0) return
allocate(vout(size(vin,1),size(vin,2)),stat=info)
if (info /= 0) return
end if
end if
vout = vin
deallocate(vin,stat=info)
end if
#endif
end Subroutine psb_dtransfer2d
Subroutine psb_ztransfer1d(vin,vout,info)
use psb_error_mod
complex(kind(1.d0)), allocatable, intent(inout) :: vin(:),vout(:)
integer, intent(out) :: info
!
! To be reimplemented with MOVE_ALLOC
!
info = 0
call move_alloc(vin,vout)
!!$ if (.not.allocated(vin) ) then
!!$ if (allocated(vout)) then
!!$ deallocate(vout,stat=info)
!!$ end if
!!$ else if (allocated(vin)) then
!!$ if (.not.allocated(vout)) then
!!$ allocate(vout(size(vin)),stat=info)
!!$ if (info /= 0) return
!!$ else
!!$ if (size(vout) /= size(vin)) then
!!$ deallocate(vout,stat=info)
!!$ if (info /= 0) return
!!$ allocate(vout(size(vin)),stat=info)
!!$ if (info /= 0) return
!!$ end if
!!$ end if
!!$ vout = vin
!!$ deallocate(vin,stat=info)
!!$ end if
#ifdef HAVE_MOVE_ALLOC
if (allocated(vin)) then
call move_alloc(vin,vout)
else if (allocated(vout)) then
deallocate(vout)
end if
#else
if (.not.allocated(vin) ) then
if (allocated(vout)) then
deallocate(vout,stat=info)
end if
else if (allocated(vin)) then
if (.not.allocated(vout)) then
allocate(vout(size(vin)),stat=info)
if (info /= 0) return
else
if (size(vout) /= size(vin)) then
deallocate(vout,stat=info)
if (info /= 0) return
allocate(vout(size(vin)),stat=info)
if (info /= 0) return
end if
end if
vout = vin
deallocate(vin,stat=info)
end if
#endif
end Subroutine psb_ztransfer1d
Subroutine psb_ztransfer2d(vin,vout,info)
use psb_error_mod
complex(kind(1.d0)), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer, intent(out) :: info
!
!
info = 0
#ifdef HAVE_MOVE_ALLOC
if (allocated(vin)) then
call move_alloc(vin,vout)
else if (allocated(vout)) then
deallocate(vout)
end if
#else
if (.not.allocated(vin) ) then
if (allocated(vout)) then
deallocate(vout,stat=info)
end if
else if (allocated(vin)) then
if (.not.allocated(vout)) then
allocate(vout(size(vin,1),size(vin,2)),stat=info)
if (info /= 0) return
else
if (size(vout) /= size(vin)) then
deallocate(vout,stat=info)
if (info /= 0) return
allocate(vout(size(vin,1),size(vin,2)),stat=info)
if (info /= 0) return
end if
end if
vout = vin
deallocate(vin,stat=info)
end if
#endif
end Subroutine psb_ztransfer2d
Subroutine psb_itransfer1d(vin,vout,info)
use psb_error_mod
integer, allocatable, intent(inout) :: vin(:),vout(:)
integer, intent(out) :: info
!
! To be reimplemented with MOVE_ALLOC
!
info = 0
call move_alloc(vin,vout)
!!$ if (.not.allocated(vin) ) then
!!$ if (allocated(vout)) then
!!$ deallocate(vout,stat=info)
!!$ end if
!!$ else if (allocated(vin)) then
!!$ if (.not.allocated(vout)) then
!!$ allocate(vout(size(vin)),stat=info)
!!$ if (info /= 0) return
!!$ else
!!$ if (size(vout) /= size(vin)) then
!!$ deallocate(vout,stat=info)
!!$ if (info /= 0) return
!!$ allocate(vout(size(vin)),stat=info)
!!$ if (info /= 0) return
!!$ end if
!!$ end if
!!$ vout = vin
!!$ deallocate(vin,stat=info)
!!$ end if
#ifdef HAVE_MOVE_ALLOC
if (allocated(vin)) then
call move_alloc(vin,vout)
else if (allocated(vout)) then
write(0,*) 'transfer: Clearing output'
deallocate(vout)
end if
#else
if (.not.allocated(vin) ) then
if (allocated(vout)) then
deallocate(vout,stat=info)
end if
else if (allocated(vin)) then
if (.not.allocated(vout)) then
allocate(vout(size(vin)),stat=info)
if (info /= 0) return
else
if (size(vout) /= size(vin)) then
deallocate(vout,stat=info)
if (info /= 0) return
allocate(vout(size(vin)),stat=info)
if (info /= 0) return
end if
end if
vout = vin
deallocate(vin,stat=info)
end if
#endif
end Subroutine psb_itransfer1d
Subroutine psb_itransfer2d(vin,vout,info)
use psb_error_mod
integer, allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer, intent(out) :: info
!
!
info = 0
#ifdef HAVE_MOVE_ALLOC
if (allocated(vin)) then
call move_alloc(vin,vout)
else if (allocated(vout)) then
deallocate(vout)
end if
#else
if (.not.allocated(vin) ) then
if (allocated(vout)) then
deallocate(vout,stat=info)
end if
else if (allocated(vin)) then
if (.not.allocated(vout)) then
allocate(vout(size(vin,1),size(vin,2)),stat=info)
if (info /= 0) return
else
if (size(vout) /= size(vin)) then
deallocate(vout,stat=info)
if (info /= 0) return
allocate(vout(size(vin,1),size(vin,2)),stat=info)
if (info /= 0) return
end if
end if
vout = vin
deallocate(vin,stat=info)
end if
#endif
end Subroutine psb_itransfer2d
end module psb_realloc_mod
src/modules/psb_spmat_type.f90
-1
View File
@@ -1556,6 +1556,5 @@ contains
end subroutine psb_zspinfo
end module psb_spmat_type
src/modules/psb_tools_mod.f90
+13 -5
View File
@@ -38,7 +38,7 @@ Module psb_tools_mod
implicit none
real(kind(1.d0)), allocatable, intent(out) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer :: info
integer,intent(out) :: info
integer, optional, intent(in) :: n
end subroutine psb_dalloc
! 1-D double precision version
@@ -46,7 +46,7 @@ Module psb_tools_mod
use psb_descriptor_type
real(kind(1.d0)), allocatable, intent(out) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer :: info
integer,intent(out) :: info
integer, optional, intent(in) :: n
end subroutine psb_dallocv
! 2-D integer version
@@ -372,6 +372,13 @@ Module psb_tools_mod
integer, intent(out) :: info
Type(psb_desc_type), intent(out) :: desc_a
end subroutine psb_cdalv
subroutine psb_cd_inloc(v, ictxt, desc_a, info)
use psb_descriptor_type
implicit None
Integer, intent(in) :: ictxt, v(:)
integer, intent(out) :: info
type(psb_desc_type), intent(out) :: desc_a
end subroutine psb_cd_inloc
end interface
@@ -398,7 +405,7 @@ Module psb_tools_mod
subroutine psb_cdtransfer(desc_in, desc_out, info)
use psb_descriptor_type
type(psb_desc_type), intent(inout) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
type(psb_desc_type), intent(inout) :: desc_out
integer, intent(out) :: info
end subroutine psb_cdtransfer
end interface
@@ -413,11 +420,12 @@ Module psb_tools_mod
end interface
interface psb_cdins
subroutine psb_cdins(nz,ia,ja,desc_a,info)
subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla)
use psb_descriptor_type
type(psb_desc_type), intent(inout) :: desc_a
Integer, intent(in) :: nz,IA(:),JA(:)
integer, intent(in) :: nz,ia(:),ja(:)
integer, intent(out) :: info
integer, optional, intent(out) :: ila(:), jla(:)
end subroutine psb_cdins
end interface
src/modules/psi_mod.f90
+169 -1
View File
@@ -28,12 +28,18 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! Module containing interfaces for subroutine in SRC/F90/INTERNALS
module psi_mod
use psb_descriptor_type
!!$ interface
!!$ subroutine psi_inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc)
!!$ integer, intent(in) :: n, hashsize,hashmask,hashv(0:),glb_lc(:,:)
!!$ integer, intent(inout) :: x(:)
!!$ end subroutine psi_inner_cnv
!!$ end interface
interface
subroutine psi_compute_size(desc_data,&
& index_in, dl_lda, info)
@@ -256,6 +262,85 @@ module psi_mod
module procedure psi_cnv_dsc
end interface
interface psi_inner_cnv
module procedure psi_inner_cnv1, psi_inner_cnv2
end interface
interface psi_fnd_owner
subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
use psb_descriptor_type
integer, intent(in) :: nv
integer, intent(in) :: idx(:)
integer, allocatable, intent(out) :: iprc(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
end subroutine psi_fnd_owner
end interface
interface psi_ldsc_pre_halo
subroutine psi_ldsc_pre_halo(desc,info)
use psb_descriptor_type
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
end subroutine psi_ldsc_pre_halo
end interface
interface psi_idx_cnv
subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
use psb_descriptor_type
integer, intent(in) :: nv
integer, intent(inout) :: idxin(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: owned
end subroutine psi_idx_cnv1
subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
use psb_descriptor_type
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
logical, intent(in), optional :: owned
end subroutine psi_idx_cnv2
subroutine psi_idx_cnvs(idxin,idxout,desc,info,mask,owned)
use psb_descriptor_type
integer, intent(in) :: idxin
integer, intent(out) :: idxout
type(psb_desc_type), intent(in) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
logical, intent(in), optional :: owned
end subroutine psi_idx_cnvs
end interface
interface psi_idx_ins_cnv
subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
use psb_descriptor_type
integer, intent(in) :: nv
integer, intent(inout) :: idxin(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
end subroutine psi_idx_ins_cnv1
subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
use psb_descriptor_type
integer, intent(in) :: nv, idxin(:)
integer, intent(out) :: idxout(:)
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask(:)
end subroutine psi_idx_ins_cnv2
subroutine psi_idx_ins_cnvs(idxin,idxout,desc,info,mask)
use psb_descriptor_type
integer, intent(in) :: idxin
integer, intent(out) :: idxout
type(psb_desc_type), intent(inout) :: desc
integer, intent(out) :: info
logical, intent(in), optional, target :: mask
end subroutine psi_idx_ins_cnvs
end interface
contains
@@ -362,4 +447,87 @@ contains
end subroutine psi_cnv_dsc
subroutine psi_inner_cnv1(n,x,hashsize,hashmask,hashv,glb_lc)
integer, intent(in) :: n, hashsize,hashmask,hashv(0:),glb_lc(:,:)
integer, intent(inout) :: x(:)
integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
do i=1, n
key = x(i)
ih = iand(key,hashmask)
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
x(i) = glb_lc(tmp,2)
else
x(i) = tmp
end if
end do
end subroutine psi_inner_cnv1
subroutine psi_inner_cnv2(n,x,y,hashsize,hashmask,hashv,glb_lc)
integer, intent(in) :: n, hashsize,hashmask,hashv(0:),glb_lc(:,:)
integer, intent(in) :: x(:)
integer, intent(out) :: y(:)
integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
do i=1, n
key = x(i)
ih = iand(key,hashmask)
if (ih > ubound(hashv,1) ) then
write(0,*) ' In inner cnv: ',ih,ubound(hashv)
call flush(0)
end if
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
y(i) = glb_lc(tmp,2)
else
y(i) = tmp
end if
end do
end subroutine psi_inner_cnv2
end module psi_mod