Merge branch 'main' into compile-with-nag

Author: Damian Rouson

fpm.toml

@@ -5,6 +5,9 @@ author = ["Damian Rouson"]
 maintainer = "[email protected]"
 copyright = "2020 Sourcery Institute"
 
+[dependencies]
+assert = {git = "https://github.com/sourceryinstitute/assert", tag = "1.0.0"}
+
 [dev-dependencies]
 vegetables = {git = "https://gitlab.com/everythingfunctional/vegetables", tag = "v7.2.0"}
 

src/array_functions_implementation.f90

@@ -5,15 +5,15 @@
 !     contract # NRC-HQ-60-17-C-0007
 !
 submodule(array_functions_interface) array_functions_implementation
-  use assertions_interface, only : assert, assertions
+  use assert_m, only : assert
   implicit none
 contains
 
   module procedure column_vectors
       integer i, j, k
 
       associate( n => shape(vector_field) )
-        if (assertions) call assert(size(n)==4, "3D vector field input")
+        call assert(size(n)==4, "3D vector field input")
         allocate( array_of_3D_column_vectors( n(4), product(n(1:3)) ) )
         do concurrent( i=1:n(1), j=1:n(2), k=1:n(3) )
           associate( id => (k-1)*PRODUCT(n(1:2)) + (j-1)*n(1) + i )
@@ -34,7 +34,7 @@
     associate(cols=>size(a,2)+size(b,2))
     associate(a_unrolled=>reshape(a,[size(a)]))
     associate(b_unrolled=>reshape(b,[size(b)]))
-      if (assertions) call assert( rows==size(b,1), "array_functions: compatible shapes")
+      call assert( rows==size(b,1), "array_functions: compatible shapes")
       concatenated = reshape( [a_unrolled, b_unrolled ],[rows, cols] )
     end associate; end associate; end associate; end associate
   end procedure

src/assertions_implementation.F90

@@ -1,5 +1,5 @@
 submodule(data_partition_interface) data_partition_implementation
-  use assertions_interface, only : assert, assertions
+  use assert_m, only : assert
 #ifdef COMPILER_LACKS_COLLECTIVE_SUBROUTINES
   use emulated_intrinsics_interface, only: co_sum
 #endif
@@ -48,12 +48,12 @@ pure function overflow(im, excess) result(extra_datum)
 #endif
 
   module procedure first
-    if (assertions) call assert( allocated(first_datum), "allocated(first_datum)")
+    call assert( allocated(first_datum), "allocated(first_datum)")
     first_index= first_datum( image_number )
   end procedure
 
   module procedure last
-    if (assertions) call assert( allocated(last_datum), "allocated(last_datum)")
+    call assert( allocated(last_datum), "allocated(last_datum)")
     last_index = last_datum( image_number )
   end procedure
 

src/assertions_interface.F90

@@ -5,7 +5,7 @@
 !     contract # NRC-HQ-60-17-C-0007
 !
 submodule(emulated_intrinsics_interface) emulated_intrinsics_implementation
-  use assertions_interface, only : assert
+  use assert_m, only : assert
   implicit none
 
 contains

src/data-partition-implementation.F90

