dddot1.f

来自「网络带宽测试工具」· F 代码 · 共 69 行

      Function dddot1( 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, Parameter :: maxnod = 2048
      Integer            :: comm, datype, i, ierr, length,
     &                      status(MPI_Status_Size), tag
      Real(l_)           :: s, spart(0:maxnod-1)
! ---------------------------------------------------------------------
! --- Do local part of dotproduct.

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

      If ( k == 1 ) Return
! ---------------------------------------------------------------------
! --- Send partial results from all other processors to processor 1.


      datype = Mpi_Real8
      length = 1
      tag    = 1
      comm   = MPI_Comm_World

      If ( me > 0 .AND. me < k ) Then
         Call MPI_Send( s, length, datype , 0, tag, comm, ierr )
      Else If ( me == 0 ) Then
! ---------------------------------------------------------------------
! --- Receive partial results (blocking) on processor 1.
 
         Do i = 1, k - 1
            Call MPI_Recv( spart(i), length, datype, i, tag, comm,
     &                     status, ierr )
         End Do
      End If
! ---------------------------------------------------------------------
! --- Combine partial results.

      If ( me == 0 ) Then
         Do i = 1, k - 1
            dotres = dotres + spart(i)
         End Do
      End If
! ---------------------------------------------------------------------
! --- Send sum to all processors.

      If ( me == 0 ) Then
         Do i = 1, k - 1
            Call MPI_Send( dotres, length, datype, i, tag, comm,
     &                     ierr )
         End Do
      Else If ( me > 0 .AND. me < k ) Then
         Call MPI_Recv( dotres, length, datype, 0, tag, comm,
     &                  status, ierr )
      End If
! ---------------------------------------------------------------------
      End Function dddot1