fix: work around gfortran bugs

Author: rouson

src/matcha/distribution_s.F90

@@ -39,7 +39,7 @@ pure function monotonically_increasing(f) result(monotonic)
   module procedure velocities
 
     double precision, allocatable :: sampled_speeds(:,:),  dir(:,:,:)
-    integer cell, step
+    integer cell, step, k
 
     call_assert(allocated(self%cumulative_distribution_)) 
     call_assert(allocated(self%vel_))
@@ -48,9 +48,8 @@ pure function monotonically_increasing(f) result(monotonic)
     associate(ncells => size(speeds,1), nsteps => size(speeds,2))
       allocate(sampled_speeds(ncells,nsteps))
       do concurrent(cell = 1:ncells, step = 1:nsteps)
-        associate(k => findloc(speeds(cell,step) >= self%cumulative_distribution(), value=.false., dim=1)-1)
-          sampled_speeds(cell,step) = self%vel_(k)
-        end associate
+        k = findloc(speeds(cell,step) >= self%cumulative_distribution(), value=.false., dim=1)-1
+        sampled_speeds(cell,step) = self%vel_(k)
       end do
 
       ! Create unit vectors

src/matcha/output_s.f90

@@ -51,8 +51,8 @@ pure function sim_speeds(history) result(speeds)
       double precision, allocatable :: speeds(:)
 
       integer, parameter :: nspacedims=3
