Skip to content

Work around Cray Compiler Environment (CCE) 17.0.0 bugs #22

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
rouson merged 1 commit into from
Feb 10, 2024
Merged

Work around Cray Compiler Environment (CCE) 17.0.0 bugs #22

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 8 additions & 0 deletions example/derived_type_diagnostic.f90 → example/derived_type_diagnostic.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -137,9 +137,17 @@ program diagnostic_data_pattern

type(stuff_t) stuff

#ifndef _CRAYFTN
associate (i => stuff_t(z=(0.,1.)))
call assert(i%defined(), "main: i%defined()", characterizable_stuff_t(i))!Passes: constructor postcondition ensures defined data
end associate
#else
block
type(stuff_t) stuff
stuff = stuff_t(z=(0.,1.))
call assert(stuff%defined(), "main: i%defined()", characterizable_stuff_t(stuff))
end block
#endif

print *, stuff%z() ! Fails: accessor precondition catches use of undefined data

Expand Down
151 changes: 75 additions & 76 deletions src/assert/intrinsic_array_s.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -60,83 +60,7 @@

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 (.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))
write(character_self, *) self%complex_1D
else if (allocated(self%complex_double_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_1D))
write(character_self, *) self%complex_double_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%double_precision_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_1D))
write(character_self, *) self%double_precision_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%complex_double_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_2D))
write(character_self, *) self%complex_double_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
else if (allocated(self%double_precision_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_2D))
write(character_self, *) self%double_precision_2D
else if (allocated(self%complex_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_3D))
write(character_self, *) self%complex_3D
else if (allocated(self%complex_double_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_3D))
write(character_self, *) self%complex_double_3D
else if (allocated(self%integer_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_3D))
write(character_self, *) self%integer_3D
else if (allocated(self%logical_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_3D
else if (allocated(self%real_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_3D))
write(character_self, *) self%real_3D
else if (allocated(self%double_precision_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_3D))
write(character_self, *) self%double_precision_3D
end if

character_self = trim(adjustl(character_self))
end procedure

#else

module procedure complex_array

select rank(array)
Expand Down Expand Up @@ -214,4 +138,79 @@ pure function one_allocated_component(self) result(one_allocated)

#endif

pure function one_allocated_component(self) result(one_allocated)
type(intrinsic_array_t), intent(in) :: self
logical one_allocated
one_allocated = 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) &
])
end function

module procedure as_character
integer, parameter :: single_number_width=32

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))
write(character_self, *) self%complex_1D
else if (allocated(self%complex_double_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_1D))
write(character_self, *) self%complex_double_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%double_precision_1D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_1D))
write(character_self, *) self%double_precision_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%complex_double_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_2D))
write(character_self, *) self%complex_double_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
else if (allocated(self%double_precision_2D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_2D))
write(character_self, *) self%double_precision_2D
else if (allocated(self%complex_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_3D))
write(character_self, *) self%complex_3D
else if (allocated(self%complex_double_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%complex_double_3D))
write(character_self, *) self%complex_double_3D
else if (allocated(self%integer_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%integer_3D))
write(character_self, *) self%integer_3D
else if (allocated(self%logical_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%logical_1D))
write(character_self, *) self%logical_3D
else if (allocated(self%real_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%real_3D))
write(character_self, *) self%real_3D
else if (allocated(self%double_precision_3D)) then
character_self = repeat(" ", ncopies = single_number_width*size(self%double_precision_3D))
write(character_self, *) self%double_precision_3D
end if

character_self = trim(adjustl(character_self))
end procedure

end submodule intrinsic_array_s