Merge pull request #72 from sourceryinstitute/cray-cray

Work around Cray Compiler Environment bugs & make tests more robust

fpm.toml

@@ -6,4 +6,4 @@ maintainer = "damian@archaeologic.codes"
 copyright = "2020-2023 Sourcery Institute"
 
 [dependencies]
-assert = {git = "https://github.com/sourceryinstitute/assert", tag = "1.5.0"}
+assert = {git = "https://github.com/sourceryinstitute/assert", tag = "1.6.0"}

src/sourcery/sourcery_formats_m.f90 → src/sourcery/sourcery_formats_m.F90

@@ -5,6 +5,8 @@ module sourcery_formats_m
   character(len=*), parameter :: csv = "(*(G0,:,','))" !! comma-separated values
   character(len=*), parameter :: cscv = "(*('(',G0,',',G0,')',:,',')))" !! comma-separated complex values
 
+
+#ifndef _CRAYFTN
   interface
 
     pure module function separated_values(separator, mold) result(format_string)
@@ -14,5 +16,16 @@ pure module function separated_values(separator, mold) result(format_string)
     end function
 
   end interface
+#else
+  interface separated_values
+
+    pure module function separated_values_1D(separator, mold) result(format_string)
+      character(len=*), intent(in) :: separator 
+      class(*), intent(in) :: mold(:)
+      character(len=:), allocatable :: format_string
+    end function
+
+  end interface
+#endif
 
 end module

src/sourcery/sourcery_formats_s.f90 → src/sourcery/sourcery_formats_s.F90

@@ -4,6 +4,8 @@
 
 contains
 
+#ifndef _CRAYFTN
+
   module procedure separated_values
     character(len=*), parameter :: prefix = "(*(G0,:,'"
     character(len=*), parameter :: suffix =           "'))"
@@ -28,4 +30,28 @@
     end select
   end procedure
 
+#else
+
+  module procedure separated_values_1D
+    character(len=*), parameter :: prefix = "(*(G0,:,'"
+    character(len=*), parameter :: suffix =           "'))"
+    character(len=*), parameter :: complex_prefix = "(*('(',G0,',',G0,')',:,'" 
+
+    select type(mold)
+      type is(complex)
+        format_string = complex_prefix // separator // suffix
+      type is(real)
+        format_string = prefix // separator // suffix
+      type is(integer)
+        format_string = prefix // separator // suffix
+      type is(character(len=*))
+        format_string = prefix // separator // suffix
+      class default
+         error stop "format_s separated_values_1D: unsupported type"
+    end select
+  end procedure
+
+
+#endif
+
 end submodule sourcery_formats_s

src/sourcery/sourcery_string_m.f90

@@ -57,7 +57,7 @@ elemental module function from_real(x) result(string)
 
   interface operator(.cat.)
 
-    pure module function concatenate_elements(strings) result(concatenated_strings)
+   pure  module function concatenate_elements(strings) result(concatenated_strings)
       implicit none
       type(string_t), intent(in) :: strings(:)
       type(string_t) concatenated_strings

src/sourcery/sourcery_string_s.f90

@@ -25,17 +25,14 @@
   end procedure
 
   module procedure from_real
-    integer, parameter :: sign_ = 1, decimal_ = 1, digits = precision(x) + 6, exponent = 4
-    character(len=sign_ + decimal_ + digits + exponent) characters
+    character(len=100) characters
     write(characters, '(g0)') x
     string = string_t(characters)
   end procedure
 
   module procedure concatenate_elements
     integer s 
 
-    !allocate(concatenated_strings(sum(len(strings%string()))))
-
     concatenated_strings = ""
     do s = 1, size(strings)
       concatenated_strings = concatenated_strings // strings(s)%string()

src/sourcery/sourcery_test_s.f90 → src/sourcery/sourcery_test_s.F90

@@ -8,6 +8,8 @@
 
     associate(me => this_image())
       if (me==1) print *, new_line('a'), test%subject()
+
+#ifndef _CRAYFTN
       associate(test_results => test%results())
         associate(num_tests => size(test_results))
           tests = tests + num_tests
@@ -30,6 +32,30 @@
           end block
         end associate
       end associate
+#else
+      block
+        logical, allocatable :: passing_tests(:)
+        type(test_result_t), allocatable :: test_results(:)
+        integer i
+
+        test_results = test%results()
+        associate(num_tests => size(test_results))
+          tests = tests + num_tests
+          if (me==1) then
+            do i=1,num_tests
+              if (me==1) print *,"   ",test_results(i)%characterize()
+            end do
+          end if
+          passing_tests = test_results%passed()
+          call co_all(passing_tests)
+          associate(num_passes => count(passing_tests))
+            if (me==1) print '(a,2(i0,a))'," ",num_passes," of ", num_tests," tests pass."
+            passes = passes + num_passes
+          end associate
+        end associate
+      end block
+#endif
+
     end associate
 
   end procedure

test/data_partition_test.f90 → test/data_partition_test.F90

@@ -43,55 +43,87 @@ function results() result(test_results)
   function verify_block_partitioning() result(test_passes)
     !! Verify that the data is partitioned across images evenly to
     !! within a difference of one datum between any two images.
-    type(data_partition_t) partition
     logical test_passes
-    integer my_particles
 
+#ifndef _CRAYFTN
     associate( me=>this_image(), partition => data_partition_t(cardinality=num_particles))
       associate( my_first=>partition%first(me), my_last=>partition%last(me) )
-        my_particles = my_last - my_first + 1
-        associate( ni=>num_images() )
+        associate( ni=>num_images(), my_particles => my_last - my_first + 1)
+          associate( quotient=>num_particles/ni, remainder=>mod(num_particles,ni)  )
+            test_passes = quotient + merge(1, 0, me<=remainder) == my_particles
+          end associate
+        end associate
+      end associate
+    end associate
+#else
+    type(data_partition_t) partition
+
+    associate(me=>this_image())
+      partition = data_partition_t(cardinality=num_particles)
+      associate( my_first=>partition%first(me), my_last=>partition%last(me) )
+        associate( ni=>num_images(), my_particles => my_last - my_first + 1)
           associate( quotient=>num_particles/ni, remainder=>mod(num_particles,ni)  )
             test_passes = quotient + merge(1, 0, me<=remainder) == my_particles
           end associate
         end associate
       end associate
     end associate
+#endif
 
   end function
 
   function verify_default_image_number() result(test_passes)
     !! Verify that the first and last functions assume image_number == this_image() if image_number is not  present
-    type(data_partition_t) partition
     logical test_passes
 
+#ifndef _CRAYFTN
     associate( me=>this_image(), partition => data_partition_t(cardinality=num_particles))
       test_passes = partition%first() == partition%first(me) .and.partition%last() == partition%last(me)
     end associate
+#else
+    type(data_partition_t) partition
+
+    partition = data_partition_t(cardinality=num_particles)
+    associate( me=>this_image())
+      test_passes = partition%first() == partition%first(me) .and. partition%last() == partition%last(me)
+    end associate
+#endif
   end function
 
   function verify_all_particles_partitioned() result(test_passes)
     !! Verify that the number of particles on each image sums to the
     !! total number of particles distributed.
-    type(data_partition_t) partition
     logical test_passes
     integer particles
 
-    associate( me=>this_image(), partition => data_partition_t(cardinality=num_particles))
-      associate( my_first=>partition%first(me), my_last=>partition%last(me) )
+#ifndef _CRAYFTN
+    associate(me => this_image(), partition => data_partition_t(cardinality=num_particles))
+      associate(my_first=>partition%first(me), my_last=>partition%last(me))
+        particles = my_last - my_first + 1
+        call co_sum(particles)
+        test_passes = num_particles == particles
+      end associate
+    end associate
+#else
+    type(data_partition_t) partition
+
+    partition = data_partition_t(cardinality=num_particles)
+    associate(me=>this_image())
+      associate(my_first=>partition%first(me), my_last=>partition%last(me))
         particles = my_last - my_first + 1
         call co_sum(particles)
         test_passes = num_particles == particles
       end associate
     end associate
+#endif
   end function
 
  function verify_all_gather_1D_real_array() result(test_passes)
-   type(data_partition_t) partition
    logical test_passes
    real(real64) :: particle_scalar(num_particles)
    real(real64), parameter :: junk=-12345._real64, expected=1._real64
 
+#ifndef _CRAYFTN
    associate( me=>this_image(), partition => data_partition_t(cardinality=num_particles))
      associate( first=>partition%first(me), last=>partition%last(me) )
        particle_scalar(first:last) = expected !! values to be gathered
@@ -101,56 +133,93 @@ function verify_all_gather_1D_real_array() result(test_passes)
        test_passes = all(particle_scalar==expected)
      end associate
    end associate
+#else
+   type(data_partition_t) partition
+
+   associate( me=>this_image())
+     partition = data_partition_t(cardinality=num_particles)
+     associate( first=>partition%first(me), last=>partition%last(me) )
+       particle_scalar(first:last) = expected !! values to be gathered
+       particle_scalar(1:first-1)  = junk !! values to be overwritten by the gather
+       particle_scalar(last+1:)  = junk !! values to be overwritten by the gather
+       call partition%gather(particle_scalar)
+       test_passes = all(particle_scalar==expected)
+     end associate
+   end associate
+#endif
  end function
 
  function verify_all_gather_2D_real_array() result(test_passes)