-      integer i, j, k
-      double precision, allocatable :: x(:,:,:)
+      integer i, j, k, ij
+      double precision, allocatable :: x(:,:,:), t(:), u(:)
 
       associate( &
         npositions => size(history,1), &
@@ -62,17 +62,13 @@ pure function sim_speeds(history) result(speeds)
         do concurrent(i=1:npositions)
           x(i,:,:) = history(i)%positions()
         end do
-        associate(t => history%time())
-          allocate(speeds(ncells*(npositions-1)))
-          do concurrent(i = 1:npositions-1, j = 1:ncells)
-            associate( &
-              u => (x(i+1,j,:) - x(i,j,:))/(t(i+1) - t(i)), &
-              ij => i + (j-1)*(npositions-1) &
-            )   
-              speeds(ij) = sqrt(sum([(u(k)**2, k=1,nspacedims)]))
-            end associate
-          end do
-        end associate
+        t = history%time()
+        allocate(speeds(ncells*(npositions-1)))
+        do concurrent(i = 1:npositions-1, j = 1:ncells)
+          u = (x(i+1,j,:) - x(i,j,:))/(t(i+1) - t(i))
+          ij = i + (j-1)*(npositions-1)
+          speeds(ij) = sqrt(sum([(u(k)**2, k=1,nspacedims)]))
+        end do
       end associate
     end function
 

test/matcha_test_m.F90

@@ -5,14 +5,15 @@
 
 module matcha_test_m
   use julienne_m, only : &
-     string_t, &
-     test_t, &
-     test_diagnosis_t &
-    ,vector_test_description_t &
-#if ! HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY
-    ,vector_diagnosis_function_i &
+     string_t &
+#if __GFORTRAN__
+    ,diagnosis_function_i &
+    ,test_description_t &
 #endif
-    ,test_result_t
+    ,test_diagnosis_t &
+    ,vector_test_description_t &
+    ,test_result_t &
+    ,test_t
   use input_m, only : input_t
   use output_m, only : output_t
   use matcha_m, only : matcha
@@ -35,6 +36,7 @@ pure function subject() result(specimen)
     specimen = "A matcha_t object"
   end function
 
+#ifndef __GFORTRAN__
   function results() result(test_results)
     type(test_result_t), allocatable :: test_results(:)
     type(vector_test_description_t), allocatable :: vector_test_descriptions(:)
@@ -54,7 +56,26 @@ function results() result(test_results)
       test_results = vector_test_descriptions(i)%run()
     end do
   end function
+#else
+  function results() result(test_results)
+    type(test_result_t), allocatable :: test_results(:)
+    type(test_description_t), allocatable :: test_descriptions(:)
+    procedure(diagnosis_function_i), pointer :: &
+       compare_image_distributions_ptr &
+      ,compare_global_distributions_ptr
+
+       compare_image_distributions_ptr => compare_image_distributions
+       compare_global_distributions_ptr => compare_global_distributions
+
+    test_descriptions = [ &
+       test_description_t("matching simulated distributions to empirical distribution", compare_image_distributions_ptr) &
+      ,test_description_t("matching simulated global distributions to empirical distribution", compare_global_distributions_ptr) &
+    ]
+    test_results = test_descriptions%run()
+  end function
+#endif
 
+#ifndef __GFORTRAN__
   function compare_image_distributions() result(test_diagnoses)
     logical test_passes
     type(test_diagnosis_t), allocatable :: test_diagnoses(:)
@@ -87,7 +108,37 @@ function compare_image_distributions() result(test_diagnoses)
       end associate
     end associate
   end function
-  
+#else
+  function compare_image_distributions() result(test_diagnosis)
+    logical test_passes
+    type(test_diagnosis_t) test_diagnosis
+    type(output_t) output
+    
+    integer, parameter :: speed=1, freq=2 ! subscripts for speeds and frequencies
+    double precision, parameter :: tolerance = 1.D-02
+
+    associate(input => input_t())
+      output = output_t(input, matcha(input))
+      associate( &
+        empirical_distribution => input%sample_distribution(), &
+        simulated_distribution => output%simulated_distribution() &
+      )
+        associate( &
+          diffmax_speeds=> maxval(abs(empirical_distribution(:,speed)-simulated_distribution(:,speed))), &
+          diffmax_freqs => maxval(abs(empirical_distribution(:,freq)-simulated_distribution(:,freq))) &
+        )
+          test_diagnosis =  test_diagnosis_t( &
+             test_passed = diffmax_freqs < tolerance .and. diffmax_speeds < tolerance &
+            ,diagnostics_string = "diffmax_speeds " // string_t(diffmax_speeds) // ", diffmax_freqs " // string_t(diffmax_freqs) &
+              // ", expected < " // string_t(tolerance) &
+          )
+        end associate
+      end associate
+    end associate
+  end function
+#endif
+
+#ifndef __GFORTRAN__
   function compare_global_distributions() result(test_diagnoses)
     type(test_diagnosis_t), allocatable :: test_diagnoses(:)
     type(output_t) output
@@ -128,5 +179,42 @@ function compare_global_distributions() result(test_diagnoses)
     end associate
 
   end function
+#else
+  function compare_global_distributions() result(test_diagnosis)
+    type(test_diagnosis_t) test_diagnosis
+    type(output_t) output
+    double precision, allocatable :: simulated_distribution(:,:)
+    integer num_cells
+    integer, parameter :: speed=1, freq=2 ! subscripts for speeds and frequencies
+    double precision, parameter :: tolerance = 1.D-02
+
+    associate(input => input_t())
+      output = output_t(input, matcha(input))
+      associate(empirical_distribution => input%sample_distribution())
+        simulated_distribution = output%simulated_distribution()  
+        num_cells = output%my_num_cells()
+        simulated_distribution(:,freq) = num_cells*simulated_distribution(:,freq)
+        call co_sum(simulated_distribution(:,freq), result_image=1)
+        call co_sum(num_cells, result_image=1)
+        if (this_image()/=1) then
+          test_diagnosis = test_diagnosis_t(test_passed=.true., diagnostics_string="")
+        else
+          simulated_distribution(:,freq) = simulated_distribution(:,freq)/dble(num_cells)
+          associate( &
+            diffmax_speeds=> maxval(abs(empirical_distribution(:,speed)-simulated_distribution(:,speed))), &
+            diffmax_freqs => maxval(abs(empirical_distribution(:,freq)-simulated_distribution(:,freq))) &
+          )
+            test_diagnosis =  test_diagnosis_t( &
+               test_passed = diffmax_freqs < tolerance .and. diffmax_speeds < tolerance &
+              ,diagnostics_string = "diffmax_speeds " // string_t(diffmax_speeds) // ", diffmax_freqs " // string_t(diffmax_freqs) &
+                // ", expected < " // string_t(tolerance) &
+            )
+          end associate
+        end if
+      end associate
+    end associate
+
+  end function
+#endif
 
 end module matcha_test_m