fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Work around CMake bug: #if (defined)->#ifdef

Browse Source
pull/5/head
Damian Rouson 9 years ago
parent 5c72f3fad2
commit a1daf4e306
1 changed files with 90 additions and 90 deletions
Show Stats Download Patch File Download Diff File

180
base/modules/psi_comm_buffers_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
!
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006, 2010, 2015, 2017
! Salvatore Filippone Cranfield University
! Alfredo Buttari CNRS-IRIT, Toulouse
!
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
@ -15,7 +15,7 @@
! 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
@ -27,9 +27,9 @@
! 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)
!
!
#ifdef SERIAL_MPI
! Provide a fake mpi module just to keep the compiler(s) happy.
module mpi
use psb_const_mod
@ -40,17 +40,17 @@ module mpi
integer(psb_mpik_), parameter :: mpi_integer8 = 2
integer(psb_mpik_), parameter :: mpi_real = 3
integer(psb_mpik_), parameter :: mpi_double_precision = 4
integer(psb_mpik_), parameter :: mpi_complex = 5
integer(psb_mpik_), parameter :: mpi_double_complex = 6
integer(psb_mpik_), parameter :: mpi_complex = 5
integer(psb_mpik_), parameter :: mpi_double_complex = 6
integer(psb_mpik_), parameter :: mpi_character = 7
integer(psb_mpik_), parameter :: mpi_logical = 8
integer(psb_mpik_), parameter :: mpi_integer2 = 9
integer(psb_mpik_), parameter :: mpi_comm_null = -1
integer(psb_mpik_), parameter :: mpi_comm_world = 1
real(psb_dpk_), external :: mpi_wtime
end module mpi
#endif
#endif
module psi_comm_buffers_mod
use psb_const_mod
@ -69,7 +69,7 @@ module psi_comm_buffers_mod
type psb_buffer_node
integer(psb_mpik_) :: request
integer(psb_mpik_) :: icontxt
integer(psb_mpik_) :: icontxt
integer(psb_mpik_) :: buffer_type
integer(psb_ipk_), allocatable :: intbuf(:)
integer(psb_long_int_k_), allocatable :: int8buf(:)
@ -112,25 +112,25 @@ module psi_comm_buffers_mod
module procedure psi_i2snd
end interface
#endif
contains
subroutine psb_init_queue(mesg_queue,info)
implicit none
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
& (.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
& (.not.associated(mesg_queue%tail))) then
! If we are here one is associated, the other is not.
! This is impossible.
! This is impossible.
info = -1
write(psb_err_unit,*) 'Wrong status on init '
return
@ -142,12 +142,12 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
type(psb_buffer_node), intent(inout) :: node
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
integer(psb_mpik_) :: status(mpi_status_size),minfo
minfo = mpi_success
call mpi_wait(node%request,status,minfo)
@ -158,13 +158,13 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
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_ipk_), intent(out) :: info
integer(psb_mpik_) :: status(mpi_status_size), minfo
minfo = mpi_success
#if defined(SERIAL_MPI)
@ -174,7 +174,7 @@ contains
#endif
info=minfo
end subroutine psb_test_buffer
subroutine psb_close_context(mesg_queue,icontxt)
type(psb_buffer_queue), intent(inout) :: mesg_queue
@ -183,10 +183,10 @@ contains
type(psb_buffer_node), pointer :: node, nextnode
node => mesg_queue%head
do
do
if (.not.associated(node)) exit
nextnode => node%next
if (node%icontxt == icontxt) then
if (node%icontxt == icontxt) then
call psb_wait_buffer(node,info)
call psb_delete_node(mesg_queue,node)
end if
@ -198,9 +198,9 @@ contains
type(psb_buffer_queue), intent(inout) :: mesg_queue
type(psb_buffer_node), pointer :: node, nextnode
integer(psb_ipk_) :: info
node => mesg_queue%head
do
do
if (.not.associated(node)) exit
nextnode => node%next
call psb_wait_buffer(node,info)
@ -214,8 +214,8 @@ contains
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
if (.not.associated(node)) then
return
end if
prevnode => node%prev
@ -224,7 +224,7 @@ contains
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)
@ -234,7 +234,7 @@ contains
node%next => null()
node%prev => null()
if ((.not.associated(mesg_queue%head)).and.&
& (.not.associated(mesg_queue%tail))) then
& (.not.associated(mesg_queue%tail))) then
mesg_Queue%head => node
mesg_queue%tail => node
return
@ -250,13 +250,13 @@ contains
type(psb_buffer_node), pointer :: node, nextnode
integer(psb_ipk_) :: info
logical :: flag
node => mesg_queue%head
do
do
if (.not.associated(node)) exit
nextnode => node%next
call psb_test_buffer(node,flag,info)
if (flag) then
if (flag) then
call psb_delete_node(mesg_queue,node)
end if
node => nextnode
@ -270,14 +270,14 @@ contains
! 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.
! has already been copied.
!
! !!!!!!!!!!!!!!!!!
subroutine psi_isnd(icontxt,tag,dest,buffer,mesg_queue)
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -287,16 +287,16 @@ contains
type(psb_buffer_node), pointer :: node
integer(psb_ipk_) :: info
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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%intbuf)
if (info /= 0) then
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
@ -304,7 +304,7 @@ contains
& dest,tag,icontxt,node%request,minfo)
info = minfo
call psb_insert_node(mesg_queue,node)
call psb_test_nodes(mesg_queue)
end subroutine psi_isnd
@ -314,7 +314,7 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -324,24 +324,24 @@ contains
type(psb_buffer_node), pointer :: node
integer(psb_mpik_) :: info
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
node%icontxt = icontxt
node%buffer_type = psb_int4_type
call move_alloc(buffer,node%int4buf)
if (info /= 0) then
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_def_integer,&
& dest,tag,icontxt,node%request,minfo)
info = minfo
info = minfo
call psb_insert_node(mesg_queue,node)
call psb_test_nodes(mesg_queue)
end subroutine psi_i4snd
@ -352,7 +352,7 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -362,24 +362,24 @@ contains
type(psb_buffer_node), pointer :: node
integer(psb_ipk_) :: info
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
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_lng_integer,&
& dest,tag,icontxt,node%request,minfo)
info = minfo
info = minfo
call psb_insert_node(mesg_queue,node)
call psb_test_nodes(mesg_queue)
end subroutine psi_i8snd
@ -390,7 +390,7 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -400,16 +400,16 @@ contains
type(psb_buffer_node), pointer :: node
integer(psb_ipk_) :: info
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
@ -417,7 +417,7 @@ contains
& 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
@ -427,7 +427,7 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -439,14 +439,14 @@ contains
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
@ -454,16 +454,16 @@ contains
& 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
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -475,14 +475,14 @@ contains
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
@ -490,16 +490,16 @@ contains
& 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
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -511,31 +511,31 @@ contains
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
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
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
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -545,16 +545,16 @@ contains
type(psb_buffer_node), pointer :: node
integer(psb_ipk_) :: info
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
@ -562,9 +562,9 @@ contains
& 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
@ -572,7 +572,7 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -582,16 +582,16 @@ contains
type(psb_buffer_node), pointer :: node
integer(psb_ipk_) :: info
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
@ -599,9 +599,9 @@ contains
& dest,tag,icontxt,node%request,minfo)
info = minfo
call psb_insert_node(mesg_queue,node)
call psb_test_nodes(mesg_queue)
end subroutine psi_lsnd
@ -609,7 +609,7 @@ contains
#ifdef MPI_MOD
use mpi
#endif
implicit none
implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
@ -619,16 +619,16 @@ contains
type(psb_buffer_node), pointer :: node
integer(psb_ipk_) :: info
integer(psb_mpik_) :: minfo
allocate(node, stat=info)
if (info /= 0) then
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
if (info /= 0) then
write(psb_err_unit,*) 'Fatal memory error inside communication subsystem'
return
end if
@ -636,9 +636,9 @@ contains
& 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

Write Preview
Loading…
Cancel
Save