From 53193622ef8be19286cfd778f7571d71a6e1458a Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 28 Nov 2006 13:54:23 +0000 Subject: [PATCH] Changed realloc and blacs_env IFDEFs. In realloc we now IFDEF on MOVE_ALLOC. Changed descriptor_type to allow for an implementation avoiding GLOB_TO_LOC of size M for very large M. --- src/modules/blacs_env.F90 | 10 +- src/modules/psb_check_mod.f90 | 126 ++--- src/modules/psb_const_mod.f90 | 5 + src/modules/psb_desc_type.f90 | 54 +- src/modules/psb_penv_mod.f90 | 1 - src/modules/psb_prec_mod.f90 | 51 ++ src/modules/psb_prec_type.f90 | 8 +- ...sb_realloc_mod.f90 => psb_realloc_mod.F90} | 460 +++++++++++++++--- src/modules/psb_spmat_type.f90 | 1 - src/modules/psb_tools_mod.f90 | 18 +- src/modules/psi_mod.f90 | 170 ++++++- 11 files changed, 739 insertions(+), 165 deletions(-) rename src/modules/{psb_realloc_mod.f90 => psb_realloc_mod.F90} (69%) diff --git a/src/modules/blacs_env.F90 b/src/modules/blacs_env.F90 index 5f85ea3c..824d50ae 100644 --- a/src/modules/blacs_env.F90 +++ b/src/modules/blacs_env.F90 @@ -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. diff --git a/src/modules/psb_check_mod.f90 b/src/modules/psb_check_mod.f90 index 2e98e5ad..dd532232 100644 --- a/src/modules/psb_check_mod.f90 +++ b/src/modules/psb_check_mod.f90 @@ -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) diff --git a/src/modules/psb_const_mod.f90 b/src/modules/psb_const_mod.f90 index 87d9a2ef..7ede5c7f 100644 --- a/src/modules/psb_const_mod.f90 +++ b/src/modules/psb_const_mod.f90 @@ -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 ! diff --git a/src/modules/psb_desc_type.f90 b/src/modules/psb_desc_type.f90 index b5dee2af..8d8e0ba0 100644 --- a/src/modules/psb_desc_type.f90 +++ b/src/modules/psb_desc_type.f90 @@ -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 diff --git a/src/modules/psb_penv_mod.f90 b/src/modules/psb_penv_mod.f90 index 8596c473..02ff49c8 100644 --- a/src/modules/psb_penv_mod.f90 +++ b/src/modules/psb_penv_mod.f90 @@ -142,7 +142,6 @@ module psb_penv_mod end interface - contains diff --git a/src/modules/psb_prec_mod.f90 b/src/modules/psb_prec_mod.f90 index b3f5d92c..17f25d6b 100644 --- a/src/modules/psb_prec_mod.f90 +++ b/src/modules/psb_prec_mod.f90 @@ -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 diff --git a/src/modules/psb_prec_type.f90 b/src/modules/psb_prec_type.f90 index 1acfd208..022ab03c 100644 --- a/src/modules/psb_prec_type.f90 +++ b/src/modules/psb_prec_type.f90 @@ -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) diff --git a/src/modules/psb_realloc_mod.f90 b/src/modules/psb_realloc_mod.F90 similarity index 69% rename from src/modules/psb_realloc_mod.f90 rename to src/modules/psb_realloc_mod.F90 index a84527cb..46ea9d48 100644 --- a/src/modules/psb_realloc_mod.f90 +++ b/src/modules/psb_realloc_mod.F90 @@ -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 diff --git a/src/modules/psb_spmat_type.f90 b/src/modules/psb_spmat_type.f90 index 300a761b..5389b0bc 100644 --- a/src/modules/psb_spmat_type.f90 +++ b/src/modules/psb_spmat_type.f90 @@ -1556,6 +1556,5 @@ contains end subroutine psb_zspinfo - end module psb_spmat_type diff --git a/src/modules/psb_tools_mod.f90 b/src/modules/psb_tools_mod.f90 index 6fec49cf..158481d6 100644 --- a/src/modules/psb_tools_mod.f90 +++ b/src/modules/psb_tools_mod.f90 @@ -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 diff --git a/src/modules/psi_mod.f90 b/src/modules/psi_mod.f90 index 4f3c47dd..fd500f0a 100644 --- a/src/modules/psi_mod.f90 +++ b/src/modules/psi_mod.f90 @@ -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 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 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