Add team features to native-multi-image.F90 app

app/native-multi-image.F90

@@ -34,18 +34,35 @@ program native_multi_image
 #endif
 #ifndef HAVE_CO_BROADCAST
 #define HAVE_CO_BROADCAST HAVE_COLLECTIVES
+#endif
+#ifndef HAVE_TEAM
+#define HAVE_TEAM 1
 #endif
 
   USE, INTRINSIC :: ISO_FORTRAN_ENV
   integer :: me, ni, peer, tmp
   character(len=5) :: c
+# if HAVE_TEAM
+  integer :: team_id
+  type(TEAM_TYPE) :: subteam, res
+# endif
 
   me = THIS_IMAGE()
   ni = NUM_IMAGES()
   peer = MIN(IEOR(me-1,1)+1, ni)
 
   write(*,'(A,I1,A,I1,A)') "Hello, world! From image ", me, " of ", ni, " images"
 
+# if SET_EXCEPTIONS
+    block 
+       ! deliberately trigger IEEE arithmetic exceptions: INEXACT and UNDERFLOW
+       real :: r
+       r = 1e-30
+       r = r + r * r
+      write (*,*) r
+    end block
+# endif
+
 # if HAVE_SYNC_ALL
     call status("Testing SYNC ALL...")
     call sync_all
@@ -91,6 +108,24 @@ program native_multi_image
     call CO_BROADCAST(c,1)
 # endif
 
+# if HAVE_TEAM
+  call status("Testing TEAMS...")
+  res = GET_TEAM(CURRENT_TEAM)
+  res = GET_TEAM(INITIAL_TEAM)
+  res = GET_TEAM()
+  write(*,'(A,I3)') "Initial team number is ", TEAM_NUMBER()
+
+    team_id = merge(1, 2, me <= (ni+1)/2)
+
+  FORM TEAM(team_id, subteam)
+  SYNC TEAM(subteam)
+  CHANGE TEAM(subteam)
+    write(*,'(A,I3,A,I3,A,I3)') 'Inside CHANGE TEAM construct: ', THIS_IMAGE(), ' of ', NUM_IMAGES(), ' in team number ', TEAM_NUMBER()
+  END TEAM
+  call sync_all
+  write(*,'(A,I3)') "After END TEAM statement, TEAM_NUMBER() is ", TEAM_NUMBER()
+# endif
+
   call sync_all
   write(*,'(A,I1,A,I1,A)') "Goodbye from image ", me, " of ", ni, " images"
 

src/caffeine/caffeine.c

@@ -5,6 +5,8 @@
 #include <stdio.h>
 #include <stdbool.h>
 #include <assert.h>
+#include <math.h>
+#include <fenv.h>
 #include <gasnetex.h>
 #include <gasnet_coll.h>
 #include <gasnet_vis.h>
@@ -34,6 +36,22 @@ typedef uint8_t byte;
 static void event_init(void);
 static void atomic_init(void);
 
+// ---------------------------------------------------
+// Floating-point exception support
+
+#ifndef IEEE_FE_MASK
+#define IEEE_FE_MASK   FE_INEXACT
+#endif
+static fexcept_t fe_flag_save;
+void caf_fe_save(void) {
+  fegetexceptflag(&fe_flag_save, IEEE_FE_MASK);
+}
+void caf_fe_restore(void) {
+  fesetexceptflag(&fe_flag_save, IEEE_FE_MASK);
+}
+#define CHECK_INEXACT() \
+  printf("%3i: inexact flag = %s\n",__LINE__,fetestexcept(FE_INEXACT) & FE_INEXACT ? "YES" : "no")
+
 // ---------------------------------------------------
 int caf_this_image(gex_TM_t tm) {
   return gex_TM_QueryRank(tm) + 1;
@@ -142,7 +160,14 @@ void caf_allocate_remaining(mspace heap, void** allocated_space, size_t* allocat
   // nor necessarily the largest open space, but in practice is likely
   // to work out that way
   struct mallinfo heap_info = mspace_mallinfo(heap);
-  *allocated_size = heap_info.keepcost * 0.9f;
+
+  // clang's implementation of nearbyint() raises FE_INEXACT,
+  // in direct contradiction to its specified purpose.
+  // Workaround this defect by saving and restoring the FE flags
+  caf_fe_save();
+  *allocated_size = (size_t)nearbyint(heap_info.keepcost * 0.9f);
+  caf_fe_restore();
+
   *allocated_space = mspace_memalign(heap, 8, *allocated_size);
   if (!*allocated_space) // uh-oh, something went wrong..
     gasnett_fatalerror("caf_allocate_remaining failed to mspace_memalign(%"PRIuSZ")",