Commit 0d470c54 authored by Robert Schweppe's avatar Robert Schweppe
Browse files

- fetching from forces/develop

- introduced Attribute type in mo_mpr_coordinate.f90
- stores attributes (6 types, 0d or 1d)
- all attributes of a coordinate variable in netCDF are now stored in the Coordinate type also
- but as nc%set_coordinate can only handle string attribute values, only strings are written to file...
- type-bound procedures has_attribute and get_attribute are added
parent 450f2358
Pipeline #54356 failed with stages
in 20 minutes and 44 seconds
......@@ -16,7 +16,7 @@ if(NOT ${FORCES_NAME}_FOUND)
FetchContent_Declare(
${FORCES_NAME}
GIT_REPOSITORY https://git.ufz.de/chs/forces.git
GIT_TAG temporary_test
GIT_TAG origin/develop
SOURCE_SUBDIR src
)
set (${FORCES_NAME}_BUILD_TESTING OFF)
......
......@@ -33,11 +33,17 @@ module mo_mpr_coordinate
! --------------------------------------------------------------------------------------
! TODO: might be moved to other place and made available to data arrays also
!> type containing all information of attributes that can be attached to any (coordinate) variable
type :: Attribute
private
! name of attribute
character(maxNameLength) :: name
! type, see https://github.com/Unidata/netcdf-fortran/blob/9597d59f14ab13f377e43733fc65f74e51aca705/fortran/netcdf_constants.f90
integer(i4) :: type
! length of characters or of vector if 1d
integer(i4) :: length
! value containers for all type and scalar/1d combinations possible
character(maxStringLength) :: valuechar
integer(i1) :: valuei1
integer(i2) :: valuei2
......@@ -50,6 +56,18 @@ module mo_mpr_coordinate
real(sp), dimension(:), allocatable :: valuessp
real(dp), dimension(:), allocatable :: valuesdp
contains
procedure :: get_valuechar
procedure :: initchar
procedure :: initi1
procedure :: initi2
procedure :: initi4
procedure :: initsp
procedure :: initdp
procedure :: initsi1
procedure :: initsi2
procedure :: initsi4
procedure :: initssp
procedure :: initsdp
generic, public :: get_value => get_valuechar
generic, public :: init => initchar, initi1, initi2, initi4, initsp, initdp, &
initsi1, initsi2, initsi4, initssp, initsdp
......@@ -97,6 +115,7 @@ module mo_mpr_coordinate
procedure :: insert_bound
procedure :: get_bound_index
procedure :: set_bound
procedure :: get_attributes_from_nc_var
procedure, public :: is_ascending
procedure, public :: set_2d_count
procedure, public :: set_polygons_from_2d
......@@ -146,18 +165,20 @@ module mo_mpr_coordinate
contains
subroutine initchar(att, name, arg)
!< init Attribute with character value
character(*), intent(in) :: name
character(*), intent(in) :: arg
class(Attribute), intent(out) :: att
att%name = name
att%type = 2_i4
att%length = size(arg)
att%length = len_trim(arg)
att%valuechar = arg
end subroutine initchar
subroutine initi1(att, name, arg)
!< init Attribute with byte value
character(*), intent(in) :: name
integer(i1), intent(in) :: arg
class(Attribute), intent(out) :: att
......@@ -170,6 +191,7 @@ contains
end subroutine initi1
subroutine initi2(att, name, arg)
!< init Attribute with integer (i2) value
character(*), intent(in) :: name
integer(i2), intent(in) :: arg
class(Attribute), intent(out) :: att
......@@ -182,6 +204,7 @@ contains
end subroutine initi2
subroutine initi4(att, name, arg)
!< init Attribute with integer (i4) value
character(*), intent(in) :: name
integer(i4), intent(in) :: arg
class(Attribute), intent(out) :: att
......@@ -194,6 +217,7 @@ contains
end subroutine initi4
subroutine initsp(att, name, arg)
!< init Attribute with short (sp) value
character(*), intent(in) :: name
real(sp), intent(in) :: arg
class(Attribute), intent(out) :: att
......@@ -206,8 +230,9 @@ contains
end subroutine initsp
subroutine initdp(att, name, arg)
!< init Attribute with double (sp) value
character(*), intent(in) :: name
integer(i1), intent(in) :: arg
real(dp), intent(in) :: arg
class(Attribute), intent(out) :: att
att%name = name
......@@ -217,7 +242,8 @@ contains
end subroutine initdp
subroutine initi1(att, name, arg)
subroutine initsi1(att, name, arg)
!< init Attribute with short byte vector
character(*), intent(in) :: name
integer(i1), intent(in), dimension(:) :: arg
class(Attribute), intent(out) :: att
......@@ -227,9 +253,10 @@ contains
att%length = size(arg)
att%valuesi1 = arg
end subroutine initi1
end subroutine initsi1
subroutine initi2(att, name, arg)
subroutine initsi2(att, name, arg)
!< init Attribute with short i2 vector
character(*), intent(in) :: name
integer(i2), intent(in), dimension(:) :: arg
class(Attribute), intent(out) :: att
......@@ -239,9 +266,10 @@ contains
att%length = size(arg)
att%valuesi2 = arg
end subroutine initi2
end subroutine initsi2
subroutine initi4(att, name, arg)
subroutine initsi4(att, name, arg)
!< init Attribute with short i4 vector
character(*), intent(in) :: name
integer(i4), intent(in), dimension(:) :: arg
class(Attribute), intent(out) :: att
......@@ -251,9 +279,10 @@ contains
att%length = size(arg)
att%valuesi4 = arg
end subroutine initi4
end subroutine initsi4
subroutine initsp(att, name, arg)
subroutine initssp(att, name, arg)
!< init Attribute with short sp vector
character(*), intent(in) :: name
real(sp), intent(in), dimension(:) :: arg
class(Attribute), intent(out) :: att
......@@ -263,21 +292,24 @@ contains
att%length = size(arg)
att%valuessp = arg
end subroutine initsp
end subroutine initssp
subroutine initdp(att, name, arg)
subroutine initsdp(att, name, arg)
!< init Attribute with short dp vector
character(*), intent(in) :: name
integer(i1), intent(in), dimension(:) :: arg
real(dp), intent(in), dimension(:) :: arg
class(Attribute), intent(out) :: att
att%name = name
att%type = 6_i4
att%length = size(arg)
att%valuesdp = arg
end subroutine initdp
end subroutine initsdp
function get_type(att) result(type)
!< get type of attribute
!< 1-byte, 2-char, 3-short, 4-int, 5-float, 6-double
class(Attribute), intent(in) :: att
integer(i4) :: type
......@@ -286,6 +318,7 @@ contains
end function get_type
function get_length(att) result(length)
!< get length of attribute
class(Attribute), intent(in) :: att
integer(i4) :: length
......@@ -294,6 +327,7 @@ contains
end function get_length
function get_name(att) result(name)
!< get name of attribute
class(Attribute), intent(in) :: att
character(maxNameLength) :: name
......@@ -302,6 +336,7 @@ contains
end function get_name
function get_valuechar(att) result(value)
!< get character value of attribute
class(Attribute), intent(in) :: att
character(maxNameLength) :: value
......@@ -528,7 +563,11 @@ contains
! set the attributes
if (present(attributeNames) .and. present(attributeValuesChar)) then
if (size(attributeNames) == size(attributeValuesChar)) then
allocate(newCoordinate%attributes(size(attributeNames)))
if (size(attributeNames) > maxNoAttributes) then
log_error(("(1X,A,I0,A,I0,A)")) 'Provided more attributes (', size(attributeNames) , &
')than allowed (', maxNoAttributes, ').'
stop 1
end if
do iAtt=1, size(attributeNames)
call newCoordinate%attributes(iAtt)%init(attributeNames(iAtt), attributeValuesChar(iAtt))
end do
......@@ -870,11 +909,12 @@ contains
call nc%close()
stop 1
end select
! get all the attribute names
call self%set_attributes(ncVar)
! get all the attribute names of the original coordinate variable (change, might be set to bnds)
ncVar = nc%getVariable(trim(self%name))
call self%get_attributes_from_nc_var(ncVar)
! set special attribute "units"
if (ncVar%hasAttribute('units')) then
call nc%getAttribute('units', self%unit)
call ncVar%getAttribute('units', self%unit)
end if
else if (nc%hasAttribute('title')) then
......@@ -962,9 +1002,10 @@ contains
end subroutine fromFile
subroutine set_attributes(self, ncVar)
subroutine get_attributes_from_nc_var(self, ncVar)
!< get all the attributes from a netcdf variable and store them in the self%attributes property
class(Coordinate), intent(inout) :: self
type(ncVariable), intent(in) :: self
type(ncVariable), intent(in) :: ncVar
character(maxNameLength), dimension(:), allocatable :: attributeNames
integer(i4) :: iAtt, attType, attLength
......@@ -980,18 +1021,19 @@ contains
integer(i4), dimension(:), allocatable :: valuesi4
real(sp), dimension(:), allocatable :: valuessp
real(dp), dimension(:), allocatable :: valuesdp
logical :: hasAttr
call ncVar%getAttributeNames(attributeNames)
allocate(self%attributes(size(attributeNames)))
! get all the names
attributeNames = ncVar%getAttributeNames()
do iAtt=1, size(attributeNames)
call ncVar%hasAttribute(attributeNames(iAtt), attType, attLength)
if (attLength > maxNoAttributeValues .and. attType /= 2_i4) then
write(errorString, "(1X,A,I0,A,A,A,A,A,A)") 'Received more than ', maxNoAttributeValues, &
! get the type and length
hasAttr = ncVar%hasAttribute(attributeNames(iAtt), attType, attLength)
! check for 1d vector values being longer than allowed
if (hasAttr .and. attLength > maxNoAttributeValues .and. attType /= 2_i4) then
log_error("(1X,A,I0,A,A,A,A)") 'Received more than ', maxNoAttributeValues, &
' attribute values for attribute ', trim(attributeNames(iAtt)), &
' of variable', trim(self%name), &
' in file ', trim(fileName)
log_error(*) errorString
' of variable', trim(ncVar%getName())
stop 1
end if
......@@ -1043,7 +1085,7 @@ contains
end select
end do
end subroutine set_attributes
end subroutine get_attributes_from_nc_var
subroutine from_values(self, values, boundArg)
!< initialize a Coordinate instance based on a vector of values
......@@ -1608,7 +1650,6 @@ contains
self%name = ''
self%is_initialized = .false.
if (allocated(self%values)) deallocate(self%values)
if (allocated(self%attributes)) deallocate(self%attributes)
if (allocated(self%subDims)) deallocate(self%subDims)
if (allocated(self%subDimSizes)) deallocate(self%subDimSizes)
if (allocated(self%cornersCoord1)) deallocate(self%cornersCoord1)
......@@ -1626,22 +1667,26 @@ contains
character(maxNameLength), dimension(size(self%attributes)) :: attributeNames
character(maxStringLength), dimension(size(self%attributes)) :: attributeValuesChar
logical, dimension(size(self%attributes)) :: maskIsChar = .false.
logical, dimension(size(self%attributes)) :: maskIsChar
integer(i4) :: iAtt
maskIsChar = .false.
! select now all the character valued attributes
do iAtt=1_i4, size(self%attributes)
if (self%attributes%get_type() == 2_i4) then
attributeNames = self%attributes%get_name()
attributeValuesChar = self%attributes%get_value()
if (self%attributes(iAtt)%get_type() == 2_i4) then
attributeNames(iAtt) = self%attributes(iAtt)%get_name()
attributeValuesChar(iAtt) = self%attributes(iAtt)%get_value()
maskIsChar(iAtt) = .true.
end if
end do
if (.not. self%is_2d()) then
NcDim = nc%setCoordinate(trim(self%name), int(self%count, kind=i4), self%values(:), self%staggerID, &
attributeNames(maskIsChar), attributeValuesChar(maskIsChar))
pack(attributeNames, maskIsChar), pack(attributeValuesChar, maskIsChar))
else if (self%is_polygon()) then
NcDim = nc%setCoordinate(trim(self%name), int(self%count, kind=i4), attribute_names=attributeNames(maskIsChar), &
attribute_values=attributeValuesChar(maskIsChar), centersDim1=self%centersCoord1, centersDim2=self%centersCoord2, &
NcDim = nc%setCoordinate(trim(self%name), int(self%count, kind=i4), &
attribute_names=pack(attributeNames, maskIsChar),&
attribute_values=pack(attributeValuesChar, maskIsChar), &
centersDim1=self%centersCoord1, centersDim2=self%centersCoord2, &
cornersDim1=self%cornersCoord1, cornersDim2=self%cornersCoord2, &
subDimSizes=int(self%subDimSizes, kind=i4), units=self%unit)
else
......@@ -2078,22 +2123,24 @@ contains
end subroutine check_within_bounds
function has_attribute(coord, attName, type, length) result(hasAttribute)
function has_attribute(coord, attName, attType, attLength) result(hasAttribute)
!< \brief check if coordinate has attribute with name attName
!< \details check if coordinate has attribute with name attName
type(Coordinate), intent(in) :: coord
class(Coordinate), intent(in) :: coord
character(*), intent(in) :: attName
integer(i4), intent(out), optional :: attType
integer(i4), intent(out), optional :: attLength
logical :: hasAttribute
character(maxNameLength) :: attNameCoord
integer(i4) :: iAtt
hasAttribute = .false.
if (present(attType)) attType = nodata_i4
if (present(attLength)) attLength = nodata_i4
do iAtt = 1, size(coord%attributes)
if (trim(coord%attributes(iAtt)%get_name()) == trim(attName))
attNameCoord = coord%attributes(iAtt)%get_name()
if (trim(attNameCoord) == trim(attName)) then
hasAttribute = .true.
if (present(attType)) attType = coord%attributes(iAtt)%get_type()
if (present(attLength)) attLength = coord%attributes(iAtt)%get_length()
......@@ -2106,15 +2153,19 @@ contains
subroutine get_attribute(coord, attName, attValue)
!< \brief get coordinate's attribute value for given attribute name
!< \details get coordinate's attribute value for given attribute name
type(Coordinate), intent(in) :: coord
class(Coordinate), intent(in) :: coord
character(*), intent(in) :: attName
character(maxStringLength) :: attValue
character(maxNameLength) :: attNameCoord
integer(i4) :: attType
integer(i4) :: iAtt
attValue = ''
do iAtt = 1, size(coord%attributes)
if (trim(coord%attributes(iAtt)%get_name()) == trim(attName) .and. coord%attributes(iAtt)%get_type() == 2_i4)
attNameCoord = coord%attributes(iAtt)%get_name()
attType = coord%attributes(iAtt)%get_type()
if (trim(attNameCoord) == trim(attName) .and. attType == 2_i4) then
attValue = coord%attributes(iAtt)%get_value()
return
end if
......
......@@ -944,10 +944,10 @@ contains
log_debug(*) 'Comparing the dimensions of each predictor data array:'
do iCoord = 1, size(IF1)
log_debug(*) 'predictor: ', trim(self%inputFieldNames(iIF)), 'dimension: ',trim(IF1(iCoord)%coord_p%name)
log_debug(*) 'predictor: ', trim(self%inputFieldNames(iIF)), ', dimension: ',trim(IF1(iCoord)%coord_p%name)
end do
do iCoord = 1, size(IF2)
log_debug(*) 'predictor: ', trim(self%inputFieldNames(jIF)), 'dimension: ', trim(IF2(iCoord)%coord_p%name)
log_debug(*) 'predictor: ', trim(self%inputFieldNames(jIF)), ', dimension: ', trim(IF2(iCoord)%coord_p%name)
end do
! this block is checking each dimension for its similarity and they are optionally concatenated
......
......@@ -1544,7 +1544,7 @@ contains
if (subcellCounter < 100_i8 .and. size(selIndices, kind=i8) > 0_i8) then
! issue a warning if too few cells are considered
log_warn(*) 'Simple nearest neighbor procedure (destination to source) ', &
'while ensuring centroid of source polygon is within target polygon might introduce great errors'
'while ensuring centroid of source polygon is within target polygon might introduce errors'
end if
else
log_warn(*) 'Could not find any polygons within target polygon ', iPolygon
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment