d_merge.f

网络带宽测试工具

      Subroutine d_merge( np, nodes, mx, keys, itabl )
! --------------------------------------------------------------------
      Use        numerics
      Implicit   None

      Integer  :: np, nodes, mx, itabl(nodes+1)
      Real(l_) :: keys(mx)

      Real(l_) :: ik, itabk(nodes)
      Integer  :: i, j, k, il, ir, ij, irnkj(nodes), jprocs
      Integer  :: irnkl(np), itabr(nodes), itabm(nodes+1)
      Real(l_) :: w(np)
! --------------------------------------------------------------------
!     Make sure that the indices have base 1.

      itabm = itabl
      If ( itabm(1) /= 1) Then
         Do i = nodes+1, 1, -1
            itabm(i) = itabm(i) - itabm(1) + 1
         End Do
      End If

      Do i = 1, nodes
         itabr(i) = itabm(i+1) - 1
      End Do

      Do j = 1, nodes
         itabk(j) = keys(itabm(j))
         irnkj(j) = j
      End Do
! --------------------------------------------------------------------
!     Check for empty segments and remove them.

      jprocs = nodes
      i = 1
      Do j = 1, nodes
         If ( itabm(irnkj(i)) > itabr(irnkj(i))) Then
            jprocs = jprocs - 1
            Do k = i, jprocs
               irnkj(k) = irnkj(k+1)
            End Do
         Else
            i = i + 1
         End If
      End Do
! --------------------------------------------------------------------
!     Sort the proc-way merging table:

      Do j = 2, jprocs

! ---    Consider each of the original elements in turn.

         ij = irnkj(j)
         ik = itabk(ij)

! ---       and look for a place to insert it.
!           The slot "j" is now empty.

         Do i = j-1, 1, -1
            If ( itabk(irnkj(i)) <= ik ) Go To 10
            irnkj(i+1) = irnkj(i)
         End Do
         i = 0
  10     Continue
         irnkj(i+1) = ij
      End Do
! --------------------------------------------------------------------
!     The merging table is now in sorted order.
!     proceed with the merge.

      Do i = 1, np

! ---    Remove the smallest element from the merging list.
         ij = irnkj(1)

! ---    Refresh the merge table.

         il = itabm(ij) + 1
         ir = itabr(ij)
         ik = keys(il)
         itabk(ij) = ik
         itabm(ij) = il
         irnkl(il-1) = i

! ---    Pick out each element in turn; The first slot is now empty.

         If ( ir >= il ) Then ! --- Look for slot to insert new data.
            Do j = 1, jprocs-1
               If ( itabk(irnkj(j+1)) >= ik ) Go To 20
               irnkj(j) = irnkj(j+1)
            End Do
            j = jprocs
  20        Continue
            irnkj(j) = ij
         Else                      ! --- Retire a slot
            jprocs = jprocs-1
            Do j = 1, jprocs
               irnkj(j) = irnkj(j+1)
            End Do
         End If
      End Do
!$omp parallel do
      Do i = 1, np
         w(irnkl(i)) = keys(i)
      End Do
!$omp parallel do
      Do i = 1, np
         keys(i) = w(i)
      End Do
! --------------------------------------------------------------------
      End Subroutine d_merge