如何以惯用方式脱离嵌套的并行(OpenMP)Fortran循环?

似乎您的顺序代码有一个依赖关系,使得它不适合被并行处理。假设有多个i&j值使“some condition”为真,则i&j do循环的执行顺序将首先确定找到这些条件中的哪一个,并设置结果值,然后返回语句结束对其他i,j情况的搜索,“some condition”为真。在顺序代码中,do循环总是以相同的顺序执行,因此程序的操作是确定性的,并且总是会找到使“some condition”为真的i&j的相同值。在并发版本中,我以非确定性的顺序执行的各种循环,这样,从运行到运行,我的不同值可能是找到真正“某些条件”的第一个i值。

也许作为程序员,您知道只有一个I&J值会导致真正的“某些条件”?在这种情况下,短路执行似乎是可以的。但是openmp规范说,“除了do语句之外,关联循环中的任何语句都不能导致分支 “在循环之外”,所以让内部循环中的某个东西中止输出循环是不允许的。如果总是只有一个真正的“某些条件”,那么在找到一个“条件”之后,可以通过让线程查找“某些条件”是真的来除去“返回”并浪费CPU时间。这可能仍然比顺序程序快。对于scaler“result”变量,它可能仍然不兼容,依赖于执行顺序。您可以将其改为“约简”,求和结果,或者将结果返回为一维维度数组(n)。如果需要找到“some condition”为真的i的最小值,可以使用fortran instrinsic函数minloc从数组结果中获取该值。

具有许多“flush”和“critical”指令的解决方案可能不会比顺序版本更快。

更新: 基于对多个结果是可能的以及任何一个结果都可能的澄清,一个并行方法是返回多个结果,并让顺序代码挑选出一个结果——将“结果”生成一个一维数组,而不是一个定标器。您可以使内部j循环短路,因为它与“omp do”指令没有“关联”,因此“result”只需要1d,根据i的范围进行尺寸标注。因此类似这样:

program test1

integer :: i, j
integer, parameter :: n = 10
integer, dimension (n) :: result

result = -999

!omp parallel default (shared) private (i, j)
!omp do
do i = 1, n
   inner: do j = i+1, n
      if ( mod (i+j,14) == 0 ) then
         result (i) = i
         exit inner
      end if
   end do inner
end do
!omp end do
!omp end parallel

write (*, *) 'All results'
write (*, *) result

write (*, *)
write (*, *) 'One result'
write (*, *) result ( maxloc (result, 1) )

end program test1

另一种方法完全是使用作为OpenMP3.0一部分的任务构造。您要做的似乎是将循环划分为多个线程,计算直到任何线程找到答案,然后停止所有线程。问题是,所有线程检查共享标志的必要性是(a)破坏性能,(b)导致您进入带有中断和循环的丑陋循环。

我认为@m.s.b.的回答对如何适应现有方法提供了非常好的建议。但是,解决这个问题的一个更自然的方法可能是让程序创建一些任务(可能对于最里面的循环的每个迭代都有一个任务),并将这些任务分派给工作线程。一旦任何线程报告成功,所有线程都可以发送一个最终确定任务,并且您的程序可以继续。

当然,这将需要对程序进行更多的重新编写,并可能使顺序执行变得更糟。它肯定需要您的OpenMP实现支持该标准的v3.0。

在这方面,你可能需要更多的帮助,而我无法管理,我只是刚开始自己玩OpenMP任务。

似乎 $OMP DO 不允许提前脱离循环。另一种选择可能是手工实现。

给每个线程一个固定的连续索引范围

跟随 Guide into OpenMP: Easy multithreading programming for C++ :

  results = "invalid_value"

  !$OMP PARALLEL private(i,j,thread_num,num_threads,start,end)

  thread_num = OMP_GET_THREAD_NUM()
  num_threads = OMP_GET_NUM_THREADS()
  start = thread_num * n / num_threads + 1
  end = (thread_num + 1) * n / num_threads

  outer: do i = start, end
     !$OMP FLUSH(found)             
     if (found) exit outer
     do j = i+1, n
        if ("some_condition") then
           found = .true.
           !$OMP FLUSH(found)
           results(thread_num+1) = "here's result"
           exit outer
        end if
     end do
  end do outer

  !$OMP END PARALLEL

  ! extract `result` from `results` if any
  do i = 1, size(results)
     if (results(i).ne."invalid_value") result = results(i)
  end do

更新 取代 goto 通过 exit ,介绍 results 基于数组 @M. S. B.'s answer .

如果存在解决方案,则此方法更快 美元OMP 由于提前退出。

每次给每个线程一个迭代来处理

使用任务指令(建议由 @High Performance Mark ):

  !$OMP PARALLEL
  !$OMP SINGLE
  !$OMP TASK UNTIED
          ! "untied" allows other threads to generate tasks
  do i = 1, n ! i is private
     !$OMP TASK ! implied "flush"
     task:     do j = i+1, n ! i is firstprivate, j is private       
        if (found) exit task
        if ("some_condition(i,j)") then
           !$OMP CRITICAL
           result = "here's result" ! result is shared              
           found = .true.           ! found is shared
           !$OMP END CRITICAL ! implied "flush"
           exit task
        end if
     end do task
     !$OMP END TASK 
  end do 
  !$OMP END TASK
  !$OMP END SINGLE
  !$OMP END PARALLEL

在我的测试中,这个变量比 outer -循环。