mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-20 12:52:14 +00:00
Merged MixedI8 in new branch (to be later merged into development)
This commit is contained in:
Salvatore Filippone
@@ -0,0 +1,744 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
module psi_c_collective_mod
|
||||
use psi_penv_mod
|
||||
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_csums, psb_csumv, psb_csumm, &
|
||||
& psb_csums_ec, psb_csumv_ec, psb_csumm_ec
|
||||
end interface
|
||||
|
||||
interface psb_amx
|
||||
module procedure psb_camxs, psb_camxv, psb_camxm, &
|
||||
& psb_camxs_ec, psb_camxv_ec, psb_camxm_ec
|
||||
end interface
|
||||
|
||||
interface psb_amn
|
||||
module procedure psb_camns, psb_camnv, psb_camnm, &
|
||||
& psb_camns_ec, psb_camnv_ec, psb_camnm_ec
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_bcast
|
||||
module procedure psb_cbcasts, psb_cbcastv, psb_cbcastm, &
|
||||
& psb_cbcasts_ec, psb_cbcastv_ec, psb_cbcastm_ec
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Reduction operations
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
|
||||
subroutine psb_csums(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_) :: dat_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,ictxt,info)
|
||||
dat = dat_
|
||||
else
|
||||
call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,root_,ictxt,info)
|
||||
if (iam == root_) dat = dat_
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_csums
|
||||
|
||||
subroutine psb_csumv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_) &
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_csumv
|
||||
|
||||
subroutine psb_csumm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_), allocatable :: dat_(:,:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_)&
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_csumm
|
||||
|
||||
subroutine psb_csums_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_csums_ec
|
||||
|
||||
subroutine psb_csumv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_csumv_ec
|
||||
|
||||
subroutine psb_csumm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_csumm_ec
|
||||
|
||||
|
||||
!
|
||||
! AMX: Maximum Absolute Value
|
||||
!
|
||||
|
||||
subroutine psb_camxs(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_) :: dat_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,ictxt,info)
|
||||
dat = dat_
|
||||
else
|
||||
call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info)
|
||||
if (iam == root_) dat = dat_
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_camxs
|
||||
|
||||
subroutine psb_camxv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_) &
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_camxv
|
||||
|
||||
subroutine psb_camxm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_), allocatable :: dat_(:,:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_)&
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_camxm
|
||||
|
||||
|
||||
subroutine psb_camxs_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amx(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amx(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_camxs_ec
|
||||
|
||||
subroutine psb_camxv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amx(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amx(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_camxv_ec
|
||||
|
||||
subroutine psb_camxm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amx(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amx(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_camxm_ec
|
||||
|
||||
|
||||
!
|
||||
! AMN: Minimum Absolute Value
|
||||
!
|
||||
|
||||
subroutine psb_camns(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_) :: dat_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,ictxt,info)
|
||||
dat = dat_
|
||||
else
|
||||
call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info)
|
||||
if (iam == root_) dat = dat_
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_camns
|
||||
|
||||
subroutine psb_camnv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_) &
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_camnv
|
||||
|
||||
subroutine psb_camnm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_spk_), allocatable :: dat_(:,:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_)&
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_camnm
|
||||
|
||||
|
||||
subroutine psb_camns_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amn(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amn(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_camns_ec
|
||||
|
||||
subroutine psb_camnv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amn(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amn(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_camnv_ec
|
||||
|
||||
subroutine psb_camnm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amn(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amn(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_camnm_ec
|
||||
|
||||
|
||||
!
|
||||
! BCAST Broadcast
|
||||
!
|
||||
|
||||
subroutine psb_cbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
call mpi_bcast(dat,1,psb_mpi_c_spk_,root_,ictxt,info)
|
||||
|
||||
#endif
|
||||
end subroutine psb_cbcasts
|
||||
|
||||
subroutine psb_cbcastv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
|
||||
call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_cbcastv
|
||||
|
||||
subroutine psb_cbcastm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
|
||||
call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_cbcastm
|
||||
|
||||
|
||||
subroutine psb_cbcasts_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_cbcasts_ec
|
||||
|
||||
subroutine psb_cbcastv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_cbcastv_ec
|
||||
|
||||
subroutine psb_cbcastm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_cbcastm_ec
|
||||
|
||||
|
||||
|
||||
end module psi_c_collective_mod
|
||||
@@ -0,0 +1,307 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
module psi_c_p2p_mod
|
||||
use psi_penv_mod
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
interface psb_snd
|
||||
module procedure psb_csnds, psb_csndv, psb_csndm, &
|
||||
& psb_csnds_ec, psb_csndv_ec, psb_csndm_ec
|
||||
end interface
|
||||
|
||||
interface psb_rcv
|
||||
module procedure psb_crcvs, psb_crcvv, psb_crcvm, &
|
||||
& psb_crcvs_ec, psb_crcvv_ec, psb_crcvm_ec
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_csnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
allocate(dat_(1), stat=info)
|
||||
dat_(1) = dat
|
||||
call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_csnds
|
||||
|
||||
subroutine psb_csndv(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(in) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
allocate(dat_(size(dat)), stat=info)
|
||||
dat_(:) = dat(:)
|
||||
call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_csndv
|
||||
|
||||
subroutine psb_csndm(ictxt,dat,dst,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(in) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_ipk_) :: i,j,k,m_,n_
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
else
|
||||
m_ = size(dat,1)
|
||||
end if
|
||||
n_ = size(dat,2)
|
||||
allocate(dat_(m_*n_), stat=info)
|
||||
k=1
|
||||
do j=1,n_
|
||||
do i=1, m_
|
||||
dat_(k) = dat(i,j)
|
||||
k = k + 1
|
||||
end do
|
||||
end do
|
||||
call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_csndm
|
||||
|
||||
subroutine psb_crcvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
call mpi_recv(dat,1,psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_crcvs
|
||||
|
||||
subroutine psb_crcvv(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(out) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_crcvv
|
||||
|
||||
subroutine psb_crcvm(ictxt,dat,src,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(out) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
complex(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
|
||||
integer(psb_mpk_) :: i,j,k
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! What should we do here??
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
ld = size(dat,1)
|
||||
n_ = size(dat,2)
|
||||
call mpi_type_vector(n_,m_,ld,psb_mpi_c_spk_,mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
|
||||
& psb_complex_tag,ictxt,status,info)
|
||||
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
|
||||
else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info)
|
||||
end if
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in psb_recv', info
|
||||
end if
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_crcvm
|
||||
|
||||
|
||||
subroutine psb_csnds_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_csnds_ec
|
||||
|
||||
subroutine psb_csndv_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(in) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_csndv_ec
|
||||
|
||||
subroutine psb_csndm_ec(ictxt,dat,dst,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(in) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_csndm_ec
|
||||
|
||||
subroutine psb_crcvs_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_crcvs_ec
|
||||
|
||||
subroutine psb_crcvv_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(out) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_crcvv_ec
|
||||
|
||||
subroutine psb_crcvm_ec(ictxt,dat,src,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(out) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_crcvm_ec
|
||||
|
||||
|
||||
end module psi_c_p2p_mod
|
||||
@@ -0,0 +1,420 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
module psi_collective_mod
|
||||
use psi_penv_mod
|
||||
use psi_m_collective_mod
|
||||
use psi_e_collective_mod
|
||||
use psi_s_collective_mod
|
||||
use psi_d_collective_mod
|
||||
use psi_c_collective_mod
|
||||
use psi_z_collective_mod
|
||||
|
||||
interface psb_bcast
|
||||
module procedure psb_hbcasts, psb_hbcastv,&
|
||||
& psb_hbcasts_ec, psb_hbcastv_ec,&
|
||||
& psb_lbcasts, psb_lbcastv, &
|
||||
& psb_lbcasts_ec, psb_lbcastv_ec
|
||||
end interface psb_bcast
|
||||
|
||||
|
||||
#if defined(SHORT_INTEGERS)
|
||||
interface psb_sum
|
||||
module procedure psb_i2sums, psb_i2sumv, psb_i2summ, &
|
||||
& psb_i2sums_ec, psb_i2sumv_ec, psb_i2summ_ec
|
||||
end interface psb_sum
|
||||
#endif
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine psb_hbcasts(ictxt,dat,root,length)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
character(len=*), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root,length
|
||||
|
||||
integer(psb_mpk_) :: iam, np, root_,length_,info
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
if (present(length)) then
|
||||
length_ = length
|
||||
else
|
||||
length_ = len(dat)
|
||||
endif
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info)
|
||||
#endif
|
||||
|
||||
end subroutine psb_hbcasts
|
||||
|
||||
subroutine psb_hbcastv(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
character(len=*), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
|
||||
integer(psb_mpk_) :: iam, np, root_,length_,info, size_
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
length_ = len(dat)
|
||||
size_ = size(dat)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info)
|
||||
#endif
|
||||
|
||||
end subroutine psb_hbcastv
|
||||
|
||||
subroutine psb_hbcasts_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
character(len=*), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_hbcasts_ec
|
||||
|
||||
subroutine psb_hbcastv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
character(len=*), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_hbcastv_ec
|
||||
|
||||
|
||||
|
||||
subroutine psb_lbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
|
||||
integer(psb_mpk_) :: iam, np, root_,info
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info)
|
||||
#endif
|
||||
|
||||
end subroutine psb_lbcasts
|
||||
|
||||
|
||||
subroutine psb_lbcastv(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
|
||||
integer(psb_mpk_) :: iam, np, root_,info
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info)
|
||||
#endif
|
||||
|
||||
end subroutine psb_lbcastv
|
||||
|
||||
|
||||
subroutine psb_lbcasts_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_lbcasts_ec
|
||||
|
||||
subroutine psb_lbcastv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_lbcastv_ec
|
||||
|
||||
|
||||
|
||||
#if defined(SHORT_INTEGERS)
|
||||
subroutine psb_i2sums(ictxt,dat,root)
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_i2pk_) :: dat_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,ictxt,info)
|
||||
dat = dat_
|
||||
else
|
||||
call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,ictxt,info)
|
||||
if (iam == root_) dat = dat_
|
||||
endif
|
||||
|
||||
#endif
|
||||
end subroutine psb_i2sums
|
||||
|
||||
subroutine psb_i2sumv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_i2pk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_=dat
|
||||
if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_=dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_i2sumv
|
||||
|
||||
subroutine psb_i2summ(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_i2pk_), allocatable :: dat_(:,:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_=dat
|
||||
if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),&
|
||||
& psb_mpi_i2pk_,mpi_sum,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_=dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info)
|
||||
else
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_i2summ
|
||||
|
||||
subroutine psb_i2sums_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_i2sums_ec
|
||||
|
||||
subroutine psb_i2sumv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_i2sumv_ec
|
||||
|
||||
subroutine psb_i2summ_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_i2pk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_i2summ_ec
|
||||
|
||||
#endif
|
||||
|
||||
end module psi_collective_mod
|
||||
@@ -0,0 +1,616 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
#if defined(SERIAL_MPI)
|
||||
! Provide a fake mpi module just to keep the compiler(s) happy.
|
||||
module mpi
|
||||
use psb_const_mod
|
||||
integer(psb_mpk_), parameter :: mpi_success = 0
|
||||
integer(psb_mpk_), parameter :: mpi_request_null = 0
|
||||
integer(psb_mpk_), parameter :: mpi_status_size = 1
|
||||
integer(psb_mpk_), parameter :: mpi_integer = 1
|
||||
integer(psb_mpk_), parameter :: mpi_integer8 = 2
|
||||
integer(psb_mpk_), parameter :: mpi_real = 3
|
||||
integer(psb_mpk_), parameter :: mpi_double_precision = 4
|
||||
integer(psb_mpk_), parameter :: mpi_complex = 5
|
||||
integer(psb_mpk_), parameter :: mpi_double_complex = 6
|
||||
integer(psb_mpk_), parameter :: mpi_character = 7
|
||||
integer(psb_mpk_), parameter :: mpi_logical = 8
|
||||
integer(psb_mpk_), parameter :: mpi_integer2 = 9
|
||||
integer(psb_mpk_), parameter :: mpi_comm_null = -1
|
||||
integer(psb_mpk_), parameter :: mpi_comm_world = 1
|
||||
|
||||
real(psb_dpk_), external :: mpi_wtime
|
||||
end module mpi
|
||||
#endif
|
||||
|
||||
module psi_comm_buffers_mod
|
||||
use psb_const_mod
|
||||
|
||||
integer(psb_mpk_), parameter:: psb_int_tag = 543987
|
||||
integer(psb_mpk_), parameter:: psb_real_tag = psb_int_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_double_tag = psb_real_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_complex_tag = psb_double_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_dcomplex_tag = psb_complex_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_logical_tag = psb_dcomplex_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_char_tag = psb_logical_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_int8_tag = psb_char_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_int2_tag = psb_int8_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_int4_tag = psb_int2_tag + 1
|
||||
integer(psb_mpk_), parameter:: psb_long_tag = psb_int4_tag + 1
|
||||
|
||||
integer(psb_mpk_), parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_double_swap_tag = psb_double_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_complex_swap_tag = psb_complex_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_dcomplex_swap_tag = psb_dcomplex_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_logical_swap_tag = psb_logical_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_char_swap_tag = psb_char_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_int2_swap_tag = psb_int2_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_int4_swap_tag = psb_int4_tag + psb_int_tag
|
||||
integer(psb_mpk_), parameter:: psb_long_swap_tag = psb_long_tag + psb_int_tag
|
||||
|
||||
|
||||
|
||||
integer(psb_mpk_), private, parameter:: psb_int_type = 987543
|
||||
integer(psb_mpk_), private, parameter:: psb_real_type = psb_int_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_double_type = psb_real_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_complex_type = psb_double_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_dcomplex_type = psb_complex_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_logical_type = psb_dcomplex_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_char_type = psb_logical_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_int8_type = psb_char_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_int2_type = psb_int8_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_int4_type = psb_int2_type + 1
|
||||
integer(psb_mpk_), private, parameter:: psb_long_type = psb_int4_type + 1
|
||||
|
||||
|
||||
type psb_buffer_node
|
||||
integer(psb_mpk_) :: request
|
||||
integer(psb_mpk_) :: icontxt
|
||||
integer(psb_mpk_) :: buffer_type
|
||||
integer(psb_epk_), allocatable :: int8buf(:)
|
||||
integer(psb_i2pk_), allocatable :: int2buf(:)
|
||||
integer(psb_mpk_), allocatable :: int4buf(:)
|
||||
real(psb_spk_), allocatable :: realbuf(:)
|
||||
real(psb_dpk_), allocatable :: doublebuf(:)
|
||||
complex(psb_spk_), allocatable :: complexbuf(:)
|
||||
complex(psb_dpk_), allocatable :: dcomplbuf(:)
|
||||
logical, allocatable :: logbuf(:)
|
||||
character(len=1), allocatable :: charbuf(:)
|
||||
type(psb_buffer_node), pointer :: prev=>null(), next=>null()
|
||||
end type psb_buffer_node
|
||||
|
||||
type psb_buffer_queue
|
||||
type(psb_buffer_node), pointer :: head=>null(), tail=>null()
|
||||
end type psb_buffer_queue
|
||||
|
||||
|
||||
interface psi_snd
|
||||
module procedure&
|
||||
& psi_msnd, psi_esnd,&
|
||||
& psi_ssnd, psi_dsnd,&
|
||||
& psi_csnd, psi_zsnd,&
|
||||
& psi_logsnd, psi_hsnd,&
|
||||
& psi_i2snd
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_init_queue(mesg_queue,info)
|
||||
implicit none
|
||||
type(psb_buffer_queue), intent(inout) :: mesg_queue
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if ((.not.associated(mesg_queue%head)).and.&
|
||||
& (.not.associated(mesg_queue%tail))) then
|
||||
! Nothing to do
|
||||
return
|
||||
end if
|
||||
|
||||
if ((.not.associated(mesg_queue%head)).or.&
|
||||
& (.not.associated(mesg_queue%tail))) then
|
||||
! If we are here one is associated, the other is not.
|
||||
! This is impossible.
|
||||
info = -1
|
||||
write(psb_err_unit,*) 'Wrong status on init '
|
||||
return
|
||||
end if
|
||||
|
||||
end subroutine psb_init_queue
|
||||
|
||||
subroutine psb_wait_buffer(node, info)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_buffer_node), intent(inout) :: node
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size),minfo
|
||||
minfo = mpi_success
|
||||
call mpi_wait(node%request,status,minfo)
|
||||
info=minfo
|
||||
end subroutine psb_wait_buffer
|
||||
|
||||
subroutine psb_test_buffer(node, flag, info)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
type(psb_buffer_node), intent(inout) :: node
|
||||
logical, intent(out) :: flag
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size), minfo
|
||||
minfo = mpi_success
|
||||
#if defined(SERIAL_MPI)
|
||||
flag = .true.
|
||||
#else
|
||||
call mpi_test(node%request,flag,status,minfo)
|
||||
#endif
|
||||
info=minfo
|
||||
end subroutine psb_test_buffer
|
||||
|
||||
|
||||
subroutine psb_close_context(mesg_queue,icontxt)
|
||||
type(psb_buffer_queue), intent(inout) :: mesg_queue
|
||||
integer(psb_mpk_), intent(in) :: icontxt
|
||||
integer(psb_ipk_) :: info
|
||||
type(psb_buffer_node), pointer :: node, nextnode
|
||||
|
||||
node => mesg_queue%head
|
||||
do
|
||||
if (.not.associated(node)) exit
|
||||
nextnode => node%next
|
||||
if (node%icontxt == icontxt) then
|
||||
call psb_wait_buffer(node,info)
|
||||
call psb_delete_node(mesg_queue,node)
|
||||
end if
|
||||
node => nextnode
|
||||
end do
|
||||
end subroutine psb_close_context
|
||||
|
||||
subroutine psb_close_all_context(mesg_queue)
|
||||
type(psb_buffer_queue), intent(inout) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node, nextnode
|
||||
integer(psb_ipk_) :: info
|
||||
|
||||
node => mesg_queue%head
|
||||
do
|
||||
if (.not.associated(node)) exit
|
||||
nextnode => node%next
|
||||
call psb_wait_buffer(node,info)
|
||||
call psb_delete_node(mesg_queue,node)
|
||||
node => nextnode
|
||||
end do
|
||||
end subroutine psb_close_all_context
|
||||
|
||||
|
||||
subroutine psb_delete_node(mesg_queue,node)
|
||||
type(psb_buffer_queue), intent(inout) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
type(psb_buffer_node), pointer :: prevnode
|
||||
|
||||
if (.not.associated(node)) then
|
||||
return
|
||||
end if
|
||||
prevnode => node%prev
|
||||
if (associated(mesg_queue%head,node)) mesg_queue%head => node%next
|
||||
if (associated(mesg_queue%tail,node)) mesg_queue%tail => prevnode
|
||||
if (associated(prevnode)) prevnode%next => node%next
|
||||
if (associated(node%next)) node%next%prev => prevnode
|
||||
deallocate(node)
|
||||
|
||||
end subroutine psb_delete_node
|
||||
|
||||
subroutine psb_insert_node(mesg_queue,node)
|
||||
type(psb_buffer_queue), intent(inout) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
|
||||
node%next => null()
|
||||
node%prev => null()
|
||||
if ((.not.associated(mesg_queue%head)).and.&
|
||||
& (.not.associated(mesg_queue%tail))) then
|
||||
mesg_Queue%head => node
|
||||
mesg_queue%tail => node
|
||||
return
|
||||
end if
|
||||
mesg_queue%tail%next => node
|
||||
node%prev => mesg_queue%tail
|
||||
mesg_queue%tail => node
|
||||
|
||||
end subroutine psb_insert_node
|
||||
|
||||
subroutine psb_test_nodes(mesg_queue)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node, nextnode
|
||||
integer(psb_ipk_) :: info
|
||||
logical :: flag
|
||||
|
||||
node => mesg_queue%head
|
||||
do
|
||||
if (.not.associated(node)) exit
|
||||
nextnode => node%next
|
||||
call psb_test_buffer(node,flag,info)
|
||||
if (flag) then
|
||||
call psb_delete_node(mesg_queue,node)
|
||||
end if
|
||||
node => nextnode
|
||||
end do
|
||||
end subroutine psb_test_nodes
|
||||
|
||||
! !!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Inner send. Basic idea:
|
||||
! the input buffer is MOVE_ALLOCed
|
||||
! to a node in the mesg queue, then it is sent.
|
||||
! Thus the calling process should guarantee that
|
||||
! the buffer is dispensable, i.e. the user data
|
||||
! has already been copied.
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!
|
||||
subroutine psi_msnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
integer(psb_mpk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_int_type
|
||||
call move_alloc(buffer,node%int4buf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%int4buf,size(node%int4buf),psb_mpi_mpk_,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_msnd
|
||||
|
||||
|
||||
subroutine psi_esnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
integer(psb_epk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_int8_type
|
||||
call move_alloc(buffer,node%int8buf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%int8buf,size(node%int8buf),psb_mpi_epk_,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_esnd
|
||||
|
||||
subroutine psi_i2snd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
integer(psb_i2pk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_int2_type
|
||||
call move_alloc(buffer,node%int2buf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%int2buf,size(node%int2buf),psb_mpi_i2pk_,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_i2snd
|
||||
|
||||
subroutine psi_ssnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
real(psb_spk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_real_type
|
||||
call move_alloc(buffer,node%realbuf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%realbuf,size(node%realbuf),psb_mpi_r_spk_,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_ssnd
|
||||
|
||||
subroutine psi_dsnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
real(psb_dpk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_double_type
|
||||
call move_alloc(buffer,node%doublebuf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%doublebuf,size(node%doublebuf),psb_mpi_r_dpk_,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_dsnd
|
||||
|
||||
subroutine psi_csnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
complex(psb_spk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_complex_type
|
||||
call move_alloc(buffer,node%complexbuf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%complexbuf,size(node%complexbuf),psb_mpi_c_spk_,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_csnd
|
||||
|
||||
subroutine psi_zsnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
complex(psb_dpk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_dcomplex_type
|
||||
call move_alloc(buffer,node%dcomplbuf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%dcomplbuf,size(node%dcomplbuf),psb_mpi_c_dpk_,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_zsnd
|
||||
|
||||
|
||||
subroutine psi_logsnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
logical, allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_logical_type
|
||||
call move_alloc(buffer,node%logbuf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%logbuf,size(node%logbuf),mpi_logical,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_logsnd
|
||||
|
||||
|
||||
subroutine psi_hsnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: icontxt, tag, dest
|
||||
character(len=1), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer(psb_ipk_) :: info
|
||||
integer(psb_mpk_) :: minfo
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_char_type
|
||||
call move_alloc(buffer,node%charbuf)
|
||||
if (info /= 0) then
|
||||
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%charbuf,size(node%charbuf),mpi_character,&
|
||||
& dest,tag,icontxt,node%request,minfo)
|
||||
info = minfo
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_hsnd
|
||||
|
||||
|
||||
end module psi_comm_buffers_mod
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,307 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
module psi_d_p2p_mod
|
||||
use psi_penv_mod
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
interface psb_snd
|
||||
module procedure psb_dsnds, psb_dsndv, psb_dsndm, &
|
||||
& psb_dsnds_ec, psb_dsndv_ec, psb_dsndm_ec
|
||||
end interface
|
||||
|
||||
interface psb_rcv
|
||||
module procedure psb_drcvs, psb_drcvv, psb_drcvm, &
|
||||
& psb_drcvs_ec, psb_drcvv_ec, psb_drcvm_ec
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_dsnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
allocate(dat_(1), stat=info)
|
||||
dat_(1) = dat
|
||||
call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_dsnds
|
||||
|
||||
subroutine psb_dsndv(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(in) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
allocate(dat_(size(dat)), stat=info)
|
||||
dat_(:) = dat(:)
|
||||
call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_dsndv
|
||||
|
||||
subroutine psb_dsndm(ictxt,dat,dst,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(in) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_ipk_) :: i,j,k,m_,n_
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
else
|
||||
m_ = size(dat,1)
|
||||
end if
|
||||
n_ = size(dat,2)
|
||||
allocate(dat_(m_*n_), stat=info)
|
||||
k=1
|
||||
do j=1,n_
|
||||
do i=1, m_
|
||||
dat_(k) = dat(i,j)
|
||||
k = k + 1
|
||||
end do
|
||||
end do
|
||||
call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_dsndm
|
||||
|
||||
subroutine psb_drcvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
call mpi_recv(dat,1,psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_drcvs
|
||||
|
||||
subroutine psb_drcvv(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(out) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_drcvv
|
||||
|
||||
subroutine psb_drcvm(ictxt,dat,src,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(out) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
real(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
|
||||
integer(psb_mpk_) :: i,j,k
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! What should we do here??
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
ld = size(dat,1)
|
||||
n_ = size(dat,2)
|
||||
call mpi_type_vector(n_,m_,ld,psb_mpi_r_dpk_,mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
|
||||
& psb_double_tag,ictxt,status,info)
|
||||
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
|
||||
else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info)
|
||||
end if
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in psb_recv', info
|
||||
end if
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_drcvm
|
||||
|
||||
|
||||
subroutine psb_dsnds_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_dsnds_ec
|
||||
|
||||
subroutine psb_dsndv_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(in) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_dsndv_ec
|
||||
|
||||
subroutine psb_dsndm_ec(ictxt,dat,dst,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(in) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_dsndm_ec
|
||||
|
||||
subroutine psb_drcvs_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_drcvs_ec
|
||||
|
||||
subroutine psb_drcvv_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(out) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_drcvv_ec
|
||||
|
||||
subroutine psb_drcvm_ec(ictxt,dat,src,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(out) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_drcvm_ec
|
||||
|
||||
|
||||
end module psi_d_p2p_mod
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,307 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
module psi_e_p2p_mod
|
||||
use psi_penv_mod
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
interface psb_snd
|
||||
module procedure psb_esnds, psb_esndv, psb_esndm, &
|
||||
& psb_esnds_ec, psb_esndv_ec, psb_esndm_ec
|
||||
end interface
|
||||
|
||||
interface psb_rcv
|
||||
module procedure psb_ercvs, psb_ercvv, psb_ercvm, &
|
||||
& psb_ercvs_ec, psb_ercvv_ec, psb_ercvm_ec
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_esnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
allocate(dat_(1), stat=info)
|
||||
dat_(1) = dat
|
||||
call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_esnds
|
||||
|
||||
subroutine psb_esndv(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(in) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
allocate(dat_(size(dat)), stat=info)
|
||||
dat_(:) = dat(:)
|
||||
call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_esndv
|
||||
|
||||
subroutine psb_esndm(ictxt,dat,dst,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(in) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
integer(psb_ipk_) :: i,j,k,m_,n_
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
else
|
||||
m_ = size(dat,1)
|
||||
end if
|
||||
n_ = size(dat,2)
|
||||
allocate(dat_(m_*n_), stat=info)
|
||||
k=1
|
||||
do j=1,n_
|
||||
do i=1, m_
|
||||
dat_(k) = dat(i,j)
|
||||
k = k + 1
|
||||
end do
|
||||
end do
|
||||
call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_esndm
|
||||
|
||||
subroutine psb_ercvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
call mpi_recv(dat,1,psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_ercvs
|
||||
|
||||
subroutine psb_ercvv(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(out) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_ercvv
|
||||
|
||||
subroutine psb_ercvm(ictxt,dat,src,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(out) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
integer(psb_epk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
|
||||
integer(psb_mpk_) :: i,j,k
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! What should we do here??
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
ld = size(dat,1)
|
||||
n_ = size(dat,2)
|
||||
call mpi_type_vector(n_,m_,ld,psb_mpi_epk_,mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
|
||||
& psb_int8_tag,ictxt,status,info)
|
||||
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
|
||||
else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info)
|
||||
end if
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in psb_recv', info
|
||||
end if
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_ercvm
|
||||
|
||||
|
||||
subroutine psb_esnds_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_esnds_ec
|
||||
|
||||
subroutine psb_esndv_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(in) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_esndv_ec
|
||||
|
||||
subroutine psb_esndm_ec(ictxt,dat,dst,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(in) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_esndm_ec
|
||||
|
||||
subroutine psb_ercvs_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_ercvs_ec
|
||||
|
||||
subroutine psb_ercvv_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(out) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_ercvv_ec
|
||||
|
||||
subroutine psb_ercvm_ec(ictxt,dat,src,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(out) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_ercvm_ec
|
||||
|
||||
|
||||
end module psi_e_p2p_mod
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,307 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
module psi_m_p2p_mod
|
||||
use psi_penv_mod
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
interface psb_snd
|
||||
module procedure psb_msnds, psb_msndv, psb_msndm, &
|
||||
& psb_msnds_ec, psb_msndv_ec, psb_msndm_ec
|
||||
end interface
|
||||
|
||||
interface psb_rcv
|
||||
module procedure psb_mrcvs, psb_mrcvv, psb_mrcvm, &
|
||||
& psb_mrcvs_ec, psb_mrcvv_ec, psb_mrcvm_ec
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_msnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
allocate(dat_(1), stat=info)
|
||||
dat_(1) = dat
|
||||
call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_msnds
|
||||
|
||||
subroutine psb_msndv(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(in) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
allocate(dat_(size(dat)), stat=info)
|
||||
dat_(:) = dat(:)
|
||||
call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_msndv
|
||||
|
||||
subroutine psb_msndm(ictxt,dat,dst,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(in) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
integer(psb_ipk_) :: i,j,k,m_,n_
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
else
|
||||
m_ = size(dat,1)
|
||||
end if
|
||||
n_ = size(dat,2)
|
||||
allocate(dat_(m_*n_), stat=info)
|
||||
k=1
|
||||
do j=1,n_
|
||||
do i=1, m_
|
||||
dat_(k) = dat(i,j)
|
||||
k = k + 1
|
||||
end do
|
||||
end do
|
||||
call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_msndm
|
||||
|
||||
subroutine psb_mrcvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
call mpi_recv(dat,1,psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_mrcvs
|
||||
|
||||
subroutine psb_mrcvv(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(out) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_mrcvv
|
||||
|
||||
subroutine psb_mrcvm(ictxt,dat,src,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(out) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
integer(psb_mpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
|
||||
integer(psb_mpk_) :: i,j,k
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! What should we do here??
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
ld = size(dat,1)
|
||||
n_ = size(dat,2)
|
||||
call mpi_type_vector(n_,m_,ld,psb_mpi_mpk_,mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
|
||||
& psb_int4_tag,ictxt,status,info)
|
||||
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
|
||||
else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info)
|
||||
end if
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in psb_recv', info
|
||||
end if
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_mrcvm
|
||||
|
||||
|
||||
subroutine psb_msnds_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_msnds_ec
|
||||
|
||||
subroutine psb_msndv_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(in) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_msndv_ec
|
||||
|
||||
subroutine psb_msndm_ec(ictxt,dat,dst,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(in) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_msndm_ec
|
||||
|
||||
subroutine psb_mrcvs_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_mrcvs_ec
|
||||
|
||||
subroutine psb_mrcvv_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(out) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_mrcvv_ec
|
||||
|
||||
subroutine psb_mrcvm_ec(ictxt,dat,src,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(out) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_mrcvm_ec
|
||||
|
||||
|
||||
end module psi_m_p2p_mod
|
||||
@@ -0,0 +1,418 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
module psi_p2p_mod
|
||||
use psi_penv_mod
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
use psi_m_p2p_mod
|
||||
use psi_e_p2p_mod
|
||||
use psi_s_p2p_mod
|
||||
use psi_d_p2p_mod
|
||||
use psi_c_p2p_mod
|
||||
use psi_z_p2p_mod
|
||||
|
||||
|
||||
!
|
||||
! Add here interfaces for
|
||||
! LOGICAL scalar/vector/matrix
|
||||
! CHARACTER scalar (use H prefix as in old style Hollerith)
|
||||
!
|
||||
interface psb_snd
|
||||
module procedure psb_lsnds, psb_lsndv, psb_lsndm,&
|
||||
& psb_hsnds, psb_lsnds_ec, psb_lsndv_ec, &
|
||||
& psb_lsndm_ec, psb_hsnds_ec
|
||||
end interface
|
||||
interface psb_rcv
|
||||
module procedure psb_lrcvs, psb_lrcvv, psb_lrcvm,&
|
||||
& psb_hrcvs, psb_lrcvs_ec, psb_lrcvv_ec, &
|
||||
& psb_lrcvm_ec, psb_hrcvs_ec
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Point-to-point SND
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
subroutine psb_lsnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
logical, allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
allocate(dat_(1), stat=info)
|
||||
dat_(1) = dat
|
||||
call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_lsnds
|
||||
|
||||
subroutine psb_lsndv(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(in) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
logical, allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
allocate(dat_(size(dat)), stat=info)
|
||||
dat_(:) = dat(:)
|
||||
call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_lsndv
|
||||
|
||||
subroutine psb_lsndm(ictxt,dat,dst,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(in) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
logical, allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_ipk_) :: i,j,k,m_,n_
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
else
|
||||
m_ = size(dat,1)
|
||||
end if
|
||||
n_ = size(dat,2)
|
||||
allocate(dat_(m_*n_), stat=info)
|
||||
k=1
|
||||
do j=1,n_
|
||||
do i=1, m_
|
||||
dat_(k) = dat(i,j)
|
||||
k = k + 1
|
||||
end do
|
||||
end do
|
||||
call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_lsndm
|
||||
|
||||
subroutine psb_hsnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
character(len=*), intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
character(len=1), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info, l, i
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
l = len(dat)
|
||||
allocate(dat_(l), stat=info)
|
||||
do i=1, l
|
||||
dat_(i) = dat(i:i)
|
||||
end do
|
||||
call psi_snd(ictxt,psb_char_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_hsnds
|
||||
|
||||
subroutine psb_lsnds_ec(ictxt,dat,dst)
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_lsnds_ec
|
||||
|
||||
subroutine psb_lsndv_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(in) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_lsndv_ec
|
||||
|
||||
subroutine psb_lsndm_ec(ictxt,dat,dst,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(in) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_lsndm_ec
|
||||
|
||||
|
||||
subroutine psb_hsnds_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
character(len=*), intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_hsnds_ec
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Point-to-point RCV
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
subroutine psb_lrcvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
call mpi_recv(dat,1,mpi_logical,src,psb_logical_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_lrcvs
|
||||
|
||||
subroutine psb_lrcvv(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(out) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
call mpi_recv(dat,size(dat),mpi_logical,src,psb_logical_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_lrcvv
|
||||
|
||||
subroutine psb_lrcvm(ictxt,dat,src,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
logical, intent(out) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
|
||||
integer(psb_ipk_) :: i,j,k
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! What should we do here??
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
ld = size(dat,1)
|
||||
n_ = size(dat,2)
|
||||
call mpi_type_vector(n_,m_,ld,mpi_logical,mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
|
||||
& psb_logical_tag,ictxt,status,info)
|
||||
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
|
||||
else
|
||||
call mpi_recv(dat,size(dat),mpi_logical,src,&
|
||||
& psb_logical_tag,ictxt,status,info)
|
||||
end if
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in psb_recv', info
|
||||
end if
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_lrcvm
|
||||
|
||||
|
||||
subroutine psb_hrcvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
character(len=*), intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
character(len=1), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info, l, i
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
l = len(dat)
|
||||
allocate(dat_(l), stat=info)
|
||||
call mpi_recv(dat_,l,mpi_character,src,psb_char_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
do i=1, l
|
||||
dat(i:i) = dat_(i)
|
||||
end do
|
||||
deallocate(dat_)
|
||||
#endif
|
||||
end subroutine psb_hrcvs
|
||||
|
||||
|
||||
subroutine psb_lrcvs_ec(ictxt,dat,src)
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_lrcvs_ec
|
||||
|
||||
subroutine psb_lrcvv_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(out) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_lrcvv_ec
|
||||
|
||||
subroutine psb_lrcvm_ec(ictxt,dat,src,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
logical, intent(out) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_lrcvm_ec
|
||||
|
||||
|
||||
subroutine psb_hrcvs_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
character(len=*), intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_hrcvs_ec
|
||||
|
||||
end module psi_p2p_mod
|
||||
@@ -0,0 +1,752 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
module psi_penv_mod
|
||||
use psb_const_mod
|
||||
use psi_comm_buffers_mod, only : psb_buffer_queue
|
||||
|
||||
interface psb_init
|
||||
module procedure psb_init_mpik
|
||||
end interface
|
||||
|
||||
interface psb_exit
|
||||
module procedure psb_exit_mpik
|
||||
end interface
|
||||
|
||||
interface psb_abort
|
||||
module procedure psb_abort_mpik
|
||||
end interface
|
||||
|
||||
interface psb_info
|
||||
module procedure psb_info_mpik
|
||||
end interface
|
||||
|
||||
interface psb_barrier
|
||||
module procedure psb_barrier_mpik
|
||||
end interface
|
||||
|
||||
interface psb_init
|
||||
module procedure psb_init_epk
|
||||
end interface
|
||||
|
||||
interface psb_exit
|
||||
module procedure psb_exit_epk
|
||||
end interface
|
||||
|
||||
interface psb_abort
|
||||
module procedure psb_abort_epk
|
||||
end interface
|
||||
|
||||
interface psb_info
|
||||
module procedure psb_info_epk
|
||||
end interface
|
||||
|
||||
interface psb_barrier
|
||||
module procedure psb_barrier_epk
|
||||
end interface
|
||||
|
||||
interface psb_wtime
|
||||
module procedure psb_wtime
|
||||
end interface
|
||||
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
integer(psb_mpk_), private, save :: nctxt=0
|
||||
|
||||
#else
|
||||
|
||||
integer(psb_mpk_), save :: mpi_iamx_op, mpi_iamn_op
|
||||
integer(psb_mpk_), save :: mpi_mamx_op, mpi_mamn_op
|
||||
integer(psb_mpk_), save :: mpi_eamx_op, mpi_eamn_op
|
||||
integer(psb_mpk_), save :: mpi_samx_op, mpi_samn_op
|
||||
integer(psb_mpk_), save :: mpi_damx_op, mpi_damn_op
|
||||
integer(psb_mpk_), save :: mpi_camx_op, mpi_camn_op
|
||||
integer(psb_mpk_), save :: mpi_zamx_op, mpi_zamn_op
|
||||
integer(psb_mpk_), save :: mpi_snrm2_op, mpi_dnrm2_op
|
||||
|
||||
type(psb_buffer_queue), save :: psb_mesg_queue
|
||||
|
||||
#endif
|
||||
|
||||
private :: psi_get_sizes, psi_register_mpi_extras
|
||||
private :: psi_iamx_op, psi_iamn_op
|
||||
private :: psi_mamx_op, psi_mamn_op
|
||||
private :: psi_eamx_op, psi_eamn_op
|
||||
private :: psi_samx_op, psi_samn_op
|
||||
private :: psi_damx_op, psi_damn_op
|
||||
private :: psi_camx_op, psi_camn_op
|
||||
private :: psi_zamx_op, psi_zamn_op
|
||||
private :: psi_snrm2_op, psi_dnrm2_op
|
||||
|
||||
|
||||
contains
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Environment handling
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
subroutine psi_get_sizes()
|
||||
use psb_const_mod
|
||||
real(psb_dpk_) :: dv(2)
|
||||
real(psb_spk_) :: sv(2)
|
||||
integer(psb_i2pk_):: i2v(2)
|
||||
integer(psb_mpk_) :: mv(2)
|
||||
integer(psb_ipk_) :: iv(2)
|
||||
integer(psb_lpk_) :: lv(2)
|
||||
integer(psb_epk_) :: ev(2)
|
||||
|
||||
call psi_c_diffadd(sv(1),sv(2),psb_sizeof_sp)
|
||||
call psi_c_diffadd(dv(1),dv(2),psb_sizeof_dp)
|
||||
call psi_c_diffadd(i2v(1),i2v(2),psb_sizeof_i2p)
|
||||
call psi_c_diffadd(mv(1),mv(2),psb_sizeof_mp)
|
||||
call psi_c_diffadd(iv(1),iv(2),psb_sizeof_ip)
|
||||
call psi_c_diffadd(lv(1),lv(2),psb_sizeof_lp)
|
||||
call psi_c_diffadd(ev(1),ev(2),psb_sizeof_ep)
|
||||
|
||||
end subroutine psi_get_sizes
|
||||
|
||||
subroutine psi_register_mpi_extras(info)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
info = 0
|
||||
#if 0
|
||||
if (info == 0) call mpi_type_create_f90_integer(psb_ipk_, psb_mpi_ipk_ ,info)
|
||||
if (info == 0) call mpi_type_create_f90_integer(psb_lpk_, psb_mpi_lpk_ ,info)
|
||||
if (info == 0) call mpi_type_create_f90_integer(psb_mpk_, psb_mpi_mpk_ ,info)
|
||||
if (info == 0) call mpi_type_create_f90_integer(psb_epk_, psb_mpi_lpk_ ,info)
|
||||
if (info == 0) call mpi_type_create_f90_real(psb_spk_p_,psb_spk_r_, psb_mpi_r_spk_,info)
|
||||
if (info == 0) call mpi_type_create_f90_real(psb_dpk_p_,psb_dpk_r_, psb_mpi_r_dpk_,info)
|
||||
if (info == 0) call mpi_type_create_f90_complex(psb_spk_p_,psb_spk_r_, psb_mpi_c_spk_,info)
|
||||
if (info == 0) call mpi_type_create_f90_complex(psb_dpk_p_,psb_dpk_r_, psb_mpi_c_dpk_,info)
|
||||
#else
|
||||
#if defined(IPK4) && defined(LPK4)
|
||||
psb_mpi_ipk_ = mpi_integer4
|
||||
psb_mpi_lpk_ = mpi_integer4
|
||||
#elif defined(IPK4) && defined(LPK8)
|
||||
psb_mpi_ipk_ = mpi_integer4
|
||||
psb_mpi_lpk_ = mpi_integer8
|
||||
#elif defined(IPK8) && defined(LPK8)
|
||||
psb_mpi_ipk_ = mpi_integer8
|
||||
psb_mpi_lpk_ = mpi_integer8
|
||||
#else
|
||||
! This should never happen
|
||||
write(psb_err_unit,*) 'Warning: an impossible IPK/LPK combination.'
|
||||
write(psb_err_unit,*) 'Something went wrong at configuration time.'
|
||||
psb_mpi_ipk_ = -1
|
||||
psb_mpi_lpk_ = -1
|
||||
#endif
|
||||
psb_mpi_i2pk_ = mpi_integer2
|
||||
psb_mpi_mpk_ = mpi_integer4
|
||||
psb_mpi_epk_ = mpi_integer8
|
||||
psb_mpi_r_spk_ = mpi_real
|
||||
psb_mpi_r_dpk_ = mpi_double_precision
|
||||
psb_mpi_c_spk_ = mpi_complex
|
||||
psb_mpi_c_dpk_ = mpi_double_complex
|
||||
#endif
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (info == 0) call mpi_op_create(psi_mamx_op,.true.,mpi_mamx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_mamn_op,.true.,mpi_mamn_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_eamx_op,.true.,mpi_eamx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_eamn_op,.true.,mpi_eamn_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_samx_op,.true.,mpi_samx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_samn_op,.true.,mpi_samn_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_damx_op,.true.,mpi_damx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_damn_op,.true.,mpi_damn_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_camx_op,.true.,mpi_camx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_camn_op,.true.,mpi_camn_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_zamx_op,.true.,mpi_zamx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_zamn_op,.true.,mpi_zamn_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_snrm2_op,.true.,mpi_snrm2_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_dnrm2_op,.true.,mpi_dnrm2_op,info)
|
||||
#endif
|
||||
|
||||
end subroutine psi_register_mpi_extras
|
||||
|
||||
subroutine psb_init_epk(ictxt,np,basectxt,ids)
|
||||
integer(psb_epk_), intent(out) :: ictxt
|
||||
integer(psb_epk_), intent(in), optional :: np, basectxt, ids(:)
|
||||
|
||||
integer(psb_mpk_) :: iictxt
|
||||
integer(psb_mpk_) :: inp, ibasectxt
|
||||
integer(psb_mpk_), allocatable :: ids_(:)
|
||||
|
||||
if (present(ids)) then
|
||||
allocate(ids_(size(ids)))
|
||||
ids_ = ids
|
||||
else
|
||||
allocate(ids_(0))
|
||||
end if
|
||||
if (present(np).and.present(basectxt)) then
|
||||
inp = np
|
||||
ibasectxt = basectxt
|
||||
call psb_init(iictxt,np=inp,basectxt=ibasectxt,ids=ids_)
|
||||
else if (present(np)) then
|
||||
inp = np
|
||||
call psb_init(iictxt,np=inp,ids=ids_)
|
||||
else if (present(basectxt)) then
|
||||
ibasectxt = basectxt
|
||||
call psb_init(iictxt,basectxt=ibasectxt,ids=ids_)
|
||||
else
|
||||
call psb_init(iictxt,ids=ids_)
|
||||
end if
|
||||
ictxt = iictxt
|
||||
end subroutine psb_init_epk
|
||||
|
||||
subroutine psb_exit_epk(ictxt,close)
|
||||
integer(psb_epk_), intent(inout) :: ictxt
|
||||
logical, intent(in), optional :: close
|
||||
integer(psb_mpk_) :: iictxt
|
||||
|
||||
iictxt = ictxt
|
||||
call psb_exit(iictxt, close)
|
||||
end subroutine psb_exit_epk
|
||||
|
||||
subroutine psb_barrier_epk(ictxt)
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_) :: iictxt
|
||||
|
||||
iictxt = ictxt
|
||||
call psb_barrier(iictxt)
|
||||
end subroutine psb_barrier_epk
|
||||
|
||||
subroutine psb_abort_epk(ictxt,errc)
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(in), optional :: errc
|
||||
integer(psb_mpk_) :: iictxt, ierrc
|
||||
|
||||
iictxt = ictxt
|
||||
if (present(errc)) then
|
||||
ierrc = errc
|
||||
call psb_abort(iictxt,ierrc)
|
||||
else
|
||||
call psb_abort(iictxt)
|
||||
end if
|
||||
end subroutine psb_abort_epk
|
||||
|
||||
subroutine psb_info_epk(ictxt,iam,np)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
integer(psb_epk_), intent(out) :: iam, np
|
||||
|
||||
!
|
||||
! Simple caching scheme, keep track
|
||||
! of the last CTXT encountered.
|
||||
!
|
||||
integer(psb_mpk_), save :: lctxt=-1, lam, lnp
|
||||
if (ictxt /= lctxt) then
|
||||
lctxt = ictxt
|
||||
call psb_info(lctxt,lam,lnp)
|
||||
end if
|
||||
iam = lam
|
||||
np = lnp
|
||||
end subroutine psb_info_epk
|
||||
|
||||
subroutine psb_init_mpik(ictxt,np,basectxt,ids)
|
||||
use psi_comm_buffers_mod
|
||||
use psb_const_mod
|
||||
use psb_error_mod
|
||||
use psb_mat_mod
|
||||
use psb_vect_mod
|
||||
! !$ use psb_rsb_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(out) :: ictxt
|
||||
integer(psb_mpk_), intent(in), optional :: np, basectxt, ids(:)
|
||||
|
||||
integer(psb_mpk_) :: i, isnullcomm
|
||||
integer(psb_mpk_), allocatable :: iids(:)
|
||||
logical :: initialized
|
||||
integer(psb_mpk_) :: np_, npavail, iam, info, basecomm, basegroup, newgroup
|
||||
character(len=20), parameter :: name='psb_init'
|
||||
integer(psb_ipk_) :: iinfo
|
||||
!
|
||||
call psb_set_debug_unit(psb_err_unit)
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
ictxt = nctxt
|
||||
nctxt = nctxt + 1
|
||||
|
||||
call psi_register_mpi_extras(info)
|
||||
call psi_get_sizes()
|
||||
|
||||
#else
|
||||
call mpi_initialized(initialized,info)
|
||||
if ((.not.initialized).or.(info /= mpi_success)) then
|
||||
if (info == mpi_success) call mpi_init(info)
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in initalizing MPI, bailing out',info
|
||||
stop
|
||||
end if
|
||||
end if
|
||||
|
||||
if (present(basectxt)) then
|
||||
basecomm = basectxt
|
||||
else
|
||||
basecomm = mpi_comm_world
|
||||
end if
|
||||
|
||||
if (present(np)) then
|
||||
if (np < 1) then
|
||||
iinfo=psb_err_initerror_neugh_procs_
|
||||
call psb_errpush(iinfo,name)
|
||||
call psb_error()
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
endif
|
||||
call mpi_comm_size(basecomm,np_,info)
|
||||
if (np_ < np) then
|
||||
iinfo=psb_err_initerror_neugh_procs_
|
||||
call psb_errpush(iinfo,name)
|
||||
call psb_error()
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
endif
|
||||
call mpi_comm_group(basecomm,basegroup,info)
|
||||
if (present(ids)) then
|
||||
if (size(ids)<np) then
|
||||
write(psb_err_unit,*) 'Error in init: too few ids in input'
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
end if
|
||||
do i=1, np
|
||||
if ((ids(i)<0).or.(ids(i)>np_)) then
|
||||
write(psb_err_unit,*) 'Error in init: invalid rank in input'
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
end if
|
||||
end do
|
||||
call mpi_group_incl(basegroup,np,ids,newgroup,info)
|
||||
if (info /= mpi_success) then
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
endif
|
||||
else
|
||||
allocate(iids(np),stat=info)
|
||||
if (info /= 0) then
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
endif
|
||||
do i=1, np
|
||||
iids(i) = i-1
|
||||
end do
|
||||
call mpi_group_incl(basegroup,np,iids,newgroup,info)
|
||||
if (info /= mpi_success) then
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
endif
|
||||
deallocate(iids)
|
||||
end if
|
||||
call mpi_comm_create(basecomm,newgroup,ictxt,info)
|
||||
|
||||
else
|
||||
if (basecomm /= mpi_comm_null) then
|
||||
call mpi_comm_dup(basecomm,ictxt,info)
|
||||
else
|
||||
ictxt = mpi_comm_null
|
||||
end if
|
||||
endif
|
||||
call psi_register_mpi_extras(info)
|
||||
call psi_get_sizes()
|
||||
if (ictxt == mpi_comm_null) return
|
||||
#endif
|
||||
call psb_init_vect_defaults()
|
||||
call psb_init_mat_defaults()
|
||||
! !$ call psb_rsb_init(info)
|
||||
! !$ if (info.ne.psb_rsb_const_success) then
|
||||
! !$ if (info.eq.psb_rsb_const_not_available) then
|
||||
! !$ info=psb_success_ ! rsb is not present
|
||||
! !$ else
|
||||
! !$ ! rsb failed to initialize, and we issue an internal error.
|
||||
! !$ ! or shall we tolerate this ?
|
||||
! !$ info=psb_err_internal_error_
|
||||
! !$ call psb_errpush(info,name)
|
||||
! !$ call psb_error(ictxt)
|
||||
! !$ endif
|
||||
! !$ endif
|
||||
|
||||
end subroutine psb_init_mpik
|
||||
|
||||
subroutine psb_exit_mpik(ictxt,close)
|
||||
use psi_comm_buffers_mod
|
||||
! !$ use psb_rsb_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(inout) :: ictxt
|
||||
logical, intent(in), optional :: close
|
||||
logical :: close_
|
||||
integer(psb_mpk_) :: info
|
||||
character(len=20), parameter :: name='psb_exit'
|
||||
|
||||
info = 0
|
||||
if (present(close)) then
|
||||
close_ = close
|
||||
else
|
||||
close_ = .true.
|
||||
end if
|
||||
! !$ if (close_) call psb_rsb_exit(info)
|
||||
! !$ if (info.ne.psb_rsb_const_success) then
|
||||
! !$ if (info.eq.psb_rsb_const_not_available) then
|
||||
! !$ info=psb_success_ ! rsb is not present
|
||||
! !$ else
|
||||
! !$ info=psb_err_internal_error_ ! rsb failed to exit, and we issue an internal error. or shall we tolerate this ?
|
||||
! !$ call psb_errpush(info,name)
|
||||
! !$ call psb_error(ictxt)
|
||||
! !$ endif
|
||||
! !$ endif
|
||||
#if defined(SERIAL_MPI)
|
||||
! Under serial mode, CLOSE has no effect, but reclaim
|
||||
! the used ICTXT number.
|
||||
nctxt = max(0, nctxt - 1)
|
||||
#else
|
||||
if (close_) then
|
||||
call psb_close_all_context(psb_mesg_queue)
|
||||
else
|
||||
call psb_close_context(psb_mesg_queue,ictxt)
|
||||
end if
|
||||
if ((ictxt /= mpi_comm_null).and.(ictxt /= mpi_comm_world)) then
|
||||
call mpi_comm_Free(ictxt,info)
|
||||
end if
|
||||
|
||||
if (close_) call mpi_finalize(info)
|
||||
#endif
|
||||
|
||||
|
||||
end subroutine psb_exit_mpik
|
||||
|
||||
|
||||
subroutine psb_barrier_mpik(ictxt)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
|
||||
integer(psb_mpk_) :: info
|
||||
#if !defined(SERIAL_MPI)
|
||||
if (ictxt /= mpi_comm_null) then
|
||||
call mpi_barrier(ictxt, info)
|
||||
end if
|
||||
#endif
|
||||
|
||||
end subroutine psb_barrier_mpik
|
||||
|
||||
function psb_wtime()
|
||||
use psb_const_mod
|
||||
! use mpi_constants
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
real(psb_dpk_) :: psb_wtime
|
||||
|
||||
psb_wtime = mpi_wtime()
|
||||
end function psb_wtime
|
||||
|
||||
subroutine psb_abort_mpik(ictxt,errc)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(in), optional :: errc
|
||||
|
||||
integer(psb_mpk_) :: code, info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
stop
|
||||
#else
|
||||
if (present(errc)) then
|
||||
code = errc
|
||||
else
|
||||
code = -1
|
||||
endif
|
||||
|
||||
call mpi_abort(ictxt,code,info)
|
||||
#endif
|
||||
|
||||
end subroutine psb_abort_mpik
|
||||
|
||||
|
||||
subroutine psb_info_mpik(ictxt,iam,np)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
integer(psb_mpk_), intent(out) :: iam, np
|
||||
integer(psb_mpk_) :: info
|
||||
!
|
||||
! Simple caching scheme, keep track
|
||||
! of the last CTXT encountered.
|
||||
!
|
||||
integer(psb_mpk_), save :: lctxt=-1, lam, lnp
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
iam = 0
|
||||
np = 1
|
||||
#else
|
||||
iam = -1
|
||||
np = -1
|
||||
if (ictxt == lctxt) then
|
||||
iam = lam
|
||||
np = lnp
|
||||
else
|
||||
if (ictxt /= mpi_comm_null) then
|
||||
call mpi_comm_size(ictxt,np,info)
|
||||
if (info /= mpi_success) np = -1
|
||||
call mpi_comm_rank(ictxt,iam,info)
|
||||
if (info /= mpi_success) iam = -1
|
||||
end if
|
||||
lctxt = ictxt
|
||||
lam = iam
|
||||
lnp = np
|
||||
end if
|
||||
#endif
|
||||
|
||||
end subroutine psb_info_mpik
|
||||
|
||||
|
||||
subroutine psb_get_mpicomm(ictxt,comm)
|
||||
integer(psb_mpk_) :: ictxt, comm
|
||||
|
||||
comm = ictxt
|
||||
end subroutine psb_get_mpicomm
|
||||
|
||||
subroutine psb_get_rank(rank,ictxt,id)
|
||||
integer(psb_mpk_) :: rank,ictxt,id
|
||||
|
||||
rank = id
|
||||
end subroutine psb_get_rank
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Base binary operations
|
||||
!
|
||||
! Note: len & type are always default integer.
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
subroutine psi_mamx_op(inv, outv,len,type)
|
||||
integer(psb_mpk_) :: inv(*),outv(*)
|
||||
integer(psb_mpk_) :: len,type
|
||||
integer(psb_mpk_) :: i
|
||||
|
||||
do i=1, len
|
||||
if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_mamx_op
|
||||
|
||||
subroutine psi_mamn_op(inv, outv,len,type)
|
||||
integer(psb_mpk_) :: inv(*),outv(*)
|
||||
integer(psb_mpk_) :: len,type
|
||||
integer(psb_mpk_) :: i
|
||||
|
||||
do i=1, len
|
||||
if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_mamn_op
|
||||
|
||||
subroutine psi_eamx_op(inv, outv,len,type)
|
||||
integer(psb_epk_) :: inv(*),outv(*)
|
||||
integer(psb_mpk_) :: len,type
|
||||
integer(psb_mpk_) :: i
|
||||
|
||||
do i=1, len
|
||||
if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_eamx_op
|
||||
|
||||
subroutine psi_eamn_op(inv, outv,len,type)
|
||||
integer(psb_epk_) :: inv(*),outv(*)
|
||||
integer(psb_mpk_) :: len,type
|
||||
integer(psb_mpk_) :: i
|
||||
|
||||
do i=1, len
|
||||
if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_eamn_op
|
||||
|
||||
subroutine psi_samx_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
real(psb_spk_), intent(in) :: vin(len)
|
||||
real(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_samx_op
|
||||
|
||||
subroutine psi_samn_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
real(psb_spk_), intent(in) :: vin(len)
|
||||
real(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_samn_op
|
||||
|
||||
subroutine psi_damx_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
real(psb_dpk_), intent(in) :: vin(len)
|
||||
real(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_damx_op
|
||||
|
||||
subroutine psi_damn_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
real(psb_dpk_), intent(in) :: vin(len)
|
||||
real(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_damn_op
|
||||
|
||||
subroutine psi_camx_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
complex(psb_spk_), intent(in) :: vin(len)
|
||||
complex(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_camx_op
|
||||
|
||||
subroutine psi_camn_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
complex(psb_spk_), intent(in) :: vin(len)
|
||||
complex(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_camn_op
|
||||
|
||||
subroutine psi_zamx_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
complex(psb_dpk_), intent(in) :: vin(len)
|
||||
complex(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_zamx_op
|
||||
|
||||
subroutine psi_zamn_op(vin,vinout,len,itype)
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
complex(psb_dpk_), intent(in) :: vin(len)
|
||||
complex(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
do i=1, len
|
||||
if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i)
|
||||
end do
|
||||
end subroutine psi_zamn_op
|
||||
|
||||
subroutine psi_snrm2_op(vin,vinout,len,itype)
|
||||
implicit none
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
real(psb_spk_), intent(in) :: vin(len)
|
||||
real(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
real(psb_spk_) :: w, z
|
||||
do i=1, len
|
||||
w = max( vin(i), vinout(i) )
|
||||
z = min( vin(i), vinout(i) )
|
||||
if ( z == szero ) then
|
||||
vinout(i) = w
|
||||
else
|
||||
vinout(i) = w*sqrt( sone+( z / w )**2 )
|
||||
end if
|
||||
end do
|
||||
end subroutine psi_snrm2_op
|
||||
|
||||
subroutine psi_dnrm2_op(vin,vinout,len,itype)
|
||||
implicit none
|
||||
integer(psb_mpk_), intent(in) :: len, itype
|
||||
real(psb_dpk_), intent(in) :: vin(len)
|
||||
real(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer(psb_mpk_) :: i
|
||||
real(psb_dpk_) :: w, z
|
||||
do i=1, len
|
||||
w = max( vin(i), vinout(i) )
|
||||
z = min( vin(i), vinout(i) )
|
||||
if ( z == dzero ) then
|
||||
vinout(i) = w
|
||||
else
|
||||
vinout(i) = w*sqrt( done+( z / w )**2 )
|
||||
end if
|
||||
end do
|
||||
end subroutine psi_dnrm2_op
|
||||
|
||||
end module psi_penv_mod
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,307 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
module psi_s_p2p_mod
|
||||
use psi_penv_mod
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
interface psb_snd
|
||||
module procedure psb_ssnds, psb_ssndv, psb_ssndm, &
|
||||
& psb_ssnds_ec, psb_ssndv_ec, psb_ssndm_ec
|
||||
end interface
|
||||
|
||||
interface psb_rcv
|
||||
module procedure psb_srcvs, psb_srcvv, psb_srcvm, &
|
||||
& psb_srcvs_ec, psb_srcvv_ec, psb_srcvm_ec
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_ssnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
allocate(dat_(1), stat=info)
|
||||
dat_(1) = dat
|
||||
call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_ssnds
|
||||
|
||||
subroutine psb_ssndv(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(in) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
allocate(dat_(size(dat)), stat=info)
|
||||
dat_(:) = dat(:)
|
||||
call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_ssndv
|
||||
|
||||
subroutine psb_ssndm(ictxt,dat,dst,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(in) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_ipk_) :: i,j,k,m_,n_
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
else
|
||||
m_ = size(dat,1)
|
||||
end if
|
||||
n_ = size(dat,2)
|
||||
allocate(dat_(m_*n_), stat=info)
|
||||
k=1
|
||||
do j=1,n_
|
||||
do i=1, m_
|
||||
dat_(k) = dat(i,j)
|
||||
k = k + 1
|
||||
end do
|
||||
end do
|
||||
call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_ssndm
|
||||
|
||||
subroutine psb_srcvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
call mpi_recv(dat,1,psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_srcvs
|
||||
|
||||
subroutine psb_srcvv(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(out) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_srcvv
|
||||
|
||||
subroutine psb_srcvm(ictxt,dat,src,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(out) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
real(psb_spk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
|
||||
integer(psb_mpk_) :: i,j,k
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! What should we do here??
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
ld = size(dat,1)
|
||||
n_ = size(dat,2)
|
||||
call mpi_type_vector(n_,m_,ld,psb_mpi_r_spk_,mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
|
||||
& psb_real_tag,ictxt,status,info)
|
||||
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
|
||||
else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info)
|
||||
end if
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in psb_recv', info
|
||||
end if
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_srcvm
|
||||
|
||||
|
||||
subroutine psb_ssnds_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_ssnds_ec
|
||||
|
||||
subroutine psb_ssndv_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(in) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_ssndv_ec
|
||||
|
||||
subroutine psb_ssndm_ec(ictxt,dat,dst,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(in) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_ssndm_ec
|
||||
|
||||
subroutine psb_srcvs_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_srcvs_ec
|
||||
|
||||
subroutine psb_srcvv_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(out) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_srcvv_ec
|
||||
|
||||
subroutine psb_srcvm_ec(ictxt,dat,src,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
real(psb_spk_), intent(out) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_srcvm_ec
|
||||
|
||||
|
||||
end module psi_s_p2p_mod
|
||||
@@ -0,0 +1,744 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
module psi_z_collective_mod
|
||||
use psi_penv_mod
|
||||
|
||||
|
||||
interface psb_sum
|
||||
module procedure psb_zsums, psb_zsumv, psb_zsumm, &
|
||||
& psb_zsums_ec, psb_zsumv_ec, psb_zsumm_ec
|
||||
end interface
|
||||
|
||||
interface psb_amx
|
||||
module procedure psb_zamxs, psb_zamxv, psb_zamxm, &
|
||||
& psb_zamxs_ec, psb_zamxv_ec, psb_zamxm_ec
|
||||
end interface
|
||||
|
||||
interface psb_amn
|
||||
module procedure psb_zamns, psb_zamnv, psb_zamnm, &
|
||||
& psb_zamns_ec, psb_zamnv_ec, psb_zamnm_ec
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_bcast
|
||||
module procedure psb_zbcasts, psb_zbcastv, psb_zbcastm, &
|
||||
& psb_zbcasts_ec, psb_zbcastv_ec, psb_zbcastm_ec
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Reduction operations
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
|
||||
!
|
||||
! SUM
|
||||
!
|
||||
|
||||
subroutine psb_zsums(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_) :: dat_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,ictxt,info)
|
||||
dat = dat_
|
||||
else
|
||||
call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info)
|
||||
if (iam == root_) dat = dat_
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zsums
|
||||
|
||||
subroutine psb_zsumv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_) &
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zsumv
|
||||
|
||||
subroutine psb_zsumm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_), allocatable :: dat_(:,:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_)&
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zsumm
|
||||
|
||||
subroutine psb_zsums_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zsums_ec
|
||||
|
||||
subroutine psb_zsumv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zsumv_ec
|
||||
|
||||
subroutine psb_zsumm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_sum(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_sum(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zsumm_ec
|
||||
|
||||
|
||||
!
|
||||
! AMX: Maximum Absolute Value
|
||||
!
|
||||
|
||||
subroutine psb_zamxs(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_) :: dat_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info)
|
||||
dat = dat_
|
||||
else
|
||||
call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info)
|
||||
if (iam == root_) dat = dat_
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zamxs
|
||||
|
||||
subroutine psb_zamxv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_) &
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zamxv
|
||||
|
||||
subroutine psb_zamxm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_), allocatable :: dat_(:,:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_)&
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zamxm
|
||||
|
||||
|
||||
subroutine psb_zamxs_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amx(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amx(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zamxs_ec
|
||||
|
||||
subroutine psb_zamxv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amx(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amx(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zamxv_ec
|
||||
|
||||
subroutine psb_zamxm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amx(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amx(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zamxm_ec
|
||||
|
||||
|
||||
!
|
||||
! AMN: Minimum Absolute Value
|
||||
!
|
||||
|
||||
subroutine psb_zamns(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_) :: dat_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info)
|
||||
dat = dat_
|
||||
else
|
||||
call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info)
|
||||
if (iam == root_) dat = dat_
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zamns
|
||||
|
||||
subroutine psb_zamnv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_) &
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zamnv
|
||||
|
||||
subroutine psb_zamnm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
complex(psb_dpk_), allocatable :: dat_(:,:)
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = -1
|
||||
endif
|
||||
if (root_ == -1) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
if (iinfo == psb_success_)&
|
||||
& call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info)
|
||||
else
|
||||
if (iam == root_) then
|
||||
call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo)
|
||||
dat_ = dat
|
||||
call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info)
|
||||
else
|
||||
call psb_realloc(1,1,dat_,iinfo)
|
||||
call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info)
|
||||
end if
|
||||
endif
|
||||
#endif
|
||||
end subroutine psb_zamnm
|
||||
|
||||
|
||||
subroutine psb_zamns_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amn(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amn(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zamns_ec
|
||||
|
||||
subroutine psb_zamnv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amn(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amn(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zamnv_ec
|
||||
|
||||
subroutine psb_zamnm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_amn(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_amn(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zamnm_ec
|
||||
|
||||
|
||||
!
|
||||
! BCAST Broadcast
|
||||
!
|
||||
|
||||
subroutine psb_zbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
call mpi_bcast(dat,1,psb_mpi_c_dpk_,root_,ictxt,info)
|
||||
|
||||
#endif
|
||||
end subroutine psb_zbcasts
|
||||
|
||||
subroutine psb_zbcastv(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
|
||||
call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_zbcastv
|
||||
|
||||
subroutine psb_zbcastm(ictxt,dat,root)
|
||||
use psb_realloc_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: root_
|
||||
|
||||
integer(psb_mpk_) :: iam, np, info
|
||||
integer(psb_ipk_) :: iinfo
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
call psb_info(ictxt,iam,np)
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
endif
|
||||
|
||||
call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_zbcastm
|
||||
|
||||
|
||||
subroutine psb_zbcasts_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zbcasts_ec
|
||||
|
||||
subroutine psb_zbcastv_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zbcastv_ec
|
||||
|
||||
subroutine psb_zbcastm_ec(ictxt,dat,root)
|
||||
implicit none
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in), optional :: root
|
||||
integer(psb_mpk_) :: ictxt_, root_
|
||||
|
||||
ictxt_ = ictxt
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
call psb_bcast(ictxt_,dat,root_)
|
||||
else
|
||||
call psb_bcast(ictxt_,dat)
|
||||
end if
|
||||
end subroutine psb_zbcastm_ec
|
||||
|
||||
|
||||
|
||||
end module psi_z_collective_mod
|
||||
@@ -0,0 +1,307 @@
|
||||
!
|
||||
! Parallel Sparse BLAS version 3.5
|
||||
! (C) Copyright 2006-2018
|
||||
! Salvatore Filippone
|
||||
! Alfredo Buttari
|
||||
!
|
||||
! 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.
|
||||
!
|
||||
!
|
||||
|
||||
module psi_z_p2p_mod
|
||||
use psi_penv_mod
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
interface psb_snd
|
||||
module procedure psb_zsnds, psb_zsndv, psb_zsndm, &
|
||||
& psb_zsnds_ec, psb_zsndv_ec, psb_zsndm_ec
|
||||
end interface
|
||||
|
||||
interface psb_rcv
|
||||
module procedure psb_zrcvs, psb_zrcvv, psb_zrcvm, &
|
||||
& psb_zrcvs_ec, psb_zrcvv_ec, psb_zrcvm_ec
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_zsnds(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(in) :: dat
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
allocate(dat_(1), stat=info)
|
||||
dat_(1) = dat
|
||||
call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_zsnds
|
||||
|
||||
subroutine psb_zsndv(ictxt,dat,dst)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(in) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
allocate(dat_(size(dat)), stat=info)
|
||||
dat_(:) = dat(:)
|
||||
call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_zsndv
|
||||
|
||||
subroutine psb_zsndm(ictxt,dat,dst,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(in) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: dst
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_ipk_) :: i,j,k,m_,n_
|
||||
integer(psb_mpk_) :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
else
|
||||
m_ = size(dat,1)
|
||||
end if
|
||||
n_ = size(dat,2)
|
||||
allocate(dat_(m_*n_), stat=info)
|
||||
k=1
|
||||
do j=1,n_
|
||||
do i=1, m_
|
||||
dat_(k) = dat(i,j)
|
||||
k = k + 1
|
||||
end do
|
||||
end do
|
||||
call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_zsndm
|
||||
|
||||
subroutine psb_zrcvs(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(out) :: dat
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! do nothing
|
||||
#else
|
||||
call mpi_recv(dat,1,psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_zrcvs
|
||||
|
||||
subroutine psb_zrcvv(ictxt,dat,src)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(out) :: dat(:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
#else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info)
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
|
||||
end subroutine psb_zrcvv
|
||||
|
||||
subroutine psb_zrcvm(ictxt,dat,src,m)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer(psb_mpk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(out) :: dat(:,:)
|
||||
integer(psb_mpk_), intent(in) :: src
|
||||
integer(psb_ipk_), intent(in), optional :: m
|
||||
complex(psb_dpk_), allocatable :: dat_(:)
|
||||
integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type
|
||||
integer(psb_mpk_) :: i,j,k
|
||||
integer(psb_mpk_) :: status(mpi_status_size)
|
||||
#if defined(SERIAL_MPI)
|
||||
! What should we do here??
|
||||
#else
|
||||
if (present(m)) then
|
||||
m_ = m
|
||||
ld = size(dat,1)
|
||||
n_ = size(dat,2)
|
||||
call mpi_type_vector(n_,m_,ld,psb_mpi_c_dpk_,mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info)
|
||||
if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,&
|
||||
& psb_dcomplex_tag,ictxt,status,info)
|
||||
if (info == mpi_success) call mpi_type_free(mp_rcv_type,info)
|
||||
else
|
||||
call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info)
|
||||
end if
|
||||
if (info /= mpi_success) then
|
||||
write(psb_err_unit,*) 'Error in psb_recv', info
|
||||
end if
|
||||
call psb_test_nodes(psb_mesg_queue)
|
||||
#endif
|
||||
end subroutine psb_zrcvm
|
||||
|
||||
|
||||
subroutine psb_zsnds_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(in) :: dat
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_zsnds_ec
|
||||
|
||||
subroutine psb_zsndv_ec(ictxt,dat,dst)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(in) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_zsndv_ec
|
||||
|
||||
subroutine psb_zsndm_ec(ictxt,dat,dst,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(in) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: dst
|
||||
|
||||
integer(psb_mpk_) :: iictxt, idst
|
||||
|
||||
iictxt = ictxt
|
||||
idst = dst
|
||||
call psb_snd(iictxt, dat, idst)
|
||||
|
||||
end subroutine psb_zsndm_ec
|
||||
|
||||
subroutine psb_zrcvs_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(out) :: dat
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_zrcvs_ec
|
||||
|
||||
subroutine psb_zrcvv_ec(ictxt,dat,src)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(out) :: dat(:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_zrcvv_ec
|
||||
|
||||
subroutine psb_zrcvm_ec(ictxt,dat,src,m)
|
||||
|
||||
integer(psb_epk_), intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(out) :: dat(:,:)
|
||||
integer(psb_epk_), intent(in) :: src
|
||||
|
||||
integer(psb_mpk_) :: iictxt, isrc
|
||||
|
||||
iictxt = ictxt
|
||||
isrc = src
|
||||
call psb_rcv(iictxt, dat, isrc)
|
||||
|
||||
end subroutine psb_zrcvm_ec
|
||||
|
||||
|
||||
end module psi_z_p2p_mod
|
||||
Reference in New Issue
Block a user