dddot2.f

网络带宽测试工具

      Function dddot2( k, n, x, y )                    Result( dotres )
! ---------------------------------------------------------------------
      Use                   dist_module
      Use                   numerics 
      Implicit              None
      Integer            :: k, n
      Real(l_)           :: x(n), y(n), dotres

      Include               'mpif.h' 

      Integer            :: comm, datype, tag
      Integer            :: ierr, status(MPI_Status_Size) 
      Integer            :: i, left, right, up, maxup
      Real(l_)           :: s, sleft, sright
! ---------------------------------------------------------------------
! --- Do local part of dotproduct.

      s = 0.0_l_
      Do i = 1, n
         s = s + x(i)*y(i)
      End Do
! ---------------------------------------------------------------------
! --- If on 1 processor we are done: Return.
 
      If ( me == 0 ) dotres = s
      If ( k == 1 ) Return
! ---------------------------------------------------------------------
! --- Combine partial results on processor 1.

      datype = MPI_Real8
      tag    = 1
      comm   = MPI_Comm_World

      right  = 2*(me + 1)
      left   = right - 1
      up     = (me - 1)/2
      maxup  = (k - 2)/2

      If ( right < k ) Then
         Call MPI_Recv( sright, 1, datype, right, tag, comm,
     &                  status, ierr )
         Call MPI_Recv( sleft, 1, datype, left, tag, comm,
     &                  status, ierr )
         s = s + sleft + sright
      Else If ( left < k ) Then
         Call MPI_Recv( sleft, 1, datype, left, tag, comm,
     &                  status, ierr )
         s = s + sleft
      End If
      If ( me > 0 .AND. me < k ) Then
         Call MPI_Send( s, 1, datype, up, tag, comm, ierr )
      End If
      If ( me == 0 ) dotres = s
! ---------------------------------------------------------------------
! --- Send sum to all processors.
 
      If ( me == 0 ) Then
         Call MPI_Send( dotres, 1, datype, left, tag, comm, ierr)
         If ( right < k ) Then
            Call MPI_Send( dotres, 1, datype, right, tag, comm, ierr )
         End If
      Else
         If ( up <= maxup ) Then
            Call MPI_Recv( dotres, 1, datype, up, tag, comm, status,
     &                     ierr )
         End If
         If ( right < k ) Then
            Call MPI_Send( dotres, 1, datype, right, tag, comm, ierr )
            Call MPI_Send( dotres, 1, datype, left , tag, comm, ierr )
         Else If ( left < k ) Then
            Call MPI_Send( dotres, 1, datype, left , tag, comm, ierr )
         End If
      End If
! ---------------------------------------------------------------------
      End Function dddot2