@@ -0,0 +1,130 @@
+!
+!     (c) 2019-2020 Guide Star Engineering, LLC
+!     This Software was developed for the US Nuclear Regulatory Commission (US NRC) under contract
+!     "Multi-Dimensional Physics Implementation into Fuel Analysis under Steady-state and Transients (FAST)",
+!     contract # NRC-HQ-60-17-C-0007
+!
+submodule(units_interface) units_implementation
+    use assertions_interface, only : assertions,assert
+    implicit none
+
+    contains
+
+        module procedure set_units
+            !! define units exponents
+            this%exponents_ = exponents
+            this%system= system
+        end procedure
+
+        module procedure get_system
+            system_of_units = this%system
+        end procedure
+
+        module procedure get_units
+            exponents = this%exponents_
+        end procedure
+
+        module procedure assign_units
+            lhs%exponents_ = rhs%exponents_
+            lhs%system = rhs%system
+        end procedure
+
+        module procedure is_dimensionless
+            nondimensional = all([this%exponents_==0]) .and. this%system==dimensionless
+        end procedure
+
+        module procedure has_length_units
+            length_units = this%exponents_(m)==1 .and. all(this%exponents_([kg,sec,K])==0)
+        end procedure
+
+        module procedure has_mass_units
+            mass_units = this%exponents_(kg)==1 .and. all(this%exponents_([m,sec,K])==0)
+        end procedure
+
+        module procedure has_time_units
+            time_units = this%exponents_(sec)==1 .and. all(this%exponents_([m,kg,K])==0)
+        end procedure
+
+        module procedure has_temperature_units
+            temperature_units = this%exponents_(K)==1 .and. all(this%exponents_([m,kg,sec])==0)
+        end procedure
+
+        module procedure has_velocity_units
+            velocity_units = all(this%exponents_([m,sec])==[1,-1]) .and. all(this%exponents_([kg,K])==0)
+        end procedure
+
+        module procedure has_energy_units
+            energy_units = all(this%exponents_([kg,m,sec])==[1,2,-2]) .and. this%exponents_(K)==0
+        end procedure
+
+        module procedure has_density_units
+            density_units = all(this%exponents_([kg,m])==[1,-3]) .and. all(this%exponents_([sec,K])==0)
+        end procedure
+
+        module procedure has_specific_energy_units
+            specific_energy_units = all(this%exponents_([m,sec])==[2,-2]) .and. all(this%exponents_([kg,K])==0)
+        end procedure
+
+        module procedure has_stress_units
+            stress_units = all(this%exponents_([kg,m,sec])==[1,-1,-2]) .and. this%exponents_(K)==0
+        end procedure
+
+        module procedure has_power_units
+            power_units = all(this%exponents_([kg,m,sec])==[1,2,-3]) .and. this%exponents_(K)==0
+        end procedure
+
+        module procedure integer_power
+            this_raised%system = this%system
+            this_raised%exponents_ = exponent_*this%exponents_
+        end procedure
+
+        module procedure real_power
+            if (assertions) call assert(this%is_dimensionless(), &
+                &   "units%real_power: an entity raised to a real power must be dimensionless")
+            !! Require dimensionless operand => result is default-initialized as dimensionless
+        end procedure
+
+        module procedure negate
+            negative_this%exponents_ = this%exponents_
+            negative_this%system= this%system
+        end procedure
+
+        module procedure add
+            if (assertions) then
+                !! Require consistent operand units
+                associate(preconditions => [lhs%system==rhs%system, lhs%exponents_==rhs%exponents_] )
+                    call assert( all(preconditions), "units%add: consistent operands units")
+                end associate
+            end if
+            total%exponents_  = lhs%exponents_
+            total%system = lhs%system
+        end procedure
+
+        module procedure subtract
+            if (assertions) then
+                !! Require consistent operand units
+                associate(preconditions => [lhs%system==rhs%system, lhs%exponents_==rhs%exponents_] )
+                    call assert( all(preconditions), "units%subtract: consistent operand units")
+                end associate
+            end if
+            difference%exponents_  = lhs%exponents_
+            difference%system = lhs%system
+        end procedure
+
+        module procedure multiply
+
+            if (assertions) call assert( lhs%system==rhs%system, "units%multiply: consistent operand units" )
+
+            product_%exponents_  = lhs%exponents_ + rhs%exponents_
+            product_%system = lhs%system
+        end procedure
+
+        module procedure divide
+
+            if (assertions) call assert( numerator%system==denominator%system, "units%divide: consistent operand units" )
+
+            ratio%exponents_  = numerator%exponents_ - denominator%exponents_
+            ratio%system = merge(numerator%system,dimensionless,any(ratio%exponents_/=0))
+        end procedure
+
+end submodule units_implementation