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

psblas3:

Browse Source 
Updated license statement on all files in preparation for 3.0 release.
Defined i_base_vect and i_vect; also to get through with preprocessing
defined idot and inrm2 even if they are not actually used (and inrm2
really does norm1).
This commit is contained in:
Salvatore Filippone
2012-05-11 14:48:52 +00:00
parent b498a99289
commit c0e8ccabea
456 changed files with 4914 additions and 1457 deletions
Download Patch File Download Diff File Expand all files Collapse all files
README
+4 -3
View File
@@ -117,7 +117,8 @@ small cases have been tested but we do not offer full guarantee (yet).
COMPILER NOTES.
Notes: This code is confirmed to work with the following compilers (or
This code is confirmed to work with the following compilers (or
later versions thereof):
NAGware 5.2;
XLF 13.1;
@@ -136,8 +137,8 @@ with both CCE and GNU lower-level compilers.
KNOWN ISSUES.
For the GNU compilers 4.6.x we are aware of a number of memory management
issues that may or may not surface in your applications; all of them
(that we're aware of) are solved in version 4.7.0.
issues that might surface in your applications; all of them (that
we're aware of) are solved in version 4.7.0.
The Intel compiler up to version 12.1 fails due to a bug in the
handling of generic interfaces.
base/comm/psb_cgather.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -178,7 +178,7 @@ end subroutine psb_cgatherm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_chalo.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -223,7 +223,7 @@ end subroutine psb_chalom
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_covrl.f90
+3 -3
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -204,7 +204,7 @@ subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode)
end subroutine psb_covrlm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -242,7 +242,7 @@ end subroutine psb_covrlm
! x(:) - complex The local part of the dense vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code.
! work - real(optional). A work area.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
base/comm/psb_cscatter.F90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -235,7 +235,7 @@ end subroutine psb_cscatterm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_cspgather.F90
+32
View File
@@ -1,3 +1,35 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ 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.
!!$
!!$
! File: psb_cspgather.f90
subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
use psb_descriptor_type
use psb_error_mod
base/comm/psb_dgather.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -178,7 +178,7 @@ end subroutine psb_dgatherm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_dhalo.f90
+6 -6
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -223,7 +223,7 @@ end subroutine psb_dhalom
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -499,12 +499,12 @@ subroutine psb_dhalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
call psb_errpush(info,name)
end if
err = info
err=info
call psb_errcomm(ictxt,err)
if (err /= 0) goto 9999
if(err /= 0) goto 9999
if (present(alpha)) then
if (alpha /= done) then
if(present(alpha)) then
if(alpha /= done) then
call x%scal(alpha)
end if
end if
base/comm/psb_dovrl.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -204,7 +204,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode)
end subroutine psb_dovrlm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_dscatter.F90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -235,7 +235,7 @@ end subroutine psb_dscatterm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_dspgather.F90
+32
View File
@@ -1,3 +1,35 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ 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.
!!$
!!$
! File: psb_dspgather.f90
subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
use psb_descriptor_type
use psb_error_mod
base/comm/psb_igather.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -174,7 +174,7 @@ end subroutine psb_igatherm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_ihalo.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -227,7 +227,7 @@ end subroutine psb_ihalom
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_iovrl.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -203,7 +203,7 @@ end subroutine psb_iovrlm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_iscatter.F90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -233,7 +233,7 @@ end subroutine psb_iscatterm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_sgather.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -178,7 +178,7 @@ end subroutine psb_sgatherm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_shalo.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -223,7 +223,7 @@ end subroutine psb_shalom
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_sovrl.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -204,7 +204,7 @@ subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode)
end subroutine psb_sovrlm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_sscatter.F90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -235,7 +235,7 @@ end subroutine psb_sscatterm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_sspgather.F90
+32
View File
@@ -1,3 +1,35 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ 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.
!!$
!!$
! File: psb_sspgather.f90
subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
use psb_descriptor_type
use psb_error_mod
base/comm/psb_zgather.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -178,7 +178,7 @@ end subroutine psb_zgatherm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_zhalo.f90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -223,7 +223,7 @@ end subroutine psb_zhalom
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_zovrl.f90
+3 -3
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -204,7 +204,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode)
end subroutine psb_zovrlm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -242,7 +242,7 @@ end subroutine psb_zovrlm
! x(:) - complex The local part of the dense vector.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code.
! work - real(optional). A work area.
! work - complex(optional). A work area.
! update - integer(optional). Type of update:
! psb_none_ do nothing
! psb_sum_ sum of overlaps
base/comm/psb_zscatter.F90
+2 -2
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -235,7 +235,7 @@ end subroutine psb_zscatterm
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/comm/psb_zspgather.F90
+32
View File
@@ -1,3 +1,35 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ 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.
!!$
!!$
! File: psb_zspgather.f90
subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
use psb_descriptor_type
use psb_error_mod
base/internals/psb_indx_map_fnd_owner.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_bld_tmphalo.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_bld_tmpovrl.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_compute_size.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_crea_bnd_elem.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_crea_index.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_crea_ovr_elem.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_cswapdata.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_cswaptran.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_desc_impl.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_desc_index.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_dl_check.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_dswapdata.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_dswaptran.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_exist_ovr_elem.f
+1 -1
View File
@@ -1,6 +1,6 @@
C
C Parallel Sparse BLAS version 3.0
C (C) Copyright 2006, 2007, 2008, 2009, 2010
C (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
C Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari CNRS-IRIT, Toulouse
C
base/internals/psi_extrct_dl.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_fnd_owner.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_idx_cnv.f90
+3 -3
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -136,7 +136,7 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
end subroutine psi_idx_cnv1
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -260,7 +260,7 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
end subroutine psi_idx_cnv2
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_idx_ins_cnv.f90
+4 -4
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -138,7 +138,7 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask,lidx)
end subroutine psi_idx_ins_cnv1
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -265,7 +265,7 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask,lidx)
end subroutine psi_idx_ins_cnv2
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -342,7 +342,7 @@ subroutine psi_idx_ins_cnvs2(idxin,idxout,desc,info,mask,lidx)
end subroutine psi_idx_ins_cnvs2
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_iswapdata.F90
+438 -438
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -1014,440 +1014,440 @@ subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
return
end subroutine psi_iswapidxv
!!$subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
!!$
!!$ use psi_mod, psb_protect_name => psi_iswapdata_vect
!!$ use psb_i_base_vect_mod
!!$ use psb_error_mod
!!$ use psb_descriptor_type
!!$ use psb_penv_mod
!!$#ifdef MPI_MOD
!!$ use mpi
!!$#endif
!!$ implicit none
!!$#ifdef MPI_H
!!$ include 'mpif.h'
!!$#endif
!!$
!!$ integer(psb_ipk_), intent(in) :: flag
!!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta
!!$ integer(psb_ipk_), target :: work(:)
!!$ type(psb_desc_type),target :: desc_a
!!$ integer(psb_ipk_), optional :: data
!!$
!!$ ! locals
!!$ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
!!$ integer(psb_ipk_), pointer :: d_idx(:)
!!$ character(len=20) :: name
!!$
!!$ info=psb_success_
!!$ name='psi_swap_datav'
!!$ call psb_erractionsave(err_act)
!!$
!!$ ictxt=desc_a%get_context()
!!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then
!!$ info=psb_err_context_error_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$
!!$ if (.not.psb_is_asb_desc(desc_a)) then
!!$ info=psb_err_invalid_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$
!!$ icomm = desc_a%get_mpic()
!!$
!!$ if(present(data)) then
!!$ data_ = data
!!$ else
!!$ data_ = psb_comm_halo_
!!$ end if
!!$
!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
!!$ goto 9999
!!$ end if
!!$
!!$ call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
!!$ if (info /= psb_success_) goto 9999
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$ if (err_act == psb_act_abort_) then
!!$ call psb_error(ictxt)
!!$ return
!!$ end if
!!$ return
!!$end subroutine psi_iswapdata_vect
!!$
!!$
!!$subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
!!$
!!$ use psi_mod, psb_protect_name => psi_iswapidx_vect
!!$ use psb_error_mod
!!$ use psb_descriptor_type
!!$ use psb_penv_mod
!!$ use psb_i_base_vect_mod
!!$#ifdef MPI_MOD
!!$ use mpi
!!$#endif
!!$ implicit none
!!$#ifdef MPI_H
!!$ include 'mpif.h'
!!$#endif
!!$
!!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
!!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta
!!$ integer(psb_ipk_), target :: work(:)
!!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
!!$
!!$ ! locals
!!$ integer(psb_mpik_) :: ictxt, icomm, np, me,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
!!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
!!$ integer(psb_ipk_) :: nesd, nerv,&
!!$ & err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, n
!!$ integer(psb_ipk_) :: ierr(5)
!!$ logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
!!$ & albf,do_send,do_recv
!!$ logical, parameter :: usersend=.false.
!!$
!!$ integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
!!$#ifdef HAVE_VOLATILE
!!$ volatile :: sndbuf, rcvbuf
!!$#endif
!!$ character(len=20) :: name
!!$
!!$ info=psb_success_
!!$ name='psi_swap_datav'
!!$ call psb_erractionsave(err_act)
!!$ ictxt = iictxt
!!$ icomm = iicomm
!!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then
!!$ info=psb_err_context_error_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$
!!$ n=1
!!$
!!$ swap_mpi = iand(flag,psb_swap_mpi_) /= 0
!!$ swap_sync = iand(flag,psb_swap_sync_) /= 0
!!$ swap_send = iand(flag,psb_swap_send_) /= 0
!!$ swap_recv = iand(flag,psb_swap_recv_) /= 0
!!$ do_send = swap_mpi .or. swap_sync .or. swap_send
!!$ do_recv = swap_mpi .or. swap_sync .or. swap_recv
!!$
!!$ totrcv_ = totrcv * n
!!$ totsnd_ = totsnd * n
!!$
!!$ if (swap_mpi) then
!!$ allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
!!$ & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
!!$ & stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$
!!$ rvhd(:) = mpi_request_null
!!$ sdsz(:) = 0
!!$ rvsz(:) = 0
!!$
!!$ ! prepare info for communications
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
!!$
!!$ brvidx(proc_to_comm) = rcv_pt
!!$ rvsz(proc_to_comm) = nerv
!!$
!!$ bsdidx(proc_to_comm) = snd_pt
!!$ sdsz(proc_to_comm) = nesd
!!$
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$
!!$ end do
!!$
!!$ else
!!$ allocate(rvhd(totxch),prcid(totxch),stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$ end if
!!$
!!$
!!$ totrcv_ = max(totrcv_,1)
!!$ totsnd_ = max(totsnd_,1)
!!$ if((totrcv_+totsnd_) < size(work)) then
!!$ sndbuf => work(1:totsnd_)
!!$ rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
!!$ albf=.false.
!!$ else
!!$ allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$ albf=.true.
!!$ end if
!!$
!!$
!!$ if (do_send) then
!!$
!!$ ! Pack send buffers
!!$ pnti = 1
!!$ snd_pt = 1
!!$ do i=1, totxch
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ idx_pt = 1+pnti+nerv+psb_n_elem_send_
!!$ call y%gth(nesd,idx(idx_pt:idx_pt+nesd-1),&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1))
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$ end if
!!$
!!$ ! Case SWAP_MPI
!!$ if (swap_mpi) then
!!$
!!$ ! swap elements using mpi_alltoallv
!!$ call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
!!$ & psb_mpi_ipk_integer,rcvbuf,rvsz,&
!!$ & brvidx,psb_mpi_ipk_integer,icomm,iret)
!!$ if(iret /= mpi_success) then
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ else if (swap_sync) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$
!!$ if (proc_to_comm < me) then
!!$ if (nesd>0) call psb_snd(ictxt,&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
!!$ if (nerv>0) call psb_rcv(ictxt,&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
!!$ else if (proc_to_comm > me) then
!!$ if (nerv>0) call psb_rcv(ictxt,&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
!!$ if (nesd>0) call psb_snd(ictxt,&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
!!$ else if (proc_to_comm == me) then
!!$ if (nesd /= nerv) then
!!$ write(psb_err_unit,*) &
!!$ & 'Fatal error in swapdata: mismatch on self send',&
!!$ & nerv,nesd
!!$ end if
!!$ rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
!!$ end if
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$
!!$ else if (swap_send .and. swap_recv) then
!!$
!!$ ! First I post all the non blocking receives
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$
!!$ call psb_get_rank(prcid(i),ictxt,proc_to_comm)
!!$ if ((nerv>0).and.(proc_to_comm /= me)) then
!!$ p2ptag = psb_int_swap_tag
!!$ call mpi_irecv(rcvbuf(rcv_pt),nerv,&
!!$ & psb_mpi_ipk_integer,prcid(i),&
!!$ & p2ptag, icomm,rvhd(i),iret)
!!$ end if
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$
!!$ ! Then I post all the blocking sends
!!$ if (usersend) call mpi_barrier(icomm,iret)
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$
!!$ p2ptag = psb_int_swap_tag
!!$
!!$ if ((nesd>0).and.(proc_to_comm /= me)) then
!!$ if (usersend) then
!!$ call mpi_rsend(sndbuf(snd_pt),nesd,&
!!$ & psb_mpi_ipk_integer,prcid(i),&
!!$ & p2ptag,icomm,iret)
!!$ else
!!$ call mpi_send(sndbuf(snd_pt),nesd,&
!!$ & psb_mpi_ipk_integer,prcid(i),&
!!$ & p2ptag,icomm,iret)
!!$ end if
!!$
!!$ if(iret /= mpi_success) then
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ end if
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$
!!$ pnti = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$
!!$ p2ptag = psb_int_swap_tag
!!$
!!$ if ((proc_to_comm /= me).and.(nerv>0)) then
!!$ call mpi_wait(rvhd(i),p2pstat,iret)
!!$ if(iret /= mpi_success) then
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ else if (proc_to_comm == me) then
!!$ if (nesd /= nerv) then
!!$ write(psb_err_unit,*) &
!!$ & 'Fatal error in swapdata: mismatch on self send',&
!!$ & nerv,nesd
!!$ end if
!!$ rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
!!$ end if
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$
!!$ else if (swap_send) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ if (nesd>0) call psb_snd(ictxt,&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$ else if (swap_recv) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ if (nerv>0) call psb_rcv(ictxt,&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$ end if
!!$
!!$ if (do_recv) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ idx_pt = 1+pnti+psb_n_elem_recv_
!!$ call y%sct(nerv,idx(idx_pt:idx_pt+nerv-1),&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$ end if
!!$
!!$ if (swap_mpi) then
!!$ deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
!!$ & stat=info)
!!$ else
!!$ deallocate(rvhd,prcid,stat=info)
!!$ end if
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$ if(albf) deallocate(sndbuf,rcvbuf,stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$ if (err_act == psb_act_abort_) then
!!$ call psb_error(ictxt)
!!$ return
!!$ end if
!!$ return
!!$end subroutine psi_iswapidx_vect
!!$
subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswapdata_vect
use psb_i_base_vect_mod
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:)
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info=psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
icomm = desc_a%get_mpic()
if(present(data)) then
data_ = data
else
data_ = psb_comm_halo_
end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_iswapdata_vect
subroutine psi_iswapidx_vect(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_iswapidx_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
use psb_i_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
totrcv_ = totrcv * n
totsnd_ = totsnd * n
if (swap_mpi) then
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
rvhd(:) = mpi_request_null
sdsz(:) = 0
rvsz(:) = 0
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
bsdidx(proc_to_comm) = snd_pt
sdsz(proc_to_comm) = nesd
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
sndbuf => work(1:totsnd_)
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
end if
if (do_send) then
! Pack send buffers
pnti = 1
snd_pt = 1
do i=1, totxch
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_
call y%gth(nesd,idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+nesd-1))
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(sndbuf,sdsz,bsdidx,&
& psb_mpi_ipk_integer,rcvbuf,rvsz,&
& brvidx,psb_mpi_ipk_integer,icomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag
call mpi_irecv(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int_swap_tag
if ((nesd>0).and.(proc_to_comm /= me)) then
if (usersend) then
call mpi_rsend(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
else
call mpi_send(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,iret)
end if
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int_swap_tag
if ((proc_to_comm /= me).and.(nerv>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swapdata: mismatch on self send',&
& nerv,nesd
end if
rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1)
end if
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_snd(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_rcv(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
call y%sct(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1),beta)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_iswapidx_vect
base/internals/psi_iswaptran.F90
+451 -451
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -1041,453 +1041,453 @@ subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work
end subroutine psi_itranidxv
!!$subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
!!$
!!$ use psi_mod, psb_protect_name => psi_iswaptran_vect
!!$ use psb_error_mod
!!$ use psb_descriptor_type
!!$ use psb_penv_mod
!!$ use psb_i_base_vect_mod
!!$#ifdef MPI_MOD
!!$ use mpi
!!$#endif
!!$ implicit none
!!$#ifdef MPI_H
!!$ include 'mpif.h'
!!$#endif
!!$
!!$ integer(psb_ipk_), intent(in) :: flag
!!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta
!!$ integer(psb_ipk_), target :: work(:)
!!$ type(psb_desc_type),target :: desc_a
!!$ integer(psb_ipk_), optional :: data
!!$
!!$ ! locals
!!$ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
!!$ integer(psb_ipk_), pointer :: d_idx(:)
!!$ integer(psb_ipk_) :: ierr(5)
!!$ character(len=20) :: name
!!$
!!$ info=psb_success_
!!$ name='psi_swap_tranv'
!!$ call psb_erractionsave(err_act)
!!$
!!$ ictxt = desc_a%get_context()
!!$ icomm = desc_a%get_mpic()
!!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then
!!$ info=psb_err_context_error_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$
!!$ if (.not.psb_is_asb_desc(desc_a)) then
!!$ info=psb_err_invalid_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$
!!$ if (present(data)) then
!!$ data_ = data
!!$ else
!!$ data_ = psb_comm_halo_
!!$ end if
!!$
!!$ call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
!!$ goto 9999
!!$ end if
!!$
!!$ call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
!!$ if (info /= psb_success_) goto 9999
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$ if (err_act == psb_act_abort_) then
!!$ call psb_error(ictxt)
!!$ return
!!$ end if
!!$ return
!!$end subroutine psi_iswaptran_vect
!!$
!!$
!!$
!!$subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
!!$ & totxch,totsnd,totrcv,work,info)
!!$
!!$ use psi_mod, psb_protect_name => psi_itranidx_vect
!!$ use psb_error_mod
!!$ use psb_descriptor_type
!!$ use psb_penv_mod
!!$ use psb_i_base_vect_mod
!!$#ifdef MPI_MOD
!!$ use mpi
!!$#endif
!!$ implicit none
!!$#ifdef MPI_H
!!$ include 'mpif.h'
!!$#endif
!!$
!!$ integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
!!$ integer(psb_ipk_), intent(out) :: info
!!$ class(psb_i_base_vect_type) :: y
!!$ integer(psb_ipk_) :: beta
!!$ integer(psb_ipk_), target :: work(:)
!!$ integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
!!$
!!$ ! locals
!!$ integer(psb_mpik_) :: ictxt, icomm, np, me,&
!!$ & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
!!$ integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
!!$ & sdsz, rvsz, prcid, rvhd, sdhd
!!$ integer(psb_ipk_) :: nesd, nerv,&
!!$ & err_act, i, idx_pt, totsnd_, totrcv_,&
!!$ & snd_pt, rcv_pt, pnti, n
!!$ integer(psb_ipk_) :: ierr(5)
!!$ logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
!!$ & albf,do_send,do_recv
!!$ logical, parameter :: usersend=.false.
!!$
!!$ integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
!!$#ifdef HAVE_VOLATILE
!!$ volatile :: sndbuf, rcvbuf
!!$#endif
!!$ character(len=20) :: name
!!$
!!$ info=psb_success_
!!$ name='psi_swap_tran'
!!$ call psb_erractionsave(err_act)
!!$ ictxt = iictxt
!!$ icomm = iicomm
!!$
!!$ call psb_info(ictxt,me,np)
!!$ if (np == -1) then
!!$ info=psb_err_context_error_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$
!!$ n=1
!!$ swap_mpi = iand(flag,psb_swap_mpi_) /= 0
!!$ swap_sync = iand(flag,psb_swap_sync_) /= 0
!!$ swap_send = iand(flag,psb_swap_send_) /= 0
!!$ swap_recv = iand(flag,psb_swap_recv_) /= 0
!!$ do_send = swap_mpi .or. swap_sync .or. swap_send
!!$ do_recv = swap_mpi .or. swap_sync .or. swap_recv
!!$
!!$ totrcv_ = totrcv * n
!!$ totsnd_ = totsnd * n
!!$
!!$ if (swap_mpi) then
!!$ allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
!!$ & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
!!$ & stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$
!!$ rvhd(:) = mpi_request_null
!!$ sdsz(:) = 0
!!$ rvsz(:) = 0
!!$
!!$ ! prepare info for communications
!!$
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
!!$
!!$ brvidx(proc_to_comm) = rcv_pt
!!$ rvsz(proc_to_comm) = nerv
!!$
!!$ bsdidx(proc_to_comm) = snd_pt
!!$ sdsz(proc_to_comm) = nesd
!!$
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$
!!$ end do
!!$
!!$ else
!!$ allocate(rvhd(totxch),prcid(totxch),stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$ end if
!!$
!!$
!!$ totrcv_ = max(totrcv_,1)
!!$ totsnd_ = max(totsnd_,1)
!!$ if((totrcv_+totsnd_) < size(work)) then
!!$ sndbuf => work(1:totsnd_)
!!$ rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
!!$ albf=.false.
!!$ else
!!$ allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$ albf=.true.
!!$ end if
!!$
!!$
!!$ if (do_send) then
!!$
!!$ ! Pack send buffers
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ idx_pt = 1+pnti+psb_n_elem_recv_
!!$
!!$ call y%gth(nerv,idx(idx_pt:idx_pt+nerv-1),&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1))
!!$
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$ end if
!!$
!!$ ! Case SWAP_MPI
!!$ if (swap_mpi) then
!!$
!!$ ! swap elements using mpi_alltoallv
!!$ call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
!!$ & psb_mpi_ipk_integer,&
!!$ & sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,icomm,iret)
!!$ if(iret /= mpi_success) then
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ else if (swap_sync) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$
!!$ if (proc_to_comm < me) then
!!$ if (nerv>0) call psb_snd(ictxt,&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
!!$ if (nesd>0) call psb_rcv(ictxt,&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
!!$ else if (proc_to_comm > me) then
!!$ if (nesd>0) call psb_rcv(ictxt,&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
!!$ if (nerv>0) call psb_snd(ictxt,&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
!!$ else if (proc_to_comm == me) then
!!$ if (nesd /= nerv) then
!!$ write(psb_err_unit,*) &
!!$ & 'Fatal error in swaptran: mismatch on self send',&
!!$ & nerv,nesd
!!$ end if
!!$ sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
!!$ end if
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$
!!$ end do
!!$
!!$
!!$ else if (swap_send .and. swap_recv) then
!!$
!!$ ! First I post all the non blocking receives
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ call psb_get_rank(prcid(i),ictxt,proc_to_comm)
!!$ if ((nesd>0).and.(proc_to_comm /= me)) then
!!$ p2ptag = psb_int_swap_tag
!!$ call mpi_irecv(sndbuf(snd_pt),nesd,&
!!$ & psb_mpi_ipk_integer,prcid(i),&
!!$ & p2ptag,icomm,rvhd(i),iret)
!!$ end if
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$
!!$ ! Then I post all the blocking sends
!!$ if (usersend) call mpi_barrier(icomm,iret)
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$
!!$ if ((nerv>0).and.(proc_to_comm /= me)) then
!!$ p2ptag = psb_int_swap_tag
!!$ if (usersend) then
!!$ call mpi_rsend(rcvbuf(rcv_pt),nerv,&
!!$ & psb_mpi_ipk_integer,prcid(i),&
!!$ & p2ptag, icomm,iret)
!!$ else
!!$ call mpi_send(rcvbuf(rcv_pt),nerv,&
!!$ & psb_mpi_ipk_integer,prcid(i),&
!!$ & p2ptag, icomm,iret)
!!$ end if
!!$
!!$ if(iret /= mpi_success) then
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ end if
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$
!!$ end do
!!$
!!$
!!$ pnti = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ p2ptag = psb_int_swap_tag
!!$
!!$ if ((proc_to_comm /= me).and.(nesd>0)) then
!!$ call mpi_wait(rvhd(i),p2pstat,iret)
!!$ if(iret /= mpi_success) then
!!$ ierr(1) = iret
!!$ info=psb_err_mpi_error_
!!$ call psb_errpush(info,name,i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ else if (proc_to_comm == me) then
!!$ if (nesd /= nerv) then
!!$ write(psb_err_unit,*) &
!!$ & 'Fatal error in swaptran: mismatch on self send', &
!!$ & nerv,nesd
!!$ end if
!!$ sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
!!$ end if
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$
!!$ else if (swap_send) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ if (nerv>0) call psb_snd(ictxt,&
!!$ & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$
!!$ end do
!!$
!!$ else if (swap_recv) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ if (nesd>0) call psb_rcv(ictxt,&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$
!!$ end do
!!$
!!$ end if
!!$
!!$
!!$ if (do_recv) then
!!$
!!$ pnti = 1
!!$ snd_pt = 1
!!$ rcv_pt = 1
!!$ do i=1, totxch
!!$ proc_to_comm = idx(pnti+psb_proc_id_)
!!$ nerv = idx(pnti+psb_n_elem_recv_)
!!$ nesd = idx(pnti+nerv+psb_n_elem_send_)
!!$ idx_pt = 1+pnti+nerv+psb_n_elem_send_
!!$ call y%sct(nesd,idx(idx_pt:idx_pt+nesd-1),&
!!$ & sndbuf(snd_pt:snd_pt+nesd-1),beta)
!!$ rcv_pt = rcv_pt + nerv
!!$ snd_pt = snd_pt + nesd
!!$ pnti = pnti + nerv + nesd + 3
!!$ end do
!!$
!!$ end if
!!$
!!$
!!$ if (swap_mpi) then
!!$ deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
!!$ & stat=info)
!!$ else
!!$ deallocate(rvhd,prcid,stat=info)
!!$ end if
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$ if(albf) deallocate(sndbuf,rcvbuf,stat=info)
!!$ if(info /= psb_success_) then
!!$ call psb_errpush(psb_err_alloc_dealloc_,name)
!!$ goto 9999
!!$ end if
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$ if (err_act == psb_act_abort_) then
!!$ call psb_error(ictxt)
!!$ return
!!$ end if
!!$ return
!!$end subroutine psi_itranidx_vect
!!$
!!$
!!$
subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psi_mod, psb_protect_name => psi_iswaptran_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
use psb_i_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
type(psb_desc_type),target :: desc_a
integer(psb_ipk_), optional :: data
! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:)
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
name='psi_swap_tranv'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info=psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(data)) then
data_ = data
else
data_ = psb_comm_halo_
end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999
end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_iswaptran_vect
subroutine psi_itranidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidx_vect
use psb_error_mod
use psb_descriptor_type
use psb_penv_mod
use psb_i_base_vect_mod
#ifdef MPI_MOD
use mpi
#endif
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
integer(psb_ipk_), target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret
integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,&
& sdsz, rvsz, prcid, rvhd, sdhd
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,&
& snd_pt, rcv_pt, pnti, n
integer(psb_ipk_) :: ierr(5)
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
logical, parameter :: usersend=.false.
integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf
#ifdef HAVE_VOLATILE
volatile :: sndbuf, rcvbuf
#endif
character(len=20) :: name
info=psb_success_
name='psi_swap_tran'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
totrcv_ = totrcv * n
totsnd_ = totsnd * n
if (swap_mpi) then
allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),&
& brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),&
& stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
rvhd(:) = mpi_request_null
sdsz(:) = 0
rvsz(:) = 0
! prepare info for communications
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm)
brvidx(proc_to_comm) = rcv_pt
rvsz(proc_to_comm) = nerv
bsdidx(proc_to_comm) = snd_pt
sdsz(proc_to_comm) = nesd
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else
allocate(rvhd(totxch),prcid(totxch),stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
end if
totrcv_ = max(totrcv_,1)
totsnd_ = max(totsnd_,1)
if((totrcv_+totsnd_) < size(work)) then
sndbuf => work(1:totsnd_)
rcvbuf => work(totsnd_+1:totsnd_+totrcv_)
albf=.false.
else
allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
albf=.true.
end if
if (do_send) then
! Pack send buffers
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+psb_n_elem_recv_
call y%gth(nerv,idx(idx_pt:idx_pt+nerv-1),&
& rcvbuf(rcv_pt:rcv_pt+nerv-1))
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
! Case SWAP_MPI
if (swap_mpi) then
! swap elements using mpi_alltoallv
call mpi_alltoallv(rcvbuf,rvsz,brvidx,&
& psb_mpi_ipk_integer,&
& sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,icomm,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (swap_sync) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (proc_to_comm < me) then
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
else if (proc_to_comm > me) then
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send',&
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send .and. swap_recv) then
! First I post all the non blocking receives
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
call psb_get_rank(prcid(i),ictxt,proc_to_comm)
if ((nesd>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag
call mpi_irecv(sndbuf(snd_pt),nesd,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag,icomm,rvhd(i),iret)
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
! Then I post all the blocking sends
if (usersend) call mpi_barrier(icomm,iret)
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if ((nerv>0).and.(proc_to_comm /= me)) then
p2ptag = psb_int_swap_tag
if (usersend) then
call mpi_rsend(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret)
else
call mpi_send(rcvbuf(rcv_pt),nerv,&
& psb_mpi_ipk_integer,prcid(i),&
& p2ptag, icomm,iret)
end if
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
end if
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
pnti = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
p2ptag = psb_int_swap_tag
if ((proc_to_comm /= me).and.(nesd>0)) then
call mpi_wait(rvhd(i),p2pstat,iret)
if(iret /= mpi_success) then
ierr(1) = iret
info=psb_err_mpi_error_
call psb_errpush(info,name,i_err=ierr)
goto 9999
end if
else if (proc_to_comm == me) then
if (nesd /= nerv) then
write(psb_err_unit,*) &
& 'Fatal error in swaptran: mismatch on self send', &
& nerv,nesd
end if
sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1)
end if
pnti = pnti + nerv + nesd + 3
end do
else if (swap_send) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nerv>0) call psb_snd(ictxt,&
& rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
else if (swap_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
if (nesd>0) call psb_rcv(ictxt,&
& sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (do_recv) then
pnti = 1
snd_pt = 1
rcv_pt = 1
do i=1, totxch
proc_to_comm = idx(pnti+psb_proc_id_)
nerv = idx(pnti+psb_n_elem_recv_)
nesd = idx(pnti+nerv+psb_n_elem_send_)
idx_pt = 1+pnti+nerv+psb_n_elem_send_
call y%sct(nesd,idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+nesd-1),beta)
rcv_pt = rcv_pt + nerv
snd_pt = snd_pt + nesd
pnti = pnti + nerv + nesd + 3
end do
end if
if (swap_mpi) then
deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,&
& stat=info)
else
deallocate(rvhd,prcid,stat=info)
end if
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
if(albf) deallocate(sndbuf,rcvbuf,stat=info)
if(info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psi_itranidx_vect
base/internals/psi_ldsc_pre_halo.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_ovrl_restr.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_ovrl_save.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_ovrl_upd.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_sort_dl.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_sswapdata.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_sswaptran.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_zswapdata.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/psi_zswaptran.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/internals/srtlist.f
+1 -1
View File
@@ -1,6 +1,6 @@
C
C Parallel Sparse BLAS version 3.0
C (C) Copyright 2006, 2007, 2008, 2009, 2010
C (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
C Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari CNRS-IRIT, Toulouse
C
base/modules/Makefile
+9 -7
View File
@@ -13,6 +13,7 @@ UTIL_MODS = psb_string_mod.o psb_desc_const_mod.o psb_indx_map_mod.o\
psb_s_linmap_mod.o psb_d_linmap_mod.o psb_c_linmap_mod.o psb_z_linmap_mod.o \
psb_comm_mod.o psb_i_comm_mod.o psb_s_comm_mod.o psb_d_comm_mod.o\
psb_c_comm_mod.o psb_z_comm_mod.o \
psb_i_base_vect_mod.o psb_i_vect_mod.o\
psb_d_base_vect_mod.o psb_d_vect_mod.o\
psb_s_base_vect_mod.o psb_s_vect_mod.o\
psb_c_base_vect_mod.o psb_c_vect_mod.o\
@@ -62,7 +63,7 @@ psb_s_base_mat_mod.o: psb_s_base_vect_mod.o
psb_d_base_mat_mod.o: psb_d_base_vect_mod.o
psb_c_base_mat_mod.o: psb_c_base_vect_mod.o
psb_z_base_mat_mod.o: psb_z_base_vect_mod.o
psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psi_serial_mod.o psb_realloc_mod.o
psb_i_base_vect_mod.o psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psi_serial_mod.o psb_realloc_mod.o
psb_s_mat_mod.o: psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_csc_mat_mod.o psb_s_vect_mod.o
psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_csc_mat_mod.o psb_d_vect_mod.o
psb_c_mat_mod.o: psb_c_base_mat_mod.o psb_c_csr_mat_mod.o psb_c_csc_mat_mod.o psb_c_vect_mod.o
@@ -75,11 +76,11 @@ psb_mat_mod.o: psb_vect_mod.o psb_s_mat_mod.o psb_d_mat_mod.o psb_c_mat_mod.o ps
error.o psb_realloc_mod.o: psb_error_mod.o
psb_error_impl.o: psb_penv_mod.o
psb_spmat_type.o: psb_string_mod.o psb_sort_mod.o
psi_i_mod.o: psb_desc_type.o
psi_s_mod.o: psb_desc_type.o psb_s_base_vect_mod.o
psi_d_mod.o: psb_desc_type.o psb_d_base_vect_mod.o
psi_c_mod.o: psb_desc_type.o psb_c_base_vect_mod.o
psi_z_mod.o: psb_desc_type.o psb_z_base_vect_mod.o
psi_i_mod.o: psb_desc_type.o psb_i_vect_mod.o
psi_s_mod.o: psb_desc_type.o psb_s_vect_mod.o
psi_d_mod.o: psb_desc_type.o psb_d_vect_mod.o
psi_c_mod.o: psb_desc_type.o psb_c_vect_mod.o
psi_z_mod.o: psb_desc_type.o psb_z_vect_mod.o
psi_mod.o: psb_penv_mod.o psb_desc_type.o psi_serial_mod.o psb_serial_mod.o\
psi_i_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o
psb_desc_type.o: psb_penv_mod.o psb_realloc_mod.o\
@@ -103,6 +104,7 @@ psb_base_linmap_mod.o: psb_desc_type.o psb_serial_mod.o psb_comm_mod.o
psb_comm_mod.o: psb_desc_type.o psb_mat_mod.o
psb_check_mod.o: psb_desc_type.o
psb_serial_mod.o: psb_mat_mod.o psb_string_mod.o psb_sort_mod.o psi_serial_mod.o
psb_i_vect_mod.o: psb_i_base_vect_mod.o
psb_s_vect_mod.o: psb_s_base_vect_mod.o
psb_d_vect_mod.o: psb_d_base_vect_mod.o
psb_c_vect_mod.o: psb_c_base_vect_mod.o
@@ -123,7 +125,7 @@ psb_psblas_mod.o: psb_s_psblas_mod.o psb_c_psblas_mod.o psb_d_psblas_mod.o psb_
psb_s_psblas_mod.o psb_c_psblas_mod.o psb_d_psblas_mod.o psb_z_psblas_mod.o: psb_mat_mod.o psb_desc_type.o
psb_vect_mod.o: psb_d_vect_mod.o psb_s_vect_mod.o psb_c_vect_mod.o psb_z_vect_mod.o
psb_comm_mod.o: psb_i_comm_mod.o psb_s_comm_mod.o psb_d_comm_mod.o psb_c_comm_mod.o psb_z_comm_mod.o
psb_i_comm_mod.o: psb_desc_type.o
psb_i_comm_mod.o: psb_i_vect_mod.o psb_desc_type.o
psb_s_comm_mod.o: psb_s_vect_mod.o psb_desc_type.o psb_mat_mod.o
psb_d_comm_mod.o: psb_d_vect_mod.o psb_desc_type.o psb_mat_mod.o
psb_c_comm_mod.o: psb_c_vect_mod.o psb_desc_type.o psb_mat_mod.o
base/modules/error.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_base_linmap_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_base_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_base_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_base_tools_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_base_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_base_vect_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_comm_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_csc_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_csr_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_linmap_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_psblas_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_tools_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_c_vect_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_check_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_comm_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_const_mod.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_base_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_base_vect_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_comm_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_csc_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_csr_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_linmap_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_mat_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_psblas_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_tools_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_d_vect_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_desc_const_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_desc_type.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_error_mod.F90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_gen_block_map_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_glist_map_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_hash_map_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_hash_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_i_base_vect_mod.f90
+807
View File
@@ -0,0 +1,807 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ 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_i_base_vect_mod
!
! This module contains the definition of the psb_i_base_vect type which
! is a container for dense vectors.
! This is encapsulated instead of being just a simple array to allow for
! more complicated situations, such as GPU programming, where the memory
! area we are interested in is not easily accessible from the host/Fortran
! side. It is also meant to be encapsulated in an outer type, to allow
! runtime switching as per the STATE design pattern, similar to the
! sparse matrix types.
!
!
module psb_i_base_vect_mod
use psb_const_mod
use psb_error_mod
!> \namespace psb_base_mod \class psb_i_base_vect_type
!! The psb_i_base_vect_type
!! defines a middle level integer(psb_ipk_) encapsulated dense vector.
!! The encapsulation is needed, in place of a simple array, to allow
!! for complicated situations, such as GPU programming, where the memory
!! area we are interested in is not easily accessible from the host/Fortran
!! side. It is also meant to be encapsulated in an outer type, to allow
!! runtime switching as per the STATE design pattern, similar to the
!! sparse matrix types.
!!
type psb_i_base_vect_type
integer(psb_ipk_), allocatable :: v(:)
contains
!
! Constructors/allocators
!
procedure, pass(x) :: bld_x => i_base_bld_x
procedure, pass(x) :: bld_n => i_base_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: all => i_base_all
!
! Insert/set. Assembly and free.
! Assembly does almost nothing here, but is important
! in derived classes.
!
procedure, pass(x) :: ins => i_base_ins
procedure, pass(x) :: zero => i_base_zero
procedure, pass(x) :: asb => i_base_asb
procedure, pass(x) :: free => i_base_free
!
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
! will guarantee that both fortran/host side and
! external side contain the same data. The base
! version is only a placeholder.
!
procedure, pass(x) :: sync => i_base_sync
procedure, pass(x) :: is_host => i_base_is_host
procedure, pass(x) :: is_dev => i_base_is_dev
procedure, pass(x) :: is_sync => i_base_is_sync
procedure, pass(x) :: set_host => i_base_set_host
procedure, pass(x) :: set_dev => i_base_set_dev
procedure, pass(x) :: set_sync => i_base_set_sync
!
! Basic info
procedure, pass(x) :: get_nrows => i_base_get_nrows
procedure, pass(x) :: sizeof => i_base_sizeof
!
! Set/get data from/to an external array; also
! overload assignment.
!
procedure, pass(x) :: get_vect => i_base_get_vect
procedure, pass(x) :: set_scal => i_base_set_scal
procedure, pass(x) :: set_vect => i_base_set_vect
generic, public :: set => set_vect, set_scal
!
! Dot product and AXPBY
!
procedure, pass(x) :: dot_v => i_base_dot_v
procedure, pass(x) :: dot_a => i_base_dot_a
generic, public :: dot => dot_v, dot_a
procedure, pass(y) :: axpby_v => i_base_axpby_v
procedure, pass(y) :: axpby_a => i_base_axpby_a
generic, public :: axpby => axpby_v, axpby_a
!
! Vector by vector multiplication. Need all variants
! to handle multiple requirements from preconditioners
!
procedure, pass(y) :: mlt_v => i_base_mlt_v
procedure, pass(y) :: mlt_a => i_base_mlt_a
procedure, pass(z) :: mlt_a_2 => i_base_mlt_a_2
procedure, pass(z) :: mlt_v_2 => i_base_mlt_v_2
procedure, pass(z) :: mlt_va => i_base_mlt_va
procedure, pass(z) :: mlt_av => i_base_mlt_av
generic, public :: mlt => mlt_v, mlt_a, mlt_a_2, mlt_v_2, mlt_av, mlt_va
!
! Scaling and norms
!
procedure, pass(x) :: scal => i_base_scal
procedure, pass(x) :: nrm2 => i_base_nrm2
procedure, pass(x) :: amax => i_base_amax
procedure, pass(x) :: asum => i_base_asum
!
! Gather/scatter. These are needed for MPI interfacing.
! May have to be reworked.
!
procedure, pass(x) :: gthab => i_base_gthab
procedure, pass(x) :: gthzv => i_base_gthzv
generic, public :: gth => gthab, gthzv
procedure, pass(y) :: sctb => i_base_sctb
generic, public :: sct => sctb
end type psb_i_base_vect_type
public :: psb_i_base_vect
private :: constructor, size_const
interface psb_i_base_vect
module procedure constructor, size_const
end interface psb_i_base_vect
contains
!
! Constructors.
!
function constructor(x) result(this)
integer(psb_ipk_) :: x(:)
type(psb_i_base_vect_type) :: this
integer(psb_ipk_) :: info
this%v = x
call this%asb(size(x,kind=psb_ipk_),info)
end function constructor
function size_const(n) result(this)
integer(psb_ipk_), intent(in) :: n
type(psb_i_base_vect_type) :: this
integer(psb_ipk_) :: info
call this%asb(n,info)
end function size_const
!
! Build from a sample
!
subroutine i_base_bld_x(x,this)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: this(:)
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
call psb_realloc(size(this),x%v,info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld')
return
end if
x%v(:) = this(:)
end subroutine i_base_bld_x
!
! Create with size, but no initialization
!
subroutine i_base_bld_n(x,n)
use psb_realloc_mod
integer(psb_ipk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_) :: info
call psb_realloc(n,x%v,info)
call x%asb(n,info)
end subroutine i_base_bld_n
subroutine i_base_all(n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_base_vect_type), intent(out) :: x
integer(psb_ipk_), intent(out) :: info
call psb_realloc(n,x%v,info)
end subroutine i_base_all
!
! Insert a bunch of values at specified positions.
!
subroutine i_base_ins(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (psb_errstatus_fatal()) return
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
else if (n > min(size(irl),size(val))) then
info = psb_err_invalid_input_
else
select case(dupl)
case(psb_dupl_ovwrt_)
do i = 1, n
!loop over all val's rows
! row actual block row
if (irl(i) > 0) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = val(i)
end if
enddo
case(psb_dupl_add_)
do i = 1, n
!loop over all val's rows
if (irl(i) > 0) then
! this row belongs to me
! copy i-th row of block val in x
x%v(irl(i)) = x%v(irl(i)) + val(i)
end if
enddo
case default
info = 321
!!$ call psb_errpush(info,name)
!!$ goto 9999
end select
end if
if (info /= 0) then
call psb_errpush(info,'base_vect_ins')
return
end if
end subroutine i_base_ins
!
subroutine i_base_zero(x)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
if (allocated(x%v)) x%v=izero
end subroutine i_base_zero
!
! Assembly.
! For derived classes: after this the vector
! storage is supposed to be in sync.
!
subroutine i_base_asb(n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (x%get_nrows() < n) &
& call psb_realloc(n,x%v,info)
if (info /= 0) &
& call psb_errpush(psb_err_alloc_dealloc_,'vect_asb')
end subroutine i_base_asb
subroutine i_base_free(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) deallocate(x%v, stat=info)
if (info /= 0) call &
& psb_errpush(psb_err_alloc_dealloc_,'vect_free')
end subroutine i_base_free
!
! The base version of SYNC & friends does nothing, it's just
! a placeholder.
!
subroutine i_base_sync(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
end subroutine i_base_sync
subroutine i_base_set_host(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
end subroutine i_base_set_host
subroutine i_base_set_dev(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
end subroutine i_base_set_dev
subroutine i_base_set_sync(x)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
end subroutine i_base_set_sync
function i_base_is_dev(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = .false.
end function i_base_is_dev
function i_base_is_host(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = .true.
end function i_base_is_host
function i_base_is_sync(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
logical :: res
res = .true.
end function i_base_is_sync
!
! Size info.
!
function i_base_get_nrows(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = size(x%v)
end function i_base_get_nrows
function i_base_sizeof(x) result(res)
implicit none
class(psb_i_base_vect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
! Force 8-byte integers.
res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows()
end function i_base_sizeof
!
! Two versions of extracting an array: one of them
! overload the assignment.
!
function i_base_get_vect(x) result(res)
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), allocatable :: res(:)
integer(psb_ipk_) :: info
if (.not.allocated(x%v)) return
call x%sync()
allocate(res(x%get_nrows()),stat=info)
if (info /= 0) then
call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect')
return
end if
res(:) = x%v(:)
end function i_base_get_vect
!
! Reset all values
!
subroutine i_base_set_scal(x,val)
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_) :: info
x%v = val
end subroutine i_base_set_scal
subroutine i_base_set_vect(x,val)
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_) :: nr
integer(psb_ipk_) :: info
if (allocated(x%v)) then
nr = min(size(x%v),size(val))
x%v(1:nr) = val(1:nr)
else
x%v = val
end if
end subroutine i_base_set_vect
!
! Dot products
!
function i_base_dot_v(n,x,y) result(res)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x, y
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
integer(psb_ipk_), external :: idot
res = izero
!
! Note: this is the base implementation.
! When we get here, we are sure that X is of
! TYPE psb_i_base_vect.
! If Y is not, throw the burden on it, implicitly
! calling dot_a
!
select type(yy => y)
type is (psb_i_base_vect_type)
res = idot(n,x%v,1,y%v,1)
class default
res = y%dot(n,x%v)
end select
end function i_base_dot_v
!
! Base workhorse is good old BLAS1
!
function i_base_dot_a(n,x,y) result(res)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: y(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
integer(psb_ipk_), external :: idot
res = idot(n,y,1,x%v,1)
end function i_base_dot_a
!
! AXPBY is invoked via Y, hence the structure below.
!
subroutine i_base_axpby_v(m,alpha, x, beta, y, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_i_base_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info
select type(xx => x)
type is (psb_i_base_vect_type)
call psb_geaxpby(m,alpha,x%v,beta,y%v,info)
class default
call y%axpby(m,alpha,x%v,beta,info)
end select
end subroutine i_base_axpby_v
subroutine i_base_axpby_a(m,alpha, x, beta, y, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info
call psb_geaxpby(m,alpha,x,beta,y%v,info)
end subroutine i_base_axpby_a
!
! Multiple variants of two operations:
! Simple multiplication Y(:) = X(:)*Y(:)
! blas-like: Z(:) = alpha*X(:)*Y(:)+beta*Z(:)
!
! Variants expanded according to the dynamic type
! of the involved entities
!
subroutine i_base_mlt_v(x, y, info)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
select type(xx => x)
type is (psb_i_base_vect_type)
n = min(size(y%v), size(xx%v))
do i=1, n
y%v(i) = y%v(i)*xx%v(i)
end do
class default
call y%mlt(x%v,info)
end select
end subroutine i_base_mlt_v
subroutine i_base_mlt_a(x, y, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_base_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
n = min(size(y%v), size(x))
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
end subroutine i_base_mlt_a
subroutine i_base_mlt_a_2(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
integer(psb_ipk_), intent(in) :: y(:)
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
n = min(size(z%v), size(x), size(y))
!!$ write(0,*) 'Mlt_a_2: ',n
if (alpha == izero) then
if (beta == ione) then
return
else
do i=1, n
z%v(i) = beta*z%v(i)
end do
end if
else
if (alpha == ione) then
if (beta == izero) then
do i=1, n
z%v(i) = y(i)*x(i)
end do
else if (beta == ione) then
do i=1, n
z%v(i) = z%v(i) + y(i)*x(i)
end do
else
do i=1, n
z%v(i) = beta*z%v(i) + y(i)*x(i)
end do
end if
else if (alpha == -ione) then
if (beta == izero) then
do i=1, n
z%v(i) = -y(i)*x(i)
end do
else if (beta == ione) then
do i=1, n
z%v(i) = z%v(i) - y(i)*x(i)
end do
else
do i=1, n
z%v(i) = beta*z%v(i) - y(i)*x(i)
end do
end if
else
if (beta == izero) then
do i=1, n
z%v(i) = alpha*y(i)*x(i)
end do
else if (beta == ione) then
do i=1, n
z%v(i) = z%v(i) + alpha*y(i)*x(i)
end do
else
do i=1, n
z%v(i) = beta*z%v(i) + alpha*y(i)*x(i)
end do
end if
end if
end if
end subroutine i_base_mlt_a_2
subroutine i_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
use psi_serial_mod
use psb_string_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
class(psb_i_base_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
character(len=1), intent(in), optional :: conjgx, conjgy
integer(psb_ipk_) :: i, n
logical :: conjgx_, conjgy_
info = 0
if (.not.psb_i_is_complex_) then
call z%mlt(alpha,x%v,y%v,beta,info)
else
conjgx_=.false.
if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C')
conjgy_=.false.
if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C')
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
call z%mlt(alpha,x%v,y%v,beta,info)
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
end if
end subroutine i_base_mlt_v_2
subroutine i_base_mlt_av(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_base_vect_type), intent(inout) :: y
class(psb_i_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
call z%mlt(alpha,x,y%v,beta,info)
end subroutine i_base_mlt_av
subroutine i_base_mlt_va(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
integer(psb_ipk_), intent(in) :: y(:)
class(psb_i_base_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
call z%mlt(alpha,y,x,beta,info)
end subroutine i_base_mlt_va
!
! Simple scaling
!
subroutine i_base_scal(alpha, x)
use psi_serial_mod
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent (in) :: alpha
if (allocated(x%v)) x%v = alpha*x%v
end subroutine i_base_scal
!
! Norms 1, 2 and infinity
!
function i_base_nrm2(n,x) result(res)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
integer(psb_ipk_), external :: inrm2
res = inrm2(n,x%v,1)
end function i_base_nrm2
function i_base_amax(n,x) result(res)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
res = maxval(abs(x%v(1:n)))
end function i_base_amax
function i_base_asum(n,x) result(res)
implicit none
class(psb_i_base_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
res = sum(abs(x%v(1:n)))
end function i_base_asum
!
! Gather: Y = beta * Y + alpha * X(IDX(:))
!
subroutine i_base_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: alpha, beta, y(:)
class(psb_i_base_vect_type) :: x
call x%sync()
call psi_gth(n,idx,alpha,x%v,beta,y)
end subroutine i_base_gthab
!
! shortcut alpha=1 beta=0
!
subroutine i_base_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: y(:)
class(psb_i_base_vect_type) :: x
call x%sync()
call psi_gth(n,idx,x%v,y)
end subroutine i_base_gthzv
!
! Scatter:
! Y(IDX(:)) = beta*Y(IDX(:)) + X(:)
!
subroutine i_base_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: beta, x(:)
class(psb_i_base_vect_type) :: y
call y%sync()
call psi_sct(n,idx,x,beta,y%v)
call y%set_host()
end subroutine i_base_sctb
end module psb_i_base_vect_mod
base/modules/psb_i_comm_mod.f90
+80 -40
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
@@ -34,82 +34,122 @@ module psb_i_comm_mod
interface psb_ovrl
subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
use psb_descriptor_type
integer(psb_ipk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
integer(psb_ipk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode
end subroutine psb_iovrlm
subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
use psb_descriptor_type
integer(psb_ipk_), intent(inout), target :: x(:)
integer(psb_ipk_), intent(inout), target :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_iovrlv
subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode)
use psb_descriptor_type
use psb_i_vect_mod
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: update,mode
end subroutine psb_iovrlv
end interface
end subroutine psb_iovrl_vect
end interface psb_ovrl
interface psb_halo
subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode,data)
use psb_descriptor_type
integer(psb_ipk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(in), optional :: alpha
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
integer(psb_ipk_), intent(inout), target :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data
character, intent(in), optional :: tran
end subroutine psb_ihalom
subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode,data)
use psb_descriptor_type
integer(psb_ipk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
real(psb_dpk_), intent(in), optional :: alpha
integer(psb_ipk_), intent(inout), optional, target :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
integer(psb_ipk_), intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_ihalov
end interface
subroutine psb_ihalo_vect(x,desc_a,info,alpha,work,tran,mode,data)
use psb_descriptor_type
use psb_i_vect_mod
type(psb_i_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: alpha
integer(psb_ipk_), target, optional, intent(inout) :: work(:)
integer(psb_ipk_), intent(in), optional :: mode,data
character, intent(in), optional :: tran
end subroutine psb_ihalo_vect
end interface psb_halo
interface psb_scatter
subroutine psb_iscatterm(globx, locx, desc_a, info, root)
use psb_descriptor_type
integer(psb_ipk_), intent(out) :: locx(:,:)
integer(psb_ipk_), intent(in) :: globx(:,:)
integer(psb_ipk_), intent(out) :: locx(:,:)
integer(psb_ipk_), intent(in) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_iscatterm
subroutine psb_iscatterv(globx, locx, desc_a, info, root)
use psb_descriptor_type
integer(psb_ipk_), intent(out) :: locx(:)
integer(psb_ipk_), intent(in) :: globx(:)
integer(psb_ipk_), intent(out) :: locx(:)
integer(psb_ipk_), intent(in) :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_iscatterv
end interface
end interface psb_scatter
interface psb_gather
subroutine psb_igatherm(globx, locx, desc_a, info, root)
!!$ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
! !$ use psb_descriptor_type
! !$ use psb_mat_mod
! !$ implicit none
! !$ type(psb_ispmat_type), intent(inout) :: loca
! !$ type(psb_ispmat_type), intent(out) :: globa
! !$ type(psb_desc_type), intent(in) :: desc_a
! !$ integer(psb_ipk_), intent(out) :: info
! !$ integer(psb_ipk_), intent(in), optional :: root,dupl
! !$ logical, intent(in), optional :: keepnum,keeploc
! !$ end subroutine psb_isp_allgather
subroutine psb_igatherm(globx, locx, desc_a, info, root)
use psb_descriptor_type
integer(psb_ipk_), intent(in) :: locx(:,:)
integer(psb_ipk_), intent(out) :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
integer(psb_ipk_), intent(in) :: locx(:,:)
integer(psb_ipk_), intent(out), allocatable :: globx(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_igatherm
subroutine psb_igatherv(globx, locx, desc_a, info, root)
use psb_descriptor_type
integer(psb_ipk_), intent(in) :: locx(:)
integer(psb_ipk_), intent(out) :: globx(:)
integer(psb_ipk_), intent(in) :: locx(:)
integer(psb_ipk_), intent(out), allocatable :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_igatherv
subroutine psb_igather_vect(globx, locx, desc_a, info, root)
use psb_descriptor_type
use psb_i_vect_mod
type(psb_i_vect_type), intent(inout) :: locx
integer(psb_ipk_), intent(out), allocatable :: globx(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: root
end subroutine psb_igatherv
end interface
end subroutine psb_igather_vect
end interface psb_gather
end module psb_i_comm_mod
base/modules/psb_i_vect_mod.f90
+542
View File
@@ -0,0 +1,542 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ 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_i_vect_mod
!
! This module contains the definition of the psb_i_vect type which
! is the outer container for dense vectors.
! Therefore all methods simply invoke the corresponding methods of the
! inner component.
!
module psb_i_vect_mod
use psb_i_base_vect_mod
type psb_i_vect_type
class(psb_i_base_vect_type), allocatable :: v
contains
procedure, pass(x) :: get_nrows => i_vect_get_nrows
procedure, pass(x) :: sizeof => i_vect_sizeof
procedure, pass(x) :: dot_v => i_vect_dot_v
procedure, pass(x) :: dot_a => i_vect_dot_a
generic, public :: dot => dot_v, dot_a
procedure, pass(y) :: axpby_v => i_vect_axpby_v
procedure, pass(y) :: axpby_a => i_vect_axpby_a
generic, public :: axpby => axpby_v, axpby_a
procedure, pass(y) :: mlt_v => i_vect_mlt_v
procedure, pass(y) :: mlt_a => i_vect_mlt_a
procedure, pass(z) :: mlt_a_2 => i_vect_mlt_a_2
procedure, pass(z) :: mlt_v_2 => i_vect_mlt_v_2
procedure, pass(z) :: mlt_va => i_vect_mlt_va
procedure, pass(z) :: mlt_av => i_vect_mlt_av
generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
& mlt_v_2, mlt_av, mlt_va
procedure, pass(x) :: scal => i_vect_scal
procedure, pass(x) :: nrm2 => i_vect_nrm2
procedure, pass(x) :: amax => i_vect_amax
procedure, pass(x) :: asum => i_vect_asum
procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: zero => i_vect_zero
procedure, pass(x) :: asb => i_vect_asb
procedure, pass(x) :: sync => i_vect_sync
procedure, pass(x) :: gthab => i_vect_gthab
procedure, pass(x) :: gthzv => i_vect_gthzv
generic, public :: gth => gthab, gthzv
procedure, pass(y) :: sctb => i_vect_sctb
generic, public :: sct => sctb
procedure, pass(x) :: free => i_vect_free
procedure, pass(x) :: ins => i_vect_ins
procedure, pass(x) :: bld_x => i_vect_bld_x
procedure, pass(x) :: bld_n => i_vect_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: get_vect => i_vect_get_vect
procedure, pass(x) :: cnv => i_vect_cnv
procedure, pass(x) :: set_scal => i_vect_set_scal
procedure, pass(x) :: set_vect => i_vect_set_vect
generic, public :: set => set_vect, set_scal
end type psb_i_vect_type
public :: psb_i_vect
private :: constructor, size_const
interface psb_i_vect
module procedure constructor, size_const
end interface psb_i_vect
contains
subroutine i_vect_bld_x(x,invect,mold)
integer(psb_ipk_), intent(in) :: invect(:)
class(psb_i_vect_type), intent(out) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
if (present(mold)) then
allocate(x%v,stat=info,mold=mold)
else
allocate(psb_i_base_vect_type :: x%v,stat=info)
endif
if (info == psb_success_) call x%v%bld(invect)
end subroutine i_vect_bld_x
subroutine i_vect_bld_n(x,n,mold)
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(out) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
if (present(mold)) then
allocate(x%v,stat=info,mold=mold)
else
allocate(psb_i_base_vect_type :: x%v,stat=info)
endif
if (info == psb_success_) call x%v%bld(n)
end subroutine i_vect_bld_n
function i_vect_get_vect(x) result(res)
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), allocatable :: res(:)
integer(psb_ipk_) :: info
if (allocated(x%v)) then
res = x%v%get_vect()
end if
end function i_vect_get_vect
subroutine i_vect_set_scal(x,val)
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine i_vect_set_scal
subroutine i_vect_set_vect(x,val)
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine i_vect_set_vect
function constructor(x) result(this)
integer(psb_ipk_) :: x(:)
type(psb_i_vect_type) :: this
integer(psb_ipk_) :: info
allocate(psb_i_base_vect_type :: this%v, stat=info)
if (info == 0) call this%v%bld(x)
call this%asb(size(x,kind=psb_ipk_),info)
end function constructor
function size_const(n) result(this)
integer(psb_ipk_), intent(in) :: n
type(psb_i_vect_type) :: this
integer(psb_ipk_) :: info
allocate(psb_i_base_vect_type :: this%v, stat=info)
call this%asb(n,info)
end function size_const
function i_vect_get_nrows(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_nrows()
end function i_vect_get_nrows
function i_vect_sizeof(x) result(res)
implicit none
class(psb_i_vect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = 0
if (allocated(x%v)) res = x%v%sizeof()
end function i_vect_sizeof
function i_vect_dot_v(n,x,y) result(res)
implicit none
class(psb_i_vect_type), intent(inout) :: x, y
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
res = izero
if (allocated(x%v).and.allocated(y%v)) &
& res = x%v%dot(n,y%v)
end function i_vect_dot_v
function i_vect_dot_a(n,x,y) result(res)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: y(:)
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
res = izero
if (allocated(x%v)) &
& res = x%v%dot(n,y)
end function i_vect_dot_a
subroutine i_vect_axpby_v(m,alpha, x, beta, y, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_vect_type), intent(inout) :: y
integer(psb_ipk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v).and.allocated(y%v)) then
call y%v%axpby(m,alpha,x%v,beta,info)
else
info = psb_err_invalid_vect_state_
end if
end subroutine i_vect_axpby_v
subroutine i_vect_axpby_a(m,alpha, x, beta, y, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: m
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_vect_type), intent(inout) :: y
integer(psb_ipk_), intent (in) :: alpha, beta
integer(psb_ipk_), intent(out) :: info
if (allocated(y%v)) &
& call y%v%axpby(m,alpha,x,beta,info)
end subroutine i_vect_axpby_a
subroutine i_vect_mlt_v(x, y, info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (allocated(x%v).and.allocated(y%v)) &
& call y%v%mlt(x%v,info)
end subroutine i_vect_mlt_v
subroutine i_vect_mlt_a(x, y, info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_vect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (allocated(y%v)) &
& call y%v%mlt(x,info)
end subroutine i_vect_mlt_a
subroutine i_vect_mlt_a_2(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
integer(psb_ipk_), intent(in) :: y(:)
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (allocated(z%v)) &
& call z%v%mlt(alpha,x,y,beta,info)
end subroutine i_vect_mlt_a_2
subroutine i_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_vect_type), intent(inout) :: y
class(psb_i_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
character(len=1), intent(in), optional :: conjgx, conjgy
integer(psb_ipk_) :: i, n
info = 0
if (allocated(x%v).and.allocated(y%v).and.&
& allocated(z%v)) &
& call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
end subroutine i_vect_mlt_v_2
subroutine i_vect_mlt_av(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
integer(psb_ipk_), intent(in) :: x(:)
class(psb_i_vect_type), intent(inout) :: y
class(psb_i_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (allocated(z%v).and.allocated(y%v)) &
& call z%v%mlt(alpha,x,y%v,beta,info)
end subroutine i_vect_mlt_av
subroutine i_vect_mlt_va(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
integer(psb_ipk_), intent(in) :: alpha,beta
integer(psb_ipk_), intent(in) :: y(:)
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_vect_type), intent(inout) :: z
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i, n
info = 0
if (allocated(z%v).and.allocated(x%v)) &
& call z%v%mlt(alpha,x%v,y,beta,info)
end subroutine i_vect_mlt_va
subroutine i_vect_scal(alpha, x)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent (in) :: alpha
if (allocated(x%v)) call x%v%scal(alpha)
end subroutine i_vect_scal
function i_vect_nrm2(n,x) result(res)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%nrm2(n)
else
res = izero
end if
end function i_vect_nrm2
function i_vect_amax(n,x) result(res)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%amax(n)
else
res = izero
end if
end function i_vect_amax
function i_vect_asum(n,x) result(res)
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n
integer(psb_ipk_) :: res
if (allocated(x%v)) then
res = x%v%asum(n)
else
res = izero
end if
end function i_vect_asum
subroutine i_vect_all(n, x, info, mold)
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(out) :: x
class(psb_i_base_vect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
allocate(x%v,stat=info,mold=mold)
else
allocate(psb_i_base_vect_type :: x%v,stat=info)
endif
if (info == 0) then
call x%v%all(n,info)
else
info = psb_err_alloc_dealloc_
end if
end subroutine i_vect_all
subroutine i_vect_zero(x)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
if (allocated(x%v)) call x%v%zero()
end subroutine i_vect_zero
subroutine i_vect_asb(n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: n
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(n,info)
end subroutine i_vect_asb
subroutine i_vect_sync(x)
implicit none
class(psb_i_vect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine i_vect_sync
subroutine i_vect_gthab(n,idx,alpha,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: alpha, beta, y(:)
class(psb_i_vect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,alpha,beta,y)
end subroutine i_vect_gthab
subroutine i_vect_gthzv(n,idx,x,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: y(:)
class(psb_i_vect_type) :: x
if (allocated(x%v)) &
& call x%v%gth(n,idx,y)
end subroutine i_vect_gthzv
subroutine i_vect_sctb(n,idx,x,beta,y)
use psi_serial_mod
integer(psb_ipk_) :: n, idx(:)
integer(psb_ipk_) :: beta, x(:)
class(psb_i_vect_type) :: y
if (allocated(y%v)) &
& call y%v%sct(n,idx,x,beta)
end subroutine i_vect_sctb
subroutine i_vect_free(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) then
call x%v%free(info)
if (info == 0) deallocate(x%v,stat=info)
end if
end subroutine i_vect_free
subroutine i_vect_ins(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_i_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl,val,dupl,info)
end subroutine i_vect_ins
subroutine i_vect_cnv(x,mold)
class(psb_i_vect_type), intent(inout) :: x
class(psb_i_base_vect_type), intent(in) :: mold
class(psb_i_base_vect_type), allocatable :: tmp
integer(psb_ipk_), allocatable :: invect(:)
integer(psb_ipk_) :: info
allocate(tmp,stat=info,mold=mold)
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
call move_alloc(tmp,x%v)
end subroutine i_vect_cnv
end module psb_i_vect_mod
base/modules/psb_indx_map_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_ip_reord_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_linmap_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_list_map_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$
base/modules/psb_psblas_mod.f90
+1 -1
View File
@@ -1,6 +1,6 @@
!!$
!!$ Parallel Sparse BLAS version 3.0
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$

Some files were not shown because too many files have changed in this diff Show More