Merge pull request #8 from sourceryinstitute/nag-workaround

Add multidimensional array support and work around missing assumed-rank in NAG

Author: Damian Rouson

.gitignore

@@ -34,3 +34,6 @@ build
 *.exe
 *.out
 *.app
+
+# FORD-generated documentation files
+doc/html

doc-generator.md

@@ -0,0 +1,15 @@
+---
+project: Assert library 
+summary: A toolkit for checking runtime assertions.
+src_dir: src/
+exclude_dir: doc
+output_dir: doc/html
+preprocess: true
+macro: FORD
+preprocessor: gfortran -E
+display: public
+         protected
+         private
+source: true
+graph: true
+md_extensions: markdown.extensions.toc

src/assert_s.f90 renamed to src/assert_s.F90

@@ -56,7 +56,11 @@
 
     end if toggle_assertions
 
+#ifndef FORD
   contains
+#else
+  end procedure
+#endif
 
     pure function string(numeric) result(number_as_string)
       !! Result is a string represention of the numeric argument
@@ -82,6 +86,8 @@ pure function string(numeric) result(number_as_string)
 
     end function string
 
+#ifndef FORD
   end procedure
+#endif
 
 end submodule

src/intrinsic_array_m.f90 renamed to src/intrinsic_array_m.F90

@@ -7,10 +7,20 @@ module intrinsic_array_m
   public :: intrinsic_array_t
 
   type, extends(characterizable_t) :: intrinsic_array_t
-    complex, allocatable :: c(:)
-    integer, allocatable :: i(:)
-    logical, allocatable :: l(:)
-    real, allocatable :: r(:)
+    complex, allocatable :: complex_1D(:)
+    integer, allocatable :: integer_1D(:)
+    logical, allocatable :: logical_1D(:)
+    real,    allocatable :: real_1D(:)
+
+    complex, allocatable :: complex_2D(:,:)
+    integer, allocatable :: integer_2D(:,:)
+    logical, allocatable :: logical_2D(:,:)
+    real,    allocatable :: real_2D(:,:)
+
+    complex, allocatable :: complex_3D(:,:,:)
+    integer, allocatable :: integer_3D(:,:,:)
+    logical, allocatable :: logical_3D(:,:,:)
+    real,    allocatable :: real_3D(:,:,:)
   contains
     procedure :: as_character
   end type
@@ -19,7 +29,11 @@ module intrinsic_array_m
 
     pure module function construct(array) result(intrinsic_array)
       implicit none
+#ifndef NAGFOR
       class(*), intent(in) :: array(..)
+#else
+      class(*), intent(in) :: array(:)
+#endif
       type(intrinsic_array_t) intrinsic_array
     end function
 

src/intrinsic_array_s.F90

@@ -0,0 +1,97 @@
+submodule(intrinsic_array_m) intrinsic_array_s
+  implicit none
+
+contains
+
+  module procedure construct
+
+#ifndef NAGFOR
+    select rank(array)
+    rank(1)
+#endif
+      select type(array)
+      type is(complex)
+        intrinsic_array%complex_1D = array
+      type is(integer)
+        intrinsic_array%integer_1D = array
+      type is(logical)
+        intrinsic_array%logical_1D = array
+      type is(real)
+        intrinsic_array%real_1D = array
+      class default
+        error  stop "intrinsic_array_t construct: unsupported rank-2 type"
+      end select
+#ifndef NAGFOR
+    rank(2)
+      select type(array)
+      type is(complex)
+        intrinsic_array%complex_2D = array
+      type is(integer)
+        intrinsic_array%integer_2D = array
+      type is(logical)
+        intrinsic_array%logical_2D = array
+      type is(real)
+        intrinsic_array%real_2D = array
+      class default
+        error  stop "intrinsic_array_t construct: unsupported rank-2 type"
+      end select
+
+    rank(3)
+      select type(array)
+      type is(complex)
+        intrinsic_array%complex_3D = array
+      type is(integer)
+        intrinsic_array%integer_3D = array
+      type is(logical)
+        intrinsic_array%logical_3D = array
+      type is(real)
+        intrinsic_array%real_3D = array
+      class default
+        error  stop "intrinsic_array_t construct: unsupported rank-3 type"
+      end select
+
+    rank default
+      error  stop "intrinsic_array_t construct: unsupported rank"
+    end select
+#endif
+
+  end procedure
+  
+  module procedure as_character
+    integer, parameter :: single_number_width=32
+
+    if (1 /= count( & 
+      [ allocated(self%complex_1D), allocated(self%integer_1D), allocated(self%logical_1D), allocated(self%real_1D) & 
+       ,allocated(self%complex_2D), allocated(self%integer_2D), allocated(self%logical_2D), allocated(self%real_2D) &
+      ])) error stop "intrinsic_array_t as_character: ambiguous component allocation status."
+
+    if (allocated(self%complex_1D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D))
+      write(character_self, *) self%complex_1D
+    else if (allocated(self%integer_1D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%integer_1D))
+      write(character_self, *) self%integer_1D
+    else if (allocated(self%logical_1D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
+      write(character_self, *) self%logical_1D
+    else if (allocated(self%real_1D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%real_1D))
+      write(character_self, *) self%real_1D
+    else if (allocated(self%complex_2D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%complex_2D))
+      write(character_self, *) self%complex_2D
+    else if (allocated(self%integer_2D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%integer_2D))
+      write(character_self, *) self%integer_2D
+    else if (allocated(self%logical_2D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
+      write(character_self, *) self%logical_2D
+    else if (allocated(self%real_2D)) then
+      character_self = repeat(" ", ncopies = single_number_width*size(self%real_2D))
+      write(character_self, *) self%real_2D
+    end if
+
+    character_self = trim(adjustl(character_self))
+  end procedure 
+
+end submodule intrinsic_array_s

src/intrinsic_array_s.f90

@@ -43,7 +43,21 @@ pure function both(lhs,rhs) result(lhs_or_rhs)
   subroutine co_all(boolean)
     logical, intent(inout) :: boolean
 
+#ifndef NAGFOR
     call co_reduce(boolean, both)
+#else
+    ! Because parallel NAG runs happen in shared memory and because this function is called only once in 
+    ! one test, a simplistic, non-scalable reduction algorithm suffices until co_reduce is supported.
+    block
+      logical, save :: my_boolean[*]
+      integer i
+
+      my_boolean = boolean
+      do i=1,num_images()
+        my_boolean = my_boolean .and.  my_boolean[i]
+      end do
+    end block
+#endif
 
   end subroutine