-   type(data_partition_t) partition
    logical test_passes
    integer, parameter :: vec_space_dim=3
    real(real64) particle_vector(vec_space_dim, num_particles)
    real(real64), parameter :: junk=-12345._real64, expected=1._real64
 
+#ifndef _CRAYFTN
    associate( me=>this_image(), partition => data_partition_t(cardinality=num_particles))
      associate( first=>partition%first(me), last=>partition%last(me) )
+       particle_vector(:, first:last) = expected !! values to be gathered
+       particle_vector(:, 1:first-1)  = junk !! values to be overwritten by the gather
+       particle_vector(:, last+1:)  = junk !! values to be overwritten by the gather
+       call partition%gather(particle_vector)
+       test_passes = all(particle_vector==expected)
+     end associate
+   end associate
+#else
+   type(data_partition_t) partition
 
+   associate( me=>this_image())
+     partition = data_partition_t(cardinality=num_particles)
+     associate( first=>partition%first(me), last=>partition%last(me) )
        particle_vector(:, first:last) = expected !! values to be gathered
        particle_vector(:, 1:first-1)  = junk !! values to be overwritten by the gather
        particle_vector(:, last+1:)  = junk !! values to be overwritten by the gather
        call partition%gather(particle_vector)
        test_passes = all(particle_vector==expected)
      end associate
    end associate
+#endif
  end function
 
  function verify_all_gather_2D_real_array_dim1() result(test_passes)
-   type(data_partition_t) partition
    logical test_passes
    integer, parameter :: vec_space_dim=3
    real(real64) :: vector_transpose(num_particles, vec_space_dim)
    real(real64), parameter :: junk=-12345._real64, expected=1._real64
 
+#ifndef _CRAYFTN
    associate( me=>this_image(), partition => data_partition_t(cardinality=num_particles))
      associate( first=>partition%first(me), last=>partition%last(me) )
-
        vector_transpose(first:last, :) = expected !! values to be gathered
        vector_transpose(1:first-1, :)  = junk !! values to be overwritten by the gather
        vector_transpose(last+1:, :)  = junk !! values to be overwritten by the gather
-
        call partition%gather( vector_transpose, dim=1)
-
        test_passes= all(vector_transpose==expected)
+      end associate
+    end associate
+#else
+   type(data_partition_t) partition
 
+   associate(me=>this_image())
+     partition = data_partition_t(cardinality=num_particles)
+     associate( first=>partition%first(me), last=>partition%last(me) )
+       vector_transpose(first:last, :) = expected !! values to be gathered
+       vector_transpose(1:first-1, :)  = junk !! values to be overwritten by the gather
+       vector_transpose(last+1:, :)  = junk !! values to be overwritten by the gather
+       call partition%gather( vector_transpose, dim=1)
+       test_passes= all(vector_transpose==expected)
       end associate
     end associate
+#endif
  end function
 
  function verify_gather_2D_real_array_dim1() result(test_passes)
-   type(data_partition_t) partition
    logical test_passes
    integer, parameter :: vec_space_dim=3
    real(real64) :: vector_transpose(num_particles, vec_space_dim)
    real(real64), parameter :: junk=-12345._real64, expected=1._real64
 
+#ifndef _CRAYFTN
    associate( me=>this_image(), partition => data_partition_t(cardinality=num_particles))
      associate( first=>partition%first(me), last=>partition%last(me) )
 
@@ -171,6 +240,31 @@ function verify_gather_2D_real_array_dim1() result(test_passes)
 
      end associate
    end associate
+#else
+   type(data_partition_t) partition
+
+   associate(me=>this_image())
+     partition = data_partition_t(cardinality=num_particles)
+     associate( first=>partition%first(me), last=>partition%last(me) )
+
+       vector_transpose(first:last, :) = expected !! values to be gathered
+       vector_transpose(1:first-1, :)  = junk !! values to be overwritten by the gather
+       vector_transpose(last+1:, :)  = junk !! values to be overwritten by the gather
+
+       call partition%gather( vector_transpose, result_image=gatherer, dim=1)
+
+       if (me==gatherer) then
+         test_passes = all(vector_transpose==expected)
+       else
+         test_passes = &
+           all(vector_transpose(1:first-1,:)==junk) .and. &
+           all(vector_transpose(first:last,:)==expected) .and. &
+           all(vector_transpose(last+1:,:)==junk)
+       end if
+
+     end associate
+   end associate
+#endif
  end function
 
 end module data_partition_test_m