From 66cefd1e4100a9e7e48dac5aee081accfad8869c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 16 Dec 2010 14:55:11 +0000 Subject: [PATCH] psblas3: base/modules/psb_desc_const_mod.f90 base/modules/psb_desc_type.f90 base/modules/psb_gen_block_map_mod.f03 base/modules/psb_glist_map_mod.f03 base/modules/psb_hash_map_mod.f03 base/modules/psb_indx_map_mod.f03 base/modules/psb_list_map_mod.f03 base/modules/psb_repl_map_mod.f03 base/modules/psi_comm_buffers_mod.F90 base/modules/psi_p2p_mod.F90 base/modules/psi_reduce_mod.F90 base/tools/psb_cd_set_bld.f90 Add headers for recent INDXMAP work. --- base/modules/psb_desc_const_mod.f90 | 36 + base/modules/psb_desc_type.f90 | 145 +- base/modules/psb_gen_block_map_mod.f03 | 47 + base/modules/psb_glist_map_mod.f03 | 43 + base/modules/psb_hash_map_mod.f03 | 1980 ++++++++++++------------ base/modules/psb_indx_map_mod.f03 | 169 +- base/modules/psb_list_map_mod.f03 | 41 + base/modules/psb_repl_map_mod.f03 | 42 + base/modules/psi_comm_buffers_mod.F90 | 44 + base/modules/psi_p2p_mod.F90 | 188 +++ base/modules/psi_reduce_mod.F90 | 129 ++ base/tools/psb_cd_set_bld.f90 | 2 +- 12 files changed, 1743 insertions(+), 1123 deletions(-) diff --git a/base/modules/psb_desc_const_mod.f90 b/base/modules/psb_desc_const_mod.f90 index 34e10fd7..6d39627d 100644 --- a/base/modules/psb_desc_const_mod.f90 +++ b/base/modules/psb_desc_const_mod.f90 @@ -1,3 +1,39 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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. +!!$ +!!$ +! +! +! package: psb_desc_const_mod +! Auxiliary module for descriptor: constant values. +! module psb_desc_const_mod ! ! Communication, prolongation & restriction diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 139d70d9..8f0eae7e 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -47,17 +47,9 @@ module psb_descriptor_type ! type: psb_desc_type ! ! Communication Descriptor data structure. - !| type psb_idxmap_type - !| integer :: state - !| integer, allocatable :: loc_to_glob(:) - !| integer, allocatable :: glob_to_loc(:) - !| integer :: hashvsize, hashvmask - !| integer, allocatable :: hashv(:), glb_lc(:,:) - !| type(psb_hash_type) :: hash - !| end type psb_idxmap_type - ! ! !| type psb_desc_type + !| class(psb_indx_map), allocatable :: indxmap !| integer, allocatable :: matrix_data(:) !| integer, allocatable :: halo_index(:), ext_index(:) !| integer, allocatable :: bnd_elem(:) @@ -77,25 +69,30 @@ module psb_descriptor_type ! mesh discretization pattern. Thus building a communication descriptor is ! very much linked to building a sparse matrix (since the matrix sparsity ! pattern embodies the topology of the discretization graph). - ! - ! Most general info about the descriptor is stored in the matrix_data - ! component, including the STATE which can be PSB_DESC_BLD_, - ! PSB_DESC_ASB_ or PSB_DESC_REPL_. - ! Upon allocation with PSB_CDALL the descriptor enters the BLD state; - ! then the user can specify the discretization pattern with PSB_CDINS; - ! the call to PSB_CDASB puts the descriptor in the PSB_ASB_ state. ! - ! PSB_DESC_REPL_ is a special value that specifies a replicated index space, - ! and is only entered by the psb_cdrep call. Currently it is only - ! used in the last level of some multilevel preconditioners. - ! - ! The LOC_TO_GLOB, GLOB_TO_LOC, GLB_LC, HASHV and HASH data structures - ! inside IDXMAP implement the mapping between local and global indices, - ! according to the following guidelines: + ! This is a two-level data structure: it combines an INDX_MAP with + ! a set of auxiliary lists. + ! For a complete description of INDX_MAP see its own file, but the + ! idea here is the following: the INDX_MAP contains information about + ! the index space and its allocation to the various processors. + ! In particular, besides the communicator, it contains the data relevant + ! to the following queries: + ! 1. How many global rows/columns? + ! 2. How many local rows/columns? + ! 3. Convert between local and global indices + ! 4. Add to local indices. + ! 5. Find (one of) the owner(s) of a given index + ! Checking for the existence of overlap is very expensive, thus + ! it is done at build time (for extended-halo cases it can be inferred from + ! the construction process). + ! There are multiple ways to represent an INDX_MAP internally, hence it is + ! a CLASS variable, which can take different forms, more or less memory hungry. + ! + ! Guidelines ! ! 1. Each global index I is owned by at least one process; ! - ! 2. On each process, indices from 1 to N_ROW (desc%matrix_dat(psb_n_row_)) + ! 2. On each process, indices from 1 to N_ROW (desc%indxmap%get_lr()) ! are locally owned; the value of N_ROW can be determined upon allocation ! based on the index distribution (see also the interface to CDALL). ! @@ -109,36 +106,9 @@ module psb_descriptor_type ! form the HALO of the current process. Halo indices are assigned local indices ! from N_ROW+1 to N_COL (inclusive). ! - ! 5. Regardless of the descriptor state, LOC_TO_GLOB(I), I=1:N_COL always - ! contains the global index corresponding to local index I; the upper bound - ! N_COL moves during the descriptor build process (see CDINS). + ! 5. The upper bound N_COL moves during the descriptor build process (see CDINS). ! - ! 6. The descriptor also contains the inverse global-to-local mapping. This - ! mapping can take two forms according to the value returned by - ! psb_cd_choose_large_state: - ! i. If the global index space size is not too large, it is possible to store - ! a complete mapping in GLOB_TO_LOC: each entry contains the corresponding - ! local index (if there is one), or an encoded value identifying the process - ! owning that index. This array is filled in at initialization time CDALL, - ! and thus it is available throughout the insertion phase. The local storage - ! will thus be N_COL + N_GLOB - ! ii. If the global index space is very large (larger than the threshold value - ! which may be set by the user), then it is not advisable to have such an - ! array. - ! In this case we only record the global indices that do have a - ! local counterpart, so that the local storage will be proportional to - ! N_COL. - ! The idea is that glb_lc(:,1) will hold sorted global indices, and - ! glb_lc(:,2) the corresponding local indices, so that we may do a binary search. - ! To cut down the search time we partition glb_lc into a set of lists - ! addressed by hashv(:) based on the value of the lowest - ! PSB_HASH_BITS bits of the global index. - ! During the build phase glb_lc() will store the indices of the internal points, - ! i.e. local indices 1:NROW, since those are known ad CDALL time. - ! The halo indices that we encounter during the build phase are put in - ! a PSB_HASH_TYPE data structure, which implements a very simple hash; this - ! hash will nonetheless be quite fast at low occupancy rates. - ! At assembly time, we move everything into hashv(:) and glb_lc(:,:). + ! 6. The descriptor also contains the inverse global-to-local mapping. ! ! 7. The data exchange is based on lists of local indices to be exchanged; all the ! lists have the same format, as follows: @@ -181,10 +151,10 @@ module psb_descriptor_type ! 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 (remember: we do not have - ! the space to encode the owning process index in the GLOB_TO_LOC mapping); thus + ! However this implies that we know who owns the indices; + ! this is actually only true for the OVERLAP list + ! that is filled in at CDALL time, and not for the HALO (remember: we do not + ! necessarily have the space to encode the owning process index); thus ! the HALO list is rebuilt during the CDASB process ! (in the psi_ldsc_pre_halo subroutine). ! @@ -219,9 +189,8 @@ module psb_descriptor_type ! It is complex, but it does the following: ! 1. Allows a purely local matrix/stencil buildup phase, requiring only ! one synch point at the end (CDASB) - ! 2. Takes shortcuts when the problem size is not too large (the default threshold - ! assumes that you are willing to spend up to 4 MB on each process for the - ! glob_to_loc mapping) + ! 2. Takes shortcuts when the problem size is not too large + ! ! 3. Supports restriction/prolongation operators with the same routines ! just choosing (in the swapdata/swaptran internals) on which index list ! they should work. @@ -434,59 +403,11 @@ contains end function psb_is_asb_desc - - logical function psb_is_ok_dec(dectype) - integer :: dectype - - psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.& - &(dectype == psb_cd_ovl_asb_).or.(dectype == psb_cd_ovl_bld_).or.& - &(dectype == psb_desc_upd_).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_).or.(dectype == psb_cd_ovl_bld_) - end function psb_is_bld_dec - - logical function psb_is_upd_dec(dectype) - integer :: dectype - - psb_is_upd_dec = (dectype == psb_desc_upd_) - - end function psb_is_upd_dec - - logical function psb_is_repl_dec(dectype) - integer :: dectype - - psb_is_repl_dec = (dectype == psb_desc_repl_) - - end function psb_is_repl_dec - - - logical function psb_is_asb_dec(dectype) - integer :: dectype - - psb_is_asb_dec = (dectype == psb_desc_asb_).or.& - & (dectype == psb_desc_repl_).or.(dectype == psb_cd_ovl_asb_) - - end function psb_is_asb_dec - - logical function psb_is_ovl_dec(dectype) - integer :: dectype - - psb_is_ovl_dec = (dectype == psb_cd_ovl_bld_).or.& - & (dectype == psb_cd_ovl_asb_) - - end function psb_is_ovl_dec - - integer function psb_cd_get_local_rows(desc) type(psb_desc_type), intent(in) :: desc if (psb_is_ok_desc(desc)) then - psb_cd_get_local_rows = desc%matrix_data(psb_n_row_) + psb_cd_get_local_rows = desc%indxmap%get_lr() else psb_cd_get_local_rows = -1 endif @@ -496,7 +417,7 @@ contains 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_) + psb_cd_get_local_cols = desc%indxmap%get_lc() else psb_cd_get_local_cols = -1 endif @@ -506,7 +427,7 @@ contains type(psb_desc_type), intent(in) :: desc if (psb_is_ok_desc(desc)) then - psb_cd_get_global_rows = desc%matrix_data(psb_m_) + psb_cd_get_global_rows = desc%indxmap%get_gr() else psb_cd_get_global_rows = -1 endif @@ -517,7 +438,7 @@ contains type(psb_desc_type), intent(in) :: desc if (psb_is_ok_desc(desc)) then - psb_cd_get_global_cols = desc%matrix_data(psb_n_) + psb_cd_get_global_cols = desc%indxmap%get_gc() else psb_cd_get_global_cols = -1 endif diff --git a/base/modules/psb_gen_block_map_mod.f03 b/base/modules/psb_gen_block_map_mod.f03 index 876eee2b..988836ee 100644 --- a/base/modules/psb_gen_block_map_mod.f03 +++ b/base/modules/psb_gen_block_map_mod.f03 @@ -1,3 +1,50 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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. +!!$ +!!$ +! +! +! package: psb_gen_block_map_mod +! Defines the GEN_BLOCK_MAP type. +! +! It is the implementation of the general BLOCK distribution, +! i.e. process I gets the I-th block of consecutive indices. +! It needs to store the limits of the owned block, plus the global +! indices of the local halo. +! The choice is to store the boundaries of ALL blocks, since in general +! there will be few processes, compared to indices, so it is possible +! to answer the ownership question without resorting to data exchange +! (well, the data exchange is needed but only once at initial allocation +! time). +! +! module psb_gen_block_map_mod use psb_const_mod use psb_desc_const_mod diff --git a/base/modules/psb_glist_map_mod.f03 b/base/modules/psb_glist_map_mod.f03 index b406d857..cd87138a 100644 --- a/base/modules/psb_glist_map_mod.f03 +++ b/base/modules/psb_glist_map_mod.f03 @@ -1,3 +1,46 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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. +!!$ +!!$ +! +! +! package: psb_glist_map_mod +! Defines the GLIST_MAP type. +! +! This is almost identical to the LIST_MAP type, but it has an additional +! vector of size GLOB_ROWS giving, for each index, the owning process. +! This implies that: +! 1. We have room for such an additional vector; +! 2. There are no overlap (only one process owns a given index). +! +! module psb_glist_map_mod use psb_const_mod use psb_desc_const_mod diff --git a/base/modules/psb_hash_map_mod.f03 b/base/modules/psb_hash_map_mod.f03 index 8727b1ce..303899ad 100644 --- a/base/modules/psb_hash_map_mod.f03 +++ b/base/modules/psb_hash_map_mod.f03 @@ -1,3 +1,57 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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. +!!$ +!!$ +! +! +! package: psb_hash_map_mod +! Defines the HASH_MAP type. +! +! This is the index map of choice for large index spaces. +! If the global index space is very large (larger than the threshold value +! which may be set by the user), then it is not advisable to have a full +! GLOB_TO_LOC array; therefore we only record the global indices that do have a +! local counterpart, so that the local storage will be proportional to +! N_COL. +! The idea is that glb_lc(:,1) will hold sorted global indices, and +! glb_lc(:,2) the corresponding local indices, so that we may do a binary search. +! To cut down the search time we partition glb_lc into a set of lists +! addressed by hashv(:) based on the value of the lowest +! PSB_HASH_BITS bits of the global index. +! During the build phase glb_lc() will store the indices of the internal points, +! i.e. local indices 1:NROW, since those are known ad CDALL time. +! The halo indices that we encounter during the build phase are put in +! a PSB_HASH_TYPE data structure, which implements a very simple hash; this +! hash will nonetheless be quite fast at low occupancy rates. +! At assembly time, we move everything into hashv(:) and glb_lc(:,:). +! module psb_hash_map_mod use psb_const_mod use psb_desc_const_mod @@ -6,177 +60,163 @@ module psb_hash_map_mod type, extends(psb_indx_map) :: psb_hash_map - integer :: hashvsize, hashvmask - integer, allocatable :: hashv(:), glb_lc(:,:), loc_to_glob(:) - type(psb_hash_type), allocatable :: hash + integer :: hashvsize, hashvmask + integer, allocatable :: hashv(:), glb_lc(:,:), loc_to_glob(:) + type(psb_hash_type), allocatable :: hash - contains +contains - procedure, pass(idxmap) :: init_vl => hash_init_vl - procedure, pass(idxmap) :: hash_map_init => hash_init_vg + procedure, pass(idxmap) :: init_vl => hash_init_vl + procedure, pass(idxmap) :: hash_map_init => hash_init_vg - procedure, pass(idxmap) :: sizeof => hash_sizeof - procedure, pass(idxmap) :: asb => hash_asb - procedure, pass(idxmap) :: free => hash_free - procedure, pass(idxmap) :: get_fmt => hash_get_fmt + procedure, pass(idxmap) :: sizeof => hash_sizeof + procedure, pass(idxmap) :: asb => hash_asb + procedure, pass(idxmap) :: free => hash_free + procedure, pass(idxmap) :: get_fmt => hash_get_fmt - procedure, pass(idxmap) :: row_extendable => hash_row_extendable + procedure, pass(idxmap) :: row_extendable => hash_row_extendable - procedure, pass(idxmap) :: l2gs1 => hash_l2gs1 - procedure, pass(idxmap) :: l2gs2 => hash_l2gs2 - procedure, pass(idxmap) :: l2gv1 => hash_l2gv1 - procedure, pass(idxmap) :: l2gv2 => hash_l2gv2 + procedure, pass(idxmap) :: l2gs1 => hash_l2gs1 + procedure, pass(idxmap) :: l2gs2 => hash_l2gs2 + procedure, pass(idxmap) :: l2gv1 => hash_l2gv1 + procedure, pass(idxmap) :: l2gv2 => hash_l2gv2 - procedure, pass(idxmap) :: g2ls1 => hash_g2ls1 - procedure, pass(idxmap) :: g2ls2 => hash_g2ls2 - procedure, pass(idxmap) :: g2lv1 => hash_g2lv1 - procedure, pass(idxmap) :: g2lv2 => hash_g2lv2 + procedure, pass(idxmap) :: g2ls1 => hash_g2ls1 + procedure, pass(idxmap) :: g2ls2 => hash_g2ls2 + procedure, pass(idxmap) :: g2lv1 => hash_g2lv1 + procedure, pass(idxmap) :: g2lv2 => hash_g2lv2 - procedure, pass(idxmap) :: g2ls1_ins => hash_g2ls1_ins - procedure, pass(idxmap) :: g2ls2_ins => hash_g2ls2_ins - procedure, pass(idxmap) :: g2lv1_ins => hash_g2lv1_ins - procedure, pass(idxmap) :: g2lv2_ins => hash_g2lv2_ins + procedure, pass(idxmap) :: g2ls1_ins => hash_g2ls1_ins + procedure, pass(idxmap) :: g2ls2_ins => hash_g2ls2_ins + procedure, pass(idxmap) :: g2lv1_ins => hash_g2lv1_ins + procedure, pass(idxmap) :: g2lv2_ins => hash_g2lv2_ins - procedure, pass(idxmap) :: bld_g2l_map => hash_bld_g2l_map + procedure, pass(idxmap) :: bld_g2l_map => hash_bld_g2l_map - end type psb_hash_map +end type psb_hash_map - private :: hash_init_vl, hash_init_vg, hash_sizeof, hash_asb, & - & hash_free, hash_get_fmt, hash_l2gs1, hash_l2gs2, & - & hash_l2gv1, hash_l2gv2, hash_g2ls1, hash_g2ls2, & - & hash_g2lv1, hash_g2lv2, hash_g2ls1_ins, hash_g2ls2_ins, & - & hash_g2lv1_ins, hash_g2lv2_ins, hash_init_vlu, & - & hash_bld_g2l_map, hash_inner_cnvs1, hash_inner_cnvs2,& - & hash_inner_cnv1, hash_inner_cnv2, hash_row_extendable +private :: hash_init_vl, hash_init_vg, hash_sizeof, hash_asb, & + & hash_free, hash_get_fmt, hash_l2gs1, hash_l2gs2, & + & hash_l2gv1, hash_l2gv2, hash_g2ls1, hash_g2ls2, & + & hash_g2lv1, hash_g2lv2, hash_g2ls1_ins, hash_g2ls2_ins, & + & hash_g2lv1_ins, hash_g2lv2_ins, hash_init_vlu, & + & hash_bld_g2l_map, hash_inner_cnvs1, hash_inner_cnvs2,& + & hash_inner_cnv1, hash_inner_cnv2, hash_row_extendable - interface hash_inner_cnv - module procedure hash_inner_cnvs1, hash_inner_cnvs2,& - & hash_inner_cnv1, hash_inner_cnv2 - end interface hash_inner_cnv - private :: hash_inner_cnv +interface hash_inner_cnv + module procedure hash_inner_cnvs1, hash_inner_cnvs2,& + & hash_inner_cnv1, hash_inner_cnv2 +end interface hash_inner_cnv +private :: hash_inner_cnv contains - - function hash_row_extendable(idxmap) result(val) - implicit none - class(psb_hash_map), intent(in) :: idxmap - logical :: val - val = .true. - end function hash_row_extendable - - function hash_sizeof(idxmap) result(val) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer(psb_long_int_k_) :: val - - val = idxmap%psb_indx_map%sizeof() - val = val + 2 * psb_sizeof_int - if (allocated(idxmap%hashv)) & - & val = val + size(idxmap%hashv)*psb_sizeof_int - if (allocated(idxmap%glb_lc)) & - & val = val + size(idxmap%glb_lc)*psb_sizeof_int - if (allocated(idxmap%hash)) & - & val = val + psb_sizeof(idxmap%hash) - - end function hash_sizeof - - - subroutine hash_free(idxmap) - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer :: info - - if (allocated(idxmap%hashv)) & - & deallocate(idxmap%hashv) - if (allocated(idxmap%glb_lc)) & - & deallocate(idxmap%glb_lc) - - if (allocated(idxmap%hash)) then - call psb_free(idxmap%hash,info) - deallocate(idxmap%hash) - end if - - call idxmap%psb_indx_map%free() - - end subroutine hash_free - - - subroutine hash_l2gs1(idx,idxmap,info,mask,owned) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(inout) :: idx - integer, intent(out) :: info - logical, intent(in), optional :: mask - logical, intent(in), optional :: owned - integer :: idxv(1) - info = 0 - if (present(mask)) then - if (.not.mask) return - end if - - idxv(1) = idx - call idxmap%l2g(idxv,info,owned=owned) - idx = idxv(1) - end subroutine hash_l2gs1 - - subroutine hash_l2gs2(idxin,idxout,idxmap,info,mask,owned) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(in) :: idxin - integer, intent(out) :: idxout - integer, intent(out) :: info - logical, intent(in), optional :: mask - logical, intent(in), optional :: owned - - idxout = idxin - call idxmap%l2g(idxout,info,mask,owned) - - end subroutine hash_l2gs2 - - - subroutine hash_l2gv1(idx,idxmap,info,mask,owned) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(inout) :: idx(:) - integer, intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned - integer :: i - logical :: owned_ - info = 0 - - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return - end if - end if - if (present(owned)) then - owned_ = owned - else - owned_ = .false. +function hash_row_extendable(idxmap) result(val) + implicit none + class(psb_hash_map), intent(in) :: idxmap + logical :: val + val = .true. +end function hash_row_extendable + +function hash_sizeof(idxmap) result(val) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer(psb_long_int_k_) :: val + + val = idxmap%psb_indx_map%sizeof() + val = val + 2 * psb_sizeof_int + if (allocated(idxmap%hashv)) & + & val = val + size(idxmap%hashv)*psb_sizeof_int + if (allocated(idxmap%glb_lc)) & + & val = val + size(idxmap%glb_lc)*psb_sizeof_int + if (allocated(idxmap%hash)) & + & val = val + psb_sizeof(idxmap%hash) + +end function hash_sizeof + + +subroutine hash_free(idxmap) + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer :: info + + if (allocated(idxmap%hashv)) & + & deallocate(idxmap%hashv) + if (allocated(idxmap%glb_lc)) & + & deallocate(idxmap%glb_lc) + + if (allocated(idxmap%hash)) then + call psb_free(idxmap%hash,info) + deallocate(idxmap%hash) + end if + + call idxmap%psb_indx_map%free() + +end subroutine hash_free + + +subroutine hash_l2gs1(idx,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%l2g(idxv,info,owned=owned) + idx = idxv(1) + +end subroutine hash_l2gs1 + +subroutine hash_l2gs2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%l2g(idxout,info,mask,owned) + +end subroutine hash_l2gs2 + + +subroutine hash_l2gv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i + logical :: owned_ + info = 0 + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return end if + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if - if (present(mask)) then + if (present(mask)) then - do i=1, size(idx) - if (mask(i)) then - if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then - idx(i) = idxmap%loc_to_glob(idx(i)) - else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& - & .and.(.not.owned_)) then - idx(i) = idxmap%loc_to_glob(idx(i)) - else - idx(i) = -1 - end if - end if - end do - - else if (.not.present(mask)) then - - do i=1, size(idx) + do i=1, size(idx) + if (mask(i)) then if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then idx(i) = idxmap%loc_to_glob(idx(i)) else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& @@ -185,155 +225,133 @@ contains else idx(i) = -1 end if - end do - - end if - - end subroutine hash_l2gv1 - - subroutine hash_l2gv2(idxin,idxout,idxmap,info,mask,owned) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(in) :: idxin(:) - integer, intent(out) :: idxout(:) - integer, intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned - integer :: is, im - - is = size(idxin) - im = min(is,size(idxout)) - idxout(1:im) = idxin(1:im) - call idxmap%l2g(idxout(1:im),info,mask,owned) - if (is > im) then - write(0,*) 'l2gv2 err -3' - info = -3 - end if - - end subroutine hash_l2gv2 - + end if + end do - subroutine hash_g2ls1(idx,idxmap,info,mask,owned) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(inout) :: idx - integer, intent(out) :: info - logical, intent(in), optional :: mask - logical, intent(in), optional :: owned - integer :: idxv(1) - info = 0 + else if (.not.present(mask)) then - if (present(mask)) then - if (.not.mask) return - end if - - idxv(1) = idx - call idxmap%g2l(idxv,info,owned=owned) - idx = idxv(1) - - end subroutine hash_g2ls1 - - subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(in) :: idxin - integer, intent(out) :: idxout - integer, intent(out) :: info - logical, intent(in), optional :: mask - logical, intent(in), optional :: owned - - idxout = idxin - call idxmap%g2l(idxout,info,mask,owned) - - end subroutine hash_g2ls2 - - - subroutine hash_g2lv1(idx,idxmap,info,mask,owned) - use psb_penv_mod - use psb_sort_mod - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(inout) :: idx(:) - integer, intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned - integer :: i, nv, is, mglob, ip, lip, nrow, ncol, nrm - integer :: ictxt, iam, np - logical :: owned_ - - info = 0 - ictxt = idxmap%get_ctxt() - call psb_info(ictxt,iam,np) - - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return + do i=1, size(idx) + if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& + & .and.(.not.owned_)) then + idx(i) = idxmap%loc_to_glob(idx(i)) + else + idx(i) = -1 end if - end if - if (present(owned)) then - owned_ = owned - else - owned_ = .false. - end if - - is = size(idx) + end do - mglob = idxmap%get_gr() - nrow = idxmap%get_lr() - ncol = idxmap%get_lc() - if (owned_) then - nrm = nrow - else - nrm = ncol + end if + +end subroutine hash_l2gv1 + +subroutine hash_l2gv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%l2g(idxout(1:im),info,mask,owned) + if (is > im) then + write(0,*) 'l2gv2 err -3' + info = -3 + end if + +end subroutine hash_l2gv2 + + +subroutine hash_g2ls1(idx,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idx + call idxmap%g2l(idxv,info,owned=owned) + idx = idxv(1) + +end subroutine hash_g2ls1 + +subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + idxout = idxin + call idxmap%g2l(idxout,info,mask,owned) + +end subroutine hash_g2ls2 + + +subroutine hash_g2lv1(idx,idxmap,info,mask,owned) + use psb_penv_mod + use psb_sort_mod + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer :: i, nv, is, mglob, ip, lip, nrow, ncol, nrm + integer :: ictxt, iam, np + logical :: owned_ + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return end if - if (present(mask)) then + end if + if (present(owned)) then + owned_ = owned + else + owned_ = .false. + end if - if (idxmap%is_asb()) then + is = size(idx) - call hash_inner_cnv(is,idx,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,mask=mask, nrm=nrm) + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + ncol = idxmap%get_lc() + if (owned_) then + nrm = nrow + else + nrm = ncol + end if + if (present(mask)) then - else if (idxmap%is_valid()) then + if (idxmap%is_asb()) then - do i = 1, is - if (mask(i)) then - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) - if (lip < 0) & - & call psb_hash_searchkey(ip,lip,idxmap%hash,info) - if (owned_) then - if (lip<=nrow) then - idx(i) = lip - else - idx(i) = -1 - endif - else - idx(i) = lip - endif - end if - enddo - - else - write(0,*) 'Hash status: invalid ',idxmap%get_state() - idx(1:is) = -1 - info = -1 - end if - - else if (.not.present(mask)) then + call hash_inner_cnv(is,idx,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,mask=mask, nrm=nrm) - if (idxmap%is_asb()) then + else if (idxmap%is_valid()) then - call hash_inner_cnv(is,idx,idxmap%hashvmask,& - & idxmap%hashv,idxmap%glb_lc,nrm=nrm) - - else if (idxmap%is_valid()) then - - do i = 1, is + do i = 1, is + if (mask(i)) then ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 @@ -351,158 +369,153 @@ contains else idx(i) = lip endif - enddo - - else - write(0,*) 'Hash status: invalid ',idxmap%get_state() - idx(1:is) = -1 - info = -1 - - end if + end if + enddo + else + write(0,*) 'Hash status: invalid ',idxmap%get_state() + idx(1:is) = -1 + info = -1 end if - end subroutine hash_g2lv1 - - subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) - implicit none - class(psb_hash_map), intent(in) :: idxmap - integer, intent(in) :: idxin(:) - integer, intent(out) :: idxout(:) - integer, intent(out) :: info - logical, intent(in), optional :: mask(:) - logical, intent(in), optional :: owned - - integer :: is, im - - is = size(idxin) - im = min(is,size(idxout)) - idxout(1:im) = idxin(1:im) - call idxmap%g2l(idxout(1:im),info,mask,owned) - if (is > im) then - write(0,*) 'g2lv2 err -3' - info = -3 - end if + else if (.not.present(mask)) then - end subroutine hash_g2lv2 + if (idxmap%is_asb()) then + call hash_inner_cnv(is,idx,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,nrm=nrm) + else if (idxmap%is_valid()) then - subroutine hash_g2ls1_ins(idx,idxmap,info,mask) - use psb_realloc_mod - use psb_sort_mod - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(inout) :: idx - integer, intent(out) :: info - logical, intent(in), optional :: mask + do i = 1, is + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) + if (lip < 0) & + & call psb_hash_searchkey(ip,lip,idxmap%hash,info) + if (owned_) then + if (lip<=nrow) then + idx(i) = lip + else + idx(i) = -1 + endif + else + idx(i) = lip + endif + enddo - integer :: idxv(1) + else + write(0,*) 'Hash status: invalid ',idxmap%get_state() + idx(1:is) = -1 + info = -1 - info = 0 - if (present(mask)) then - if (.not.mask) return end if - idxv(1) = idx - call idxmap%g2l_ins(idxv,info) - idx = idxv(1) - - end subroutine hash_g2ls1_ins - - subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask) - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(in) :: idxin - integer, intent(out) :: idxout - integer, intent(out) :: info - logical, intent(in), optional :: mask - - idxout = idxin - call idxmap%g2l_ins(idxout,info) - end subroutine hash_g2ls2_ins - - - subroutine hash_g2lv1_ins(idx,idxmap,info,mask) - use psb_error_mod - use psb_realloc_mod - use psb_sort_mod - use psb_penv_mod - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(inout) :: idx(:) - integer, intent(out) :: info - logical, intent(in), optional :: mask(:) - integer :: i, nv, is, ix, mglob, ip, lip, nrow, ncol, & - & nrm, nxt, err_act, ictxt, me, np - character(len=20) :: name,ch_err - - info = psb_success_ - name = 'hash_g2l_ins' - call psb_erractionsave(err_act) - - ictxt = idxmap%get_ctxt() - call psb_info(ictxt, me, np) - - is = size(idx) - - if (present(mask)) then - if (size(mask) < size(idx)) then - info = -1 - return - end if + end if + +end subroutine hash_g2lv1 + +subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_hash_map), intent(in) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l(idxout(1:im),info,mask,owned) + if (is > im) then + write(0,*) 'g2lv2 err -3' + info = -3 + end if + +end subroutine hash_g2lv2 + + + +subroutine hash_g2ls1_ins(idx,idxmap,info,mask) + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(inout) :: idx + integer, intent(out) :: info + logical, intent(in), optional :: mask + + integer :: idxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idx + call idxmap%g2l_ins(idxv,info) + idx = idxv(1) + +end subroutine hash_g2ls1_ins + +subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: idxin + integer, intent(out) :: idxout + integer, intent(out) :: info + logical, intent(in), optional :: mask + + idxout = idxin + call idxmap%g2l_ins(idxout,info) + +end subroutine hash_g2ls2_ins + + +subroutine hash_g2lv1_ins(idx,idxmap,info,mask) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_penv_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(inout) :: idx(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: i, nv, is, ix, mglob, ip, lip, nrow, ncol, & + & nrm, nxt, err_act, ictxt, me, np + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'hash_g2l_ins' + call psb_erractionsave(err_act) + + ictxt = idxmap%get_ctxt() + call psb_info(ictxt, me, np) + + is = size(idx) + + if (present(mask)) then + if (size(mask) < size(idx)) then + info = -1 + return end if + end if - mglob = idxmap%get_gr() - nrow = idxmap%get_lr() - if (idxmap%is_bld()) then - - if (present(mask)) then - do i = 1, is - ncol = idxmap%get_lc() - if (mask(i)) then - ip = idx(i) - if ((ip < 1 ).or.(ip>mglob)) then - idx(i) = -1 - cycle - endif - nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) & - & call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) - - if (info >=0) then - if (nxt == lip) then - ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1,addsz=200) - if (info /= psb_success_) then - info=1 - ch_err='psb_ensure_size' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - idxmap%loc_to_glob(nxt) = ip - call idxmap%set_lc(ncol) - endif - info = psb_success_ - else - ch_err='SearchInsKeyVal' - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - end if - idx(i) = lip - info = psb_success_ - else - idx(i) = -1 - end if - enddo + mglob = idxmap%get_gr() + nrow = idxmap%get_lr() + if (idxmap%is_bld()) then - else - do i = 1, is - ncol = idxmap%get_lc() + if (present(mask)) then + do i = 1, is + ncol = idxmap%get_lc() + if (mask(i)) then ip = idx(i) if ((ip < 1 ).or.(ip>mglob)) then idx(i) = -1 @@ -536,519 +549,523 @@ contains end if idx(i) = lip info = psb_success_ - enddo + else + idx(i) = -1 + end if + enddo + else + do i = 1, is + ncol = idxmap%get_lc() + ip = idx(i) + if ((ip < 1 ).or.(ip>mglob)) then + idx(i) = -1 + cycle + endif + nxt = ncol + 1 + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) & + & call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + + if (info >=0) then + if (nxt == lip) then + ncol = nxt + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1,addsz=200) + if (info /= psb_success_) then + info=1 + ch_err='psb_ensure_size' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + &a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + idxmap%loc_to_glob(nxt) = ip + call idxmap%set_lc(ncol) + endif + info = psb_success_ + else + ch_err='SearchInsKeyVal' + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err=ch_err,i_err=(/info,0,0,0,0/)) + goto 9999 + end if + idx(i) = lip + info = psb_success_ + enddo - end if - else - ! Wrong state - idx = -1 - info = -1 end if - call psb_erractionrestore(err_act) - return + + else + ! Wrong state + idx = -1 + info = -1 + end if + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if + if (err_act == psb_act_ret_) then return + else + call psb_error(ictxt) + end if + return + +end subroutine hash_g2lv1_ins + +subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask) + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: idxin(:) + integer, intent(out) :: idxout(:) + integer, intent(out) :: info + logical, intent(in), optional :: mask(:) + integer :: is, im + + is = size(idxin) + im = min(is,size(idxout)) + idxout(1:im) = idxin(1:im) + call idxmap%g2l_ins(idxout(1:im),info,mask) + if (is > im) then + write(0,*) 'g2lv2_ins err -3' + info = -3 + end if + +end subroutine hash_g2lv2_ins + +subroutine hash_init_vl(idxmap,ictxt,vl,info) + use psb_penv_mod + use psb_error_mod + use psb_sort_mod + use psb_realloc_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vl(:) + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, nlu, nl, m, nrt,int_err(5) + integer, allocatable :: vlu(:) + character(len=20), parameter :: name='hash_map_init_vl' + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if - end subroutine hash_g2lv1_ins - - subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask) - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(in) :: idxin(:) - integer, intent(out) :: idxout(:) - integer, intent(out) :: info - logical, intent(in), optional :: mask(:) - integer :: is, im - - is = size(idxin) - im = min(is,size(idxout)) - idxout(1:im) = idxin(1:im) - call idxmap%g2l_ins(idxout(1:im),info,mask) - if (is > im) then - write(0,*) 'g2lv2_ins err -3' - info = -3 - end if - - end subroutine hash_g2lv2_ins - - subroutine hash_init_vl(idxmap,ictxt,vl,info) - use psb_penv_mod - use psb_error_mod - use psb_sort_mod - use psb_realloc_mod - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(in) :: ictxt, vl(:) - integer, intent(out) :: info - ! To be implemented - integer :: iam, np, i, j, nlu, nl, m, nrt,int_err(5) - integer, allocatable :: vlu(:) - character(len=20), parameter :: name='hash_map_init_vl' - - info = 0 - call psb_info(ictxt,iam,np) - if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt - info = -1 - return - end if - - nl = size(vl) + nl = size(vl) - m = maxval(vl(1:nl)) - nrt = nl - call psb_sum(ictxt,nrt) - call psb_max(ictxt,m) + m = maxval(vl(1:nl)) + nrt = nl + call psb_sum(ictxt,nrt) + call psb_max(ictxt,m) - allocate(vlu(nl), stat=info) - if (info /= 0) then - info = -1 - return - end if + allocate(vlu(nl), stat=info) + if (info /= 0) then + info = -1 + return + end if + + do i=1,nl + if ((vl(i)<1).or.(vl(i)>m)) then + info = psb_err_entry_out_of_bounds_ + int_err(1) = i + int_err(2) = vl(i) + int_err(3) = nl + int_err(4) = m + exit + endif + vlu(i) = vl(i) + end do + + if ((m /= nrt).and.(iam == psb_root_)) then + write(psb_err_unit,*) trim(name),& + & ' Warning: globalcheck=.false., but there is a mismatch' + write(psb_err_unit,*) trim(name),& + & ' : in the global sizes!',m,nrt + end if + ! + ! Now sort the input items, and check for duplicates + ! (unlikely, but possible) + ! + call psb_msort_unique(vlu,nlu) + if (nlu /= nl) then + write(0,*) 'Warning: duplicates in input' + end if + + call hash_init_vlu(idxmap,ictxt,m,nlu,vlu,info) + +end subroutine hash_init_vl + +subroutine hash_init_vg(idxmap,ictxt,vg,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vg(:) + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, lc2, nl, nlu, n, nrt,int_err(5) + integer :: key, ih, ik, nh, idx, nbits, hsize, hmask + integer, allocatable :: vlu(:) + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + n = size(vg) + nl = 0 + do i=1, n + if ((vg(i)<0).or.(vg(i)>=np)) then + info = psb_err_partfunc_wrong_pid_ + int_err(1) = 3 + int_err(2) = vg(i) + int_err(3) = i + exit + endif + if (vg(i) == iam) nl = nl + 1 + end do - do i=1,nl - if ((vl(i)<1).or.(vl(i)>m)) then - info = psb_err_entry_out_of_bounds_ - int_err(1) = i - int_err(2) = vl(i) - int_err(3) = nl - int_err(4) = m - exit - endif - vlu(i) = vl(i) - end do + allocate(vlu(nl), stat=info) + if (info /= 0) then + info = -1 + return + end if - if ((m /= nrt).and.(iam == psb_root_)) then - write(psb_err_unit,*) trim(name),& - & ' Warning: globalcheck=.false., but there is a mismatch' - write(psb_err_unit,*) trim(name),& - & ' : in the global sizes!',m,nrt - end if - ! - ! Now sort the input items, and check for duplicates - ! (unlikely, but possible) - ! - call psb_msort_unique(vlu,nlu) - if (nlu /= nl) then - write(0,*) 'Warning: duplicates in input' + j = 0 + do i=1, n + if (vg(i) == iam) then + j = j + 1 + vlu(j) = i end if + end do - call hash_init_vlu(idxmap,ictxt,m,nlu,vlu,info) - - end subroutine hash_init_vl - - subroutine hash_init_vg(idxmap,ictxt,vg,info) - use psb_penv_mod - use psb_error_mod - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(in) :: ictxt, vg(:) - integer, intent(out) :: info - ! To be implemented - integer :: iam, np, i, j, lc2, nl, nlu, n, nrt,int_err(5) - integer :: key, ih, ik, nh, idx, nbits, hsize, hmask - integer, allocatable :: vlu(:) - - info = 0 - call psb_info(ictxt,iam,np) - if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt - info = -1 - return - end if - n = size(vg) - nl = 0 - do i=1, n - if ((vg(i)<0).or.(vg(i)>=np)) then - info = psb_err_partfunc_wrong_pid_ - int_err(1) = 3 - int_err(2) = vg(i) - int_err(3) = i - exit - endif - if (vg(i) == iam) nl = nl + 1 - end do - - allocate(vlu(nl), stat=info) - if (info /= 0) then - info = -1 - return - end if + call hash_init_vlu(idxmap,ictxt,n,nl,vlu,info) - j = 0 - do i=1, n - if (vg(i) == iam) then - j = j + 1 - vlu(j) = i - end if - end do +end subroutine hash_init_vg - call hash_init_vlu(idxmap,ictxt,n,nl,vlu,info) +subroutine hash_init_vlu(idxmap,ictxt,ntot,nl,vlu,info) + use psb_penv_mod + use psb_error_mod + use psb_sort_mod + use psb_realloc_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, vlu(:), nl, ntot + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, lc2, nlu, m, nrt,int_err(5) + integer :: key, ih, ik, nh, idx, nbits, hsize, hmask + character(len=20), parameter :: name='hash_map_init_vlu' - end subroutine hash_init_vg + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + idxmap%global_rows = ntot + idxmap%global_cols = ntot + idxmap%local_rows = nl + idxmap%local_cols = nl + idxmap%ictxt = ictxt + idxmap%state = psb_desc_bld_ + call psb_get_mpicomm(ictxt,idxmap%mpic) + + lc2 = int(1.5*nl) + allocate(idxmap%hash,idxmap%loc_to_glob(lc2),stat=info) + if (info /= 0) then + info = -2 + return + end if + + call psb_hash_init(nl,idxmap%hash,info) + if (info /= 0) then + write(0,*) 'from Hash_Init inside init_vlu',info + info = -3 + return + endif + + do i=1, nl + idxmap%loc_to_glob(i) = vlu(i) + end do + + call hash_bld_g2l_map(idxmap,info) + call idxmap%set_state(psb_desc_bld_) + +end subroutine hash_init_vlu + + + +subroutine hash_bld_g2l_map(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_sort_mod + use psb_realloc_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(out) :: info + ! To be implemented + integer :: ictxt, iam, np, i, j, lc2, nlu, m, nrt,int_err(5), nl + integer :: key, ih, ik, nh, idx, nbits, hsize, hmask + character(len=20), parameter :: name='hash_map_init_vlu' + + info = 0 + ictxt = idxmap%get_ctxt() + + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + nl = idxmap%get_lc() - subroutine hash_init_vlu(idxmap,ictxt,ntot,nl,vlu,info) - use psb_penv_mod - use psb_error_mod - use psb_sort_mod - use psb_realloc_mod - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(in) :: ictxt, vlu(:), nl, ntot - integer, intent(out) :: info - ! To be implemented - integer :: iam, np, i, j, lc2, nlu, m, nrt,int_err(5) - integer :: key, ih, ik, nh, idx, nbits, hsize, hmask - character(len=20), parameter :: name='hash_map_init_vlu' + call psb_realloc(nl,2,idxmap%glb_lc,info) - info = 0 - call psb_info(ictxt,iam,np) - if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt - info = -1 + nbits = psb_hash_bits + hsize = 2**nbits + do + if (hsize < 0) then + ! This should never happen for sane values + ! of psb_max_hash_bits. + write(psb_err_unit,*) & + & 'Error: hash size overflow ',hsize,nbits + info = -2 return end if - - idxmap%global_rows = ntot - idxmap%global_cols = ntot - idxmap%local_rows = nl - idxmap%local_cols = nl - idxmap%ictxt = ictxt - idxmap%state = psb_desc_bld_ - call psb_get_mpicomm(ictxt,idxmap%mpic) - - lc2 = int(1.5*nl) - allocate(idxmap%hash,idxmap%loc_to_glob(lc2),stat=info) - if (info /= 0) then - info = -2 - return + if (hsize > nl) exit + if (nbits >= psb_max_hash_bits) exit + nbits = nbits + 1 + hsize = hsize * 2 + end do + + hmask = hsize - 1 + idxmap%hashvsize = hsize + idxmap%hashvmask = hmask + + if (info == psb_success_) & + & call psb_realloc(hsize+1,idxmap%hashv,info,lb=0) + if (info /= psb_success_) then + ! !$ ch_err='psb_realloc' + ! !$ call psb_errpush(info,name,a_err=ch_err) + ! !$ goto 9999 + info = -4 + return + end if + + idxmap%hashv(:) = 0 + + do i=1, nl + key = idxmap%loc_to_glob(i) + ih = iand(key,hmask) + idxmap%hashv(ih) = idxmap%hashv(ih) + 1 + end do + + nh = idxmap%hashv(0) + idx = 1 + + do i=1, hsize + idxmap%hashv(i-1) = idx + idx = idx + nh + nh = idxmap%hashv(i) + end do + + do i=1, nl + key = idxmap%loc_to_glob(i) + ih = iand(key,hmask) + idx = idxmap%hashv(ih) + idxmap%glb_lc(idx,1) = key + idxmap%glb_lc(idx,2) = i + idxmap%hashv(ih) = idxmap%hashv(ih) + 1 + end do + + do i = hsize, 1, -1 + idxmap%hashv(i) = idxmap%hashv(i-1) + end do + + idxmap%hashv(0) = 1 + do i=0, hsize-1 + idx = idxmap%hashv(i) + nh = idxmap%hashv(i+1) - idxmap%hashv(i) + if (nh > 1) then + call psb_msort(idxmap%glb_lc(idx:idx+nh-1,1),& + & ix=idxmap%glb_lc(idx:idx+nh-1,2),& + & flag=psb_sort_keep_idx_) end if + end do - call psb_hash_init(nl,idxmap%hash,info) - if (info /= 0) then - write(0,*) 'from Hash_Init inside init_vlu',info - info = -3 - return - endif - - do i=1, nl - idxmap%loc_to_glob(i) = vlu(i) - end do - - call hash_bld_g2l_map(idxmap,info) - call idxmap%set_state(psb_desc_bld_) +end subroutine hash_bld_g2l_map - end subroutine hash_init_vlu +subroutine hash_asb(idxmap,info) + use psb_penv_mod + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_hash_map), intent(inout) :: idxmap + integer, intent(out) :: info + integer :: nhal, ictxt, iam, np - subroutine hash_bld_g2l_map(idxmap,info) - use psb_penv_mod - use psb_error_mod - use psb_sort_mod - use psb_realloc_mod - implicit none - class(psb_hash_map), intent(inout) :: idxmap - integer, intent(out) :: info - ! To be implemented - integer :: ictxt, iam, np, i, j, lc2, nlu, m, nrt,int_err(5), nl - integer :: key, ih, ik, nh, idx, nbits, hsize, hmask - character(len=20), parameter :: name='hash_map_init_vlu' + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,iam,np) - info = 0 - ictxt = idxmap%get_ctxt() - - call psb_info(ictxt,iam,np) - if (np < 0) then - write(psb_err_unit,*) 'Invalid ictxt:',ictxt - info = -1 - return - end if + nhal = max(0,idxmap%local_cols-idxmap%local_rows) - nl = idxmap%get_lc() - - call psb_realloc(nl,2,idxmap%glb_lc,info) + call hash_bld_g2l_map(idxmap,info) + if (info /= 0) then + write(0,*) 'Error from bld_g2l_map', info + return + end if - nbits = psb_hash_bits - hsize = 2**nbits + call psb_free(idxmap%hash,info) + if (info == 0) deallocate(idxmap%hash,stat=info) + if (info /= 0) then + write(0,*) 'Error from hash free', info + return + end if + + call idxmap%set_state(psb_desc_asb_) + +end subroutine hash_asb + +function hash_get_fmt(idxmap) result(res) + implicit none + class(psb_hash_map), intent(in) :: idxmap + character(len=5) :: res + res = 'HASH' +end function hash_get_fmt + + +subroutine hash_inner_cnvs1(x,hashmask,hashv,glb_lc,nrm) + + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(inout) :: x + integer, intent(in) :: nrm + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + + key = x + 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 (hsize < 0) then - ! This should never happen for sane values - ! of psb_max_hash_bits. - write(psb_err_unit,*) & - & 'Error: hash size overflow ',hsize,nbits - info = -2 - return + if (lb>ub) exit + lm = (lb+ub)/2 + if (key == glb_lc(lm,1)) then + tmp = lm + exit + else if (key nl) exit - if (nbits >= psb_max_hash_bits) exit - nbits = nbits + 1 - hsize = hsize * 2 end do - - hmask = hsize - 1 - idxmap%hashvsize = hsize - idxmap%hashvmask = hmask - - if (info == psb_success_) & - & call psb_realloc(hsize+1,idxmap%hashv,info,lb=0) - if (info /= psb_success_) then - ! !$ ch_err='psb_realloc' - ! !$ call psb_errpush(info,name,a_err=ch_err) - ! !$ goto 9999 - info = -4 - return + else + tmp = -1 + end if + if (tmp > 0) then + x = glb_lc(tmp,2) + if (x > nrm) then + x = -1 end if - - idxmap%hashv(:) = 0 - - do i=1, nl - key = idxmap%loc_to_glob(i) - ih = iand(key,hmask) - idxmap%hashv(ih) = idxmap%hashv(ih) + 1 - end do - - nh = idxmap%hashv(0) - idx = 1 - - do i=1, hsize - idxmap%hashv(i-1) = idx - idx = idx + nh - nh = idxmap%hashv(i) - end do - - do i=1, nl - key = idxmap%loc_to_glob(i) - ih = iand(key,hmask) - idx = idxmap%hashv(ih) - idxmap%glb_lc(idx,1) = key - idxmap%glb_lc(idx,2) = i - idxmap%hashv(ih) = idxmap%hashv(ih) + 1 - end do - - do i = hsize, 1, -1 - idxmap%hashv(i) = idxmap%hashv(i-1) - end do - - idxmap%hashv(0) = 1 - do i=0, hsize-1 - idx = idxmap%hashv(i) - nh = idxmap%hashv(i+1) - idxmap%hashv(i) - if (nh > 1) then - call psb_msort(idxmap%glb_lc(idx:idx+nh-1,1),& - & ix=idxmap%glb_lc(idx:idx+nh-1,2),& - & flag=psb_sort_keep_idx_) + else + x = tmp + end if +end subroutine hash_inner_cnvs1 + +subroutine hash_inner_cnvs2(x,y,hashmask,hashv,glb_lc,nrm) + integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer, intent(in) :: x + integer, intent(out) :: y + integer, intent(in) :: nrm + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + + key = x + 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 + y = glb_lc(tmp,2) + if (y > nrm) then + y = -1 end if - - call psb_free(idxmap%hash,info) - if (info == 0) deallocate(idxmap%hash,stat=info) - if (info /= 0) then - write(0,*) 'Error from hash free', info - return - end if - - call idxmap%set_state(psb_desc_asb_) - - end subroutine hash_asb - - function hash_get_fmt(idxmap) result(res) - implicit none - class(psb_hash_map), intent(in) :: idxmap - character(len=5) :: res - res = 'HASH' - end function hash_get_fmt - - - subroutine hash_inner_cnvs1(x,hashmask,hashv,glb_lc,nrm) - - integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer, intent(inout) :: x - integer, intent(in) :: nrm - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - - key = x - 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 = glb_lc(tmp,2) - if (x > nrm) then - x = -1 - end if - else - x = tmp - end if - end subroutine hash_inner_cnvs1 - - subroutine hash_inner_cnvs2(x,y,hashmask,hashv,glb_lc,nrm) - integer, intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer, intent(in) :: x - integer, intent(out) :: y - integer, intent(in) :: nrm - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - - key = x - 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 - y = glb_lc(tmp,2) - if (y > nrm) then - y = -1 - end if - else - y = tmp - end if - end subroutine hash_inner_cnvs2 - - - subroutine hash_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask,nrm) - integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) - logical, intent(in), optional :: mask(:) - integer, intent(in), optional :: nrm - integer, intent(inout) :: x(:) - - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - if (present(mask)) then - do i=1, n - if (mask(i)) then - 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) - if (present(nrm)) then - if (x(i) > nrm) then - x(i) = -1 - end if - end if - else - x(i) = tmp - end if - end if - end do - else - do i=1, n + else + y = tmp + end if +end subroutine hash_inner_cnvs2 + + +subroutine hash_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask,nrm) + integer, intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in), optional :: mask(:) + integer, intent(in), optional :: nrm + integer, intent(inout) :: x(:) + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + if (present(mask)) then + do i=1, n + if (mask(i)) then key = x(i) ih = iand(key,hashmask) idx = hashv(ih) @@ -1082,70 +1099,65 @@ contains else x(i) = tmp end if - end do - end if - end subroutine hash_inner_cnv1 - - subroutine hash_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask,nrm) - integer, intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) - logical, intent(in), optional :: mask(:) - integer, intent(in), optional :: nrm - integer, intent(in) :: x(:) - integer, intent(out) :: y(:) - - integer :: i, ih, key, idx,nh,tmp,lb,ub,lm - ! - ! When a large descriptor is assembled the indices - ! are kept in a (hashed) list of ordered lists. - ! Thus we first hash the index, then we do a binary search on the - ! ordered sublist. The hashing is based on the low-order bits - ! for a width of psb_hash_bits - ! - if (present(mask)) then - do i=1, n - if (mask(i)) then - key = x(i) - ih = iand(key,hashmask) - if (ih > ubound(hashv,1) ) then - write(psb_err_unit,*) ' In inner cnv: ',ih,ubound(hashv) - 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 + 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) - if (present(nrm)) then - if (y(i) > nrm) then - y(i) = -1 - end if - end if - else - y(i) = tmp + end do + else + tmp = -1 + end if + if (tmp > 0) then + x(i) = glb_lc(tmp,2) + if (present(nrm)) then + if (x(i) > nrm) then + x(i) = -1 end if end if - end do - - else - - do i=1, n + else + x(i) = tmp + end if + end do + end if +end subroutine hash_inner_cnv1 + +subroutine hash_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask,nrm) + integer, intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in), optional :: mask(:) + integer, intent(in), optional :: nrm + integer, intent(in) :: x(:) + integer, intent(out) :: y(:) + + integer :: i, ih, key, idx,nh,tmp,lb,ub,lm + ! + ! When a large descriptor is assembled the indices + ! are kept in a (hashed) list of ordered lists. + ! Thus we first hash the index, then we do a binary search on the + ! ordered sublist. The hashing is based on the low-order bits + ! for a width of psb_hash_bits + ! + if (present(mask)) then + do i=1, n + if (mask(i)) then key = x(i) ih = iand(key,hashmask) if (ih > ubound(hashv,1) ) then @@ -1182,9 +1194,51 @@ contains else y(i) = tmp end if - end do - end if - end subroutine hash_inner_cnv2 + end if + end do + + else + + do i=1, n + key = x(i) + ih = iand(key,hashmask) + if (ih > ubound(hashv,1) ) then + write(psb_err_unit,*) ' In inner cnv: ',ih,ubound(hashv) + 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) + if (present(nrm)) then + if (y(i) > nrm) then + y(i) = -1 + end if + end if + else + y(i) = tmp + end if + end do + end if +end subroutine hash_inner_cnv2 end module psb_hash_map_mod diff --git a/base/modules/psb_indx_map_mod.f03 b/base/modules/psb_indx_map_mod.f03 index 062d4ecb..0720d64a 100644 --- a/base/modules/psb_indx_map_mod.f03 +++ b/base/modules/psb_indx_map_mod.f03 @@ -1,7 +1,82 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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. +!!$ +!!$ +! +! +! package: psb_indx_map_mod +! Defines the PSB_INDX_MAP class. +! +! In particular, besides the communicator, it contains the data relevant +! to the following queries: +! 1. How many global rows/columns? +! 2. How many local rows/columns? +! 3. Convert between local and global indices +! 4. Add to local indices. +! 5. Find (one of) the owner(s) of a given index +! 6. Query the indx state. +! 7. Does the dynamic class support extensions of the rows? I.e., can +! it have overlap? for instance, the BLOCK cannot, it would run afoul +! of the glob_to_loc translation. +! +! Checking for the existence of overlap is very expensive, thus +! it is done at build time (for extended-halo cases it can be inferred from +! the construction process). +! +! 1. Each global index I is owned by at least one process; +! +! 2. On each process, indices from 1 to N_ROW (desc%indxmap%get_lr()) +! are locally owned; the value of N_ROW can be determined upon allocation +! based on the index distribution (see also the interface to CDALL). +! +! 3. If a global index is owned by more than one process, we have an OVERLAP +! in which case the sum of all the N_ROW values is greater than the total +! size of the index space; +! +! 4. During the buildup of the descriptor, according to the user specified +! stencil, we also take notice of indices that are not owned by the current +! process, but whose value is needed to proceed with the computation; these +! form the HALO of the current process. Halo indices are assigned local indices +! from N_ROW+1 to N_COL (inclusive). +! +! 5. The upper bound N_COL moves during the descriptor build process (see CDINS). +! +! +! +! +! +! module psb_indx_map_mod use psb_const_mod use psb_desc_const_mod - + type :: psb_indx_map integer :: state = psb_desc_null_ @@ -39,7 +114,7 @@ module psb_indx_map_mod procedure, pass(idxmap) :: set_lc => base_set_lc procedure, pass(idxmap) :: set_ctxt => base_set_ctxt procedure, pass(idxmap) :: set_mpic => base_set_mpic - + procedure, pass(idxmap) :: get_fmt => base_get_fmt procedure, pass(idxmap) :: asb => base_asb @@ -91,84 +166,84 @@ module psb_indx_map_mod integer, intent(out) :: info end subroutine psb_indx_map_fnd_owner end interface - + contains function base_get_state(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer :: val - + val = idxmap%state end function base_get_state - + function base_get_gr(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer :: val - + val = idxmap%global_rows end function base_get_gr - + function base_get_gc(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer :: val - + val = idxmap%global_cols end function base_get_gc - + function base_get_lr(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer :: val - + val = idxmap%local_rows end function base_get_lr - + function base_get_lc(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer :: val - + val = idxmap%local_cols end function base_get_lc - + function base_get_ctxt(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer :: val - + val = idxmap%ictxt end function base_get_ctxt - + function base_get_mpic(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer :: val - + val = idxmap%mpic end function base_get_mpic - + subroutine base_set_state(idxmap,val) implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(in) :: val - + idxmap%state = val end subroutine base_set_state @@ -176,15 +251,15 @@ contains implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(in) :: val - + idxmap%ictxt = val end subroutine base_set_ctxt - + subroutine base_set_gr(idxmap,val) implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(in) :: val - + idxmap%global_rows = val end subroutine base_set_gr @@ -192,7 +267,7 @@ contains implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(in) :: val - + idxmap%global_cols = val end subroutine base_set_gc @@ -200,7 +275,7 @@ contains implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(in) :: val - + idxmap%local_rows = val end subroutine base_set_lr @@ -208,7 +283,7 @@ contains implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(in) :: val - + idxmap%local_cols = val end subroutine base_set_lc @@ -216,11 +291,11 @@ contains implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(in) :: val - + idxmap%mpic = val end subroutine base_set_mpic - + function base_row_extendable(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap @@ -234,15 +309,15 @@ contains logical :: val val = .false. end function base_is_repl - + function base_is_null(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap logical :: val val = (idxmap%state == psb_desc_null_) end function base_is_null - - + + function base_is_bld(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap @@ -250,14 +325,14 @@ contains val = (idxmap%state == psb_desc_bld_).or.& & (idxmap%state == psb_desc_ovl_bld_) end function base_is_bld - + function base_is_upd(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap logical :: val val = (idxmap%state == psb_desc_upd_) end function base_is_upd - + function base_is_asb(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap @@ -265,7 +340,7 @@ contains val = (idxmap%state == psb_desc_asb_).or.& & (idxmap%state == psb_desc_ovl_asb_) end function base_is_asb - + function base_is_valid(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap @@ -273,7 +348,7 @@ contains val = idxmap%is_bld().or.idxmap%is_upd().or.idxmap%is_asb() end function base_is_valid - + function base_is_ovl(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap @@ -281,12 +356,12 @@ contains val = (idxmap%state == psb_desc_ovl_bld_).or.& & (idxmap%state == psb_desc_ovl_asb_) end function base_is_ovl - + function base_sizeof(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap integer(psb_long_int_k_) :: val - + val = 8 * psb_sizeof_int end function base_sizeof @@ -333,19 +408,19 @@ contains Integer :: err_act character(len=20) :: name='base_l2g' logical, parameter :: debug=.false. - + call psb_get_erraction(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - + if (err_act /= psb_act_ret_) then call psb_error() end if return - + end subroutine base_l2gs2 @@ -360,14 +435,14 @@ contains Integer :: err_act character(len=20) :: name='base_l2g' logical, parameter :: debug=.false. - + call psb_get_erraction(err_act) ! This is the base version. If we get here ! it means the derived class is incomplete, ! so we throw an error. call psb_errpush(psb_err_missing_override_method_,& & name,a_err=idxmap%get_fmt()) - + if (err_act /= psb_act_ret_) then call psb_error() end if @@ -453,7 +528,7 @@ contains call psb_error() end if return - + end subroutine base_g2ls2 @@ -547,7 +622,7 @@ contains integer, intent(out) :: idxout integer, intent(out) :: info logical, intent(in), optional :: mask - + Integer :: err_act character(len=20) :: name='base_g2l_ins' logical, parameter :: debug=.false. @@ -563,7 +638,7 @@ contains call psb_error() end if return - + end subroutine base_g2ls2_ins @@ -625,7 +700,7 @@ contains implicit none class(psb_indx_map), intent(inout) :: idxmap integer, intent(out) :: info - + Integer :: err_act character(len=20) :: name='base_asb' logical, parameter :: debug=.false. @@ -641,14 +716,14 @@ contains call psb_error() end if return - + end subroutine base_asb subroutine base_free(idxmap) use psb_error_mod implicit none class(psb_indx_map), intent(inout) :: idxmap - + Integer :: err_act character(len=20) :: name='base_free' logical, parameter :: debug=.false. @@ -712,7 +787,7 @@ contains end if return end subroutine base_init_vl - + end module psb_indx_map_mod diff --git a/base/modules/psb_list_map_mod.f03 b/base/modules/psb_list_map_mod.f03 index 8bfe3299..5b956d84 100644 --- a/base/modules/psb_list_map_mod.f03 +++ b/base/modules/psb_list_map_mod.f03 @@ -1,3 +1,44 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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. +!!$ +!!$ +! +! +! package: psb_list_map_mod +! Defines the LIST_MAP type. +! +! This is essentially the original PSBLAS index map. We assume that +! 1. We have room for GLOB_TO_LOC and LOC_TO_GLOB +! 2. There could be an overlap, so we don't store explicitly who owns an index. +! +! module psb_list_map_mod use psb_const_mod use psb_desc_const_mod diff --git a/base/modules/psb_repl_map_mod.f03 b/base/modules/psb_repl_map_mod.f03 index 8cc0888a..7077317f 100644 --- a/base/modules/psb_repl_map_mod.f03 +++ b/base/modules/psb_repl_map_mod.f03 @@ -1,3 +1,45 @@ +!!$ +!!$ Parallel Sparse BLAS version 3.0 +!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ +!!$ 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. +!!$ +!!$ +! +! +! package: psb_repl_map_mod +! Defines the REPL_MAP type. +! This is a replicated index space. It is also used +! when NP=1. The answer to the query for the owning process +! is always the local process, after all it's supposed to be +! replicated; also, global to local index mapping is just the +! identity, only thing to be done is to check the bounds. +! +! module psb_repl_map_mod use psb_const_mod use psb_desc_const_mod diff --git a/base/modules/psi_comm_buffers_mod.F90 b/base/modules/psi_comm_buffers_mod.F90 index d26ccacb..dcc29a91 100644 --- a/base/modules/psi_comm_buffers_mod.F90 +++ b/base/modules/psi_comm_buffers_mod.F90 @@ -13,6 +13,7 @@ module mpi integer, parameter :: mpi_double_complex = 6 integer, parameter :: mpi_character = 7 integer, parameter :: mpi_logical = 8 + integer, parameter :: mpi_integer2 = 9 integer, parameter :: mpi_comm_null = -1 integer, parameter :: mpi_comm_world = 1 @@ -31,6 +32,7 @@ module psi_comm_buffers_mod integer, private, parameter:: psb_logical_type = psb_dcomplex_type + 1 integer, private, parameter:: psb_char_type = psb_logical_type + 1 integer, private, parameter:: psb_int8_type = psb_char_type + 1 + integer, private, parameter:: psb_int2_type = psb_int8_type + 1 type psb_buffer_node @@ -39,6 +41,7 @@ module psi_comm_buffers_mod integer :: buffer_type integer(psb_int_k_), allocatable :: intbuf(:) integer(psb_long_int_k_), allocatable :: int8buf(:) + integer(2), allocatable :: int2buf(:) real(psb_spk_), allocatable :: realbuf(:) real(psb_dpk_), allocatable :: doublebuf(:) complex(psb_spk_), allocatable :: complexbuf(:) @@ -64,6 +67,11 @@ module psi_comm_buffers_mod module procedure psi_i8snd end interface #endif +#if defined(SHORT_INTEGERS) + interface psi_snd + module procedure psi_i2snd + end interface +#endif contains @@ -288,6 +296,42 @@ contains end subroutine psi_i8snd #endif +#if defined(SHORT_INTEGERS) + subroutine psi_i2snd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + integer(2), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_int2_type + call move_alloc(buffer,node%int2buf) + if (info /= 0) then + write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%int2buf,size(node%int2buf),mpi_integer2,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_i2snd +#endif + subroutine psi_ssnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD diff --git a/base/modules/psi_p2p_mod.F90 b/base/modules/psi_p2p_mod.F90 index f8a993cc..250f7df0 100644 --- a/base/modules/psi_p2p_mod.F90 +++ b/base/modules/psi_p2p_mod.F90 @@ -34,6 +34,15 @@ module psi_p2p_mod end interface #endif +#if defined(SHORT_INTEGERS) + interface psb_snd + module procedure psb_i2snds, psb_i2sndv, psb_i2sndm + end interface + + interface psb_rcv + module procedure psb_i2rcvs, psb_i2rcvv, psb_i2rcvm + end interface +#endif @@ -45,6 +54,7 @@ module psi_p2p_mod integer, private, parameter:: psb_logical_tag = psb_dcomplex_tag + 1 integer, private, parameter:: psb_char_tag = psb_logical_tag + 1 integer, private, parameter:: psb_int8_tag = psb_char_tag + 1 + integer, private, parameter:: psb_int2_tag = psb_int8_tag + 1 integer, parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag integer, parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag @@ -54,6 +64,7 @@ module psi_p2p_mod integer, parameter:: psb_logical_swap_tag = psb_logical_tag + psb_int_tag integer, parameter:: psb_char_swap_tag = psb_char_tag + psb_int_tag integer, parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag + integer, parameter:: psb_int2_swap_tag = psb_int2_tag + psb_int_tag contains @@ -692,6 +703,95 @@ contains #endif end subroutine psb_i8sndm +#endif + + +#if defined(SHORT_INTEGERS) + subroutine psb_i2snds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(in) :: dat + integer, intent(in) :: dst + integer(2), allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_i2snds + + subroutine psb_i2sndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(in) :: dat(:) + integer, intent(in) :: dst + integer(2), allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_i2sndv + + subroutine psb_i2sndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + integer(2), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_i2sndm + #endif ! !!!!!!!!!!!!!!!!!!!!!!!! @@ -1336,4 +1436,92 @@ contains #endif +#if defined(SHORT_INTEGERS) + + subroutine psb_i2rcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_integer2,src,psb_int2_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_i2rcvs + + subroutine psb_i2rcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(out) :: dat(:) + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_integer2,src,psb_int2_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_i2rcvv + + subroutine psb_i2rcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_integer2,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_int2_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_integer2,src,& + & psb_int2_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_i2rcvm + +#endif + end module psi_p2p_mod diff --git a/base/modules/psi_reduce_mod.F90 b/base/modules/psi_reduce_mod.F90 index 0f1d3cc6..45d285fe 100644 --- a/base/modules/psi_reduce_mod.F90 +++ b/base/modules/psi_reduce_mod.F90 @@ -57,6 +57,11 @@ module psi_reduce_mod & psb_dsums, psb_dsumv, psb_dsumm,& & psb_zsums, psb_zsumv, psb_zsumm end interface +#if defined(SHORT_INTEGERS) + interface psb_sum + module procedure psb_i2sums, psb_i2sumv, psb_i2summ + end interface psb_sum +#endif #if !defined(LONG_INTEGERS) interface psb_sum module procedure psb_i8sums, psb_i8sumv, psb_i8summ @@ -2674,6 +2679,130 @@ contains end subroutine psb_isumm +#if defined(SHORT_INTEGERS) + subroutine psb_i2sums(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(2) :: dat_ + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_integer2,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_integer2,mpi_sum,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_i2sums + + subroutine psb_i2sumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer(2), allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer2,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer2,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer2,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2sumv + + subroutine psb_i2summ(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(2), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer(2), allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer2,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer2,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer2,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2summ + +#endif + + #if !defined(LONG_INTEGERS) subroutine psb_i8sums(ictxt,dat,root) diff --git a/base/tools/psb_cd_set_bld.f90 b/base/tools/psb_cd_set_bld.f90 index ed44deec..9dd1d320 100644 --- a/base/tools/psb_cd_set_bld.f90 +++ b/base/tools/psb_cd_set_bld.f90 @@ -39,7 +39,7 @@ subroutine psb_cd_set_ovl_bld(desc,info) if (info == psb_success_) then if (desc%indxmap%row_extendable()) then call desc%indxmap%set_state(psb_desc_ovl_bld_) - desc%matrix_data(psb_dec_type_) = psb_cd_ovl_bld_ + desc%matrix_data(psb_dec_type_) = psb_desc_ovl_bld_ else info = psb_err_invalid_cd_state_ end if