From 625929f23692c32a48f0bd82370d27b4c7594350 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Wed, 7 Feb 2024 00:16:53 -0500 Subject: [PATCH 1/2] fix(intrinsic_array): cray compiler bug workaround --- ...nsic_array_m.f90 => intrinsic_array_m.F90} | 36 +++++++ ...nsic_array_s.f90 => intrinsic_array_s.F90} | 100 ++++++++++++++++-- 2 files changed, 128 insertions(+), 8 deletions(-) rename src/assert/{intrinsic_array_m.f90 => intrinsic_array_m.F90} (65%) rename src/assert/{intrinsic_array_s.f90 => intrinsic_array_s.F90} (65%) diff --git a/src/assert/intrinsic_array_m.f90 b/src/assert/intrinsic_array_m.F90 similarity index 65% rename from src/assert/intrinsic_array_m.f90 rename to src/assert/intrinsic_array_m.F90 index 53c9716..339c22c 100644 --- a/src/assert/intrinsic_array_m.f90 +++ b/src/assert/intrinsic_array_m.F90 @@ -33,11 +33,47 @@ module intrinsic_array_m interface intrinsic_array_t +#ifndef _CRAYFTN + pure module function construct(array) result(intrinsic_array) implicit none class(*), intent(in) :: array(..) type(intrinsic_array_t) intrinsic_array end function + +#else + + pure module function complex_array(array) result(intrinsic_array) + implicit none + complex, intent(in) :: array(..) + type(intrinsic_array_t) intrinsic_array + end function + + pure module function integer_array(array) result(intrinsic_array) + implicit none + integer, intent(in) :: array(..) + type(intrinsic_array_t) intrinsic_array + end function + + pure module function logical_array(array) result(intrinsic_array) + implicit none + logical, intent(in) :: array(..) + type(intrinsic_array_t) intrinsic_array + end function + + pure module function real_array(array) result(intrinsic_array) + implicit none + real, intent(in) :: array(..) + type(intrinsic_array_t) intrinsic_array + end function + + pure module function double_precision_array(array) result(intrinsic_array) + implicit none + double precision, intent(in) :: array(..) + type(intrinsic_array_t) intrinsic_array + end function + +#endif end interface diff --git a/src/assert/intrinsic_array_s.f90 b/src/assert/intrinsic_array_s.F90 similarity index 65% rename from src/assert/intrinsic_array_s.f90 rename to src/assert/intrinsic_array_s.F90 index 9ea16e3..c95d0e2 100644 --- a/src/assert/intrinsic_array_s.f90 +++ b/src/assert/intrinsic_array_s.F90 @@ -3,6 +3,7 @@ contains +#ifndef _CRAYFTN module procedure construct select rank(array) @@ -59,17 +60,21 @@ end procedure + pure function one_allocated_component(self) result(one_allocated) + type(intrinsic_array_t), intent(in) :: self + logical one_allocated + one_allocated = count( & + [ allocated(self%complex_1D), allocated(self%complex_double_1D), allocated(self%integer_1D), allocated(self%logical_1D), & + allocated(self%real_1D), allocated(self%complex_2D), allocated(self%complex_double_2D), allocated(self%integer_2D), & + allocated(self%logical_2D), allocated(self%real_2D), allocated(self%complex_3D), allocated(self%complex_double_3D), & + allocated(self%integer_3D), allocated(self%logical_3D), allocated(self%real_3D) & + ]) + end function + module procedure as_character integer, parameter :: single_number_width=32 - if (1 /= count( & - [ allocated(self%complex_1D), allocated(self%complex_double_1D), allocated(self%integer_1D), & - allocated(self%logical_1D), allocated(self%real_1D), & - allocated(self%complex_2D), allocated(self%complex_double_2D), allocated(self%integer_2D), & - allocated(self%logical_2D), allocated(self%real_2D), & - allocated(self%complex_3D), allocated(self%complex_double_3D), allocated(self%integer_3D), & - allocated(self%logical_3D), allocated(self%real_3D) & - ])) error stop "intrinsic_array_t as_character: ambiguous component allocation status." + if (.not. one_allocated_component(self)) error stop "intrinsic_array_s(as_character): invalid number of allocated components" if (allocated(self%complex_1D)) then character_self = repeat(" ", ncopies = single_number_width*size(self%complex_1D)) @@ -130,4 +135,83 @@ character_self = trim(adjustl(character_self)) end procedure +#else // ifndef _CRAYFTN + + module procedure complex_array + + select rank(array) + rank(1) + allocate(intrinsic_array%complex_1D, source = array) + rank(2) + allocate(intrinsic_array%complex_2D, source = array) + rank(3) + allocate(intrinsic_array%complex_3D, source = array) + rank default + error stop "intrinsic_array_t complex_array: unsupported rank" + end select + + end procedure + + module procedure integer_array + + select rank(array) + rank(1) + allocate(intrinsic_array%integer_1D, source = array) + rank(2) + allocate(intrinsic_array%integer_2D, source = array) + rank(3) + allocate(intrinsic_array%integer_3D, source = array) + rank default + error stop "intrinsic_array_t integer_array: unsupported rank" + end select + + end procedure + + module procedure logical_array + + select rank(array) + rank(1) + allocate(intrinsic_array%logical_1D, source = array) + rank(2) + allocate(intrinsic_array%logical_2D, source = array) + rank(3) + allocate(intrinsic_array%logical_3D, source = array) + rank default + error stop "intrinsic_array_t logical_array: unsupported rank" + end select + + end procedure + + module procedure real_array + + select rank(array) + rank(1) + allocate(intrinsic_array%real_1D, source = array) + rank(2) + allocate(intrinsic_array%real_2D, source = array) + rank(3) + allocate(intrinsic_array%real_3D, source = array) + rank default + error stop "intrinsic_array_t real_array: unsupported rank" + end select + + end procedure + + module procedure double_precision_array + + select rank(array) + rank(1) + allocate(intrinsic_array%double_precision_1D, source = array) + rank(2) + allocate(intrinsic_array%double_precision_2D, source = array) + rank(3) + allocate(intrinsic_array%double_precision_3D, source = array) + rank default + error stop "intrinsic_array_t double_precision_array: unsupported rank" + end select + + end procedure + +#endif + end submodule intrinsic_array_s From 0fc4380514205de31cc00973b7c29ed40acb8f44 Mon Sep 17 00:00:00 2001 From: Damian Rouson Date: Thu, 8 Feb 2024 12:14:12 -0800 Subject: [PATCH 2/2] fix(intrinsic_array_s): rm preprocessor typo --- src/assert/intrinsic_array_s.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/assert/intrinsic_array_s.F90 b/src/assert/intrinsic_array_s.F90 index c95d0e2..2d0b3b5 100644 --- a/src/assert/intrinsic_array_s.F90 +++ b/src/assert/intrinsic_array_s.F90 @@ -135,7 +135,7 @@ pure function one_allocated_component(self) result(one_allocated) character_self = trim(adjustl(character_self)) end procedure -#else // ifndef _CRAYFTN +#else module procedure complex_array