Salvatore Filippone
15 years ago
parent
7530cafc83
commit
a614197538
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,103 @@
|
||||
! checks wether an error has occurred on one of the porecesses in the execution pool
|
||||
subroutine psb_errcomm(ictxt, err)
|
||||
use psb_error_mod, psb_protect_name => psb_errcomm
|
||||
use psb_penv_mod
|
||||
integer, intent(in) :: ictxt
|
||||
integer, intent(inout):: err
|
||||
integer :: temp(2)
|
||||
! Cannot use psb_amx or otherwise we have a recursion in module usage
|
||||
#if !defined(SERIAL_MPI)
|
||||
call psb_amx(ictxt, err)
|
||||
#endif
|
||||
end subroutine psb_errcomm
|
||||
! handles the occurence of an error in a serial routine
|
||||
subroutine psb_serror()
|
||||
use psb_error_mod!, psb_protect_name => psb_serror
|
||||
|
||||
integer :: err_c
|
||||
character(len=20) :: r_name
|
||||
character(len=40) :: a_e_d
|
||||
integer :: i_e_d(5)
|
||||
|
||||
if(error_status > 0) then
|
||||
if(verbosity_level > 1) then
|
||||
|
||||
do while (psb_get_numerr() > izero)
|
||||
write(0,'(50("="))')
|
||||
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
|
||||
call psb_errmsg(err_c, r_name, i_e_d, a_e_d)
|
||||
! write(0,'(50("="))')
|
||||
end do
|
||||
|
||||
else
|
||||
|
||||
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
|
||||
call psb_errmsg(err_c, r_name, i_e_d, a_e_d)
|
||||
do while (psb_get_numerr() > 0)
|
||||
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
|
||||
end subroutine psb_serror
|
||||
|
||||
|
||||
! handles the occurence of an error in a parallel routine
|
||||
subroutine psb_perror(ictxt)
|
||||
use psb_error_mod!, psb_protect_name => psb_perror
|
||||
use psb_penv_mod
|
||||
|
||||
integer, intent(in) :: ictxt
|
||||
integer :: err_c
|
||||
character(len=20) :: r_name
|
||||
character(len=40) :: a_e_d
|
||||
integer :: i_e_d(5)
|
||||
integer :: iam, np
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
me = -1
|
||||
#else
|
||||
call psb_info(ictxt,iam,np)
|
||||
#endif
|
||||
|
||||
|
||||
if(error_status > 0) then
|
||||
if(verbosity_level > 1) then
|
||||
|
||||
do while (psb_get_numerr() > izero)
|
||||
write(0,'(50("="))')
|
||||
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
|
||||
call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me)
|
||||
! write(0,'(50("="))')
|
||||
end do
|
||||
#if defined(SERIAL_MPI)
|
||||
stop
|
||||
#else
|
||||
call psb_abort(ictxt,-1)
|
||||
#endif
|
||||
else
|
||||
|
||||
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
|
||||
call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me)
|
||||
do while (psb_get_numerr() > 0)
|
||||
call psb_errpop(err_c, r_name, i_e_d, a_e_d)
|
||||
end do
|
||||
#if defined(SERIAL_MPI)
|
||||
stop
|
||||
#else
|
||||
call psb_abort(ictxt,-1)
|
||||
#endif
|
||||
end if
|
||||
end if
|
||||
|
||||
if(error_status > izero) then
|
||||
#if defined(SERIAL_MPI)
|
||||
stop
|
||||
#else
|
||||
call psb_abort(ictxt,err_c)
|
||||
#endif
|
||||
end if
|
||||
|
||||
|
||||
end subroutine psb_perror
|
||||
|
||||
@ -0,0 +1,538 @@
|
||||
|
||||
|
||||
module psi_bcast_mod
|
||||
use psb_const_mod
|
||||
use psi_penv_mod
|
||||
interface psb_bcast
|
||||
module procedure psb_ibcasts, psb_ibcastv, psb_ibcastm,&
|
||||
& psb_dbcasts, psb_dbcastv, psb_dbcastm,&
|
||||
& psb_zbcasts, psb_zbcastv, psb_zbcastm,&
|
||||
& psb_sbcasts, psb_sbcastv, psb_sbcastm,&
|
||||
& psb_cbcasts, psb_cbcastv, psb_cbcastm,&
|
||||
& psb_hbcasts, psb_hbcastv, psb_lbcasts, psb_lbcastv
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Broadcasts
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
||||
subroutine psb_ibcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
integer, intent(inout) :: dat
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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,psb_mpi_integer,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_ibcasts
|
||||
|
||||
subroutine psb_ibcastv(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
integer, intent(inout) :: dat(:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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),psb_mpi_integer,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_ibcastv
|
||||
|
||||
subroutine psb_ibcastm(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
integer, intent(inout) :: dat(:,:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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),psb_mpi_integer,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_ibcastm
|
||||
|
||||
|
||||
subroutine psb_sbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
real(psb_spk_), intent(inout) :: dat
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_real,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_sbcasts
|
||||
|
||||
|
||||
subroutine psb_sbcastv(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
real(psb_spk_), intent(inout) :: dat(:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_real,root_,ictxt,info)
|
||||
|
||||
#endif
|
||||
end subroutine psb_sbcastv
|
||||
|
||||
subroutine psb_sbcastm(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
real(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_real,root_,ictxt,info)
|
||||
|
||||
#endif
|
||||
end subroutine psb_sbcastm
|
||||
|
||||
|
||||
subroutine psb_dbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(inout) :: dat
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_double_precision,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_dbcasts
|
||||
|
||||
|
||||
subroutine psb_dbcastv(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_double_precision,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_dbcastv
|
||||
|
||||
subroutine psb_dbcastm(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
real(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_double_precision,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_dbcastm
|
||||
|
||||
subroutine psb_cbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_complex,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_cbcasts
|
||||
|
||||
subroutine psb_cbcastv(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_complex,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_cbcastv
|
||||
|
||||
subroutine psb_cbcastm(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
complex(psb_spk_), intent(inout) :: dat(:,:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_complex,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_cbcastm
|
||||
|
||||
subroutine psb_zbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_double_complex,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_zbcasts
|
||||
|
||||
subroutine psb_zbcastv(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_double_complex,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_zbcastv
|
||||
|
||||
subroutine psb_zbcastm(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
complex(psb_dpk_), intent(inout) :: dat(:,:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_double_complex,root_,ictxt,info)
|
||||
#endif
|
||||
end subroutine psb_zbcastm
|
||||
|
||||
|
||||
subroutine psb_hbcasts(ictxt,dat,root,length)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
character(len=*), intent(inout) :: dat
|
||||
integer, intent(in), optional :: root,length
|
||||
|
||||
integer :: 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, intent(in) :: ictxt
|
||||
character(len=*), intent(inout) :: dat(:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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_lbcasts(ictxt,dat,root)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
logical, intent(inout) :: dat
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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, intent(in) :: ictxt
|
||||
logical, intent(inout) :: dat(:)
|
||||
integer, intent(in), optional :: root
|
||||
|
||||
integer :: 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
|
||||
|
||||
end module psi_bcast_mod
|
||||
@ -0,0 +1,478 @@
|
||||
module psi_comm_buffers_mod
|
||||
use psb_const_mod
|
||||
|
||||
integer, private, parameter:: psb_int_type = 987543
|
||||
integer, private, parameter:: psb_real_type = psb_int_type + 1
|
||||
integer, private, parameter:: psb_double_type = psb_real_type + 1
|
||||
integer, private, parameter:: psb_complex_type = psb_double_type + 1
|
||||
integer, private, parameter:: psb_dcomplex_type = psb_complex_type + 1
|
||||
integer, private, parameter:: psb_logical_type = psb_dcomplex_type + 1
|
||||
integer, private, parameter:: psb_char_type = psb_logical_type + 1
|
||||
integer, private, parameter:: psb_int8_type = psb_char_type + 1
|
||||
|
||||
|
||||
type psb_buffer_node
|
||||
integer :: request
|
||||
integer :: icontxt
|
||||
integer :: buffer_type
|
||||
integer(psb_int_k_), allocatable :: intbuf(:)
|
||||
integer(psb_long_int_k_), allocatable :: int8buf(:)
|
||||
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_isnd,&
|
||||
& psi_ssnd, psi_dsnd,&
|
||||
& psi_csnd, psi_zsnd,&
|
||||
& psi_lsnd, psi_hsnd
|
||||
end interface
|
||||
#if !defined(LONG_INTEGERS)
|
||||
interface psi_snd
|
||||
module procedure psi_i8snd
|
||||
end interface
|
||||
#endif
|
||||
|
||||
contains
|
||||
|
||||
subroutine psb_init_queue(mesg_queue,info)
|
||||
type(psb_buffer_queue), intent(inout) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: item
|
||||
|
||||
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(0,*) '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, intent(out) :: info
|
||||
integer :: status(mpi_status_size)
|
||||
|
||||
call mpi_wait(node%request,status,info)
|
||||
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, intent(out) :: info
|
||||
integer :: status(mpi_status_size)
|
||||
|
||||
call mpi_test(node%request,flag,status,info)
|
||||
end subroutine psb_test_buffer
|
||||
|
||||
|
||||
subroutine psb_close_context(mesg_queue,icontxt)
|
||||
type(psb_buffer_queue), intent(inout) :: mesg_queue
|
||||
integer, intent(in) :: icontxt
|
||||
integer :: 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 :: 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 :: 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_isnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer :: icontxt, tag, dest
|
||||
integer(psb_int_k_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
node%icontxt = icontxt
|
||||
node%buffer_type = psb_int_type
|
||||
call move_alloc(buffer,node%intbuf)
|
||||
if (info /= 0) then
|
||||
write(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%intbuf,size(node%intbuf),psb_mpi_integer,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_isnd
|
||||
|
||||
#if !defined(LONG_INTEGERS)
|
||||
subroutine psi_i8snd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer :: icontxt, tag, dest
|
||||
integer(psb_long_int_k_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) '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(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%int8buf,size(node%int8buf),mpi_integer8,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_i8snd
|
||||
#endif
|
||||
|
||||
|
||||
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 :: icontxt, tag, dest
|
||||
real(psb_spk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) '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(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%realbuf,size(node%realbuf),mpi_real,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
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 :: icontxt, tag, dest
|
||||
real(psb_dpk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) '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(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%doublebuf,size(node%doublebuf),mpi_double_precision,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
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 :: icontxt, tag, dest
|
||||
complex(psb_spk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) '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(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%complexbuf,size(node%complexbuf),mpi_complex,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
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 :: icontxt, tag, dest
|
||||
complex(psb_dpk_), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) '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(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%dcomplbuf,size(node%dcomplbuf),mpi_double_complex,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_zsnd
|
||||
|
||||
|
||||
subroutine psi_lsnd(icontxt,tag,dest,buffer,mesg_queue)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer :: icontxt, tag, dest
|
||||
logical, allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) '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(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%logbuf,size(node%logbuf),mpi_logical,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
call psb_insert_node(mesg_queue,node)
|
||||
|
||||
call psb_test_nodes(mesg_queue)
|
||||
|
||||
end subroutine psi_lsnd
|
||||
|
||||
|
||||
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 :: icontxt, tag, dest
|
||||
character(len=1), allocatable, intent(inout) :: buffer(:)
|
||||
type(psb_buffer_queue) :: mesg_queue
|
||||
type(psb_buffer_node), pointer :: node
|
||||
integer :: info
|
||||
|
||||
allocate(node, stat=info)
|
||||
if (info /= 0) then
|
||||
write(0,*) '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(0,*) 'Fatal memory error inside communication subsystem'
|
||||
return
|
||||
end if
|
||||
call mpi_isend(node%charbuf,size(node%charbuf),mpi_character,&
|
||||
& dest,tag,icontxt,node%request,info)
|
||||
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,572 @@
|
||||
module psi_penv_mod
|
||||
use psb_const_mod
|
||||
use psi_comm_buffers_mod, only : psb_buffer_queue
|
||||
|
||||
interface psb_init
|
||||
module procedure psb_init
|
||||
end interface
|
||||
|
||||
interface psb_exit
|
||||
module procedure psb_exit
|
||||
end interface
|
||||
|
||||
interface psb_abort
|
||||
module procedure psb_abort
|
||||
end interface
|
||||
|
||||
interface psb_info
|
||||
module procedure psb_info
|
||||
end interface
|
||||
|
||||
interface psb_barrier
|
||||
module procedure psb_barrier
|
||||
end interface
|
||||
|
||||
interface psb_wtime
|
||||
module procedure psb_wtime
|
||||
end interface
|
||||
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
integer, private, save :: nctxt=0
|
||||
|
||||
#else
|
||||
|
||||
integer, save :: mpi_iamx_op, mpi_iamn_op
|
||||
integer, save :: mpi_i8amx_op, mpi_i8amn_op
|
||||
integer, save :: mpi_samx_op, mpi_samn_op
|
||||
integer, save :: mpi_damx_op, mpi_damn_op
|
||||
integer, save :: mpi_camx_op, mpi_camn_op
|
||||
integer, save :: mpi_zamx_op, mpi_zamn_op
|
||||
integer, 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_i8amx_op, psi_i8amn_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 :: iv(2)
|
||||
integer(psb_long_int_k_) :: ilv(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(iv(1),iv(2),psb_sizeof_int)
|
||||
call psi_c_diffadd(ilv(1),ilv(2),psb_sizeof_long_int)
|
||||
|
||||
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 info
|
||||
info = 0
|
||||
|
||||
#if defined(LONG_INTEGERS)
|
||||
psb_mpi_integer = mpi_integer8
|
||||
#else
|
||||
psb_mpi_integer = mpi_integer
|
||||
#endif
|
||||
|
||||
if (info == 0) call mpi_op_create(psi_iamx_op,.true.,mpi_iamx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_iamn_op,.true.,mpi_iamn_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_i8amx_op,.true.,mpi_i8amx_op,info)
|
||||
if (info == 0) call mpi_op_create(psi_i8amn_op,.true.,mpi_i8amn_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)
|
||||
|
||||
end subroutine psi_register_mpi_extras
|
||||
|
||||
|
||||
subroutine psb_init(ictxt,np,basectxt,ids)
|
||||
use psi_comm_buffers_mod
|
||||
use psb_const_mod
|
||||
use psb_error_mod
|
||||
! !$ use psb_rsb_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(out) :: ictxt
|
||||
integer, intent(in), optional :: np, basectxt, ids(:)
|
||||
|
||||
|
||||
integer :: i, isnullcomm
|
||||
integer, allocatable :: iids(:)
|
||||
logical :: initialized
|
||||
integer :: np_, npavail, iam, info, basecomm, basegroup, newgroup
|
||||
character(len=20), parameter :: name='psb_init'
|
||||
#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
|
||||
call mpi_init(info)
|
||||
if (info /= mpi_success) then
|
||||
write(0,*) '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
|
||||
info=psb_err_initerror_neugh_procs_
|
||||
call psb_errpush(info,name)
|
||||
call psb_error()
|
||||
ictxt = mpi_comm_null
|
||||
return
|
||||
endif
|
||||
call mpi_comm_size(basecomm,np_,info)
|
||||
if (np_ < np) then
|
||||
info=psb_err_initerror_neugh_procs_
|
||||
call psb_errpush(info,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(0,*) '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(0,*) 'Error in init: invalid ransk 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_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
|
||||
|
||||
subroutine psb_exit(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, intent(in) :: ictxt
|
||||
logical, intent(in), optional :: close
|
||||
logical :: close_
|
||||
integer :: 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)
|
||||
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
|
||||
|
||||
|
||||
subroutine psb_barrier(ictxt)
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
integer, intent(in) :: ictxt
|
||||
|
||||
integer :: info
|
||||
#if !defined(SERIAL_MPI)
|
||||
if (ictxt /= mpi_comm_null) then
|
||||
call mpi_barrier(ictxt, info)
|
||||
end if
|
||||
#endif
|
||||
|
||||
end subroutine psb_barrier
|
||||
|
||||
function psb_wtime()
|
||||
use psb_const_mod
|
||||
#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(ictxt,errc)
|
||||
use psi_comm_buffers_mod
|
||||
|
||||
integer, intent(in) :: ictxt
|
||||
integer, intent(in), optional :: errc
|
||||
|
||||
integer :: code, info
|
||||
|
||||
if (present(errc)) then
|
||||
code = errc
|
||||
else
|
||||
core = -1
|
||||
endif
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
stop code
|
||||
#else
|
||||
call mpi_abort(ictxt,code,info)
|
||||
#endif
|
||||
|
||||
end subroutine psb_abort
|
||||
|
||||
|
||||
subroutine psb_info(ictxt,iam,np)
|
||||
use psi_comm_buffers_mod
|
||||
#ifdef MPI_MOD
|
||||
use mpi
|
||||
#endif
|
||||
implicit none
|
||||
#ifdef MPI_H
|
||||
include 'mpif.h'
|
||||
#endif
|
||||
|
||||
integer, intent(in) :: ictxt
|
||||
integer, intent(out) :: iam, np
|
||||
integer :: info
|
||||
|
||||
#if defined(SERIAL_MPI)
|
||||
iam = 0
|
||||
np = 1
|
||||
#else
|
||||
iam = -1
|
||||
np = -1
|
||||
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
|
||||
#endif
|
||||
|
||||
end subroutine psb_info
|
||||
|
||||
|
||||
|
||||
subroutine psb_set_coher(ictxt,isvch)
|
||||
integer :: ictxt, isvch
|
||||
! Ensure global repeatability for convergence checks.
|
||||
! Do nothing. Obsolete.
|
||||
end subroutine psb_set_coher
|
||||
|
||||
subroutine psb_restore_coher(ictxt,isvch)
|
||||
integer :: ictxt, isvch
|
||||
! Ensure global coherence for convergence checks.
|
||||
! Do nothing. Obsolete.
|
||||
|
||||
end subroutine psb_restore_coher
|
||||
|
||||
subroutine psb_get_mpicomm(ictxt,comm)
|
||||
integer :: ictxt, comm
|
||||
|
||||
comm = ictxt
|
||||
end subroutine psb_get_mpicomm
|
||||
|
||||
subroutine psb_get_rank(rank,ictxt,id)
|
||||
integer :: rank,ictxt,id
|
||||
|
||||
rank = id
|
||||
end subroutine psb_get_rank
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
!
|
||||
! Base binary operations
|
||||
!
|
||||
! !!!!!!!!!!!!!!!!!!!!!!
|
||||
subroutine psi_iamx_op(inv, outv,len,type)
|
||||
integer :: inv(*),outv(*)
|
||||
integer :: len,type
|
||||
integer :: i
|
||||
|
||||
do i=1, len
|
||||
if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_iamx_op
|
||||
|
||||
subroutine psi_iamn_op(inv, outv,len,type)
|
||||
integer :: inv(*),outv(*)
|
||||
integer :: len,type
|
||||
integer :: i
|
||||
do i=1, len
|
||||
if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_iamn_op
|
||||
|
||||
subroutine psi_i8amx_op(inv, outv,len,type)
|
||||
integer(psb_long_int_k_) :: inv(*),outv(*)
|
||||
integer :: len,type
|
||||
integer :: i
|
||||
|
||||
do i=1, len
|
||||
if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_i8amx_op
|
||||
|
||||
subroutine psi_i8amn_op(inv, outv,len,type)
|
||||
integer(psb_long_int_k_) :: inv(*),outv(*)
|
||||
integer :: len,type
|
||||
integer :: i
|
||||
if (type /= mpi_integer8) then
|
||||
write(0,*) 'Invalid type !!!'
|
||||
end if
|
||||
do i=1, len
|
||||
if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i)
|
||||
end do
|
||||
end subroutine psi_i8amn_op
|
||||
|
||||
subroutine psi_samx_op(vin,vinout,len,itype)
|
||||
integer, intent(in) :: len, itype
|
||||
real(psb_spk_), intent(in) :: vin(len)
|
||||
real(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
real(psb_spk_), intent(in) :: vin(len)
|
||||
real(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
real(psb_dpk_), intent(in) :: vin(len)
|
||||
real(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
real(psb_dpk_), intent(in) :: vin(len)
|
||||
real(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
complex(psb_spk_), intent(in) :: vin(len)
|
||||
complex(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
complex(psb_spk_), intent(in) :: vin(len)
|
||||
complex(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
complex(psb_dpk_), intent(in) :: vin(len)
|
||||
complex(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
complex(psb_dpk_), intent(in) :: vin(len)
|
||||
complex(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
real(psb_spk_), intent(in) :: vin(len)
|
||||
real(psb_spk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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, intent(in) :: len, itype
|
||||
real(psb_dpk_), intent(in) :: vin(len)
|
||||
real(psb_dpk_), intent(inout) :: vinout(len)
|
||||
|
||||
integer :: 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
Loading…
Reference in New Issue