From d9b2fbfea166f7e2260fcf8532726ccf39b0727b Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 3 Dec 2024 09:56:23 -0500 Subject: [PATCH 1/3] fixes #3210 --- base/FileMetadataUtilities.F90 | 79 +++----------------- pfio/Variable.F90 | 133 +++++++++++++++++++++++++++++++++ 2 files changed, 144 insertions(+), 68 deletions(-) diff --git a/base/FileMetadataUtilities.F90 b/base/FileMetadataUtilities.F90 index ea8c858f7ccb..b42ff3ba8de1 100644 --- a/base/FileMetadataUtilities.F90 +++ b/base/FileMetadataUtilities.F90 @@ -116,30 +116,15 @@ function get_var_attr_real32(this,var_name,attr_name,rc) result(attr_real32) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - real(REAL32) :: tmp(1) - real(REAL64) :: tmpd(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(real(kind=REAL32)) - tmp = attr_val - attr_real32 = tmp(1) - type is(real(kind=REAL64)) - tmpd = attr_val - attr_real32 = REAL(tmpd(1)) - class default - _FAIL('unsupported subclass (not real32) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_real32 = var%get_attribute_real32(attr_name, rc=status) + _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_real32 @@ -151,28 +136,17 @@ function get_var_attr_real64(this,var_name,attr_name,rc) result(attr_real64) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - real(REAL64) :: tmp(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(real(kind=REAL64)) - tmp = attr_val - attr_real64 = tmp(1) - class default - _FAIL('unsupported subclass (not real64) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select - + attr_real64 = var%get_attribute_real64(attr_name, rc=status) + _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) + end function get_var_attr_real64 function get_var_attr_int32(this,var_name,attr_name,rc) result(attr_int32) @@ -182,26 +156,15 @@ function get_var_attr_int32(this,var_name,attr_name,rc) result(attr_int32) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - integer(INT32) :: tmp(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(integer(kind=INT32)) - tmp = attr_val - attr_int32 = tmp(1) - class default - _FAIL('unsupported subclass (not int32) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_int32 = var%get_attribute_int32(attr_name, rc=status) + _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_int32 @@ -213,26 +176,15 @@ function get_var_attr_int64(this,var_name,attr_name,rc) result(attr_int64) character(len=*), intent(in) :: attr_name integer, optional, intent(out) :: rc - integer(INT64) :: tmp(1) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val(:) fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_values() - select type(attr_val) - type is(integer(kind=INT64)) - tmp = attr_val - attr_int64 = tmp(1) - class default - _FAIL('unsupported subclass (not int64) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_int64 = var%get_attribute_int64(attr_name, rc=status) + _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_int64 @@ -246,22 +198,13 @@ function get_var_attr_string(this,var_name,attr_name,rc) result(attr_string) integer :: status character(:), allocatable :: fname - type(Attribute), pointer :: attr type(Variable), pointer :: var - class(*), pointer :: attr_val fname = this%get_file_name(_RC) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) - attr => var%get_attribute(attr_name,_RC) - _ASSERT(associated(attr),"no attribute named "//attr_name//" in "//var_name//" in "//fname) - attr_val => attr%get_value() - select type(attr_val) - type is(character(*)) - attr_string = attr_val - class default - _FAIL('unsupported subclass (not string) for units of attribute named '//attr_name//' in '//var_name//' in '//fname) - end select + attr_string = var%get_attribute_string(attr_name, rc=status) + _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_string diff --git a/pfio/Variable.F90 b/pfio/Variable.F90 index 84958a172945..001e22a92968 100644 --- a/pfio/Variable.F90 +++ b/pfio/Variable.F90 @@ -12,6 +12,7 @@ module pFIO_VariableMod use pFIO_AttributeMod use pFIO_StringAttributeMapMod use pFIO_StringAttributeMapUtilMod + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT32, INT64 implicit none private @@ -40,6 +41,11 @@ module pFIO_VariableMod procedure :: get_const_value procedure :: get_attribute + procedure :: get_attribute_string + procedure :: get_attribute_int32 + procedure :: get_attribute_int64 + procedure :: get_attribute_real32 + procedure :: get_attribute_real64 generic :: add_attribute => add_attribute_0d generic :: add_attribute => add_attribute_1d procedure :: add_attribute_0d @@ -258,6 +264,133 @@ function get_attribute(this, attr_name, rc) result(attr) _RETURN(_SUCCESS) end function get_attribute + function get_attribute_string(this, attr_name, rc) result(attr_string) + character(len=:), allocatable :: attr_string + class (Variable), target, intent(in) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no such attribute "//attr_name) + attr_val => attr%get_value() + select type(attr_val) + type is(character(*)) + attr_string = attr_val + class default + _FAIL('unsupported subclass (not string) of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_string + + function get_attribute_real32(this,attr_name,rc) result(attr_real32) + real(REAL32) :: attr_real32 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + real(REAL32) :: tmp(1) + real(REAL64) :: tmpd(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no attribute named "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(real(kind=REAL32)) + tmp = attr_val + attr_real32 = tmp(1) + type is(real(kind=REAL64)) + tmpd = attr_val + attr_real32 = REAL(tmpd(1)) + class default + _FAIL('unsupported subclass (not real32) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_real32 + + function get_attribute_real64(this,attr_name,rc) result(attr_real64) + real(REAL64) :: attr_real64 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + real(REAL64) :: tmp(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no such attribute "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(real(kind=REAL64)) + tmp = attr_val + attr_real64 = tmp(1) + class default + _FAIL('unsupported subclass (not real64) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_real64 + + function get_attribute_int32(this,attr_name,rc) result(attr_int32) + integer(INT32) :: attr_int32 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + integer(INT32) :: tmp(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no attribute named "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(integer(kind=INT32)) + tmp = attr_val + attr_int32 = tmp(1) + class default + _FAIL('unsupported subclass (not int32) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_int32 + + function get_attribute_int64(this,attr_name,rc) result(attr_int64) + integer(INT64) :: attr_int64 + class(Variable), intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + + integer(INT64) :: tmp(1) + integer :: status + type(Attribute), pointer :: attr + class(*), pointer :: attr_val(:) + + attr => this%get_attribute(attr_name,_RC) + _ASSERT(associated(attr),"no attribute named "//attr_name) + attr_val => attr%get_values() + select type(attr_val) + type is(integer(kind=INT64)) + tmp = attr_val + attr_int64 = tmp(1) + class default + _FAIL('unsupported subclass (not int64) for units of attribute named '//attr_name) + end select + + _RETURN(_SUCCESS) + end function get_attribute_int64 + subroutine add_const_value(this, const_value, rc) class (Variable), target, intent(inout) :: this type (UnlimitedEntity), intent(in) :: const_value From daab7d73ad0b5ad26eb1887eaa7672355ae1d4f5 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 3 Dec 2024 11:18:51 -0500 Subject: [PATCH 2/3] oops --- base/FileMetadataUtilities.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/base/FileMetadataUtilities.F90 b/base/FileMetadataUtilities.F90 index b42ff3ba8de1..133037ce3c4a 100644 --- a/base/FileMetadataUtilities.F90 +++ b/base/FileMetadataUtilities.F90 @@ -124,7 +124,7 @@ function get_var_attr_real32(this,var_name,attr_name,rc) result(attr_real32) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) attr_real32 = var%get_attribute_real32(attr_name, rc=status) - _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_real32 @@ -144,7 +144,7 @@ function get_var_attr_real64(this,var_name,attr_name,rc) result(attr_real64) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) attr_real64 = var%get_attribute_real64(attr_name, rc=status) - _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_real64 @@ -164,7 +164,7 @@ function get_var_attr_int32(this,var_name,attr_name,rc) result(attr_int32) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) attr_int32 = var%get_attribute_int32(attr_name, rc=status) - _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_int32 @@ -184,7 +184,7 @@ function get_var_attr_int64(this,var_name,attr_name,rc) result(attr_int64) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) attr_int64 = var%get_attribute_int64(attr_name, rc=status) - _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_int64 @@ -204,7 +204,7 @@ function get_var_attr_string(this,var_name,attr_name,rc) result(attr_string) var => this%get_variable(var_name,_RC) _ASSERT(associated(var),"no variable named "//var_name//" in "//fname) attr_string = var%get_attribute_string(attr_name, rc=status) - _ASSERT(status /= _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) + _ASSERT(status == _SUCCESS, 'failed to get attribute named '//attr_name//' in '//var_name//' in '//fname) _RETURN(_SUCCESS) end function get_var_attr_string From 5ad02a1936d525e787b89f72b56a2bf172c157e5 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 3 Dec 2024 11:50:46 -0500 Subject: [PATCH 3/3] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4c1be6318f47..0a0293c1ee8d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Allow update offsets of ±timestep in ExtData2G - Minor revision (and generalization) of grid-def for GSI purposes - Trajectory sampler: fix a bug when group_name does not exist in netCDF file and a bug that omitted the first time point +- PFIO/Variable class, new procedures to retrieve string/reals/int attributes from a variable ### Changed