diff --git a/base/internals/psi_bld_tmphalo.f90 b/base/internals/psi_bld_tmphalo.f90 index 87e6a04f..2ae3cef8 100644 --- a/base/internals/psi_bld_tmphalo.f90 +++ b/base/internals/psi_bld_tmphalo.f90 @@ -91,7 +91,7 @@ subroutine psi_bld_tmphalo(desc,info) ! Here we do not know yet who owns what, so we have ! to call fnd_owner. nh = (n_col-n_row) - if (nh > 0) then + if (nh >= 0) then Allocate(helem(nh),stat=info) if (info /= 0) then call psb_errpush(4010,name,a_err='Allocate') diff --git a/base/internals/psi_desc_index.F90 b/base/internals/psi_desc_index.F90 index bd835153..b1d22084 100644 --- a/base/internals/psi_desc_index.F90 +++ b/base/internals/psi_desc_index.F90 @@ -214,15 +214,12 @@ subroutine psi_desc_index(desc,index_in,dep_list,& endif ntot = (3*(count((sdsz>0).or.(rvsz>0)))+ iszs + iszr) + 1 - if (allocated(desc_index)) then - nidx = size(desc_index) - else - nidx = 0 - endif - if (nidx < ntot) then - call psb_realloc(ntot,desc_index,info) + if (ntot > psb_size(desc_index)) then + call psb_realloc(ntot,desc_index,info) endif +!!$ call psb_ensure_size(ntot,desc_index,info) + if (info /= 0) then call psb_errpush(4010,name,a_err='psb_realloc') goto 9999 diff --git a/base/internals/psi_dl_check.f90 b/base/internals/psi_dl_check.f90 index e34a9c2f..49ca6321 100644 --- a/base/internals/psi_dl_check.f90 +++ b/base/internals/psi_dl_check.f90 @@ -66,7 +66,7 @@ subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) outer: do if (i >length_dl(proc)) exit outer proc2=dep_list(i,proc) - if (proc2 /= -1) then + if ((proc2 /= -1).and.(proc2 /= proc)) then ! ...search proc in proc2's dep_list.... j=1 p2loop:do diff --git a/base/internals/psi_inter_desc_index.F90 b/base/internals/psi_inter_desc_index.F90 new file mode 100644 index 00000000..bfb5a639 --- /dev/null +++ b/base/internals/psi_inter_desc_index.F90 @@ -0,0 +1,338 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! +! File: psi_inter_desc_index.f90 +! +! Subroutine: psi_inter_desc_index +! Converts a list of data exchanges from build format to assembled format. +! See below for a description of the formats. +! +! Arguments: +! desc_a - type(psb_desc_type) The descriptor; in this context only the index +! mapping parts are used. +! index_in(:) - integer The index list, build format +! index_out(:) - integer, allocatable The index list, assembled format +! glob_idx - logical Whether the input indices are in local or global +! numbering; the global numbering is used when +! converting the overlap exchange lists. +! nxch - integer The number of data exchanges on the calling process +! nsnd - integer Total send buffer size on the calling process +! nrcv - integer Total receive buffer size on the calling process +! +! The format of the index lists. Copied from base/modules/psb_desc_type +! +! 7. The data exchange is based on lists of local indices to be exchanged; all the +! lists have the same format, as follows: +! the list is composed of variable dimension blocks, one for each process to +! communicate with; each block contains indices of local elements to be +! exchanged. We do choose the order of communications: do not change +! the sequence of blocks unless you know what you're doing, or you'll +! risk a deadlock. NOTE: This is the format when the state is PSB_ASB_. +! See below for BLD. The end-of-list is marked with a -1. +! +! notation stored in explanation +! --------------- --------------------------- ----------------------------------- +! process_id index_v(p+proc_id_) identifier of process with which +! data is exchanged. +! n_elements_recv index_v(p+n_elem_recv_) number of elements to receive. +! elements_recv index_v(p+elem_recv_+i) indexes of local elements to +! receive. these are stored in the +! array from location p+elem_recv_ to +! location p+elem_recv_+ +! index_v(p+n_elem_recv_)-1. +! n_elements_send index_v(p+n_elem_send_) number of elements to send. +! elements_send index_v(p+elem_send_+i) indexes of local elements to +! send. these are stored in the +! array from location p+elem_send_ to +! location p+elem_send_+ +! index_v(p+n_elem_send_)-1. +! +! This organization is valid for both halo and overlap indices; overlap entries +! need to be updated to ensure that a variable at a given global index +! (assigned to multiple processes) has the same value. The way to resolve the +! issue is to exchange the data and then sum (or average) the values. See +! psb_ovrl subroutine. +! +! 8. When the descriptor is in the BLD state the INDEX vectors contains only +! the indices to be received, organized as a sequence +! of entries of the form (proc,N,(lx1,lx2,...,lxn)) with owning process, +! number of indices (most often N=1), list of local indices. +! This is because we only know the list of halo indices to be received +! as we go about building the sparse matrix pattern, and we want the build +! phase to be loosely synchronized. Thus we record the indices we have to ask +! for, and at the time we call PSB_CDASB we match all the requests to figure +! out who should be sending what to whom. +! However this implies that we know who owns the indices; if we are in the +! LARGE case (as described above) this is actually only true for the OVERLAP list +! that is filled in at CDALL time, and not for the HALO; thus the HALO list +! is rebuilt during the CDASB process (in the psi_ldsc_pre_halo subroutine). +! +! +subroutine psi_inter_desc_index(desc,index_in,dep_list,& + & length_dl,nsnd,nrcv,desc_index,isglob_in,info) + use psb_descriptor_type + use psb_realloc_mod + use psb_error_mod + use psb_const_mod +#ifdef MPI_MOD + use mpi +#endif + use psb_penv_mod + use psi_mod, psb_protect_name => psi_inter_desc_index + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + ! ...array parameters..... + type(psb_desc_type) :: desc + integer :: index_in(:),dep_list(:) + integer,allocatable :: desc_index(:) + integer :: length_dl,nsnd,nrcv,info + logical :: isglob_in + ! ....local scalars... + integer :: j,me,np,i,proc + ! ...parameters... + integer :: ictxt + integer, parameter :: no_comm=-1 + ! ...local arrays.. + integer,allocatable :: brvindx(:),rvsz(:),& + & bsdindx(:),sdsz(:), sndbuf(:), rcvbuf(:) + + integer :: ihinsz,ntot,k,err_act,nidx,& + & idxr, idxs, iszs, iszr, nesd, nerv, icomm + + logical,parameter :: usempi=.true. + integer :: debug_level, debug_unit + character(len=20) :: name + + info = 0 + name='psi_inter_desc_index' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc) + icomm = psb_cd_get_mpic(desc) + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': start' + call psb_barrier(ictxt) + endif + + ! + ! first, find out the sizes to be exchanged. + ! note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things + ! to be received/sent (in the final psblas descriptor). + ! be careful of the inversion + ! + allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info) + if(info /= 0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + + sdsz(:) = 0 + rvsz(:) = 0 + bsdindx(:) = 0 + brvindx(:) = 0 + i = 1 + do + if (index_in(i) == -1) exit + proc = index_in(i) + i = i + 1 + nerv = index_in(i) + sdsz(proc+1) = sdsz(proc+1) + nerv + i = i + nerv + 1 + end do + ihinsz=i + call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mpi_alltoall') + goto 9999 + end if + + i = 1 + idxs = 0 + idxr = 0 + do i=1, length_dl + proc = dep_list(i) + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + end do + iszs = sum(sdsz) + iszr = sum(rvsz) + nsnd = iszr + nrcv = iszs + + if ((iszs /= idxs).or.(iszr /= idxr)) then + write(0,*) 'strange results?', iszs,idxs,iszr,idxr + end if + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': computed sizes ',iszr,iszs + call psb_barrier(ictxt) + endif + + ntot = (3*(count((sdsz>0).or.(rvsz>0)))+ iszs + iszr) + 1 + if (allocated(desc_index)) then + nidx = size(desc_index) + else + nidx = 0 + endif + + if (nidx < ntot) then + call psb_realloc(ntot,desc_index,info) + endif + if (info /= 0) then + call psb_errpush(4010,name,a_err='psb_realloc') + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': computed allocated workspace ',iszr,iszs + call psb_barrier(ictxt) + endif + allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) + if(info /= 0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + + ! + ! Second build the lists of requests + ! + i = 1 + do + if (i > ihinsz) then + write(0,*) me,' did not find index_in end??? ',i,ihinsz + exit + end if + if (index_in(i) == -1) exit + proc = index_in(i) + i = i + 1 + nerv = index_in(i) + ! + ! note that here bsdinx is zero-based, hence the following loop + ! + if (isglob_in) then + do j=1, nerv + sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) + end do + else + + do j=1, nerv + sndbuf(bsdindx(proc+1)+j) = desc%loc_to_glob(index_in(i+j)) + end do + endif + bsdindx(proc+1) = bsdindx(proc+1) + nerv + i = i + nerv + 1 + end do + + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': prepared send buffer ' + call psb_barrier(ictxt) + endif + ! + ! now have to regenerate bsdindx + ! + idxs = 0 + idxr = 0 + do i=1, length_dl + proc = dep_list(i) + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + end do + + call mpi_alltoallv(sndbuf,sdsz,bsdindx,mpi_integer,& + & rcvbuf,rvsz,brvindx,mpi_integer,icomm,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='mpi_alltoallv') + goto 9999 + end if + + ! + ! at this point we can finally build the output desc_index. beware + ! of snd/rcv inversion. + ! + i = 1 + do k = 1, length_dl + proc = dep_list(k) + desc_index(i) = proc + i = i + 1 + nerv = sdsz(proc+1) + desc_index(i) = nerv + call psi_idx_cnv(nerv,sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& + & desc_index(i+1:i+nerv),desc,info) + i = i + nerv + 1 + nesd = rvsz(proc+1) + desc_index(i) = nesd + call psi_idx_cnv(nesd,rcvbuf(brvindx(proc+1)+1:brvindx(proc+1)+nesd),& + & desc_index(i+1:i+nesd),desc,info) + i = i + nesd + 1 + end do + desc_index(i) = - 1 + + deallocate(sdsz,rvsz,bsdindx,brvindx,sndbuf,rcvbuf,stat=info) + if (info /= 0) then + info=4000 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) me,' ',trim(name),': done' + call psb_barrier(ictxt) + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + return +end subroutine psi_inter_desc_index diff --git a/base/modules/Makefile b/base/modules/Makefile index 33d75436..22998afd 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -27,9 +27,9 @@ psb_realloc_mod.o : psb_error_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o psb_error_mod.o: psb_const_mod.o psb_penv_mod.o: psb_const_mod.o psb_error_mod.o psb_realloc_mod.o -psi_serial_mod.o: psb_const_mod.o +psi_serial_mod.o: psb_const_mod.o psb_realloc_mod.o psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o psi_serial_mod.o -psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o +psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o psb_inter_desc_type.o: psb_desc_type.o psb_spmat_type.o psb_error_mod.o psb_serial_mod.o psb_comm_mod.o psb_check_mod.o: psb_desc_type.o psb_serial_mod.o: psb_spmat_type.o psb_string_mod.o psb_sort_mod.o psi_serial_mod.o diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index f38020f6..41996387 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -61,7 +61,7 @@ module psb_descriptor_type integer, parameter :: psb_map_asov_ = psb_map_xhal_+1 integer, parameter :: psb_map_aggr_ = psb_map_asov_+1 integer, parameter :: psb_map_gen_linear_ = psb_map_aggr_+1 - + integer, parameter :: psb_ovt_xhal_ = psb_map_xhal_, psb_ovt_asov_=psb_map_asov_ ! ! Entries and values in desc%matrix_data @@ -112,8 +112,8 @@ module psb_descriptor_type integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1 integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 integer, parameter :: psb_n_dom_ovr_=1 - - + + ! ! type: psb_desc_type ! @@ -288,19 +288,19 @@ module psb_descriptor_type ! ! type psb_desc_type - integer, allocatable :: matrix_data(:) - integer, allocatable :: halo_index(:) - integer, allocatable :: ext_index(:) - integer, allocatable :: ovrlap_index(:) - integer, allocatable :: ovrlap_elem(:,:) - integer, allocatable :: ovr_mst_idx(:) - integer, allocatable :: bnd_elem(:) - integer, allocatable :: loc_to_glob(:) - integer, allocatable :: glob_to_loc (:) - integer, allocatable :: hashv(:), glb_lc(:,:), ptree(:) - integer, allocatable :: lprm(:) - integer, allocatable :: idx_space(:) - type(psb_desc_type), pointer :: base_desc => null() + integer, allocatable :: matrix_data(:) + integer, allocatable :: halo_index(:) + integer, allocatable :: ext_index(:) + integer, allocatable :: ovrlap_index(:) + integer, allocatable :: ovrlap_elem(:,:) + integer, allocatable :: ovr_mst_idx(:) + integer, allocatable :: bnd_elem(:) + integer, allocatable :: loc_to_glob(:) + integer, allocatable :: glob_to_loc (:) + integer, allocatable :: hashv(:), glb_lc(:,:), ptree(:) + integer, allocatable :: lprm(:) + integer, allocatable :: idx_space(:) + type(psb_desc_type), pointer :: base_desc => null() end type psb_desc_type interface psb_sizeof @@ -330,9 +330,39 @@ module psb_descriptor_type interface psb_is_large_desc module procedure psb_is_large_desc end interface - - + + interface psb_cdcpy + module procedure psb_cdcpy +!!$ subroutine psb_cdcpy(desc_in, desc_out, info) +!!$ use psb_descriptor_type +!!$ type(psb_desc_type), intent(in) :: desc_in +!!$ type(psb_desc_type), intent(out) :: desc_out +!!$ integer, intent(out) :: info +!!$ end subroutine psb_cdcpy + end interface + + interface psb_cdtransfer + module procedure psb_cdtransfer +!!$ 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(inout) :: desc_out +!!$ integer, intent(out) :: info +!!$ end subroutine psb_cdtransfer + end interface + + + interface psb_cdfree + module procedure psb_cdfree +!!$ subroutine psb_cdfree(desc_a,info) +!!$ use psb_descriptor_type +!!$ type(psb_desc_type), intent(inout) :: desc_a +!!$ integer, intent(out) :: info +!!$ end subroutine psb_cdfree + end interface + + integer, private, save :: cd_large_threshold=psb_default_large_threshold @@ -364,10 +394,10 @@ contains if (allocated(desc%idx_space)) val = val + 4*size(desc%idx_space) if (allocated(desc%ptree)) val = val + 4*size(desc%ptree) +& & SizeofPairSearchTree(desc%ptree) - + psb_cd_sizeof = val end function psb_cd_sizeof - + subroutine psb_cd_set_large_threshold(ith) @@ -399,7 +429,7 @@ contains & (m > psb_cd_get_large_threshold()) .and. & & (np > 2) end function psb_cd_choose_large_state - + subroutine psb_nullify_desc(desc) type(psb_desc_type), intent(inout) :: desc ! We have nothing left to do here. @@ -503,7 +533,7 @@ contains integer function psb_cd_get_local_cols(desc) type(psb_desc_type), intent(in) :: desc - + if (psb_is_ok_desc(desc)) then psb_cd_get_local_cols = desc%matrix_data(psb_n_col_) else @@ -513,7 +543,7 @@ contains integer function psb_cd_get_global_rows(desc) type(psb_desc_type), intent(in) :: desc - + if (psb_is_ok_desc(desc)) then psb_cd_get_global_rows = desc%matrix_data(psb_m_) else @@ -524,7 +554,7 @@ contains integer function psb_cd_get_global_cols(desc) type(psb_desc_type), intent(in) :: desc - + if (psb_is_ok_desc(desc)) then psb_cd_get_global_cols = desc%matrix_data(psb_n_) else @@ -543,13 +573,12 @@ contains call psb_errpush(1122,'psb_cd_get_context') call psb_error() end if - end function psb_cd_get_context integer function psb_cd_get_dectype(desc) use psb_error_mod type(psb_desc_type), intent(in) :: desc - + if (allocated(desc%matrix_data)) then psb_cd_get_dectype = desc%matrix_data(psb_dec_type_) else @@ -563,7 +592,7 @@ contains integer function psb_cd_get_size(desc) use psb_error_mod type(psb_desc_type), intent(in) :: desc - + if (allocated(desc%matrix_data)) then psb_cd_get_size = desc%matrix_data(psb_desc_size_) else @@ -577,6 +606,7 @@ contains integer function psb_cd_get_mpic(desc) use psb_error_mod type(psb_desc_type), intent(in) :: desc + if (allocated(desc%matrix_data)) then psb_cd_get_mpic = desc%matrix_data(psb_mpi_c_) else @@ -617,6 +647,9 @@ contains ! check on blacs grid call psb_info(ictxt, me, np) if (debug) write(0,*) me,'Entered CDSETBLD' + if (psb_is_asb_desc(desc)) then +!!$ write(0,*) 'Warning: doing setbld on an assembled descriptor' + end if if (psb_is_large_desc(desc)) then if (debug) write(0,*) me,'SET_BLD: alocating ptree' @@ -660,7 +693,7 @@ contains type(psb_desc_type), intent(inout) :: desc integer :: info - + if (psb_is_asb_desc(desc)) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_asb_ end subroutine psb_cd_set_ovl_asb @@ -676,8 +709,8 @@ contains if (info == 0) desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_ end subroutine psb_cd_set_ovl_bld - - + + subroutine psb_get_xch_idx(idx,totxch,totsnd,totrcv) implicit none integer, intent(in) :: idx(:) @@ -706,7 +739,7 @@ contains end do end subroutine psb_get_xch_idx - + subroutine psb_cd_get_list(data,desc,ipnt,totxch,idxr,idxs,info) @@ -757,7 +790,7 @@ contains goto 9999 end select call psb_get_xch_idx(ipnt,totxch,idxs,idxr) - + call psb_erractionrestore(err_act) return @@ -773,5 +806,558 @@ contains return end subroutine psb_cd_get_list + ! + ! Subroutine: psb_cdfree + ! Frees a descriptor data structure. + ! + ! Arguments: + ! desc_a - type(psb_desc_type). The communication descriptor to be freed. + ! info - integer. return code. + subroutine psb_cdfree(desc_a,info) + !...free descriptor structure... + use psb_const_mod + use psb_error_mod + use psb_penv_mod + implicit none + !....parameters... + type(psb_desc_type), intent(inout) :: desc_a + integer, intent(out) :: info + !...locals.... + integer :: ictxt,np,me, err_act + character(len=20) :: name + + if(psb_get_errstatus() /= 0) return + info=0 + call psb_erractionsave(err_act) + name = 'psb_cdfree' + + + if (.not.allocated(desc_a%matrix_data)) then + info=295 + call psb_errpush(info,name) + return + end if + + ictxt=psb_cd_get_context(desc_a) + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + !...deallocate desc_a.... + if(.not.allocated(desc_a%loc_to_glob)) then + info=296 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate loc_to_glob field + deallocate(desc_a%loc_to_glob,stat=info) + if (info /= 0) then + info=2051 + call psb_errpush(info,name) + goto 9999 + end if + + if (.not.psb_is_large_desc(desc_a)) then + if (.not.allocated(desc_a%glob_to_loc)) then + info=297 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate glob_to_loc field + deallocate(desc_a%glob_to_loc,stat=info) + if (info /= 0) then + info=2052 + call psb_errpush(info,name) + goto 9999 + end if + endif + + if (.not.allocated(desc_a%halo_index)) then + info=298 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate halo_index field + deallocate(desc_a%halo_index,stat=info) + if (info /= 0) then + info=2053 + call psb_errpush(info,name) + goto 9999 + end if + + if (.not.allocated(desc_a%bnd_elem)) then +!!$ info=296 +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if + else + !deallocate halo_index field + deallocate(desc_a%bnd_elem,stat=info) + if (info /= 0) then + info=2054 + call psb_errpush(info,name) + goto 9999 + end if + end if + + if (.not.allocated(desc_a%ovrlap_index)) then + info=299 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate ovrlap_index field + deallocate(desc_a%ovrlap_index,stat=info) + if (info /= 0) then + info=2055 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate ovrlap_elem field + deallocate(desc_a%ovrlap_elem,stat=info) + if (info /= 0) then + info=2056 + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate ovrlap_index field + deallocate(desc_a%ovr_mst_idx,stat=info) + if (info /= 0) then + info=2055 + call psb_errpush(info,name) + goto 9999 + end if + + + deallocate(desc_a%lprm,stat=info) + if (info /= 0) then + info=2057 + call psb_errpush(info,name) + goto 9999 + end if + + if (allocated(desc_a%hashv)) then + deallocate(desc_a%hashv,stat=info) + if (info /= 0) then + info=2058 + call psb_errpush(info,name) + goto 9999 + end if + end if + + if (allocated(desc_a%glb_lc)) then + deallocate(desc_a%glb_lc,stat=info) + if (info /= 0) then + info=2059 + call psb_errpush(info,name) + goto 9999 + end if + end if + + if (allocated(desc_a%ptree)) then + call FreePairSearchTree(desc_a%ptree) + deallocate(desc_a%ptree,stat=info) + if (info /= 0) then + info=2059 + call psb_errpush(info,name) + goto 9999 + end if + end if + + + + if (allocated(desc_a%idx_space)) then + deallocate(desc_a%idx_space,stat=info) + if (info /= 0) then + info=2056 + call psb_errpush(info,name) + goto 9999 + end if + end if + + deallocate(desc_a%matrix_data) + + call psb_nullify_desc(desc_a) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + + end subroutine psb_cdfree + ! + ! Subroutine: psb_cdcpy + ! Produces a clone of a descriptor. + ! + ! Arguments: + ! desc_in - type(psb_desc_type). The communication descriptor to be cloned. + ! desc_out - type(psb_desc_type). The output communication descriptor. + ! info - integer. Return code. + subroutine psb_cdcpy(desc_in, desc_out, info) + + use psb_realloc_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + + implicit none + !....parameters... + + type(psb_desc_type), intent(in) :: desc_in + type(psb_desc_type), intent(out) :: desc_out + integer, intent(out) :: info + + !locals + integer :: np,me,ictxt, err_act + integer :: debug_level, debug_unit + character(len=20) :: name + + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (psb_get_errstatus() /= 0) return + info = 0 + call psb_erractionsave(err_act) + name = 'psb_cdcpy' + + ictxt = psb_cd_get_context(desc_in) + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Entered' + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + call psb_safe_ab_cpy(desc_in%matrix_data,desc_out%matrix_data,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%halo_index,desc_out%halo_index,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%ext_index,desc_out%ext_index,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%ovrlap_index,desc_out%ovrlap_index,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%ovr_mst_idx,desc_out%ovr_mst_idx,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%loc_to_glob,desc_out%loc_to_glob,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%glob_to_loc,desc_out%glob_to_loc,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%lprm,desc_out%lprm,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%hashv,desc_out%hashv,info) + if (info == 0) call psb_safe_ab_cpy(desc_in%glb_lc,desc_out%glb_lc,info) + + if (info == 0) then + if (allocated(desc_in%ptree)) then + allocate(desc_out%ptree(2),stat=info) + if (info /= 0) then + info=4000 + goto 9999 + endif + call ClonePairSearchTree(desc_in%ptree,desc_out%ptree) + end if + end if + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name) + goto 9999 + endif + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': Done' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + + end subroutine psb_cdcpy + ! + ! Subroutine: psb_cdtransfer + ! Transfers data and allocation from in to out; behaves like MOVE_ALLOC, i.e. + ! the IN arg is empty (and deallocated) upon exit. + ! + ! + ! Arguments: + ! desc_in - type(psb_desc_type). The communication descriptor to be + ! transferred. + ! desc_out - type(psb_desc_type). The output communication descriptor. + ! info - integer. Return code. + subroutine psb_cdtransfer(desc_in, desc_out, info) + + use psb_realloc_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + + implicit none + !....parameters... + + type(psb_desc_type), intent(inout) :: desc_in + type(psb_desc_type), intent(inout) :: desc_out + integer, intent(out) :: info + + !locals + integer :: np,me,ictxt, err_act + integer :: debug_level, debug_unit + character(len=20) :: name + + if (psb_get_errstatus()/=0) return + info = 0 + call psb_erractionsave(err_act) + name = 'psb_cdtransfer' + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=psb_cd_get_context(desc_in) + + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': start.' + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + call psb_transfer( desc_in%matrix_data , desc_out%matrix_data , info) + if (info == 0) & + & call psb_transfer( desc_in%halo_index , desc_out%halo_index , info) + if (info == 0) & + & call psb_transfer( desc_in%bnd_elem , desc_out%bnd_elem , info) + if (info == 0) & + & call psb_transfer( desc_in%ovrlap_elem , desc_out%ovrlap_elem , info) + if (info == 0) & + & call psb_transfer( desc_in%ovrlap_index, desc_out%ovrlap_index , info) + if (info == 0) & + & call psb_transfer( desc_in%ovr_mst_idx , desc_out%ovr_mst_idx , info) + if (info == 0) & + & call psb_transfer( desc_in%ext_index , desc_out%ext_index , info) + if (info == 0) & + & call psb_transfer( desc_in%loc_to_glob , desc_out%loc_to_glob , info) + if (info == 0) & + & call psb_transfer( desc_in%glob_to_loc , desc_out%glob_to_loc , info) + if (info == 0) & + & call psb_transfer( desc_in%lprm , desc_out%lprm , info) + if (info == 0) & + & call psb_transfer( desc_in%idx_space , desc_out%idx_space , info) + if (info == 0) & + & call psb_transfer( desc_in%hashv , desc_out%hashv , info) + if (info == 0) & + & call psb_transfer( desc_in%glb_lc , desc_out%glb_lc , info) + if (info == 0) & + & call psb_transfer( desc_in%ptree , desc_out%ptree , info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name) + goto 9999 + endif + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + + end subroutine psb_cdtransfer + + + + Subroutine psb_cd_get_recv_idx(tmp,desc,data,info,toglob) + + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + Implicit None + integer, allocatable, intent(out) :: tmp(:) + integer, intent(in) :: data + Type(psb_desc_type), Intent(in), target :: desc + integer, intent(out) :: info + logical, intent(in) :: toglob + + ! .. Local Scalars .. + Integer :: incnt, outcnt, j, np, me, ictxt, l_tmp,& + & idx, gidx, proc, n_elem_send, n_elem_recv + Integer, pointer :: idxlist(:) + integer :: debug_level, debug_unit, err_act + character(len=20) :: name + + name = 'psb_cd_get_recv_idx' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc) + call psb_info(ictxt, me, np) + + select case(data) + case(psb_comm_halo_) + idxlist => desc%halo_index + case(psb_comm_ovr_) + idxlist => desc%ovrlap_index + case(psb_comm_ext_) + idxlist => desc%ext_index + case(psb_comm_mov_) + idxlist => desc%ovr_mst_idx + write(0,*) 'Warning: unusual request getidx on ovr_mst_idx' + case default + info=4010 + call psb_errpush(info,name,a_err='wrong Data selector') + goto 9999 + end select + + l_tmp = 3*size(idxlist) + + allocate(tmp(l_tmp),stat=info) + if (info /= 0) then + info = 4010 + call psb_errpush(4010,name,a_err='Allocate') + goto 9999 + end if + + incnt = 1 + outcnt = 1 + tmp(:) = -1 + Do While (idxlist(incnt) /= -1) + proc = idxlist(incnt+psb_proc_id_) + n_elem_recv = idxlist(incnt+psb_n_elem_recv_) + n_elem_send = idxlist(incnt+n_elem_recv+psb_n_elem_send_) + + Do j=0,n_elem_recv-1 + idx = idxlist(incnt+psb_elem_recv_+j) + call psb_ensure_size((outcnt+3),tmp,info,pad=-1) + if (info /= 0) then + info=4010 + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + if (toglob) then + If(idx > Size(desc%loc_to_glob)) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + gidx = desc%loc_to_glob(idx) + tmp(outcnt) = proc + tmp(outcnt+1) = 1 + tmp(outcnt+2) = gidx + tmp(outcnt+3) = -1 + else + tmp(outcnt) = proc + tmp(outcnt+1) = 1 + tmp(outcnt+2) = idx + tmp(outcnt+3) = -1 + end if + outcnt = outcnt+3 + end Do + incnt = incnt+n_elem_recv+n_elem_send+3 + end Do + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + Return + + end Subroutine psb_cd_get_recv_idx + + Subroutine psb_cd_reinit(desc,info) + + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + Implicit None + + ! .. Array Arguments .. + Type(psb_desc_type), Intent(inout) :: desc + integer, intent(out) :: info + + integer icomm, err_act + + ! .. Local Scalars .. + Integer :: np, me, ictxt + Integer, allocatable :: tmp_halo(:),tmp_ext(:), tmp_ovr(:) + integer :: debug_level, debug_unit + character(len=20) :: name, ch_err + + name='psb_cd_reinit' + info = 0 + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc) + icomm = psb_cd_get_mpic(desc) + Call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': start' + + call psb_cd_get_recv_idx(tmp_ovr,desc,psb_comm_ovr_,info,toglob=.true.) + call psb_cd_get_recv_idx(tmp_halo,desc,psb_comm_halo_,info,toglob=.false.) + call psb_cd_get_recv_idx(tmp_ext,desc,psb_comm_ext_,info,toglob=.false.) + + call psb_transfer(tmp_ovr,desc%ovrlap_index,info) + call psb_transfer(tmp_halo,desc%halo_index,info) + call psb_transfer(tmp_ext,desc%ext_index,info) + call psb_cd_set_bld(desc,info) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error(ictxt) + return + end if + Return + + End Subroutine psb_cd_reinit + + end module psb_descriptor_type diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index d330b267..d96be34a 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -85,7 +85,7 @@ module psb_error_mod type(psb_errstack), save :: error_stack ! the PSBLAS-2.0 error stack integer, save :: error_status=0 ! the error status (maybe not here) integer, save :: verbosity_level=1 ! the verbosity level (maybe not here) - integer, save :: err_action=1 + integer, save :: err_action=psb_act_abort_ integer, save :: debug_level=0, debug_unit=0, serial_debug_level=0 contains diff --git a/base/modules/psb_inter_desc_type.f90 b/base/modules/psb_inter_desc_type.f90 index 7d121889..f7f85465 100644 --- a/base/modules/psb_inter_desc_type.f90 +++ b/base/modules/psb_inter_desc_type.f90 @@ -65,7 +65,8 @@ module psb_inter_descriptor_type type psb_inter_desc_type integer, allocatable :: itd_data(:) type(psb_desc_type), pointer :: desc_1=>null(), desc_2=>null() - integer, allocatable :: exch_fw_idx(:), exch_bk_idx(:) + integer, allocatable :: exch_fw_idx(:), exch_bk_idx(:) + type(psb_desc_type) :: desc_ext_1, desc_ext_2 type(psb_d_map_type) :: dmap type(psb_z_map_type) :: zmap end type psb_inter_desc_type @@ -245,12 +246,14 @@ contains if (allocated(desc%itd_data)) val = val + 4*size(desc%itd_data) if (allocated(desc%exch_fw_idx)) val = val + 4*size(desc%exch_fw_idx) if (allocated(desc%exch_bk_idx)) val = val + 4*size(desc%exch_bk_idx) + val = val + psb_sizeof(desc%desc_ext_1) + val = val + psb_sizeof(desc%desc_ext_2) val = val + psb_sizeof(desc%dmap) val = val + psb_sizeof(desc%zmap) psb_itd_sizeof = val end function psb_itd_sizeof - function psb_d_inter_desc(map_kind,desc1, desc2, map_fw, map_bk, idx_fw, idx_bk) + function psb_d_inter_desc(map_kind,desc1,desc2,map_fw,map_bk,idx_fw,idx_bk) use psb_serial_mod use psi_mod implicit none @@ -313,7 +316,7 @@ contains case (psb_map_aggr_) ! OK case default - write(0,*) 'Bad mapp kind into psb_inter_desc ',map_kind + write(0,*) 'Bad map kind into psb_inter_desc ',map_kind info = 1 end select @@ -409,7 +412,7 @@ contains case (psb_map_aggr_) ! OK case default - write(0,*) 'Bad mapp kind into psb_inter_desc ',map_kind + write(0,*) 'Bad map kind into psb_inter_desc ',map_kind info = 1 end select @@ -487,7 +490,8 @@ contains select case(map_kind) case(psb_map_aggr_) - ! Ok, we just need to call a halo update and a matrix-vector product. + ! Ok, we just need to call a halo update on the base desc + ! and a matrix-vector product. call psb_halo(x,desc%desc_1,info,work=work) if (info == 0) call psb_csmm(alpha,desc%dmap%map_fw,x,beta,y,info) @@ -495,6 +499,15 @@ contains write(0,*) trim(name),' Error from inner routines',info info = -1 end if + + case(psb_map_gen_linear_) + call psb_halo(x,desc%desc_ext_1,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%dmap%map_fw,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if case default @@ -557,6 +570,15 @@ contains info = -1 end if + + case(psb_map_gen_linear_) + call psb_halo(x,desc%desc_ext_2,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%dmap%map_bk,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if case default write(0,*) trim(name),' Invalid descriptor inupt' @@ -618,6 +640,14 @@ contains info = -1 end if + case(psb_map_gen_linear_) + call psb_halo(x,desc%desc_ext_1,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%zmap%map_fw,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if case default write(0,*) trim(name),' Invalid descriptor inupt' @@ -679,6 +709,15 @@ contains info = -1 end if + + case(psb_map_gen_linear_) + call psb_halo(x,desc%desc_ext_2,info,work=work) + if (info == 0) call psb_csmm(alpha,desc%zmap%map_bk,x,beta,y,info) + + if (info /= 0) then + write(0,*) trim(name),' Error from inner routines',info + info = -1 + end if case default write(0,*) trim(name),' Invalid descriptor inupt' diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index 73d16070..9f29e799 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -102,7 +102,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 if (allocated(vin)) then isz = size(vin) @@ -149,7 +152,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 if (allocated(vin)) then isz1 = size(vin,1) @@ -198,7 +204,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 if (allocated(vin)) then isz = size(vin) @@ -245,7 +254,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 if (allocated(vin)) then isz1 = size(vin,1) @@ -294,7 +306,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 if (allocated(vin)) then isz = size(vin) @@ -341,7 +356,10 @@ Contains name='psb_safe_ab_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 if (allocated(vin)) then isz1 = size(vin,1) @@ -391,7 +409,10 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 isz = size(vin) lb = lbound(vin,1) @@ -436,7 +457,10 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 isz1 = size(vin,1) isz2 = size(vin,2) @@ -483,7 +507,10 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 isz = size(vin) lb = lbound(vin,1) @@ -528,7 +555,11 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if + info = 0 isz1 = size(vin,1) isz2 = size(vin,2) @@ -575,7 +606,10 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 isz = size(vin) lb = lbound(vin,1) @@ -620,7 +654,10 @@ Contains name='psb_safe_cpy' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info = 0 isz1 = size(vin,1) isz2 = size(vin,2) @@ -757,7 +794,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info=0 If (len > psb_size(v)) Then @@ -813,7 +853,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info=0 If (len > psb_size(v)) Then @@ -869,7 +912,10 @@ Contains name='psb_ensure_size' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info=0 If (len > psb_size(v)) Then @@ -926,7 +972,10 @@ Contains call psb_erractionsave(err_act) if (debug) write(0,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info=0 if (present(lb)) then lb_ = lb @@ -1424,7 +1473,10 @@ Contains name='psb_dreallocate2i' call psb_erractionsave(err_act) - if(psb_get_errstatus() /= 0) return + if(psb_get_errstatus() /= 0) then + info = 4010 + goto 9999 + end if info=0 call psb_dreallocate1i(len,rrax,info,pad=pad) if (info /= 0) then diff --git a/base/modules/psb_spmat_type.f90 b/base/modules/psb_spmat_type.f90 index cbadf743..45c977ca 100644 --- a/base/modules/psb_spmat_type.f90 +++ b/base/modules/psb_spmat_type.f90 @@ -435,11 +435,12 @@ contains INFO = 0 call psb_nullify_sp(a) nnz = 2*max(1,m,k) - if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k a%m=max(0,m) a%k=max(0,k) + if (debug) write(0,*) 'SPALL : NNZ ',nnz,a%m,a%k call psb_sp_reall(a,nnz,info) - + if (debug) write(0,*) 'Check in ALLOCATE ',info,allocated(a%pl),allocated(a%pr) + if (info /= 0) return a%pl(:)=0 a%pr(:)=0 ! set INFOA fields diff --git a/base/modules/psb_tools_mod.f90 b/base/modules/psb_tools_mod.f90 index 4c2239a0..6826f673 100644 --- a/base/modules/psb_tools_mod.f90 +++ b/base/modules/psb_tools_mod.f90 @@ -295,41 +295,22 @@ Module psb_tools_mod module procedure psb_cdasb end interface - interface psb_cdcpy - subroutine psb_cdcpy(desc_in, desc_out, info) - use psb_descriptor_type - type(psb_desc_type), intent(in) :: desc_in - type(psb_desc_type), intent(out) :: desc_out - integer, intent(out) :: info - end subroutine psb_cdcpy - end interface - - interface psb_cdtransfer - 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(inout) :: desc_out - integer, intent(out) :: info - end subroutine psb_cdtransfer - end interface - - - interface psb_cdfree - subroutine psb_cdfree(desc_a,info) - use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(out) :: info - end subroutine psb_cdfree - end interface - interface psb_cdins - subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) + subroutine psb_cdinsrc(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(out) :: info integer, optional, intent(out) :: ila(:), jla(:) - end subroutine psb_cdins + end subroutine psb_cdinsrc + subroutine psb_cdinsc(nz,ja,desc,info,jla,mask) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc + integer, intent(in) :: nz,ja(:) + integer, intent(out) :: info + integer, optional, intent(out) :: jla(:) + logical, optional, target, intent(in) :: mask(:) + end subroutine psb_cdinsc end interface @@ -354,13 +335,23 @@ Module psb_tools_mod integer, intent(out) :: info integer, intent(in),optional :: extype end Subroutine psb_zcdbldext + Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) + use psb_descriptor_type + Implicit None + Type(psb_desc_type), Intent(in), target :: desc_a + integer, intent(in) :: in_list(:) + Type(psb_desc_type), Intent(out) :: desc_ov + integer, intent(out) :: info + logical, intent(in), optional, target :: mask(:) + integer, intent(in),optional :: extype + end Subroutine psb_cd_lstext end interface interface psb_cdren subroutine psb_cdren(trans,iperm,desc_a,info) use psb_descriptor_type - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(inout) :: iperm(:) + type(psb_desc_type), intent(inout) :: desc_a + integer, intent(inout) :: iperm(:) character, intent(in) :: trans integer, intent(out) :: info end subroutine psb_cdren @@ -579,7 +570,7 @@ contains end subroutine psb_get_boundary - subroutine psb_cdall(ictxt, desc_a, info,mg,ng,parts,vg,vl,flag,nl,repl) + subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl) use psb_descriptor_type use psb_serial_mod use psb_const_mod @@ -591,36 +582,36 @@ contains integer, intent(in) :: flag logical, intent(in) :: repl integer, intent(out) :: info - type(psb_desc_type), intent(out) :: desc_a + type(psb_desc_type), intent(out) :: desc optional :: mg,ng,parts,vg,vl,flag,nl,repl interface - subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) + subroutine psb_cdals(m, n, parts, ictxt, desc, info) use psb_descriptor_type include 'parts.fh' Integer, intent(in) :: m,n,ictxt - Type(psb_desc_type), intent(out) :: desc_a + Type(psb_desc_type), intent(out) :: desc integer, intent(out) :: info end subroutine psb_cdals - subroutine psb_cdalv(v, ictxt, desc_a, info, flag) + subroutine psb_cdalv(v, ictxt, desc, info, flag) use psb_descriptor_type Integer, intent(in) :: ictxt, v(:) integer, intent(in), optional :: flag integer, intent(out) :: info - Type(psb_desc_type), intent(out) :: desc_a + Type(psb_desc_type), intent(out) :: desc end subroutine psb_cdalv - subroutine psb_cd_inloc(v, ictxt, desc_a, info) + subroutine psb_cd_inloc(v, ictxt, desc, info) use psb_descriptor_type implicit None Integer, intent(in) :: ictxt, v(:) integer, intent(out) :: info - type(psb_desc_type), intent(out) :: desc_a + type(psb_desc_type), intent(out) :: desc end subroutine psb_cd_inloc - subroutine psb_cdrep(m, ictxt, desc_a,info) + subroutine psb_cdrep(m, ictxt, desc,info) use psb_descriptor_type Integer, intent(in) :: m,ictxt - Type(psb_desc_type), intent(out) :: desc_a + Type(psb_desc_type), intent(out) :: desc integer, intent(out) :: info end subroutine psb_cdrep end interface @@ -630,7 +621,7 @@ contains - if(psb_get_errstatus() /= 0) return + if (psb_get_errstatus() /= 0) return info=0 name = 'psb_cdall' call psb_erractionsave(err_act) @@ -644,7 +635,7 @@ contains goto 999 endif - desc_a%base_desc => null() + desc%base_desc => null() if (present(parts)) then if (.not.present(mg)) then @@ -657,7 +648,7 @@ contains else n_ = mg endif - call psb_cdals(mg, n_, parts, ictxt, desc_a, info) + call psb_cdals(mg, n_, parts, ictxt, desc, info) else if (present(repl)) then if (.not.present(mg)) then @@ -670,7 +661,7 @@ contains call psb_errpush(info,name) goto 999 end if - call psb_cdrep(mg, ictxt, desc_a, info) + call psb_cdrep(mg, ictxt, desc, info) else if (present(vg)) then if (present(flag)) then @@ -678,10 +669,10 @@ contains else flag_=0 endif - call psb_cdalv(vg, ictxt, desc_a, info, flag=flag_) + call psb_cdalv(vg, ictxt, desc, info, flag=flag_) else if (present(vl)) then - call psb_cd_inloc(vl,ictxt,desc_a,info) + call psb_cd_inloc(vl,ictxt,desc,info) else if (present(nl)) then allocate(itmpsz(0:np-1),stat=info) @@ -698,10 +689,12 @@ contains do i=0, me-1 nlp = nlp + itmpsz(i) end do - call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc_a,info) + call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc,info) endif + if (info /= 0) goto 999 + call psb_erractionrestore(err_act) return @@ -716,22 +709,22 @@ contains end subroutine psb_cdall - subroutine psb_cdasb(desc_a,info) + subroutine psb_cdasb(desc,info) use psb_descriptor_type interface - subroutine psb_icdasb(desc_a,info,ext_hv) + subroutine psb_icdasb(desc,info,ext_hv) use psb_descriptor_type - Type(psb_desc_type), intent(inout) :: desc_a + Type(psb_desc_type), intent(inout) :: desc integer, intent(out) :: info logical, intent(in),optional :: ext_hv end subroutine psb_icdasb end interface - Type(psb_desc_type), intent(inout) :: desc_a + Type(psb_desc_type), intent(inout) :: desc integer, intent(out) :: info - call psb_icdasb(desc_a,info,ext_hv=.false.) + call psb_icdasb(desc,info,ext_hv=.false.) end subroutine psb_cdasb diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index 9bc4d403..79198c9d 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -476,7 +476,8 @@ contains ! first the halo index - if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo' + if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo',& + & size(halo_in) call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) if (info /= 0) then call psb_errpush(4010,name,a_err='psi_crea_index') diff --git a/base/tools/Makefile b/base/tools/Makefile index 27c5fe45..eb58bcf0 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -2,9 +2,8 @@ include ../../Make.inc FOBJS = psb_dallc.o psb_dasb.o psb_cdprt.o \ psb_dfree.o psb_dins.o \ - psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdcpy.o \ - psb_cdfree.o psb_cdins.o \ - psb_cdren.o psb_cdrep.o psb_cdtransfer.o psb_get_overlap.o\ + psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o \ + psb_cdren.o psb_cdrep.o psb_get_overlap.o\ psb_dspalloc.o psb_dspasb.o \ psb_dspfree.o psb_dspins.o psb_dsprn.o \ psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \ diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index 698cf304..d3fef3be 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -39,9 +39,9 @@ ! Arguments: ! v - integer, dimension(:). The array containg the partitioning scheme. ! ictxt - integer. The communication context. -! desc_a - type(psb_desc_type). The communication descriptor. +! desc - type(psb_desc_type). The communication descriptor. ! info - integer. Eventually returns an error code -subroutine psb_cd_inloc(v, ictxt, desc_a, info) +subroutine psb_cd_inloc(v, ictxt, desc, info) use psb_descriptor_type use psb_serial_mod use psb_const_mod @@ -52,7 +52,7 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) !....Parameters... Integer, intent(in) :: ictxt, v(:) integer, intent(out) :: info - type(psb_desc_type), intent(out) :: desc_a + type(psb_desc_type), intent(out) :: desc !locals Integer :: counter,i,j,np,me,loc_row,err,& @@ -162,19 +162,19 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) end if - call psb_nullify_desc(desc_a) + call psb_nullify_desc(desc) !count local rows number ! allocate work vector if (psb_cd_choose_large_state(ictxt,m)) then - allocate(desc_a%matrix_data(psb_mdata_size_),& + allocate(desc%matrix_data(psb_mdata_size_),& &temp_ovrlap(m),stat=info) - desc_a%matrix_data(psb_desc_size_) = psb_desc_large_ + desc%matrix_data(psb_desc_size_) = psb_desc_large_ else - allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& + allocate(desc%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& &temp_ovrlap(m),stat=info) - desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_ + desc%matrix_data(psb_desc_size_) = psb_desc_normal_ end if if (info /= 0) then info=4025 @@ -183,11 +183,11 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) goto 9999 endif - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = n + desc%matrix_data(psb_m_) = m + desc%matrix_data(psb_n_) = n ! This has to be set BEFORE any call to SET_BLD - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) + desc%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) if (debug_level >= psb_debug_ext_) & @@ -241,9 +241,9 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) ! estimate local cols number loc_col = min(2*loc_row,m) - allocate(desc_a%loc_to_glob(loc_col), desc_a%lprm(1),& - & desc_a%ptree(2),stat=info) - if (info == 0) call InitPairSearchTree(desc_a%ptree,info) + allocate(desc%loc_to_glob(loc_col), desc%lprm(1),& + & desc%ptree(2),stat=info) + if (info == 0) call InitPairSearchTree(desc%ptree,info) if (info /= 0) then info=4025 int_err(1)=loc_col @@ -252,14 +252,14 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) end if ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 + desc%lprm(1) = 0 + desc%loc_to_glob(:) = -1 k = 0 do i=1,m if ((tmpgidx(i,1)-flag_) == me) then k = k + 1 - desc_a%loc_to_glob(k) = i - call SearchInsKeyVal(desc_a%ptree,i,k,glx,info) + desc%loc_to_glob(k) = i + call SearchInsKeyVal(desc%ptree,i,k,glx,info) endif enddo if (k /= loc_row) then @@ -297,9 +297,9 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) if ((tmpgidx(i,1)-flag_) == me) then ! this point belongs to me counter=counter+1 - desc_a%glob_to_loc(i) = counter + desc%glob_to_loc(i) = counter else - desc_a%glob_to_loc(i) = -(np+(tmpgidx(i,1)-flag_)+1) + desc%glob_to_loc(i) = -(np+(tmpgidx(i,1)-flag_)+1) end if enddo @@ -319,8 +319,8 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) ! estimate local cols number loc_col = min(2*loc_row,m) - allocate(desc_a%loc_to_glob(loc_col),& - &desc_a%lprm(1),stat=info) + allocate(desc%loc_to_glob(loc_col),& + &desc%lprm(1),stat=info) if (info /= 0) then info=4025 int_err(1)=loc_col @@ -329,19 +329,19 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) end if ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 + desc%lprm(1) = 0 + desc%loc_to_glob(:) = -1 do i=1,m - k = desc_a%glob_to_loc(i) + k = desc%glob_to_loc(i) if (k > 0) then - desc_a%loc_to_glob(k) = i + desc%loc_to_glob(k) = i endif enddo end if - call psi_bld_tmpovrl(temp_ovrlap,desc_a,info) + call psi_bld_tmpovrl(temp_ovrlap,desc,info) deallocate(temp_ovrlap,stat=info) if (info /= 0) then @@ -350,23 +350,24 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info) goto 9999 endif - ! set fields in desc_a%MATRIX_DATA.... - desc_a%matrix_data(psb_n_row_) = loc_row - desc_a%matrix_data(psb_n_col_) = loc_row - call psb_cd_set_bld(desc_a,info) + ! set fields in desc%MATRIX_DATA.... + desc%matrix_data(psb_n_row_) = loc_row + desc%matrix_data(psb_n_col_) = loc_row - call psb_realloc(1,desc_a%halo_index, info) - if (info == 0) call psb_realloc(1,desc_a%ext_index, info) + call psb_realloc(1,desc%halo_index, info) + if (info == 0) call psb_realloc(1,desc%ext_index, info) if (info /= 0) then info=4010 call psb_errpush(info,name,a_err='psb_realloc') Goto 9999 end if - desc_a%halo_index(:) = -1 - desc_a%ext_index(:) = -1 + desc%halo_index(:) = -1 + desc%ext_index(:) = -1 if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' + call psb_cd_set_bld(desc,info) + call psb_erractionrestore(err_act) return diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index 40a8fbdd..596558ce 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -41,9 +41,9 @@ ! parts - external subroutine. The routine that contains the ! partitioning scheme. ! ictxt - integer. The communication context. -! desc_a - type(psb_desc_type). The communication descriptor. +! desc - type(psb_desc_type). The communication descriptor. ! info - integer. Error code (if any). -subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) +subroutine psb_cdals(m, n, parts, ictxt, desc, info) use psb_error_mod use psb_descriptor_type use psb_realloc_mod @@ -55,7 +55,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) include 'parts.fh' !....Parameters... Integer, intent(in) :: M,N,ictxt - Type(psb_desc_type), intent(out) :: desc_a + Type(psb_desc_type), intent(out) :: desc integer, intent(out) :: info !locals @@ -122,18 +122,18 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) call psb_cd_set_large_threshold(exch(3)) endif - call psb_nullify_desc(desc_a) + call psb_nullify_desc(desc) !count local rows number ! allocate work vector if (psb_cd_choose_large_state(ictxt,m)) then - allocate(desc_a%matrix_data(psb_mdata_size_),& + allocate(desc%matrix_data(psb_mdata_size_),& & temp_ovrlap(m),prc_v(np),stat=info) - desc_a%matrix_data(psb_desc_size_) = psb_desc_large_ + desc%matrix_data(psb_desc_size_) = psb_desc_large_ else - allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& + allocate(desc%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& & temp_ovrlap(m),prc_v(np),stat=info) - desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_ + desc%matrix_data(psb_desc_size_) = psb_desc_normal_ end if if (info /= 0) then info=4025 @@ -142,11 +142,11 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) call psb_errpush(err,name,int_err,a_err='integer') goto 9999 endif - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = n + desc%matrix_data(psb_m_) = m + desc%matrix_data(psb_n_) = n ! This has to be set BEFORE any call to SET_BLD - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) + desc%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) if (debug_level >= psb_debug_ext_) & @@ -168,9 +168,9 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) ! hashed by the low order bits of the entries. ! loc_col = (m+np-1)/np - allocate(desc_a%loc_to_glob(loc_col), desc_a%lprm(1),& - & desc_a%ptree(2),stat=info) - if (info == 0) call InitPairSearchTree(desc_a%ptree,info) + allocate(desc%loc_to_glob(loc_col), desc%lprm(1),& + & desc%ptree(2),stat=info) + if (info == 0) call InitPairSearchTree(desc%ptree,info) if (info /= 0) then info=4025 int_err(1)=loc_col @@ -179,8 +179,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) end if ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 + desc%lprm(1) = 0 + desc%loc_to_glob(:) = -1 k = 0 do i=1,m if (info == 0) then @@ -226,14 +226,14 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) if (prc_v(j) == me) then ! this point belongs to me k = k + 1 - call psb_ensure_size((k+1),desc_a%loc_to_glob,info,pad=-1) + call psb_ensure_size((k+1),desc%loc_to_glob,info,pad=-1) if (info /= 0) then info=4010 call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - desc_a%loc_to_glob(k) = i - call SearchInsKeyVal(desc_a%ptree,i,k,glx,info) + desc%loc_to_glob(k) = i + call SearchInsKeyVal(desc%ptree,i,k,glx,info) if (nprocs > 1) then call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) if (info /= 0) then @@ -304,7 +304,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) end if end do endif - desc_a%glob_to_loc(i) = -(np+prc_v(1)+1) + desc%glob_to_loc(i) = -(np+prc_v(1)+1) j=1 do if (j > nprocs) exit @@ -315,7 +315,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) if (prc_v(j) == me) then ! this point belongs to me counter=counter+1 - desc_a%glob_to_loc(i) = counter + desc%glob_to_loc(i) = counter if (nprocs > 1) then call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1) if (info /= 0) then @@ -338,20 +338,20 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) loc_row=counter loc_col=min(2*loc_row,m) - allocate(desc_a%loc_to_glob(loc_col),& - &desc_a%lprm(1),stat=info) + allocate(desc%loc_to_glob(loc_col),& + &desc%lprm(1),stat=info) if (info /= 0) then call psb_errpush(4010,name,a_err='Allocate') goto 9999 end if ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 + desc%lprm(1) = 0 + desc%loc_to_glob(:) = -1 do i=1,m - k = desc_a%glob_to_loc(i) + k = desc%glob_to_loc(i) if (k > 0) then - desc_a%loc_to_glob(k) = i + desc%loc_to_glob(k) = i endif enddo @@ -366,7 +366,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) & write(debug_unit,*) me,' ',trim(name),': error check:' ,err - call psi_bld_tmpovrl(temp_ovrlap,desc_a,info) + call psi_bld_tmpovrl(temp_ovrlap,desc,info) if (info == 0) deallocate(prc_v,temp_ovrlap,stat=info) if (info /= psb_no_err_) then @@ -376,20 +376,22 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info) Goto 9999 endif - ! set fields in desc_a%MATRIX_DATA.... - desc_a%matrix_data(psb_n_row_) = loc_row - desc_a%matrix_data(psb_n_col_) = loc_row - call psb_cd_set_bld(desc_a,info) + ! set fields in desc%MATRIX_DATA.... + desc%matrix_data(psb_n_row_) = loc_row + desc%matrix_data(psb_n_col_) = loc_row - call psb_realloc(1,desc_a%halo_index, info) - if (info == 0) call psb_realloc(1,desc_a%ext_index, info) + call psb_realloc(1,desc%halo_index, info) + if (info == 0) call psb_realloc(1,desc%ext_index, info) if (info /= 0) then info=4010 call psb_errpush(info,name,a_err='psb_realloc') Goto 9999 end if - desc_a%halo_index(:) = -1 - desc_a%ext_index(:) = -1 + desc%halo_index(:) = -1 + desc%ext_index(:) = -1 + + call psb_cd_set_bld(desc,info) + if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index d6724bc2..ecdbdba7 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -40,10 +40,10 @@ ! Arguments: ! v - integer, dimension(:). The array containg the partitioning scheme. ! ictxt - integer. The communication context. -! desc_a - type(psb_desc_type). The communication descriptor. +! desc - type(psb_desc_type). The communication descriptor. ! info - integer. Return code ! flag - integer. Are V's contents 0- or 1-based? -subroutine psb_cdalv(v, ictxt, desc_a, info, flag) +subroutine psb_cdalv(v, ictxt, desc, info, flag) use psb_descriptor_type use psb_serial_mod use psb_const_mod @@ -55,7 +55,7 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) Integer, intent(in) :: ictxt, v(:) integer, intent(in), optional :: flag integer, intent(out) :: info - type(psb_desc_type), intent(out) :: desc_a + type(psb_desc_type), intent(out) :: desc !locals Integer :: counter,i,j,np,me,loc_row,err,& @@ -120,7 +120,7 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) call psb_cd_set_large_threshold(exch(3)) endif - call psb_nullify_desc(desc_a) + call psb_nullify_desc(desc) if (present(flag)) then flag_=flag @@ -138,13 +138,13 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) !count local rows number ! allocate work vector if (psb_cd_choose_large_state(ictxt,m)) then - allocate(desc_a%matrix_data(psb_mdata_size_),& + allocate(desc%matrix_data(psb_mdata_size_),& &temp_ovrlap(m),stat=info) - desc_a%matrix_data(psb_desc_size_) = psb_desc_large_ + desc%matrix_data(psb_desc_size_) = psb_desc_large_ else - allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& + allocate(desc%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& &temp_ovrlap(m),stat=info) - desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_ + desc%matrix_data(psb_desc_size_) = psb_desc_normal_ end if if (info /= 0) then info=4025 @@ -153,11 +153,11 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) goto 9999 endif - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = n + desc%matrix_data(psb_m_) = m + desc%matrix_data(psb_n_) = n ! This has to be set BEFORE any call to SET_BLD - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) + desc%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info @@ -211,9 +211,9 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) ! estimate local cols number loc_col = min(2*loc_row,m) - allocate(desc_a%loc_to_glob(loc_col), desc_a%lprm(1),& - & desc_a%ptree(2),stat=info) - if (info == 0) call InitPairSearchTree(desc_a%ptree,info) + allocate(desc%loc_to_glob(loc_col), desc%lprm(1),& + & desc%ptree(2),stat=info) + if (info == 0) call InitPairSearchTree(desc%ptree,info) if (info /= 0) then info=4025 int_err(1)=loc_col @@ -222,14 +222,14 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) end if ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 + desc%lprm(1) = 0 + desc%loc_to_glob(:) = -1 k = 0 do i=1,m if ((v(i)-flag_) == me) then k = k + 1 - desc_a%loc_to_glob(k) = i - call SearchInsKeyVal(desc_a%ptree,i,k,glx,info) + desc%loc_to_glob(k) = i + call SearchInsKeyVal(desc%ptree,i,k,glx,info) endif enddo @@ -258,9 +258,9 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) if ((v(i)-flag_) == me) then ! this point belongs to me counter=counter+1 - desc_a%glob_to_loc(i) = counter + desc%glob_to_loc(i) = counter else - desc_a%glob_to_loc(i) = -(np+(v(i)-flag_)+1) + desc%glob_to_loc(i) = -(np+(v(i)-flag_)+1) end if enddo @@ -280,8 +280,8 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) ! estimate local cols number loc_col = min(2*loc_row,m) - allocate(desc_a%loc_to_glob(loc_col),& - &desc_a%lprm(1),stat=info) + allocate(desc%loc_to_glob(loc_col),& + &desc%lprm(1),stat=info) if (info /= 0) then info=4025 int_err(1)=loc_col @@ -290,18 +290,18 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) end if ! set LOC_TO_GLOB array to all "-1" values - desc_a%lprm(1) = 0 - desc_a%loc_to_glob(:) = -1 + desc%lprm(1) = 0 + desc%loc_to_glob(:) = -1 do i=1,m - k = desc_a%glob_to_loc(i) + k = desc%glob_to_loc(i) if (k > 0) then - desc_a%loc_to_glob(k) = i + desc%loc_to_glob(k) = i endif enddo end if - call psi_bld_tmpovrl(temp_ovrlap,desc_a,info) + call psi_bld_tmpovrl(temp_ovrlap,desc,info) deallocate(temp_ovrlap,stat=info) if (info /= 0) then @@ -310,27 +310,27 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag) goto 9999 endif - ! set fields in desc_a%MATRIX_DATA.... - desc_a%matrix_data(psb_n_row_) = loc_row - desc_a%matrix_data(psb_n_col_) = loc_row - call psb_cd_set_bld(desc_a,info) + ! set fields in desc%MATRIX_DATA.... + desc%matrix_data(psb_n_row_) = loc_row + desc%matrix_data(psb_n_col_) = loc_row - call psb_realloc(1,desc_a%halo_index, info) + call psb_realloc(1,desc%halo_index, info) if (info /= psb_no_err_) then info=4010 call psb_errpush(err,name,a_err='psb_realloc') Goto 9999 end if - desc_a%halo_index(:) = -1 + desc%halo_index(:) = -1 - call psb_realloc(1,desc_a%ext_index, info) + call psb_realloc(1,desc%ext_index, info) if (info /= psb_no_err_) then info=4010 call psb_errpush(err,name,a_err='psb_realloc') Goto 9999 end if - desc_a%ext_index(:) = -1 + desc%ext_index(:) = -1 + call psb_cd_set_bld(desc,info) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cdcpy.f90 b/base/tools/psb_cdcpy.f90 deleted file mode 100644 index f61625c2..00000000 --- a/base/tools/psb_cdcpy.f90 +++ /dev/null @@ -1,128 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cdcpy.f90 -! -! Subroutine: psb_cdcpy -! Produces a clone of a descriptor. -! -! Arguments: -! desc_in - type(psb_desc_type). The communication descriptor to be cloned. -! desc_out - type(psb_desc_type). The output communication descriptor. -! info - integer. Return code. -subroutine psb_cdcpy(desc_in, desc_out, info) - - use psb_descriptor_type - use psb_serial_mod - use psb_realloc_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - - implicit none - !....parameters... - - type(psb_desc_type), intent(in) :: desc_in - type(psb_desc_type), intent(out) :: desc_out - integer, intent(out) :: info - - !locals - integer :: np,me,ictxt, err_act - integer :: debug_level, debug_unit - character(len=20) :: name - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (psb_get_errstatus() /= 0) return - info = 0 - call psb_erractionsave(err_act) - name = 'psb_cdcpy' - - ictxt = psb_cd_get_context(desc_in) - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Entered' - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_safe_ab_cpy(desc_in%matrix_data,desc_out%matrix_data,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%halo_index,desc_out%halo_index,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ext_index,desc_out%ext_index,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ovrlap_index,desc_out%ovrlap_index,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%ovr_mst_idx,desc_out%ovr_mst_idx,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%loc_to_glob,desc_out%loc_to_glob,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%glob_to_loc,desc_out%glob_to_loc,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%lprm,desc_out%lprm,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%idx_space,desc_out%idx_space,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%hashv,desc_out%hashv,info) - if (info == 0) call psb_safe_ab_cpy(desc_in%glb_lc,desc_out%glb_lc,info) - - if (info == 0) then - if (allocated(desc_in%ptree)) then - allocate(desc_out%ptree(2),stat=info) - if (info /= 0) then - info=4000 - goto 9999 - endif - call ClonePairSearchTree(desc_in%ptree,desc_out%ptree) - end if - end if - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name) - goto 9999 - endif - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': Done' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_cdcpy diff --git a/base/tools/psb_cdfree.f90 b/base/tools/psb_cdfree.f90 deleted file mode 100644 index 4eb4278a..00000000 --- a/base/tools/psb_cdfree.f90 +++ /dev/null @@ -1,230 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cdfree.f90 -! -! Subroutine: psb_cdfree -! Frees a descriptor data structure. -! -! Arguments: -! desc_a - type(psb_desc_type). The communication descriptor to be freed. -! info - integer. return code. -subroutine psb_cdfree(desc_a,info) - !...free descriptor structure... - use psb_descriptor_type - use psb_const_mod - use psb_error_mod - use psb_penv_mod - implicit none - !....parameters... - type(psb_desc_type), intent(inout) :: desc_a - integer, intent(out) :: info - !...locals.... - integer :: ictxt,np,me, err_act - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - name = 'psb_cdfree' - - - if (.not.allocated(desc_a%matrix_data)) then - info=295 - call psb_errpush(info,name) - return - end if - - ictxt=psb_cd_get_context(desc_a) - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - !...deallocate desc_a.... - if(.not.allocated(desc_a%loc_to_glob)) then - info=296 - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate loc_to_glob field - deallocate(desc_a%loc_to_glob,stat=info) - if (info /= 0) then - info=2051 - call psb_errpush(info,name) - goto 9999 - end if - - if (.not.psb_is_large_desc(desc_a)) then - if (.not.allocated(desc_a%glob_to_loc)) then - info=297 - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate glob_to_loc field - deallocate(desc_a%glob_to_loc,stat=info) - if (info /= 0) then - info=2052 - call psb_errpush(info,name) - goto 9999 - end if - endif - - if (.not.allocated(desc_a%halo_index)) then - info=298 - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate halo_index field - deallocate(desc_a%halo_index,stat=info) - if (info /= 0) then - info=2053 - call psb_errpush(info,name) - goto 9999 - end if - - if (.not.allocated(desc_a%bnd_elem)) then -!!$ info=296 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if - else - !deallocate halo_index field - deallocate(desc_a%bnd_elem,stat=info) - if (info /= 0) then - info=2054 - call psb_errpush(info,name) - goto 9999 - end if - end if - - if (.not.allocated(desc_a%ovrlap_index)) then - info=299 - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate ovrlap_index field - deallocate(desc_a%ovrlap_index,stat=info) - if (info /= 0) then - info=2055 - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate ovrlap_elem field - deallocate(desc_a%ovrlap_elem,stat=info) - if (info /= 0) then - info=2056 - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate ovrlap_index field - deallocate(desc_a%ovr_mst_idx,stat=info) - if (info /= 0) then - info=2055 - call psb_errpush(info,name) - goto 9999 - end if - - - deallocate(desc_a%lprm,stat=info) - if (info /= 0) then - info=2057 - call psb_errpush(info,name) - goto 9999 - end if - - if (allocated(desc_a%hashv)) then - deallocate(desc_a%hashv,stat=info) - if (info /= 0) then - info=2058 - call psb_errpush(info,name) - goto 9999 - end if - end if - - if (allocated(desc_a%glb_lc)) then - deallocate(desc_a%glb_lc,stat=info) - if (info /= 0) then - info=2059 - call psb_errpush(info,name) - goto 9999 - end if - end if - - if (allocated(desc_a%ptree)) then - call FreePairSearchTree(desc_a%ptree) - deallocate(desc_a%ptree,stat=info) - if (info /= 0) then - info=2059 - call psb_errpush(info,name) - goto 9999 - end if - end if - - - - if (allocated(desc_a%idx_space)) then - deallocate(desc_a%idx_space,stat=info) - if (info /= 0) then - info=2056 - call psb_errpush(info,name) - goto 9999 - end if - end if - - deallocate(desc_a%matrix_data) - - call psb_nullify_desc(desc_a) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_cdfree diff --git a/base/tools/psb_cdins.f90 b/base/tools/psb_cdins.f90 index c8a0eedd..b4d7b0de 100644 --- a/base/tools/psb_cdins.f90 +++ b/base/tools/psb_cdins.f90 @@ -45,14 +45,14 @@ ! ila(:) - integer, optional The row indices in local numbering ! jla(:) - integer, optional The col indices in local numbering ! -subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) - +subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) use psb_descriptor_type use psb_serial_mod use psb_const_mod use psb_error_mod use psb_penv_mod use psi_mod + use psb_tools_mod, psb_protect_name => psb_cdinsrc implicit none !....PARAMETERS... @@ -90,11 +90,13 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) goto 9999 endif - if (nz <= 0) then + if (nz < 0) then info = 1111 call psb_errpush(info,name) goto 9999 end if + if (nz == 0) return + if (size(ia) < nz) then info = 1111 call psb_errpush(info,name) @@ -122,22 +124,147 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) end if if (present(ila).and.present(jla)) then +!!$ call psi_idx_cnv(nz,ia,ila,desc_a,info,owned=.true.) +!!$ call psi_idx_ins_cnv(nz,ja,jla,desc_a,info,mask=(ila(1:nz)>0)) call psi_idx_cnv(nz,ia,ila,desc_a,info,owned=.true.) - call psi_idx_ins_cnv(nz,ja,jla,desc_a,info,mask=(ila(1:nz)>0)) - + call psb_cdins(nz,ja,desc_a,info,jla=jla,mask=(ila(1:nz)>0)) else if (present(ila).or.present(jla)) then write(0,*) 'Inconsistent call : ',present(ila),present(jla) endif - allocate(ila_(nz),jla_(nz),stat=info) + allocate(ila_(nz),stat=info) if (info /= 0) then info = 4000 call psb_errpush(info,name) goto 9999 end if call psi_idx_cnv(nz,ia,ila_,desc_a,info,owned=.true.) - call psi_idx_ins_cnv(nz,ja,jla_,desc_a,info,mask=(ila_(1:nz)>0)) - deallocate(ila_,jla_) + call psb_cdins(nz,ja,desc_a,info,mask=(ila_(1:nz)>0)) + deallocate(ila_) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_ret_) then + return + else + call psb_error(ictxt) + end if + return + +end subroutine psb_cdinsrc + +! +! Subroutine: psb_cdinsc +! Takes as input a list of indices points and updates the descriptor accordingly. +! The optional argument mask may be used to control which indices are actually +! used. +! +! Arguments: +! nz - integer. The number of points to insert. +! ja(:) - integer The column indices of the points. +! desc - type(psb_desc_type). The communication descriptor +! info - integer. Return code. +! jla(:) - integer, optional The col indices in local numbering +! mask(:) - logical, optional, target +! +subroutine psb_cdinsc(nz,ja,desc,info,jla,mask) + + use psb_descriptor_type + use psb_serial_mod + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psi_mod + use psb_tools_mod, psb_protect_name => psb_cdinsc + implicit none + + !....PARAMETERS... + Type(psb_desc_type), intent(inout) :: desc + Integer, intent(in) :: nz,ja(:) + integer, intent(out) :: info + integer, optional, intent(out) :: jla(:) + logical, optional, target, intent(in) :: mask(:) + + !LOCALS..... + + integer :: ictxt,dectype,mglob, nglob + integer :: np, me + integer :: nrow,ncol, err_act + logical, parameter :: debug=.false. + integer, parameter :: relocsz=200 + integer, allocatable :: ila_(:), jla_(:) + logical, allocatable, target :: mask__(:) + logical, pointer :: mask_(:) + character(len=20) :: name + + info = 0 + name = 'psb_cdins' + call psb_erractionsave(err_act) + + ictxt = psb_cd_get_context(desc) + dectype = psb_cd_get_dectype(desc) + mglob = psb_cd_get_global_rows(desc) + nglob = psb_cd_get_global_cols(desc) + nrow = psb_cd_get_local_rows(desc) + ncol = psb_cd_get_local_cols(desc) + + call psb_info(ictxt, me, np) + + if (.not.psb_is_bld_desc(desc)) then + info = 3110 + call psb_errpush(info,name) + goto 9999 + endif + + if (nz < 0) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + if (nz == 0) return + + if (size(ja) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + + if (present(jla)) then + if (size(jla) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + end if + if (present(mask)) then + if (size(mask) < nz) then + info = 1111 + call psb_errpush(info,name) + goto 9999 + end if + mask_ => mask + else + allocate(mask__(nz)) + mask_ => mask__ + mask_ = .true. + end if + + if (present(jla)) then + call psi_idx_ins_cnv(nz,ja,jla,desc,info,mask=mask_) + else + allocate(jla_(nz),stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + call psi_idx_ins_cnv(nz,ja,jla_,desc,info,mask=mask_) + deallocate(jla_) end if call psb_erractionrestore(err_act) @@ -153,5 +280,5 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info,ila,jla) end if return -end subroutine psb_cdins +end subroutine psb_cdinsc diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index c819048d..9b779db3 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -29,7 +29,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psb_cdrep(m, ictxt, desc_a, info) +subroutine psb_cdrep(m, ictxt, desc, info) ! Purpose ! ======= @@ -49,8 +49,8 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) ! ! OUTPUT !========= - ! desc_a : TYPEDESC - ! desc_a OUTPUT FIELDS: + ! desc : TYPEDESC + ! desc OUTPUT FIELDS: ! ! MATRIX_DATA : Pointer to integer Array ! contains some @@ -100,7 +100,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) ! List is terminated with -1. ! ! - ! END OF desc_a OUTPUT FIELDS + ! END OF desc OUTPUT FIELDS ! ! @@ -114,7 +114,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) !....Parameters... Integer, intent(in) :: m,ictxt integer, intent(out) :: info - Type(psb_desc_type), intent(out) :: desc_a + Type(psb_desc_type), intent(out) :: desc !locals Integer :: i,np,me,err,n,err_act @@ -174,14 +174,14 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) end if - call psb_nullify_desc(desc_a) + call psb_nullify_desc(desc) !count local rows number ! allocate work vector - allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& - & desc_a%loc_to_glob(m),desc_a%lprm(1),& - & desc_a%ovrlap_elem(0,3),stat=info) + allocate(desc%glob_to_loc(m),desc%matrix_data(psb_mdata_size_),& + & desc%loc_to_glob(m),desc%lprm(1),& + & desc%ovrlap_elem(0,3),stat=info) if (info /= 0) then info=4025 int_err(1)=2*m+psb_mdata_size_+1 @@ -190,34 +190,34 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) endif ! If the index space is replicated there's no point in not having ! the full map on the current process. - desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_ + desc%matrix_data(psb_desc_size_) = psb_desc_normal_ - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = n - desc_a%matrix_data(psb_n_row_) = m - desc_a%matrix_data(psb_n_col_) = n - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) - desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ + desc%matrix_data(psb_m_) = m + desc%matrix_data(psb_n_) = n + desc%matrix_data(psb_n_row_) = m + desc%matrix_data(psb_n_col_) = n + desc%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) + desc%matrix_data(psb_dec_type_) = psb_desc_bld_ do i=1,m - desc_a%glob_to_loc(i) = i - desc_a%loc_to_glob(i) = i + desc%glob_to_loc(i) = i + desc%loc_to_glob(i) = i enddo tovr = -1 thalo = -1 text = -1 - desc_a%lprm(:) = 0 + desc%lprm(:) = 0 - call psi_cnv_dsc(thalo,tovr,text,desc_a,info) + call psi_cnv_dsc(thalo,tovr,text,desc,info) if (info /= 0) then call psb_errpush(4010,name,a_err='psi_cvn_dsc') goto 9999 end if - desc_a%matrix_data(psb_dec_type_) = psb_desc_repl_ + desc%matrix_data(psb_dec_type_) = psb_desc_repl_ if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': end' diff --git a/base/tools/psb_cdtransfer.f90 b/base/tools/psb_cdtransfer.f90 deleted file mode 100644 index 01dc725b..00000000 --- a/base/tools/psb_cdtransfer.f90 +++ /dev/null @@ -1,132 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cdtransfer.f90 -! -! Subroutine: psb_cdtransfer -! Transfers data and allocation from in to out; behaves like MOVE_ALLOC, i.e. -! the IN arg is empty (and deallocated) upon exit. -! -! -! Arguments: -! desc_in - type(psb_desc_type). The communication descriptor to be -! transferred. -! desc_out - type(psb_desc_type). The output communication descriptor. -! info - integer. Return code. -subroutine psb_cdtransfer(desc_in, desc_out, info) - - use psb_descriptor_type - use psb_serial_mod - use psb_realloc_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - - implicit none - !....parameters... - - type(psb_desc_type), intent(inout) :: desc_in - type(psb_desc_type), intent(inout) :: desc_out - integer, intent(out) :: info - - !locals - integer :: np,me,ictxt, err_act - integer :: debug_level, debug_unit - character(len=20) :: name - - if (psb_get_errstatus()/=0) return - info = 0 - call psb_erractionsave(err_act) - name = 'psb_cdtransfer' - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=psb_cd_get_context(desc_in) - - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_outer_)& - & write(debug_unit,*) me,' ',trim(name),': Entered.' - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_transfer( desc_in%matrix_data , desc_out%matrix_data , info) - if (info == 0) & - & call psb_transfer( desc_in%halo_index , desc_out%halo_index , info) - if (info == 0) & - & call psb_transfer( desc_in%bnd_elem , desc_out%bnd_elem , info) - if (info == 0) & - & call psb_transfer( desc_in%ovrlap_elem , desc_out%ovrlap_elem , info) - if (info == 0) & - & call psb_transfer( desc_in%ovrlap_index, desc_out%ovrlap_index , info) - if (info == 0) & - & call psb_transfer( desc_in%ovr_mst_idx , desc_out%ovr_mst_idx , info) - if (info == 0) & - & call psb_transfer( desc_in%ext_index , desc_out%ext_index , info) - if (info == 0) & - & call psb_transfer( desc_in%loc_to_glob , desc_out%loc_to_glob , info) - if (info == 0) & - & call psb_transfer( desc_in%glob_to_loc , desc_out%glob_to_loc , info) - if (info == 0) & - & call psb_transfer( desc_in%lprm , desc_out%lprm , info) - if (info == 0) & - & call psb_transfer( desc_in%idx_space , desc_out%idx_space , info) - if (info == 0) & - & call psb_transfer( desc_in%hashv , desc_out%hashv , info) - if (info == 0) & - & call psb_transfer( desc_in%glb_lc , desc_out%glb_lc , info) - if (info == 0) & - & call psb_transfer( desc_in%ptree , desc_out%ptree , info) - - if (info /= 0) then - info = 4010 - call psb_errpush(info,name) - goto 9999 - endif - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_cdtransfer