!------------------------------------------------------------------------------ ! Global Modeling and Assimilation Office (GMAO) ! ! Goddard Earth Observing System (GEOS) ! ! MAPL Component ! !------------------------------------------------------------------------------ #include "MAPL_ErrLog.h" #include "unused_dummy.H" !> !### MODULE: `pFIO_UnlimitedEntityMod` ! ! Author: GMAO SI-Team ! ! The module `pFIO_UnlimitedEntityMod` encapsulates notion of variable UnlimitedEntitys. ! ! `CFIO_AtttributeMod` is a support layer for the CFIO package and ! which implements encapsulates variable UnlimitedEntitys ala NetCDF. ! An UnlimitedEntity can be any Fortan kind/type and can either be a scalar ! or a 1-dimensional vector. (Strings can only be scalars.) ! ! While some functionality exists for containing non-intrinsic types ! (e.g., user defined types), the primary intended use is for ! establishing correspondence with intrinsic types stored in files. ! module pFIO_UnlimitedEntityMod use pFIO_ConstantsMod use pFIO_UtilitiesMod use MAPL_ExceptionHandling use, intrinsic :: iso_fortran_env, only: INT32, INT64 use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none private public :: UnlimitedEntity public :: UnlimitedEntity_deserialize public :: StringWrap type :: UnlimitedEntity private integer, allocatable :: shape(:) class (*), allocatable :: value class (*), allocatable :: values(:) logical :: valid = .false. !! just to avoid warning for empty constructor contains procedure :: get_shape procedure :: get_rank procedure :: get_value procedure :: get_values generic :: operator(==) => equal generic :: operator(/=) => not_equal procedure :: equal procedure :: not_equal procedure :: set procedure :: serialize procedure :: get_string procedure :: is_empty procedure :: destroy end type UnlimitedEntity !> ! This derived type is a workaround for sporadic Intel Fortran ! issues when accessing strings through unlimited polymorphic ! entities. type :: StringWrap character(len=:), allocatable :: value end type StringWrap interface UnlimitedEntity module procedure new_UnlimitedEntity_empty !! scalar constructor module procedure new_UnlimitedEntity_0d !! scalar constructor module procedure new_UnlimitedEntity_1d !! vector constructor module procedure new_UnlimitedEntity_2d !! vector constructor module procedure new_UnlimitedEntity_3d !! vector constructor module procedure new_UnlimitedEntity_4d !! vector constructor module procedure new_UnlimitedEntity_5d !! vector constructor end interface UnlimitedEntity integer :: EMPTY(0) contains function new_UnlimitedEntity_empty() result(attr) type (UnlimitedEntity) :: attr attr%valid = .true. end function new_UnlimitedEntity_empty function new_UnlimitedEntity_0d(value, rc) result(attr) type (UnlimitedEntity) :: attr class (*), intent(in) :: value integer, optional, intent(out) :: rc type(StringWrap) :: w attr%shape = EMPTY select type (value) type is (character(len=*)) ! workaround for gfortran-6.2 and ifort-17.0.1 w = StringWrap('') w%value = value allocate(attr%value,source=w) class default allocate(attr%value, source=value) end select _RETURN(_SUCCESS) end function new_UnlimitedEntity_0d function new_UnlimitedEntity_1d(values, rc) result(attr) type (UnlimitedEntity) :: attr class (*), intent(in) :: values(:) integer, optional, intent(out) :: rc select type (values) type is (character(len=*)) _FAIL( 'unsupported unless shape is [1]') class default allocate(attr%values, source=values) attr%shape = shape(values) end select _RETURN(_SUCCESS) end function new_UnlimitedEntity_1d function new_UnlimitedEntity_2d(values, rc) result(attr) type (UnlimitedEntity) :: attr class (*), intent(in) :: values(:,:) integer, optional, intent(out) :: rc class (*), allocatable :: values1d(:) select type (values) type is (integer(INT32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (integer(INT64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (logical) allocate(values1d, source = reshape(values, [product(shape(values))])) class default _FAIL( 'not support type') end select attr = UnlimitedEntity(values1d) attr%shape = shape(values) deallocate(values1d) _RETURN(_SUCCESS) end function new_UnlimitedEntity_2d function new_UnlimitedEntity_3d(values, rc) result(attr) type (UnlimitedEntity) :: attr class (*), intent(in) :: values(:,:,:) integer, optional, intent(out) :: rc class (*), allocatable :: values1d(:) select type (values) type is (integer(INT32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (integer(INT64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (logical) allocate(values1d, source = reshape(values, [product(shape(values))])) class default _FAIL( 'not support type') end select attr = UnlimitedEntity(values1d) attr%shape = shape(values) deallocate(values1d) _RETURN(_SUCCESS) end function new_UnlimitedEntity_3d function new_UnlimitedEntity_4d(values, rc) result(attr) type (UnlimitedEntity) :: attr class (*), intent(in) :: values(:,:,:,:) integer, optional, intent(out) :: rc class (*), allocatable :: values1d(:) select type (values) type is (integer(INT32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (integer(INT64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (logical) allocate(values1d, source = reshape(values, [product(shape(values))])) class default _FAIL( 'not support type') end select attr = UnlimitedEntity(values1d) attr%shape = shape(values) deallocate(values1d) _RETURN(_SUCCESS) end function new_UnlimitedEntity_4d function new_UnlimitedEntity_5d(values, rc) result(attr) type (UnlimitedEntity) :: attr class (*), intent(in) :: values(:,:,:,:,:) integer, optional, intent(out) :: rc class (*), allocatable :: values1d(:) select type (values) type is (integer(INT32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (integer(INT64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real32)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (real(real64)) allocate(values1d, source = reshape(values, [product(shape(values))])) type is (logical) allocate(values1d, source = reshape(values, [product(shape(values))])) class default _FAIL( 'not support type') end select attr = UnlimitedEntity(values1d) attr%shape = shape(values) deallocate(values1d) _RETURN(_SUCCESS) end function new_UnlimitedEntity_5d !> ! Set string or scalar subroutine set(this, value, rc) class (UnlimitedEntity), intent(inout) :: this class (*), intent(in) :: value integer, optional, intent(out) :: rc type (StringWrap) :: w if(allocated(this%value)) deallocate(this%value) select type (q => value) type is (character(len=*)) w = StringWrap('') ! Intel compiler workaround w%value = q allocate(this%value, source=w) class default allocate(this%value, source=value) end select this%shape = EMPTY _RETURN(_SUCCESS) end subroutine set subroutine destroy(this, rc) class (UnlimitedEntity), intent(inout) :: this integer, optional, intent(out) :: rc if(allocated(this%value)) deallocate(this%value) if(allocated(this%values)) deallocate(this%values) if(allocated(this%shape)) deallocate(this%shape) _RETURN(_SUCCESS) end subroutine destroy !> ! get string or scalar function get_value(this, rc) result(value) class (UnlimitedEntity), target, intent(in) :: this integer, optional, intent(out) :: rc class (*), pointer :: value if (allocated(this%value)) then select type (q => this%value) type is (StringWrap) value => q%value class default value => q end select else value => null() end if _RETURN(_SUCCESS) end function get_value !> ! get 1d , need get_shape to get back to original array function get_values(this, rc) result(values) class (UnlimitedEntity), target, intent(in) :: this integer, optional, intent(out) :: rc class (*), pointer :: values(:) if (allocated(this%values)) then values => this%values else values => null() end if _RETURN(_SUCCESS) end function get_values function get_string(this,rc) result(string) class(UnlimitedEntity), target, intent(in) :: this integer, optional, intent(out) :: rc character(len=:), allocatable :: string class (*), pointer :: value value => this%get_value() select type(value) type is (StringWrap) string = value%value type is (character(len=*)) string = value class default _RETURN(_FAILURE) end select _RETURN(_SUCCESS) end function get_string !> ! Simple accessor function get_shape(this, rc) result(shp) class (UnlimitedEntity), intent(in) :: this integer, optional, intent(out) :: rc integer, allocatable :: shp(:) if (.not. allocated(this%shape)) then shp = EMPTY else shp = this%shape endif _RETURN(_SUCCESS) end function get_shape function get_rank(this, rc) result(rank) class (UnlimitedEntity), intent(in) :: this integer, optional, intent(out) :: rc integer :: rank rank = size(this%get_shape()) _RETURN(_SUCCESS) end function get_rank function is_empty(this, rc) result(yes) class (UnlimitedEntity), target, intent(in) :: this integer, optional, intent(out) :: rc logical :: yes class (*), pointer :: value ! not initialized yes = .not. allocated(this%shape) if (yes) then _RETURN(_SUCCESS) endif ! initialized with UnlimitedEnity('') value => this%get_value() if (associated(value)) then select type (q=>value) type is (character(len=*)) yes = (q == '') end select end if _RETURN(_SUCCESS) end function is_empty !------------------------------------------------------------------------------ !> ! `equals()` - returns true if-and-only-if a and b ! are the same type, kind, shape, and have the same values. ! ! Only intrinsic data types are supported. ! ! Ugly nested SELECT TYPE is unfortunately necessary. ! logical function equal(a, b) ! class (UnlimitedEntity), target, intent(in) :: a type (UnlimitedEntity), target, intent(in) :: b integer, allocatable :: shape_a(:), shape_b(:) class (*), pointer :: value_a, value_b class (*), pointer :: values_a(:), values_b(:) integer :: rank ! check initialization equal = (.not. allocated(a%shape) .and. .not. allocated(b%shape)) if (equal) return ! both are not initialized equal = allocated(a%shape) .and. allocated(b%shape) if (.not. equal) return ! one of them is not initialized ! check size shape_a = a%get_shape() shape_b = b%get_shape() equal = size(shape_a) == size(shape_b) if (.not. equal) return ! check shape equal = all(shape_a == shape_b) if (.not. equal) return rank = a%get_rank() if ( rank > 0) then ! at this point, both a%values and b%values must have been allocated ! check type values_a => a%get_values() values_b => b%get_values() equal = same_type_as(values_a, values_b) if (.not. equal) return select type (values_a) type is (integer(INT32)) select type (values_b) type is (integer(INT32)) equal = all(values_a == values_b) end select type is (integer(INT64)) select type (values_b) type is (integer(INT64)) equal = all(values_a == values_b) end select type is (real(real32)) select type (values_b) type is (real(real32)) equal = all(nearlyEqual(values_a, values_b)) end select type is (real(real64)) select type (values_b) type is (real(real64)) equal = all(nearlyEqual(values_a, values_b)) end select type is (logical) select type (values_b) type is (logical) equal = all(values_a .eqv. values_b) end select !W.J notes: it is illegal and not used !type is (character(len=*)) ! select type (values_b) ! type is (character(len=*)) ! equal = all(values_a == values_b) ! end select class default equal = .false. end select else ! check type value_a => a%get_value() value_b => b%get_value() equal = same_type_as(value_a, value_b) if (.not. equal) return select type (value_a) type is (integer(INT32)) select type (value_b) type is (integer(INT32)) equal = (value_a == value_b) end select type is (integer(INT64)) select type (value_b) type is (integer(INT64)) equal = (value_a == value_b) end select type is (real(real32)) select type (value_b) type is (real(real32)) equal = (nearlyEqual(value_a,value_b)) end select type is (real(real64)) select type (value_b) type is (real(real64)) equal = (nearlyEqual(value_a,value_b)) end select type is (logical) select type (value_b) type is (logical) equal = (value_a .eqv. value_b) end select type is (character(len=*)) select type (value_b) type is (character(len=*)) equal = (value_a == value_b) end select ! W.J notes: get_value will not return this type !type is (StringWrap) ! select type (value_b) ! type is (StringWrap) ! equal = (value_a%value == value_b%value) ! end select class default equal = .false. end select end if end function equal logical function not_equal(a, b) class (UnlimitedEntity), intent(in) :: a type (UnlimitedEntity), intent(in) :: b not_equal = .not. (a == b) end function not_equal subroutine serialize( this, buffer, rc) class (UnlimitedEntity),target, intent(in) :: this integer, allocatable,intent(inout) :: buffer(:) integer, optional, intent(out) :: rc integer :: type_kind integer :: length, rank if(allocated(buffer)) deallocate(buffer) buffer = EMPTY rank = this%get_rank() select case (rank) case (0) if ( .not. allocated(this%value)) then type_kind = pFIO_UNSUPPORTED_TYPE buffer = [serialize_intrinsic(EMPTY), & serialize_intrinsic(type_kind)] else ! check type select type (value => this%value) type is (integer(INT32)) type_kind = pFIO_INT32 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(value)] type is (integer(INT64)) type_kind = pFIO_INT64 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(value)] type is (real(real32)) type_kind = pFIO_REAL32 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(value)] type is (real(real64)) type_kind = pFIO_REAL64 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(value)] type is (logical) type_kind = pFIO_LOGICAL buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(value)] type is (StringWrap) type_kind = pFIO_STRING buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(value%value)] class default _FAIL(" type is not supported") end select endif case (1:) ! check type select type (values=>this%values) type is (integer(INT32)) type_kind = pFIO_INT32 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(values)] type is (integer(INT64)) type_kind = pFIO_INT64 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(values)] type is (real(REAL32)) type_kind = pFIO_REAL32 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(values)] type is (real(REAL64)) type_kind = pFIO_REAL64 buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(values)] type is (logical) type_kind = pFIO_LOGICAL buffer = [serialize_intrinsic(this%shape), & serialize_intrinsic(type_kind), & serialize_intrinsic(values)] ! type is (character(len=*)) ! type_kind = pFIO_STRING ! buffer = [serialize_intrinsic(this%shape), & ! serialize_intrinsic(type_kind), & ! serialize_intrinsic(values)] class default _FAIL(" type is not supported") end select end select length = serialize_buffer_length(length) + size(buffer) buffer = [serialize_intrinsic(length),buffer] _RETURN(_SUCCESS) end subroutine serialize subroutine UnlimitedEntity_deserialize( buffer,this, rc) integer, intent(in) :: buffer(:) type (UnlimitedEntity),intent(inout) :: this integer, optional, intent(out) :: rc integer :: status this = UnlimitedEntity() call deserialize(this, buffer, rc=status) _VERIFY(status) _RETURN(_SUCCESS) contains subroutine deserialize( this, buffer, rc) class (UnlimitedEntity), target,intent(inout) :: this integer, intent(in) :: buffer(:) integer, optional, intent(out) :: rc integer :: n,type_kind,length integer(KIND=INT32) :: value_int32 integer(KIND=INT64) :: value_int64 real(KIND=REAL32) :: value_real32 real(KIND=REAL64) :: value_real64 logical :: value_logical integer(KIND=INT32), allocatable :: values_int32(:) integer(KIND=INT64), allocatable :: values_int64(:) real(KIND=REAL32), allocatable :: values_real32(:) real(KIND=REAL64), allocatable :: values_real64(:) logical, allocatable :: values_logical(:) character(len=:), allocatable :: value_char integer :: rank n = 1 call deserialize_intrinsic(buffer(n:),length) _ASSERT(length == size(buffer),'length does not match') n = n + serialize_buffer_length(length) call deserialize_intrinsic(buffer(n:),this%shape) n = n + serialize_buffer_length(this%shape) call deserialize_intrinsic(buffer(n:),type_kind) n = n + serialize_buffer_length(type_kind) rank = this%get_rank() select case (rank) case (0) select case (type_kind) case (pFIO_INT32) call deserialize_intrinsic(buffer(n:),value_int32) call this%set(value_int32) case (pFIO_INT64) call deserialize_intrinsic(buffer(n:),value_int64) call this%set(value_int64) case (pFIO_REAL32) call deserialize_intrinsic(buffer(n:),value_real32) call this%set(value_real32) case (pFIO_REAL64) call deserialize_intrinsic(buffer(n:),value_real64) call this%set(value_real64) case (pFIO_LOGICAL) call deserialize_intrinsic(buffer(n:),value_logical) call this%set(value_logical) case (pFIO_STRING) call deserialize_intrinsic(buffer(n:),value_char) call this%set(value_char) case (pFIO_UNSUPPORTED_TYPE) ! this is uninitialized case, make sure shape is not allocated even it is empty if (allocated(this%shape))deallocate(this%shape) case default _FAIL( "UnlimitedEntity deserialize not support") end select case (1:) select case (type_kind) case (pFIO_INT32) call deserialize_intrinsic(buffer(n:),values_int32) allocate(this%values, source =values_int32) case (pFIO_INT64) call deserialize_intrinsic(buffer(n:),values_int64) allocate(this%values, source =values_int64) case (pFIO_REAL32) call deserialize_intrinsic(buffer(n:),values_real32) allocate(this%values, source =values_real32) case (pFIO_REAL64) call deserialize_intrinsic(buffer(n:),values_real64) allocate(this%values, source =values_real64) case (pFIO_LOGICAL) call deserialize_intrinsic(buffer(n:),values_logical) allocate(this%values, source =values_logical) case default _FAIL( "UnlimitedEntity deserialize not support") end select end select _RETURN(_SUCCESS) end subroutine deserialize end subroutine UnlimitedEntity_deserialize end module pFIO_UnlimitedEntityMod ! The following module defines an FTL map (associative array) with keys that are deferred ! length strings and values that are UnlimitedEntitys. module pFIO_StringUnlimitedEntityMapMod use pFIO_UnlimitedEntityMod #include "types/key_deferredLengthString.inc" #define _value type (UnlimitedEntity) #define _value_equal_defined #define _map StringUnlimitedEntityMap #define _iterator StringUnlimitedEntityMapIterator #define _alt #include "templates/map.inc" end module pFIO_StringUnlimitedEntityMapMod module pFIO_StringUnlimitedEntityMapUtilMod use pFIO_UtilitiesMod use pFIO_UnlimitedEntityMod use pFIO_StringUnlimitedEntityMapMod use MAPL_ExceptionHandling implicit none private public :: StringUnlimitedEntityMap_serialize public :: StringUnlimitedEntityMap_deserialize contains subroutine StringUnlimitedEntityMap_serialize(map,buffer) type (StringUnlimitedEntityMap) ,intent(in):: map integer, allocatable,intent(inout) :: buffer(:) type (StringUnlimitedEntityMapIterator) :: iter character(len=:),pointer :: key type(UnlimitedEntity),pointer :: attr_ptr integer :: length integer, allocatable :: tmp_buffer(:) if (allocated(buffer)) deallocate(buffer) allocate(buffer(0)) iter = map%begin() do while (iter /= map%end()) key => iter%key() buffer=[buffer,serialize_intrinsic(key)] attr_ptr => iter%value() call attr_ptr%serialize(tmp_buffer) buffer = [buffer, tmp_buffer] deallocate(tmp_buffer) call iter%next() enddo length = serialize_buffer_length(length)+size(buffer) buffer = [serialize_intrinsic(length),buffer] end subroutine StringUnlimitedEntityMap_serialize subroutine StringUnlimitedEntityMap_deserialize(buffer, map, rc) integer, intent(in) :: buffer(:) type (StringUnlimitedEntityMap), intent(inout) :: map integer, optional, intent(out) :: rc character(len=:),allocatable :: key integer :: length,n,n0,n1,n2 type (UnlimitedEntity) :: attr n = 1 call deserialize_intrinsic(buffer(n:),length) n0 = serialize_buffer_length(length) n = n + n0 length = length - n0 map = StringUnlimitedEntityMap() do while (length > 0) call deserialize_intrinsic(buffer(n:),key) n1 = serialize_buffer_length(key) n = n + n1 call deserialize_intrinsic(buffer(n:),n2) call UnlimitedEntity_deserialize(buffer(n:), attr) n = n + n2 length = length - n1 - n2 call map%insert(key,attr) deallocate(key) enddo _RETURN(_SUCCESS) end subroutine StringUnlimitedEntityMap_deserialize end module pFIO_StringUnlimitedEntityMapUtilMod