Merge pull request #229 from bonachea/image_index

Implement image_index_with_team and this_image_with_{coarray,dim}, partial {image_index,num_images}_with_team_number

Author: bonachea

docs/implementation-status.md

@@ -54,9 +54,9 @@ are accepted, but in some cases, the associated runtime behavior is not fully im
 |-----------|--------|-------|
 | `prif_num_images`                   | **YES** |  |
 | `prif_num_images_with_team`         | **YES** |  |
-| `prif_num_images_with_team_number`  | no |  |
+| `prif_num_images_with_team_number`  | *partial* | no support for sibling teams |
 | `prif_this_image_no_coarray`        | **YES** |  |
-| `prif_this_image_with_coarray`, `prif_this_image_with_dim`  | no |  |
+| `prif_this_image_with_coarray`, `prif_this_image_with_dim`  | **YES** |  |
 | `prif_failed_images`                | **YES** |  |
 | `prif_stopped_images`               | **YES** |  |
 | `prif_image_status`                 | **YES** |  |
@@ -87,8 +87,8 @@ are accepted, but in some cases, the associated runtime behavior is not fully im
 | `prif_coshape`                                   | **YES** |  |
 | `prif_local_data_pointer`                        | **YES** |  |
 | `prif_image_index`                               | **YES** |  |
-| `prif_image_index_with_team`                     | no |  |
-| `prif_image_index_with_team_number`              | no |  |
+| `prif_image_index_with_team`                     | **YES** |  |
+| `prif_image_index_with_team_number`              | *partial* | no support for sibling teams |
 
 ---
 

src/caffeine/coarray_queries_s.F90

@@ -45,51 +45,61 @@
     end associate
   end procedure
 
-  module procedure prif_image_index
-    integer :: dim, i
-    integer(c_int) :: prior_size, num_img
-    logical :: invalid_cosubscripts
-
-    call_assert(coarray_handle_check(coarray_handle))
+  subroutine image_index_helper(coarray_handle, sub, num_images, image_index)
+    implicit none
+    type(prif_coarray_handle), intent(in) :: coarray_handle
+    integer(c_int64_t), intent(in) :: sub(:)
+    integer(c_int), intent(in) :: num_images
+    integer(c_int), intent(out) :: image_index
 
-    invalid_cosubscripts = .false.
+    integer :: dim
+    integer(c_int) :: prior_size
 
-    check_subscripts: do i = 1, size(sub)
-       if (sub(i) .lt. coarray_handle%info%lcobounds(i) .or. sub(i) .gt. coarray_handle%info%ucobounds(i)) then
-          invalid_cosubscripts = .true.
-          exit check_subscripts
-       end if
-    end do check_subscripts
+    call_assert(coarray_handle_check(coarray_handle))
 
-    if (.not. invalid_cosubscripts) then
-      image_index = 1 + INT(sub(1) - coarray_handle%info%lcobounds(1), c_int)
+    associate (info => coarray_handle%info) 
+      call_assert(size(sub) == info%corank)
+      if (sub(1) .lt. info%lcobounds(1) .or. sub(1) .gt. info%ucobounds(1)) then
+        image_index = 0
+        return
+      end if
+      image_index = 1 + INT(sub(1) - info%lcobounds(1), c_int)
       prior_size = 1
       ! Future work: values of prior_size are invariant across calls w/ the same coarray_handle
       !  We could store them in the coarray metadata at allocation rather than redundantly
       ! computing them here, which would accelerate calls with corank > 1 by removing
       ! corank multiply/add operations and the loop-carried dependence
       do dim = 2, size(sub)
-        prior_size = prior_size * INT(coarray_handle%info%ucobounds(dim-1) - coarray_handle%info%lcobounds(dim-1) + 1, c_int)
-        image_index = image_index + INT(sub(dim) - coarray_handle%info%lcobounds(dim), c_int) * prior_size
+        prior_size = prior_size * INT(info%ucobounds(dim-1) - info%lcobounds(dim-1) + 1, c_int)
+        if (sub(dim) .lt. info%lcobounds(dim) .or. sub(dim) .gt. info%ucobounds(dim)) then
+          image_index = 0
+          return
+        end if
+        image_index = image_index + INT(sub(dim) - info%lcobounds(dim), c_int) * prior_size
        end do
-    end if
+    end associate
 
