Homec4science
Diffusion SPClibs (feature/refactoring) Browse

spclibs/src/psum_mat.tpl
1a965ce17d3bfeature/refactoring

Last Change
Raw File

psum_mat.tpl
View Options

!>
!> @file psum_mat.tpl
!>
!> @brief
!>
!> @copyright
!> Copyright (©) 2021 EPFL (Ecole Polytechnique Fédérale de Lausanne)
!> SPC (Swiss Plasma Center)
!>
!> SPClibs is free software: you can redistribute it and/or modify it under
!> the terms of the GNU Lesser General Public License as published by the Free
!> Software Foundation, either version 3 of the License, or (at your option)
!> any later version.
!>
!> SPClibs is distributed in the hope that it will be useful, but WITHOUT ANY
!> WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
!> FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
!>
!> You should have received a copy of the GNU Lesser General Public License
!> along with this program. If not, see <https://www.gnu.org/licenses/>.
!>
!> @author
!> (in alphabetical order)
!> @author Trach-Minh Tran <trach-minh.tran@epfl.ch>
!>
INTEGER, INTENT(in) :: comm
!
INTEGER :: me, npes, ierr
INTEGER :: n, r, i, base
INTEGER :: newrank
!---------------------------------------------------------------------
! 1.0 Prologue
!
CALL mpi_comm_size(comm, npes, ierr)
CALL mpi_comm_rank(comm, me, ierr)
!
! Compute n and r defined by npes = 2**n+r
i=1
n=0
DO WHILE (2*i.LE.npes)
n=n+1
i=2*i
END DO ! i=2**n
r = npes-i
!---------------------------------------------------------------------
! 2.0 Node partition
!
! I: nodes with ranks < 2*r
! . nodes with even ranks receive from rank+1 and sum
! . odd ranks sends to rank-1
! II: nodes with ranks >= 2*r
! . do nothing
!
IF( me .LT. 2*r ) THEN
IF( MODULO(me,2) .EQ. 0 ) THEN
CALL p2p_mat(mat, me+1, 'recv', 'updt', comm)
ELSE
CALL p2p_mat(mat, me-1, 'send', 'updt', comm)
END IF
END IF
!---------------------------------------------------------------------
! 3.0 Binary tree reduction using new ranks
!
! Define new ranks
IF( MODULO(me,2).EQ.0 .AND. me.LT.2*r ) THEN ! new rank in I
newrank = me/2
ELSE IF( me.GE.2*r ) THEN ! new ranks in II
newrank = me-r
ELSE ! inactive ranks in I
newrank = -1
END IF
!
! Reduction with 2**n (positive) newranks
IF( newrank .GE. 0 ) THEN ! only for nodes with new rank > 0
base = 1
DO i=1,n
CALL p2p_mat(mat, oldrank(IEOR(newrank,base)), &
& 'sendrecv', 'updt', comm)
base = base*2
END DO
END IF
!---------------------------------------------------------------------
! 4.0 Final exchanche in I
!
IF( me .LT. 2*r ) THEN
IF( MODULO(me,2).EQ.0 ) THEN
CALL p2p_mat(mat, me+1, 'send', 'put', comm)
ELSE
CALL p2p_mat(mat, me-1, 'recv', 'put', comm)
END IF
END IF
!---------------------------------------------------------------------
CONTAINS
INTEGER FUNCTION oldrank(rank)
INTEGER, INTENT(in) :: rank
IF(rank.LT.r) THEN
oldrank = 2*rank
ELSE
oldrank = rank+r
END IF
END FUNCTION oldrank
c4science · Help