CAF と MPI 例題比較 その２

W. Gropp 等の Using MPI の例題を CAF で書き直してみるつもりが、二個目の例題で早くも大苦戦で苦笑。

CAF の sync によるバリアでは、任意の imeage を１個を待つことができないようで、manager-worker 型の処理に困りました。集団通信のように任意の順で来る全員を待つことはできるが、任意の一名が出頭すればよろしいとい形にはできないようです。（それとも何か理解を間違えているのか？ｗ）

配列 A を coarray にして、worker 側から get 出来るようにすれば色々すっきりするので、元々こういう manager-worker 型の構造は取る必要はないのかもしれません。　

とりあえず仕方がないので、manager-worker 間の制御には atomic 変数による spin-wait loop を例題から借りてきて、worker 間の排他処理には lock を用いました。citical だと内部で sync が使えないようなので、lock を用いる必要がありました。

参考：J. Reid (2009), "Coarrays in Fortran 2008"
ftp://cuter.rl.ac.uk/pub/talks/jkr.pgas.7X09.pdf

CAF

例題では c = Axb を計算しています。manager に当たる image 1 がデータの配布と結果の回収をおこない、image 2 以降が積を計算します。データの回収と配布に２回の sync が必要になります。

ソースプログラム

まだごちゃごちゃしています。intel のコンパイラのバグで debug モードでうまくいかないところがあるので回避しています。手抜きの為、MPI 版にあるプロセッサ数が行列次元より大きい場合の処理を省略しました。

    program CAF3_5
      use, intrinsic :: iso_fortran_env
      implicit none
      integer, parameter :: kd = kind(1.0d0)
      integer, parameter :: MAX_ROWS = 1000, MAX_COLS = 1000
      real(kd) :: a(MAX_ROWS, MAX_COLS), b(MAX_COLS)[*]
      real(kd) :: c(MAX_ROWS), buffer(MAX_COLS)[*], ans[*]
      integer :: rows, cols
      integer :: myid, numprocs
      integer :: i, j, numsent, cnt = 0
      integer :: row[*], no[*]

      logical(atomic_logical_kind) :: locked[*] = .true.
      logical :: val
      
      type(lock_type) :: list_lock[*]  

      myid     = this_image()
      numprocs = num_images()
      
!      manager = 1
      rows = 100
      cols = 100
      !
      ! Initialize A, b ; Broadcast b
      !
      if (myid == 1) then
        do j = 1, cols
          b(j) = 1
          do i = 1, rows
            a(i, j) = i 
          end do
        end do
        sync images(*) ! Broadcast b
        numsent = 0
      else
        sync images(1)  
        b(:) = b(:)[1]  
      end if
      !
      ! send initial data
      !
      if (myid == 1) then
        do i = 2, numprocs
          numsent = numsent + 1
          row[i] = numsent
!          buffer(:)[i] = a(numsent, :)  ! intel fortran v.18 bug in debug mode
          do j  = 1, rows
            buffer(j)[i] = a(numsent, j)  
          end do
          sync images (i)
        end do    
      else
        sync images (1)
      end if
      !
      ! main loop
      !
      do 
        if (myid == 1) then
          val = .true.   ! Spin-wait loop
          do while (val)
            call atomic_ref(val, locked)  
          end do    
          sync memory
          call atomic_define(locked, .true.)   
          ! receive data
          sync images(no)
          c(row) = ans  
          ! send new data
          numsent = numsent + 1
          row[no] = numsent
          if (numsent > rows) then 
            row[no] = 0
            cnt = cnt + 1
            if (cnt >= numprocs - 1) then 
                sync images (no)
                exit
            end if    
          end if  
!          buffer(:)[no] = a(numsent, :)  ! intel fortran v.18 bug in debug mode
          do j  = 1, rows
            buffer(j)[no] = a(numsent, j)  
          end do
          sync images(no)
        else
          if (row == 0) exit
          ans = dot_product(buffer, b)
          lock(list_lock[1])  
            ! send result
            no[1] = myid
            sync memory
            call atomic_define(locked[1], .false.) ! release image 1 from spin loop
            row[1] = row
            ans[1] = ans
            sync images (1) ! send result
            sync images (1) ! recv new data
          unlock(list_lock[1])  
        end if    
      end do    
      if (myid == 1) print *, c(:rows) 
      sync all
    end program CAF3_5

実行結果

   100.000000000000        200.000000000000        300.000000000000
   400.000000000000        500.000000000000        600.000000000000
   700.000000000000        800.000000000000        900.000000000000
   1000.00000000000        1100.00000000000        1200.00000000000
   1300.00000000000        1400.00000000000        1500.00000000000
   1600.00000000000        1700.00000000000        1800.00000000000
   1900.00000000000        2000.00000000000        2100.00000000000
   2200.00000000000        2300.00000000000        2400.00000000000
   2500.00000000000        2600.00000000000        2700.00000000000
   2800.00000000000        2900.00000000000        3000.00000000000
   3100.00000000000        3200.00000000000        3300.00000000000
   3400.00000000000        3500.00000000000        3600.00000000000
   3700.00000000000        3800.00000000000        3900.00000000000
   4000.00000000000        4100.00000000000        4200.00000000000
   4300.00000000000        4400.00000000000        4500.00000000000
   4600.00000000000        4700.00000000000        4800.00000000000
   4900.00000000000        5000.00000000000        5100.00000000000
   5200.00000000000        5300.00000000000        5400.00000000000
   5500.00000000000        5600.00000000000        5700.00000000000
   5800.00000000000        5900.00000000000        6000.00000000000
   6100.00000000000        6200.00000000000        6300.00000000000
   6400.00000000000        6500.00000000000        6600.00000000000
   6700.00000000000        6800.00000000000        6900.00000000000
   7000.00000000000        7100.00000000000        7200.00000000000
   7300.00000000000        7400.00000000000        7500.00000000000
   7600.00000000000        7700.00000000000        7800.00000000000
   7900.00000000000        8000.00000000000        8100.00000000000
   8200.00000000000        8300.00000000000        8400.00000000000
   8500.00000000000        8600.00000000000        8700.00000000000
   8800.00000000000        8900.00000000000        9000.00000000000
   9100.00000000000        9200.00000000000        9300.00000000000
   9400.00000000000        9500.00000000000        9600.00000000000
   9700.00000000000        9800.00000000000        9900.00000000000
   10000.0000000000