-    call prif_num_images(num_images=num_img)
-    if (invalid_cosubscripts .or. image_index .gt. num_img) then
+    if (image_index .gt. num_images) then
        image_index = 0
     end if
+  end subroutine
+
+  module procedure prif_image_index
+    call image_index_helper(coarray_handle, sub, current_team%info%num_images, image_index)
   end procedure
 
   module procedure prif_image_index_with_team
-    call_assert(coarray_handle_check(coarray_handle))
-
-    call unimplemented("prif_image_index_with_team")
+    call image_index_helper(coarray_handle, sub, team%info%num_images, image_index)
   end procedure
 
   module procedure prif_image_index_with_team_number
-    call_assert(coarray_handle_check(coarray_handle))
-
-    call unimplemented("prif_image_index_with_team_number")
+    if (team_number == -1) then
+      call image_index_helper(coarray_handle, sub, initial_team%num_images, image_index)
+    else if (team_number == current_team%info%team_number) then
+      call image_index_helper(coarray_handle, sub, current_team%info%num_images, image_index)
+    else
+      call unimplemented("prif_image_index_with_team_number: no support for sibling teams")
+    end if 
   end procedure
 
   module procedure prif_local_data_pointer

src/caffeine/image_queries_s.F90

@@ -19,7 +19,13 @@
   end procedure
 
   module procedure prif_num_images_with_team_number
-    call unimplemented("prif_num_images_with_team_number")
+    if (team_number == -1) then
+      num_images = initial_team%num_images 
+    else if (team_number == current_team%info%team_number) then
+      num_images = current_team%info%num_images
+    else
+      call unimplemented("prif_num_images_with_team_number: no support for sibling teams")
+    end if
   end procedure
 
   module procedure prif_this_image_no_coarray
@@ -31,15 +37,56 @@
   end procedure
 
   module procedure prif_this_image_with_coarray
+    integer(c_int) :: offset, doff, dsz
+    integer :: dim
+
     call_assert(coarray_handle_check(coarray_handle))
 
-    call unimplemented("prif_this_image_with_coarray")
+    if (present(team)) then
+      offset = team%info%this_image - 1
+    else
+      offset = current_team%info%this_image - 1
+    endif
+
+    associate (info => coarray_handle%info)
+      call_assert(size(cosubscripts) == info%corank)
+      do dim = 1, info%corank-1
+        dsz = INT(info%ucobounds(dim) - info%lcobounds(dim) + 1, c_int)
+        doff = mod(offset, dsz)
+        cosubscripts(dim) = doff + info%lcobounds(dim)
+        call_assert(cosubscripts(dim) <= info%ucobounds(dim))
+        offset = offset / dsz
+      end do
+      cosubscripts(info%corank) = offset + info%lcobounds(info%corank)
+      call_assert(cosubscripts(info%corank) <= info%ucobounds(info%corank))
+    end associate
+
+#   if ASSERTIONS
+      block ! sanity check
+        integer(c_int) :: image_index
+        if (present(team)) then
+          call prif_image_index_with_team(coarray_handle, cosubscripts, team, image_index)
+          call_assert(image_index == team%info%this_image)
+        else
+          call prif_image_index(coarray_handle, cosubscripts, image_index)
+          call_assert(image_index == current_team%info%this_image)
+        end if
+      end block
+#   endif
   end procedure
 
   module procedure prif_this_image_with_dim
     call_assert(coarray_handle_check(coarray_handle))
 
-    call unimplemented("prif_this_image_with_dim")
+    block
+      integer(c_int64_t) :: cosubscripts(coarray_handle%info%corank)
+
+      call_assert(dim >= 1 .and. dim <= coarray_handle%info%corank)
+
+      call prif_this_image_with_coarray(coarray_handle, team, cosubscripts)
+
+      cosubscript = cosubscripts(dim)
+    end block
   end procedure
 
   module procedure prif_failed_images

src/prif.F90

@@ -499,7 +499,7 @@ module subroutine prif_image_index_with_team_number(coarray_handle, sub, team_nu
       implicit none
       type(prif_coarray_handle), intent(in) :: coarray_handle
       integer(c_int64_t), intent(in) :: sub(:)
-      integer(c_int), intent(in) :: team_number
+      integer(c_int64_t), intent(in) :: team_number
       integer(c_int), intent(out) :: image_index
     end subroutine