Merged changes at r2702 from branch psblas-ovtrans.
Salvatore Filippone
17 years ago
parent
7f758de51c
commit
c8c211c0e9
@ -0,0 +1,397 @@
|
|||||||
|
!!$
|
||||||
|
!!$ Parallel Sparse BLAS v2.0
|
||||||
|
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
|
||||||
|
!!$ Alfredo Buttari University of Rome Tor Vergata
|
||||||
|
!!$
|
||||||
|
!!$ Redistribution and use in source and binary forms, with or without
|
||||||
|
!!$ modification, are permitted provided that the following conditions
|
||||||
|
!!$ are met:
|
||||||
|
!!$ 1. Redistributions of source code must retain the above copyright
|
||||||
|
!!$ notice, this list of conditions and the following disclaimer.
|
||||||
|
!!$ 2. Redistributions in binary form must reproduce the above copyright
|
||||||
|
!!$ notice, this list of conditions, and the following disclaimer in the
|
||||||
|
!!$ documentation and/or other materials provided with the distribution.
|
||||||
|
!!$ 3. The name of the PSBLAS group or the names of its contributors may
|
||||||
|
!!$ not be used to endorse or promote products derived from this
|
||||||
|
!!$ software without specific written permission.
|
||||||
|
!!$
|
||||||
|
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||||
|
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||||
|
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||||
|
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||||
|
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||||
|
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||||
|
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||||
|
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||||
|
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||||
|
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||||
|
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
!!$
|
||||||
|
!!$
|
||||||
|
! File: psb_iovrl.f90
|
||||||
|
!
|
||||||
|
! Subroutine: psb_iovrlm
|
||||||
|
! This subroutine performs the exchange of the overlap elements in a
|
||||||
|
! distributed dense matrix between all the processes.
|
||||||
|
!
|
||||||
|
! Arguments:
|
||||||
|
! x(:,:) - integer The local part of the dense matrix.
|
||||||
|
! desc_a - type(psb_desc_type). The communication descriptor.
|
||||||
|
! info - integer. Return code.
|
||||||
|
! jx - integer(optional). The starting column of the global matrix
|
||||||
|
! ik - integer(optional). The number of columns to gather.
|
||||||
|
! work - real(optional). A work area.
|
||||||
|
! update - integer(optional). Type of update:
|
||||||
|
! psb_none_ do nothing
|
||||||
|
! psb_sum_ sum of overlaps
|
||||||
|
! psb_avg_ average of overlaps
|
||||||
|
! mode - integer(optional). Choose the algorithm for data exchange:
|
||||||
|
! this is chosen through bit fields.
|
||||||
|
! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0
|
||||||
|
! - swap_sync = iand(flag,psb_swap_sync_) /= 0
|
||||||
|
! - swap_send = iand(flag,psb_swap_send_) /= 0
|
||||||
|
! - swap_recv = iand(flag,psb_swap_recv_) /= 0
|
||||||
|
! - if (swap_mpi): use underlying MPI_ALLTOALLV.
|
||||||
|
! - if (swap_sync): use PSB_SND and PSB_RCV in
|
||||||
|
! synchronized pairs
|
||||||
|
! - if (swap_send .and. swap_recv): use mpi_irecv
|
||||||
|
! and mpi_send
|
||||||
|
! - if (swap_send): use psb_snd (but need another
|
||||||
|
! call with swap_recv to complete)
|
||||||
|
! - if (swap_recv): use psb_rcv (completing a
|
||||||
|
! previous call with swap_send)
|
||||||
|
!
|
||||||
|
!
|
||||||
|
subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode)
|
||||||
|
use psb_descriptor_type
|
||||||
|
use psb_const_mod
|
||||||
|
use psi_mod
|
||||||
|
use psb_realloc_mod
|
||||||
|
use psb_check_mod
|
||||||
|
use psb_error_mod
|
||||||
|
use psb_penv_mod
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(inout), target :: x(:,:)
|
||||||
|
type(psb_desc_type), intent(in) :: desc_a
|
||||||
|
integer, intent(out) :: info
|
||||||
|
integer, optional, target :: work(:)
|
||||||
|
integer, intent(in), optional :: update,jx,ik,mode
|
||||||
|
|
||||||
|
! locals
|
||||||
|
integer :: ictxt, np, me, &
|
||||||
|
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,&
|
||||||
|
& mode_, err, liwork
|
||||||
|
integer, pointer :: iwork(:), xp(:,:)
|
||||||
|
logical :: do_swap
|
||||||
|
character(len=20) :: name, ch_err
|
||||||
|
logical :: aliw
|
||||||
|
|
||||||
|
name='psb_iovrlm'
|
||||||
|
if(psb_get_errstatus() /= 0) return
|
||||||
|
info=0
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
ictxt=psb_cd_get_context(desc_a)
|
||||||
|
|
||||||
|
! check on blacs grid
|
||||||
|
call psb_info(ictxt, me, np)
|
||||||
|
if (np == -1) then
|
||||||
|
info = 2010
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
|
||||||
|
ix = 1
|
||||||
|
if (present(jx)) then
|
||||||
|
ijx = jx
|
||||||
|
else
|
||||||
|
ijx = 1
|
||||||
|
endif
|
||||||
|
|
||||||
|
m = psb_cd_get_global_rows(desc_a)
|
||||||
|
n = psb_cd_get_global_cols(desc_a)
|
||||||
|
nrow = psb_cd_get_local_rows(desc_a)
|
||||||
|
ncol = psb_cd_get_local_cols(desc_a)
|
||||||
|
|
||||||
|
maxk=size(x,2)-ijx+1
|
||||||
|
|
||||||
|
if(present(ik)) then
|
||||||
|
if(ik > maxk) then
|
||||||
|
k=maxk
|
||||||
|
else
|
||||||
|
k=ik
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
k = maxk
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (present(update)) then
|
||||||
|
update_ = update
|
||||||
|
else
|
||||||
|
update_ = psb_avg_
|
||||||
|
endif
|
||||||
|
|
||||||
|
if (present(mode)) then
|
||||||
|
mode_ = mode
|
||||||
|
else
|
||||||
|
mode_ = IOR(psb_swap_send_,psb_swap_recv_)
|
||||||
|
endif
|
||||||
|
do_swap = (mode_ /= 0)
|
||||||
|
|
||||||
|
! check vector correctness
|
||||||
|
call psb_chkvect(m,1,size(x,1),ix,ijx,desc_a,info,iix,jjx)
|
||||||
|
if(info /= 0) then
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_chkvect'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (iix /= 1) then
|
||||||
|
info=3040
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
end if
|
||||||
|
|
||||||
|
err=info
|
||||||
|
call psb_errcomm(ictxt,err)
|
||||||
|
if(err /= 0) goto 9999
|
||||||
|
|
||||||
|
! check for presence/size of a work area
|
||||||
|
liwork=ncol
|
||||||
|
if (present(work)) then
|
||||||
|
if(size(work) >= liwork) then
|
||||||
|
aliw=.false.
|
||||||
|
else
|
||||||
|
aliw=.true.
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
aliw=.true.
|
||||||
|
end if
|
||||||
|
if (aliw) then
|
||||||
|
allocate(iwork(liwork),stat=info)
|
||||||
|
if(info /= 0) then
|
||||||
|
info=4010
|
||||||
|
call psb_errpush(info,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
iwork => work
|
||||||
|
end if
|
||||||
|
! exchange overlap elements
|
||||||
|
if(do_swap) then
|
||||||
|
xp => x(iix:size(x,1),jjx:jjx+k-1)
|
||||||
|
call psi_swapdata(mode_,k,ione,xp,&
|
||||||
|
& desc_a,iwork,info,data=psb_comm_ovr_)
|
||||||
|
end if
|
||||||
|
if (info == 0) call psi_ovrl_upd(xp,desc_a,update_,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Inner updates')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (aliw) deallocate(iwork)
|
||||||
|
nullify(iwork)
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error(ictxt)
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine psb_iovrlm
|
||||||
|
|
||||||
|
!!$
|
||||||
|
!!$ Parallel Sparse BLAS v2.0
|
||||||
|
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
|
||||||
|
!!$ Alfredo Buttari University of Rome Tor Vergata
|
||||||
|
!!$
|
||||||
|
!!$ 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.
|
||||||
|
!!$
|
||||||
|
!!$
|
||||||
|
!
|
||||||
|
! Subroutine: psb_iovrlv
|
||||||
|
! This subroutine performs the exchange of the overlap elements in a
|
||||||
|
! distributed dense vector between all the processes.
|
||||||
|
!
|
||||||
|
! Arguments:
|
||||||
|
! x(:) - integer The local part of the dense vector.
|
||||||
|
! desc_a - type(psb_desc_type). The communication descriptor.
|
||||||
|
! info - integer. Return code.
|
||||||
|
! work - real(optional). A work area.
|
||||||
|
! update - integer(optional). Type of update:
|
||||||
|
! psb_none_ do nothing
|
||||||
|
! psb_sum_ sum of overlaps
|
||||||
|
! psb_avg_ average of overlaps
|
||||||
|
! mode - integer(optional). Choose the algorithm for data exchange:
|
||||||
|
! this is chosen through bit fields.
|
||||||
|
! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0
|
||||||
|
! - swap_sync = iand(flag,psb_swap_sync_) /= 0
|
||||||
|
! - swap_send = iand(flag,psb_swap_send_) /= 0
|
||||||
|
! - swap_recv = iand(flag,psb_swap_recv_) /= 0
|
||||||
|
! - if (swap_mpi): use underlying MPI_ALLTOALLV.
|
||||||
|
! - if (swap_sync): use PSB_SND and PSB_RCV in
|
||||||
|
! synchronized pairs
|
||||||
|
! - if (swap_send .and. swap_recv): use mpi_irecv
|
||||||
|
! and mpi_send
|
||||||
|
! - if (swap_send): use psb_snd (but need another
|
||||||
|
! call with swap_recv to complete)
|
||||||
|
! - if (swap_recv): use psb_rcv (completing a
|
||||||
|
! previous call with swap_send)
|
||||||
|
!
|
||||||
|
!
|
||||||
|
!
|
||||||
|
subroutine psb_iovrlv(x,desc_a,info,work,update,mode)
|
||||||
|
use psb_descriptor_type
|
||||||
|
use psi_mod
|
||||||
|
use psb_const_mod
|
||||||
|
use psb_realloc_mod
|
||||||
|
use psb_check_mod
|
||||||
|
use psb_error_mod
|
||||||
|
use psb_penv_mod
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
integer, intent(inout), target :: x(:)
|
||||||
|
type(psb_desc_type), intent(in) :: desc_a
|
||||||
|
integer, intent(out) :: info
|
||||||
|
integer, optional, target :: work(:)
|
||||||
|
integer, intent(in), optional :: update,mode
|
||||||
|
|
||||||
|
! locals
|
||||||
|
integer :: ictxt, np, me, &
|
||||||
|
& err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,&
|
||||||
|
& mode_, err, liwork
|
||||||
|
integer,pointer :: iwork(:)
|
||||||
|
logical :: do_swap
|
||||||
|
character(len=20) :: name, ch_err
|
||||||
|
logical :: aliw
|
||||||
|
|
||||||
|
name='psb_iovrlv'
|
||||||
|
if(psb_get_errstatus() /= 0) return
|
||||||
|
info=0
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
ictxt=psb_cd_get_context(desc_a)
|
||||||
|
|
||||||
|
! check on blacs grid
|
||||||
|
call psb_info(ictxt, me, np)
|
||||||
|
if (np == -1) then
|
||||||
|
info = 2010
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
|
||||||
|
ix = 1
|
||||||
|
ijx = 1
|
||||||
|
|
||||||
|
m = psb_cd_get_global_rows(desc_a)
|
||||||
|
n = psb_cd_get_global_cols(desc_a)
|
||||||
|
nrow = psb_cd_get_local_rows(desc_a)
|
||||||
|
ncol = psb_cd_get_local_cols(desc_a)
|
||||||
|
|
||||||
|
k = 1
|
||||||
|
|
||||||
|
if (present(update)) then
|
||||||
|
update_ = update
|
||||||
|
else
|
||||||
|
update_ = psb_avg_
|
||||||
|
endif
|
||||||
|
|
||||||
|
if (present(mode)) then
|
||||||
|
mode_ = mode
|
||||||
|
else
|
||||||
|
mode_ = IOR(psb_swap_send_,psb_swap_recv_)
|
||||||
|
endif
|
||||||
|
do_swap = (mode_ /= 0)
|
||||||
|
|
||||||
|
! check vector correctness
|
||||||
|
call psb_chkvect(m,1,size(x),ix,ijx,desc_a,info,iix,jjx)
|
||||||
|
if(info /= 0) then
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_chkvect'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (iix /= 1) then
|
||||||
|
info=3040
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
end if
|
||||||
|
|
||||||
|
err=info
|
||||||
|
call psb_errcomm(ictxt,err)
|
||||||
|
if(err /= 0) goto 9999
|
||||||
|
|
||||||
|
! check for presence/size of a work area
|
||||||
|
liwork=ncol
|
||||||
|
if (present(work)) then
|
||||||
|
if(size(work) >= liwork) then
|
||||||
|
aliw=.false.
|
||||||
|
else
|
||||||
|
aliw=.true.
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
aliw=.true.
|
||||||
|
end if
|
||||||
|
if (aliw) then
|
||||||
|
allocate(iwork(liwork),stat=info)
|
||||||
|
if(info /= 0) then
|
||||||
|
info=4010
|
||||||
|
call psb_errpush(info,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
else
|
||||||
|
iwork => work
|
||||||
|
end if
|
||||||
|
|
||||||
|
! exchange overlap elements
|
||||||
|
if (do_swap) then
|
||||||
|
call psi_swapdata(mode_,ione,x(:),&
|
||||||
|
& desc_a,iwork,info,data=psb_comm_ovr_)
|
||||||
|
end if
|
||||||
|
if (info == 0) call psi_ovrl_upd(x,desc_a,update_,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Inner updates')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (aliw) deallocate(iwork)
|
||||||
|
nullify(iwork)
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error(ictxt)
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine psb_iovrlv
|
||||||
@ -0,0 +1,156 @@
|
|||||||
|
!!$
|
||||||
|
!!$ Parallel Sparse BLAS v2.0
|
||||||
|
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
|
||||||
|
!!$ Alfredo Buttari University of Rome Tor Vergata
|
||||||
|
!!$
|
||||||
|
!!$ Redistribution and use in source and binary forms, with or without
|
||||||
|
!!$ modification, are permitted provided that the following conditions
|
||||||
|
!!$ are met:
|
||||||
|
!!$ 1. Redistributions of source code must retain the above copyright
|
||||||
|
!!$ notice, this list of conditions and the following disclaimer.
|
||||||
|
!!$ 2. Redistributions in binary form must reproduce the above copyright
|
||||||
|
!!$ notice, this list of conditions, and the following disclaimer in the
|
||||||
|
!!$ documentation and/or other materials provided with the distribution.
|
||||||
|
!!$ 3. The name of the PSBLAS group or the names of its contributors may
|
||||||
|
!!$ not be used to endorse or promote products derived from this
|
||||||
|
!!$ software without specific written permission.
|
||||||
|
!!$
|
||||||
|
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||||
|
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||||
|
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||||
|
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||||
|
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||||
|
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||||
|
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||||
|
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||||
|
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||||
|
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||||
|
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
!!$
|
||||||
|
!!$
|
||||||
|
!
|
||||||
|
! File: psi_bld_tmpovrl.f90
|
||||||
|
!
|
||||||
|
! Subroutine: psi_bld_tmpovrl
|
||||||
|
! Build initial versions of overlap exchange lists.
|
||||||
|
! When the descriptor is for a large index space, we cannot build
|
||||||
|
! the data exchange lists "on-the-fly", but we also want to keep using the
|
||||||
|
! same format conversion routines we use in the small index space case,
|
||||||
|
! hence this adapter routine.
|
||||||
|
!
|
||||||
|
!
|
||||||
|
! Arguments:
|
||||||
|
! iv(:) - integer Initial list.
|
||||||
|
! index
|
||||||
|
! nprocs (sharing it)
|
||||||
|
! procs(1:nprocs)
|
||||||
|
! End marked with -1
|
||||||
|
!
|
||||||
|
! desc - type(psb_desc_type). The communication descriptor.
|
||||||
|
! info - integer. return code.
|
||||||
|
!
|
||||||
|
subroutine psi_bld_tmpovrl(iv,desc,info)
|
||||||
|
use psb_descriptor_type
|
||||||
|
use psb_serial_mod
|
||||||
|
use psb_const_mod
|
||||||
|
use psb_error_mod
|
||||||
|
use psb_penv_mod
|
||||||
|
use psb_realloc_mod
|
||||||
|
use psi_mod, psb_protect_name => psi_bld_tmpovrl
|
||||||
|
implicit none
|
||||||
|
integer, intent(in) :: iv(:)
|
||||||
|
type(psb_desc_type), intent(inout) :: desc
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
!locals
|
||||||
|
Integer :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,&
|
||||||
|
& l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, icomm
|
||||||
|
integer, allocatable :: ov_idx(:),ov_el(:,:)
|
||||||
|
|
||||||
|
integer :: ictxt,n_row, debug_unit, debug_level
|
||||||
|
character(len=20) :: name,ch_err
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
name = 'psi_bld_tmpovrl'
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
debug_unit = psb_get_debug_unit()
|
||||||
|
debug_level = psb_get_debug_level()
|
||||||
|
ictxt = psb_cd_get_context(desc)
|
||||||
|
icomm = psb_cd_get_mpic(desc)
|
||||||
|
|
||||||
|
! check on blacs grid
|
||||||
|
call psb_info(ictxt, me, np)
|
||||||
|
if (np == -1) then
|
||||||
|
info = 2010
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
|
||||||
|
l_ov_ix=0
|
||||||
|
l_ov_el=0
|
||||||
|
i = 1
|
||||||
|
do while (iv(i) /= -1)
|
||||||
|
idx = iv(i)
|
||||||
|
i = i + 1
|
||||||
|
nprocs = iv(i)
|
||||||
|
i = i + 1
|
||||||
|
l_ov_ix = l_ov_ix+3*(nprocs-1)
|
||||||
|
l_ov_el = l_ov_el + 1
|
||||||
|
i = i + nprocs
|
||||||
|
enddo
|
||||||
|
|
||||||
|
l_ov_ix = l_ov_ix+3
|
||||||
|
|
||||||
|
if (debug_level >= psb_debug_inner_) &
|
||||||
|
& write(debug_unit,*) me,' ',trim(name),': Ov len',l_ov_ix,l_ov_el
|
||||||
|
|
||||||
|
allocate(ov_idx(l_ov_ix),ov_el(l_ov_el,3), stat=info)
|
||||||
|
if (info /= psb_no_err_) then
|
||||||
|
info=4010
|
||||||
|
err=info
|
||||||
|
call psb_errpush(err,name,a_err='psb_realloc')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
l_ov_ix=0
|
||||||
|
l_ov_el=0
|
||||||
|
i = 1
|
||||||
|
do while (iv(i) /= -1)
|
||||||
|
idx = iv(i)
|
||||||
|
i = i+1
|
||||||
|
nprocs = iv(i)
|
||||||
|
l_ov_el = l_ov_el+1
|
||||||
|
ov_el(l_ov_el,1) = idx ! Index
|
||||||
|
ov_el(l_ov_el,2) = nprocs ! How many procs
|
||||||
|
ov_el(l_ov_el,3) = minval(iv(i+1:i+nprocs)) ! master proc
|
||||||
|
do j=1, nprocs
|
||||||
|
if (iv(i+j) /= me) then
|
||||||
|
ov_idx(l_ov_ix+1) = iv(i+j)
|
||||||
|
ov_idx(l_ov_ix+2) = 1
|
||||||
|
ov_idx(l_ov_ix+3) = idx
|
||||||
|
l_ov_ix = l_ov_ix+3
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
i = i + nprocs + 1
|
||||||
|
enddo
|
||||||
|
l_ov_ix = l_ov_ix + 1
|
||||||
|
ov_idx(l_ov_ix) = -1
|
||||||
|
call psb_transfer(ov_idx,desc%ovrlap_index,info)
|
||||||
|
if (info == 0) call psb_transfer(ov_el,desc%ovrlap_elem,info)
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
|
||||||
|
if (err_act == psb_act_ret_) then
|
||||||
|
return
|
||||||
|
else
|
||||||
|
call psb_error(ictxt)
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
|
||||||
|
end subroutine psi_bld_tmpovrl
|
||||||
@ -1,369 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS v2.0
|
|
||||||
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ Redistribution and use in source and binary forms, with or without
|
|
||||||
!!$ modification, are permitted provided that the following conditions
|
|
||||||
!!$ are met:
|
|
||||||
!!$ 1. Redistributions of source code must retain the above copyright
|
|
||||||
!!$ notice, this list of conditions and the following disclaimer.
|
|
||||||
!!$ 2. Redistributions in binary form must reproduce the above copyright
|
|
||||||
!!$ notice, this list of conditions, and the following disclaimer in the
|
|
||||||
!!$ documentation and/or other materials provided with the distribution.
|
|
||||||
!!$ 3. The name of the PSBLAS group or the names of its contributors may
|
|
||||||
!!$ not be used to endorse or promote products derived from this
|
|
||||||
!!$ software without specific written permission.
|
|
||||||
!!$
|
|
||||||
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
||||||
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
|
||||||
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
|
||||||
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
! File: psi_gthsct_mod.f90
|
|
||||||
!
|
|
||||||
! Module: psi_gth_scr_mod
|
|
||||||
! Provides pack/unpack routines for usage in the data exchange.
|
|
||||||
! The unpack routines take a BETA argument to have a unified treatment of
|
|
||||||
! simple receives with overwriting, and receives with sum (for overlap)
|
|
||||||
!
|
|
||||||
!
|
|
||||||
module psi_gthsct_mod
|
|
||||||
|
|
||||||
interface psi_gth
|
|
||||||
module procedure psi_igthm, psi_igthv,&
|
|
||||||
& psi_dgthm, psi_dgthv,&
|
|
||||||
& psi_zgthm, psi_zgthv
|
|
||||||
end interface
|
|
||||||
|
|
||||||
interface psi_sct
|
|
||||||
module procedure psi_isctm, psi_isctv,&
|
|
||||||
& psi_dsctm, psi_dsctv,&
|
|
||||||
& psi_zsctm, psi_zsctv
|
|
||||||
end interface
|
|
||||||
|
|
||||||
contains
|
|
||||||
|
|
||||||
subroutine psi_dgthm(n,k,idx,x,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, k, idx(:)
|
|
||||||
real(kind(1.d0)) :: x(:,:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i, j, pt
|
|
||||||
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(pt)=x(idx(i),j)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
|
|
||||||
end subroutine psi_dgthm
|
|
||||||
|
|
||||||
subroutine psi_dgthv(n,idx,x,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, idx(:)
|
|
||||||
real(kind(1.d0)) :: x(:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i
|
|
||||||
|
|
||||||
do i=1,n
|
|
||||||
y(i)=x(idx(i))
|
|
||||||
end do
|
|
||||||
|
|
||||||
end subroutine psi_dgthv
|
|
||||||
|
|
||||||
|
|
||||||
subroutine psi_dsctm(n,k,idx,x,beta,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, k, idx(:)
|
|
||||||
real(kind(1.d0)) :: beta, x(:), y(:,:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i, j, pt
|
|
||||||
|
|
||||||
if (beta == dzero) then
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
else if (beta == done) then
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = y(idx(i),j)+x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
else
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
end if
|
|
||||||
end subroutine psi_dsctm
|
|
||||||
|
|
||||||
subroutine psi_dsctv(n,idx,x,beta,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, idx(:)
|
|
||||||
real(kind(1.d0)) :: beta, x(:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i
|
|
||||||
|
|
||||||
if (beta == dzero) then
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = x(i)
|
|
||||||
end do
|
|
||||||
else if (beta == done) then
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = y(idx(i))+x(i)
|
|
||||||
end do
|
|
||||||
else
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = beta*y(idx(i))+x(i)
|
|
||||||
end do
|
|
||||||
end if
|
|
||||||
end subroutine psi_dsctv
|
|
||||||
|
|
||||||
|
|
||||||
subroutine psi_igthm(n,k,idx,x,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, k, idx(:)
|
|
||||||
integer :: x(:,:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i, j, pt
|
|
||||||
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(pt)=x(idx(i),j)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
|
|
||||||
end subroutine psi_igthm
|
|
||||||
|
|
||||||
|
|
||||||
subroutine psi_igthv(n,idx,x,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, idx(:)
|
|
||||||
integer :: x(:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i
|
|
||||||
|
|
||||||
do i=1,n
|
|
||||||
y(i)=x(idx(i))
|
|
||||||
end do
|
|
||||||
|
|
||||||
end subroutine psi_igthv
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
subroutine psi_isctm(n,k,idx,x,beta,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, k, idx(:)
|
|
||||||
integer :: beta, x(:), y(:,:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i, j, pt
|
|
||||||
|
|
||||||
if (beta == izero) then
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
else if (beta == ione) then
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = y(idx(i),j)+x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
else
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
end if
|
|
||||||
end subroutine psi_isctm
|
|
||||||
|
|
||||||
subroutine psi_isctv(n,idx,x,beta,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, idx(:)
|
|
||||||
integer :: beta, x(:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i
|
|
||||||
|
|
||||||
if (beta == izero) then
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = x(i)
|
|
||||||
end do
|
|
||||||
else if (beta == ione) then
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = y(idx(i))+x(i)
|
|
||||||
end do
|
|
||||||
else
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = beta*y(idx(i))+x(i)
|
|
||||||
end do
|
|
||||||
end if
|
|
||||||
end subroutine psi_isctv
|
|
||||||
|
|
||||||
|
|
||||||
subroutine psi_zgthm(n,k,idx,x,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, k, idx(:)
|
|
||||||
complex(kind(1.d0)) :: x(:,:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i, j, pt
|
|
||||||
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(pt)=x(idx(i),j)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
|
|
||||||
end subroutine psi_zgthm
|
|
||||||
|
|
||||||
|
|
||||||
subroutine psi_zgthv(n,idx,x,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, idx(:)
|
|
||||||
complex(kind(1.d0)) :: x(:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i
|
|
||||||
|
|
||||||
do i=1,n
|
|
||||||
y(i)=x(idx(i))
|
|
||||||
end do
|
|
||||||
|
|
||||||
end subroutine psi_zgthv
|
|
||||||
|
|
||||||
subroutine psi_zsctm(n,k,idx,x,beta,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, k, idx(:)
|
|
||||||
complex(kind(1.d0)) :: beta, x(:), y(:,:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i, j, pt
|
|
||||||
|
|
||||||
if (beta == zzero) then
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
else if (beta == zone) then
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = y(idx(i),j)+x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
else
|
|
||||||
pt=0
|
|
||||||
do j=1,k
|
|
||||||
do i=1,n
|
|
||||||
pt=pt+1
|
|
||||||
y(idx(i),j) = beta*y(idx(i),j)+x(pt)
|
|
||||||
end do
|
|
||||||
end do
|
|
||||||
end if
|
|
||||||
end subroutine psi_zsctm
|
|
||||||
|
|
||||||
|
|
||||||
subroutine psi_zsctv(n,idx,x,beta,y)
|
|
||||||
|
|
||||||
use psb_const_mod
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
integer :: n, idx(:)
|
|
||||||
complex(kind(1.d0)) :: beta, x(:), y(:)
|
|
||||||
|
|
||||||
! Locals
|
|
||||||
integer :: i
|
|
||||||
|
|
||||||
if (beta == zzero) then
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = x(i)
|
|
||||||
end do
|
|
||||||
else if (beta == zone) then
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = y(idx(i))+x(i)
|
|
||||||
end do
|
|
||||||
else
|
|
||||||
do i=1,n
|
|
||||||
y(idx(i)) = beta*y(idx(i))+x(i)
|
|
||||||
end do
|
|
||||||
end if
|
|
||||||
end subroutine psi_zsctv
|
|
||||||
|
|
||||||
end module psi_gthsct_mod
|
|
||||||
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue