Skip to content
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.

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

Initial attempt at supportind DTIO for aspects #3304

Open
wants to merge 1 commit into
base: release/MAPL-v3
Choose a base branch
from
Open
Changes from all commits
Commits
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
2 changes: 2 additions & 0 deletions generic3g/connection/SimpleConnection.F90
Original file line number Diff line number Diff line change
@@ -175,6 +175,8 @@ recursive subroutine connect_sibling(this, dst_registry, src_registry, unusable,
call dst_extension%set_producer(new_extension%get_producer(), _RC)
end if
end do

_HERE, src_registry
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Suggested change
_HERE, src_registry

I'm guessing the _HERE can be removed?


_RETURN(_SUCCESS)
_UNUSED_DUMMY(unusable)
19 changes: 19 additions & 0 deletions generic3g/registry/StateRegistry.F90
Original file line number Diff line number Diff line change
@@ -2,6 +2,7 @@

module mapl3g_StateRegistry

use mapl3g_AspectCollection
use mapl3g_AbstractRegistry
use mapl3g_RegistryPtr
use mapl3g_RegistryPtrMap
@@ -559,6 +560,7 @@ subroutine write_header(this, iostat, iomsg)
', n_extensions=', total, ')' // new_line('a')
if (iostat /= 0) return
write(unit,*,iostat=iostat,iomsg=iomsg) ' extensions: '// new_line('a')

end subroutine write_header

subroutine write_virtual_pts(this, iostat, iomsg)
@@ -572,6 +574,9 @@ subroutine write_virtual_pts(this, iostat, iomsg)
class(StateItemSpec), pointer :: spec
logical :: is_active

integer :: i
type(AspectCollection), pointer :: aspects

write(unit,*,iostat=iostat,iomsg=iomsg) ' virtuals: '// new_line('a')
if (iostat /= 0) return
associate (e => this%family_map%ftn_end())
@@ -590,6 +595,20 @@ subroutine write_virtual_pts(this, iostat, iomsg)
': ',family%num_variants(), ' variants ', &
' is primary? ', family%has_primary(), ' is active? ', is_active, new_line('a')
if (iostat /= 0) return

do i = 1, family%num_variants()
extension => family%get_extension(i)
spec => extension%get_spec()
aspects => spec%get_aspects()
write(unit,'(16x,a,i5.0,a)', iostat=iostat, iomsg=iomsg) 'Variant: ', i, new_line('a')
if (iostat/=0) return
write(unit,'(DT(20),a)',iostat=iostat, iomsg=iomsg) aspects
if (iostat/=0) return
write(unit,*, iostat=iostat, iomsg=iomsg) new_line('a')
if (iostat/=0) return
end do


end associate
end do
end associate
58 changes: 57 additions & 1 deletion generic3g/specs/AspectCollection.F90
Original file line number Diff line number Diff line change
@@ -41,13 +41,16 @@ module mapl3g_AspectCollection

procedure :: get_ungridded_dims_aspect
procedure :: set_ungridded_dims_aspect

procedure :: write_formatted
generic :: write(formatted) => write_formatted

end type AspectCollection

interface AspectCollection
procedure :: new_AspectCollection
end interface AspectCollection

contains

function new_AspectCollection( unusable, &
@@ -229,5 +232,58 @@ subroutine set_ungridded_dims_aspect(this, ungridded_dims_aspect)
this%ungridded_dims_aspect = ungridded_dims_aspect
end subroutine set_ungridded_dims_aspect


subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg)
class(AspectCollection), intent(in) :: this
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, intent(in) :: v_list(:)
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg

iostat = 0

call handle('TYPEKIND', iostat=iostat, iomsg=iomsg)
call handle('GEOM', iostat=iostat, iomsg=iomsg)
call handle('VERTICAL', iostat=iostat, iomsg=iomsg)
call handle('UNITS', iostat=iostat, iomsg=iomsg)
call handle('UNGRIDDED_DIMS', iostat=iostat, iomsg=iomsg)

_UNUSED_DUMMY(v_list)
_UNUSED_DUMMY(iotype)

contains

subroutine handle(name, iostat, iomsg)
character(*), intent(in) :: name
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg

character(10) :: fmt
class(StateItemAspect), pointer :: aspect

! v_list(1) is indent
if (size(v_list) > 0) then
write(fmt,'("(",i0,"x)")', iostat=iostat) v_list(1)
if (iostat /= 0) return
write(unit,trim(fmt), iostat=iostat, iomsg=iomsg)
if (iostat /= 0) return
end if

aspect => this%get_aspect(name)
if (associated(aspect)) then
write(unit,'(a12,":",1x)',iostat=iostat,iomsg=iomsg) name
if (iostat /= 0) return

!# write(unit, '(DT,a)', iostat=iostat, iomsg=iomsg) aspect, new_line('a')
write(unit, '(a,a)', iostat=iostat, iomsg=iomsg) aspect%get_description(), new_line('a')
return
end if

write(unit, '(a, a)', iostat=iostat, iomsg=iomsg) '< not allocated >', new_line('a')
end subroutine handle

end subroutine write_formatted

end module mapl3g_AspectCollection

11 changes: 11 additions & 0 deletions generic3g/specs/GeomAspect.F90
Original file line number Diff line number Diff line change
@@ -27,6 +27,8 @@ module mapl3g_GeomAspect
procedure :: supports_conversion_specific
procedure :: set_geom
procedure :: get_geom

procedure :: get_description
end type GeomAspect

interface GeomAspect
@@ -133,4 +135,13 @@ function get_geom(this, rc) result(geom)
_RETURN(_SUCCESS)
end function get_geom

function get_description(this) result(s)
character(:), allocatable :: s
class(GeomAspect), intent(in) :: this

! Should not get here in mirror'd case, but ...
s = 'description not implemented'

end function get_description

end module mapl3g_GeomAspect
34 changes: 34 additions & 0 deletions generic3g/specs/StateItemAspect.F90
Original file line number Diff line number Diff line change
@@ -64,6 +64,10 @@ module mapl3g_StateItemAspect
procedure, non_overridable :: set_mirror
procedure, non_overridable :: is_time_dependent
procedure, non_overridable :: set_time_dependent

procedure(I_get_description), deferred :: get_description
procedure :: write_formatted_aspect
generic :: write(formatted) => write_formatted_aspect
end type StateItemAspect


@@ -93,6 +97,11 @@ function I_make_action(src, dst, rc) result(action)
integer, optional, intent(out) :: rc
end function I_make_action

function I_get_description(this) result(s)
import StateItemAspect
character(:), allocatable :: s
class(StateItemAspect), intent(in) :: this
end function I_get_description
end interface

contains
@@ -185,6 +194,31 @@ subroutine set_time_dependent(this, time_dependent)
if (present(time_dependent)) this%time_dependent = time_dependent
end subroutine set_time_dependent


subroutine write_formatted_aspect(this, unit, iotype, v_list, iostat, iomsg)
class(StateItemAspect), intent(in) :: this
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, intent(in) :: v_list(:)
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg

character(:), allocatable :: buffer
iostat = 0

if (this%is_mirror()) then
write(unit,'(a)', iostat=iostat, iomsg=iomsg) " < mirror(tbd) > "
return
end if

buffer = "< " // this%get_description() // " >"
write(unit,'(a)', iostat=iostat, iomsg=iomsg) buffer

_UNUSED_DUMMY(v_list)
_UNUSED_DUMMY(iotype)
end subroutine write_formatted_aspect


end module mapl3g_StateItemAspect


25 changes: 22 additions & 3 deletions generic3g/specs/TypekindAspect.F90
Original file line number Diff line number Diff line change
@@ -25,6 +25,9 @@ module mapl3g_TypekindAspect

procedure :: set_typekind
procedure :: get_typekind

procedure :: get_description

end type TypekindAspect

interface TypekindAspect
@@ -61,12 +64,9 @@ logical function matches(src, dst)
class(TypekindAspect), intent(in) :: src
class(StateItemAspect), intent(in) :: dst

_HERE
select type(dst)
class is (TypekindAspect)
_HERE
matches = (src%typekind == dst%typekind) .or. count([src%typekind,dst%typekind]==MAPL_TYPEKIND_MIRROR) == 1
_HERE, matches
class default
matches = .false.
end select
@@ -103,4 +103,23 @@ function get_typekind(this) result(typekind)
typekind = this%typekind
end function get_typekind

function get_description(this) result(s)
character(:), allocatable :: s
class(TypekindAspect), intent(in) :: this

! Should not get here in mirror'd case, but ...
s = 'ERROR'

if (this%typekind == ESMF_TYPEKIND_R4) then
s = 'R4'
elseif (this%typekind == ESMF_TYPEKIND_R8) then
s = 'R8'
elseif (this%typekind == ESMF_TYPEKIND_I4) then
s = 'I4'
elseif (this%typekind == ESMF_TYPEKIND_I8) then
s = 'I8'
end if ! otherwise ERROR (from above)

end function get_description

end module mapl3g_TypekindAspect
11 changes: 11 additions & 0 deletions generic3g/specs/UngriddedDimsAspect.F90
Original file line number Diff line number Diff line change
@@ -20,6 +20,8 @@ module mapl3g_UngriddedDimsAspect
procedure :: supports_conversion_general
procedure :: supports_conversion_specific
procedure :: make_action

procedure :: get_description
end type UngriddedDimsAspect

interface UngriddedDimsAspect
@@ -76,4 +78,13 @@ function make_action(src, dst, rc) result(action)
_RETURN(_SUCCESS)
end function make_action

function get_description(this) result(s)
character(:), allocatable :: s
class(UngriddedDimsAspect), intent(in) :: this

! Should not get here in mirror'd case, but ...
s = 'description not implemented'

end function get_description

end module mapl3g_UngriddedDimsAspect
17 changes: 13 additions & 4 deletions generic3g/specs/UnitsAspect.F90
Original file line number Diff line number Diff line change
@@ -12,7 +12,6 @@ module mapl3g_UnitsAspect

public :: UnitsAspect


type, extends(StateItemAspect) :: UnitsAspect
!# private
character(:), allocatable :: units
@@ -21,11 +20,14 @@ module mapl3g_UnitsAspect
procedure :: supports_conversion_general
procedure :: supports_conversion_specific
procedure :: make_action

procedure :: get_description

end type UnitsAspect

interface UnitsAspect
procedure new_UnitsAspect
end interface
end interface UnitsAspect

contains

@@ -56,14 +58,12 @@ logical function supports_conversion_specific(src, dst)

select type (dst)
class is (UnitsAspect)
_HERE, src%units, ' --> ', dst%units
supports_conversion_specific = .true.
if (src%units == dst%units) return ! allow silly units so long as they are the same
supports_conversion_specific = are_convertible(src%units, dst%units, rc=ignore)
class default
supports_conversion_specific = .false.
end select
_HERE, supports_conversion_specific

end function supports_conversion_specific

@@ -101,4 +101,13 @@ function make_action(src, dst, rc) result(action)
_RETURN(_SUCCESS)
end function make_action

function get_description(this) result(s)
character(:), allocatable :: s
class(UnitsAspect), intent(in) :: this

! Should not get here in mirror'd case, but ...
s = 'ERROR'
if (allocated(this%units)) s = this%units
end function get_description

end module mapl3g_UnitsAspect
11 changes: 11 additions & 0 deletions generic3g/specs/VerticalGridAspect.F90
Original file line number Diff line number Diff line change
@@ -38,6 +38,8 @@ module mapl3g_VerticalGridAspect
procedure :: set_vertical_grid
procedure :: set_geom
procedure :: set_typekind

procedure :: get_description
end type VerticalGridAspect

interface VerticalGridAspect
@@ -191,4 +193,13 @@ subroutine set_typekind(self, typekind)
self%typekind = typekind
end subroutine set_typekind

function get_description(this) result(s)
character(:), allocatable :: s
class(VerticalGridAspect), intent(in) :: this

! Should not get here in mirror'd case, but ...
s = 'description not implemented'

end function get_description

end module mapl3g_VerticalGridAspect
11 changes: 11 additions & 0 deletions generic3g/tests/MockAspect.F90
Original file line number Diff line number Diff line change
@@ -17,6 +17,8 @@ module MockAspect_mod
procedure :: make_action
procedure :: supports_conversion_general
procedure :: supports_conversion_specific

procedure :: get_description
end type MockAspect

interface MockAspect
@@ -73,4 +75,13 @@ function make_action(src, dst, rc) result(action)
if (present(rc)) rc = 0
end function make_action

function get_description(this) result(s)
character(:), allocatable :: s
class(MockASpect), intent(in) :: this

! Should not get here in mirror'd case, but ...
s = 'not implemented'

end function get_description

end module MockAspect_mod