続行するには何かキーを押してください . . .

MPI Figs. 3-5, 3-6, 3-7 from W.Gropp et. al.

ソースプログラム

    program MPI3_5
      use mpi
      implicit none
      integer, parameter :: kd = kind(1.0d0)
      integer, parameter :: MAX_ROWS = 1000, MAX_COLS = 1000
      integer :: rows, cols
      real(kd) :: a(MAX_ROWS, MAX_COLS), b(MAX_COLS)
      real(kd) :: c(MAX_ROWS), buffer(MAX_COLS), ans
      
      integer :: myid, manager, numprocs, ierr, status(MPI_STATUS_SIZE)
      integer :: i, j, numsent, sender
      integer :: anstype, row
      
      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
      manager = 0
      rows = 100
      cols = 100
      
      if (myid == manager) then
        do j = 1, cols
          b(j) = 1
          do i = 1, rows
            a(i, j) = i
          end do
        end do
        numsent = 0
        !
        call MPI_BCAST(b, cols, MPI_DOUBLE_PRECISION, manager, MPI_COMM_WORLD, ierr)
        !
        do i = 1, min(numprocs - 1, rows)
          do j = 1, cols
            buffer(j) = a(i, j)
          end do
          call MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, i, i, MPI_COMM_WORLD, ierr)
          numsent = numsent + 1
        end do
        do i = 1, rows
          call MPI_RECV(ans, 1, MPI_DOUBLE_PRECISION, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
          sender  = status(MPI_SOURCE)
          anstype = status(MPI_TAG)
          c(anstype) = ans
          if (numsent < rows) then
            do j = 1, cols
              buffer(j) = a(numsent + 1, j)
            end do    
            call MPI_SEND(buffer, cols, MPI_DOUBLE_PRECISION, sender, numsent + 1, MPI_COMM_WORLD, ierr)
            numsent = numsent + 1
          else
            call MPI_SEND(MPI_BOTTOM, 0, MPI_DOUBLE_PRECISION, sender, 0, MPI_COMM_WORLD, ierr)  
          end if    
        end do  
      else
        call MPI_BCAST(b, cols, MPI_DOUBLE_PRECISION, manager, MPI_COMM_WORLD, ierr)
        if (myid <= rows) then
          do 
            call MPI_RECV(buffer, cols, MPI_DOUBLE_PRECISION, manager, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
            if (status(MPI_TAG) == 0) exit
            row = status(MPI_TAG)
            ans = 0.0_kd
            do i = 1, cols
              ans = ans + buffer(i) * b(i)
            end do  
            call MPI_SEND(ans, 1, MPI_DOUBLE_PRECISION, manager, row, MPI_COMM_WORLD, ierr)
          end do  
        end if  
      end if
      call MPI_FINALIZE(ierr)
      if (myid == 0) print *, c(:cols) 
    end program MPI3_5

実行結果

C:\Program Files (x86)\IntelSWTools>mpiexec -n 4 "C:\Users\O\Documents\Visual Studio 2015\Projects\MPI\Console2\x64\Debug\Console2.exe"
   100.000000000000        200.000000000000        300.000000000000
   400.000000000000        500.000000000000        600.000000000000
   700.000000000000        800.000000000000        900.000000000000
   1000.00000000000        1100.00000000000        1200.00000000000
   1300.00000000000        1400.00000000000        1500.00000000000
   1600.00000000000        1700.00000000000        1800.00000000000
   1900.00000000000        2000.00000000000        2100.00000000000
   2200.00000000000        2300.00000000000        2400.00000000000
   2500.00000000000        2600.00000000000        2700.00000000000
   2800.00000000000        2900.00000000000        3000.00000000000
   3100.00000000000        3200.00000000000        3300.00000000000
   3400.00000000000        3500.00000000000        3600.00000000000
   3700.00000000000        3800.00000000000        3900.00000000000
   4000.00000000000        4100.00000000000        4200.00000000000
   4300.00000000000        4400.00000000000        4500.00000000000
   4600.00000000000        4700.00000000000        4800.00000000000
   4900.00000000000        5000.00000000000        5100.00000000000
   5200.00000000000        5300.00000000000        5400.00000000000
   5500.00000000000        5600.00000000000        5700.00000000000
   5800.00000000000        5900.00000000000        6000.00000000000
   6100.00000000000        6200.00000000000        6300.00000000000
   6400.00000000000        6500.00000000000        6600.00000000000
   6700.00000000000        6800.00000000000        6900.00000000000
   7000.00000000000        7100.00000000000        7200.00000000000
   7300.00000000000        7400.00000000000        7500.00000000000
   7600.00000000000        7700.00000000000        7800.00000000000
   7900.00000000000        8000.00000000000        8100.00000000000
   8200.00000000000        8300.00000000000        8400.00000000000
   8500.00000000000        8600.00000000000        8700.00000000000
   8800.00000000000        8900.00000000000        9000.00000000000
   9100.00000000000        9200.00000000000        9300.00000000000
   9400.00000000000        9500.00000000000        9600.00000000000
   9700.00000000000        9800.00000000000        9900.00000000000
   10000.0000000000