feat: add ability to read in generic blocks to yaml parser (#1519)

parser/yaml_parser.F90

@@ -39,6 +39,9 @@ module yaml_parser_mod
 private
 
 public :: open_and_parse_file
+public :: get_num_unique_blocks
+public :: get_unique_block_ids
+public :: get_block_name
 public :: get_num_blocks
 public :: get_block_ids
 public :: get_value_from_key
@@ -127,6 +130,17 @@ function get_value(file_id, key_id) bind(c) &
    type(c_ptr) :: key_value
 end function get_value
 
+!> @brief Private c function that get the block name from a block_id in a yaml file
+!! @return String containing the value obtained
+function get_block(file_id, block_id) bind(c) &
+  result(block_name)
+  use iso_c_binding, only: c_ptr, c_int, c_bool
+  integer(kind=c_int), intent(in) :: file_id  !< File id corresponding to the yaml file that was opened
+  integer(kind=c_int), intent(in) :: block_id !< Block_id to get the block name for
+
+  type(c_ptr) :: block_name
+end function get_block
+
 !> @brief Private c function that determines the value of a key in yaml_file (see yaml_parser_binding.c)
 !! @return c pointer with the value obtained
 function get_value_from_key_wrap(file_id, block_id, key_name, success) bind(c) &
@@ -194,6 +208,26 @@ function is_valid_block_id(file_id, block_id) bind(c) &
    logical(kind=c_bool) :: is_valid !< Flag indicating if the file_id is valid
 end function is_valid_block_id
 
+!> @brief Private c function that determines the number of unique blocks that belong to
+!! a parent block with parent_block_id in the yaml file (see yaml_parser_binding.c)
+!! @return Number of unique blocks
+function get_num_unique_blocks_bind(file_id, parent_block_id) bind(c) &
+  result(nblocks)
+  use iso_c_binding, only: c_char, c_int, c_bool
+  integer(kind=c_int), intent(in) :: file_id         !< File id of the yaml file to search
+  integer(kind=c_int)             :: parent_block_id !< Id of the parent block
+
+  integer(kind=c_int) :: nblocks
+end function get_num_unique_blocks_bind
+
+!> @brief Private c function that gets the the ids of the unique blocks in the yaml file
+!! (see yaml_parser_binding.c)
+subroutine get_unique_block_ids_bind(file_id, block_ids, parent_block_id) bind(c)
+  use iso_c_binding, only: c_char, c_int, c_bool, c_ptr
+  integer(kind=c_int), intent(in)    :: file_id         !< File id corresponding to the yaml file that was opened
+  integer(kind=c_int), intent(inout) :: block_ids(*)    !< Id of the parent_block
+  integer(kind=c_int)                :: parent_block_id !< Id of the parent block
+end subroutine get_unique_block_ids_bind
 end interface
 
 !> @addtogroup yaml_parser_mod
@@ -463,6 +497,52 @@ subroutine get_key_ids (file_id, block_id, key_ids)
    call get_key_ids_binding (file_id, block_id, key_ids)
 end subroutine get_key_ids
 
+!> @brief Gets the number of unique blocks
+!! @return The number of unique blocks
+function get_num_unique_blocks(file_id, parent_block_id) &
+  result(nblocks)
+  integer, intent(in)           :: file_id !< File id corresponding to the yaml file that was opened
+  integer, intent(in), optional :: parent_block_id !< Id of the parent_block
+  integer :: nblocks
+
+  if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
+    &  "The file id in your get_num_unique_blocks call is invalid! Check your call.")
+
+  if (.not. present(parent_block_id)) then
+    nblocks = get_num_unique_blocks_bind(file_id, 0)
+  else
+    if (.not. is_valid_block_id(file_id, parent_block_id)) call mpp_error(FATAL, &
+        &  "The parent_block id in your get_block_ids call is invalid! Check your call.")
+    nblocks = get_num_unique_blocks_bind(file_id, parent_block_id)
+  endif
+end function
+
+!> @brief Gets the ids of the unique block ids
+subroutine get_unique_block_ids(file_id, block_ids, parent_block_id)
+  integer, intent(in)             :: file_id         !< File id corresponding to the yaml file that was opened
+  integer, intent(inout)          :: block_ids(:)    !< Ids of each unique block
+  integer, intent(in),   optional :: parent_block_id !< Id of the parent_block
+
+  if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
+    &  "The file id in your get_num_unique_blocks_ids call is invalid! Check your call.")
+
+  if (.not. present(parent_block_id)) then
+    call get_unique_block_ids_bind(file_id, block_ids, 0)
+  else
+    if (.not. is_valid_block_id(file_id, parent_block_id)) call mpp_error(FATAL, &
+        &  "The parent_block id in your get_block_ids call is invalid! Check your call.")
+    call get_unique_block_ids_bind(file_id, block_ids, parent_block_id)
+  endif
+end subroutine get_unique_block_ids
+
+!> @brief Gets the block name form the block id
+subroutine get_block_name(file_id, block_id, block_name)
+  integer,          intent(in)  :: file_id    !< File id corresponding to the yaml file that was opened
+  integer,          intent(in)  :: block_id   !< Id of the block to get the name from
+  character(len=*), intent(out) :: block_name !< Name of the block
+
+  block_name = fms_c2f_string(get_block(file_id, block_id))
+end subroutine
 #endif
 end module yaml_parser_mod
 !> @}

parser/yaml_parser_binding.c

@@ -97,6 +97,14 @@ char *get_value(int *file_id, int *key_id)
   return my_files.files[j].keys[*key_id].value;
 }
 
+/* @brief Private c functions get gets the block name from a block id
+   @return String containing the value obtained */
+char *get_block(int *file_id, int *block_id)
+{
+  int j = *file_id;   /* To minimize the typing :) */
+  return my_files.files[j].keys[*block_id].parent_name;
+}
+
 /* @brief Private c function that determines they value of a key in yaml_file
    @return c pointer with the value obtained */
 char *get_value_from_key_wrap(int *file_id, int *block_id, char *key_name, int *sucess) /*, char *key_name) */
@@ -136,6 +144,82 @@ int get_num_blocks_all(int *file_id, char *block_name)
   return nblocks;
 }
 
+/* @brief Private c function that determines the number of unique blocks (i.e diag_files, varlist, etc)
+   @return The number of unique blocks */
+int get_num_unique_blocks_bind(int *file_id, int *parent_block_id)
+{
+  int nblocks = 0;    /* Number of blocks */
+  int i;              /* For loops */
+  int j = *file_id;   /* To minimize the typing :) */
+  char block_names[my_files.files[j].nkeys][255]; /* Array that stores the names of the unique blocks*/
+  bool found;         /* True if the block name was already found (i.e it not unqiue)*/
+  int k;              /* For loops */
+
+  for ( i = 1; i <= my_files.files[j].nkeys; i++ )
+  {
+    if (my_files.files[j].keys[i].parent_key == *parent_block_id )
+    {
+      if (strcmp(my_files.files[j].keys[i].parent_name, "") == 0){
+        continue;
+      }
+      found = false;
+      for (k = 1; k <= nblocks; k++)
+      {
+        if (strcmp(block_names[k], my_files.files[j].keys[i].parent_name) == 0)
+        {
+          found = true;
+          break;
+        }
+      }
+
+      if (found) continue;
+
+      nblocks = nblocks + 1;
+      strcpy(block_names[nblocks], my_files.files[j].keys[i].parent_name);
+      // printf("Block names: %s \n", block_names[nblocks]);
+    }
+  }
+  return nblocks;
+}
+
+/* @brief Private c function that determines the ids of the unique blocks (i.e diag_files, varlist, etc)
+   @return The ids of the unique blocks */
+void get_unique_block_ids_bind(int *file_id, int *block_ids, int *parent_block_id)
+{
+  int nblocks = 0;    /* Number of blocks */
+  int i;              /* For loops */
+  int j = *file_id;   /* To minimize the typing :) */
+  char block_names[my_files.files[j].nkeys][255]; /* Array that stores the names of the unique blocks*/
+  bool found;         /* True if the block name was already found (i.e it not unqiue)*/
+  int k;              /* For loops */
+
+  for ( i = 1; i <= my_files.files[j].nkeys; i++ )
+  {
+    if (my_files.files[j].keys[i].parent_key == *parent_block_id )
+    {
+      if (strcmp(my_files.files[j].keys[i].parent_name, "") == 0){
+        continue;
+      }
+      found = false;
+      for (k = 1; k <= nblocks; k++)
+      {
+        if (strcmp(block_names[k], my_files.files[j].keys[i].parent_name) == 0)
+        {
+          found = true;
+          break;
+        }
+      }
+
+      if (found) continue;
+
+      nblocks = nblocks + 1;
+      block_ids[nblocks - 1] = my_files.files[j].keys[i].key_number;
+      strcpy(block_names[nblocks], my_files.files[j].keys[i].parent_name);
+      //printf("Block names: %s \n", block_names[nblocks]);
+    }
+  }
+  return;
+}
 /* @brief Private c function that determines the number of blocks with block_name that belong to
    a parent block with parent_block_id in the yaml file
    @return Number of blocks with block_name */

test_fms/parser/Makefile.am

@@ -29,14 +29,16 @@ AM_CPPFLAGS = -I${top_srcdir}/include -I$(MODDIR)
 LDADD = ${top_builddir}/libFMS/libFMS.la
 
 # Build this test program.
-check_PROGRAMS = parser_demo2 test_yaml_parser check_crashes parser_demo test_output_yaml
+check_PROGRAMS = parser_demo2 test_yaml_parser check_crashes parser_demo test_output_yaml \
+                 generic_blocks
 
 # This is the source code for the test.
 test_yaml_parser_SOURCES = test_yaml_parser.F90
 check_crashes_SOURCES = check_crashes.F90
 parser_demo_SOURCES = parser_demo.F90
 parser_demo2_SOURCES = parser_demo2.F90
 test_output_yaml_SOURCES = test_output_yaml.F90
+generic_blocks_SOURCES = generic_blocks.F90
 
 # Run the test program.
 TESTS = test_yaml_parser.sh

test_fms/parser/generic_blocks.F90

@@ -0,0 +1,132 @@
+!***********************************************************************
+!*                   GNU Lesser General Public License
+!*
+!* This file is part of the GFDL Flexible Modeling System (FMS).
+!*
+!* FMS is free software: you can redistribute it and/or modify it under
+!* the terms of the GNU Lesser General Public License as published by
+!* the Free Software Foundation, either version 3 of the License, or (at
+!* your option) any later version.
+!*
+!* FMS is distributed in the hope that it will be useful, but WITHOUT
+!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+!* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+!* for more details.
+!*
+!* You should have received a copy of the GNU Lesser General Public
+!* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
+!***********************************************************************
+
+!> @brief  This programs tests the subroutines get_num_unique_blocks, get_unique_block_ids, and
+!! get_block_name
+program generic_blocks
+#ifdef use_yaml
+  use fms_mod, only: fms_init, fms_end
+  use mpp_mod, only: mpp_error, FATAL
+  use yaml_parser_mod
+
+  implicit none
+
+  integer              :: yaml_id            !< Id of the yaml file
+  integer, allocatable :: field_table_ids(:) !< The Ids of the field table entries
+  integer, allocatable :: modlist_ids(:)     !< The ids of the mods entries
+  integer, allocatable :: varlist_ids(:)     !< The ids of the variable entries
+  integer, allocatable :: block_ids(:)       !< The ids of the block entries
+  integer, allocatable :: misc_block_ids(:)  !< The ids of the misc block entries
+  integer, allocatable :: key_ids(:)         !< The ids of the keys
+  character(len=50)    :: variable_name      !< The variable name
+  character(len=50)    :: model_type_name    !< The model type
+  character(len=50)    :: block_name         !< The name of the block
+  character(len=50)    :: key_name           !< The name of the key
+  character(len=50)    :: key_value          !< The value of the key
+  character(len=50)    :: varnames(2)        !< The expected names of the variables
+  character(len=50)    :: blocknames1(1)     !< The expected names of the blocks for the first variable
+  character(len=50)    :: blocknames2(2)     !< The expected names of the blocks for the second variable
+  character(len=50)    :: keys(5)            !< The expected names of the keys
+  character(len=50)    :: values(5)          !< The expected names values of they keys
+  integer              :: key_count          !< To keep track of the expected answers
+
+  logical :: correct_answer   !< True if the answer is correct
+  integer :: i, j, k, l, m, n !< For do loops
+
+  call fms_init()
+  varnames(1) = "sphum"
+  varnames(2) = "soa"
+
+  blocknames1(1) = "profile_type"
+  blocknames2(1) = "chem_param"
+  blocknames2(2) = "profile_type"
+
+  key_count = 0
+  keys(1) = "value";         values(1) = "fixed"
+  keys(2) = "surface_value"; values(2) = "3.0e-06"
+  keys(3) = "value";         values(3) = "aerosol"
+  keys(4) = "value";         values(4) = "fixed"
+  keys(5) = "surface_value"; values(5) = "1.0e-32"
+
+  yaml_id = open_and_parse_file("sample.yaml")
+  allocate(field_table_ids(get_num_blocks(yaml_id, "field_table")))
+  call get_block_ids(yaml_id, "field_table", field_table_ids)
+  do i = 1, size(field_table_ids)
+    allocate(modlist_ids(get_num_blocks(yaml_id, "modlist", parent_block_id=field_table_ids(i))))
+    call get_block_ids(yaml_id, "modlist", modlist_ids, field_table_ids(i))
+
+    do j = 1, size(modlist_ids)
+      call get_value_from_key(yaml_id, modlist_ids(j), "model_type", model_type_name)
+      print *, "Modlist::", trim(model_type_name)
+      if (trim(model_type_name) .ne. "atmos_mod") &
+        call mpp_error(FATAL, "Modlist is not the expected result")
+
+      allocate(varlist_ids(get_num_blocks(yaml_id, "varlist", parent_block_id=modlist_ids(j))))
+      call get_block_ids(yaml_id, "varlist", varlist_ids, modlist_ids(j))
+
+      do k = 1, size(varlist_ids)
+        call get_value_from_key(yaml_id, varlist_ids(k), "variable", variable_name)
+        print *, "Variable::", trim(variable_name)
+        if (trim(variable_name) .ne. varnames(k)) &
+          call mpp_error(FATAL, "Variable is not the expected result")
+
+        allocate(block_ids(get_num_unique_blocks(yaml_id, parent_block_id=varlist_ids(k))))
+        call get_unique_block_ids(yaml_id, block_ids, parent_block_id=varlist_ids(k))
+        do l = 1, size(block_ids)
+          call get_block_name(yaml_id, block_ids(l), block_name)
+          print *, "Block_name::", trim(block_name)
+
+          if (k == 1) then
+            correct_answer = trim(blocknames1(l)) .eq. trim(block_name)
+          else
+            correct_answer = trim(blocknames2(l)) .eq. trim(block_name)
+          endif
+
+          if (.not. correct_answer) call mpp_error(FATAL, "blockname is not the expected result")
+          allocate(misc_block_ids(get_num_blocks(yaml_id, block_name, parent_block_id=varlist_ids(k))))
+          call get_block_ids(yaml_id, block_name, misc_block_ids, parent_block_id=varlist_ids(k))
+          do m = 1, size(misc_block_ids)
+            allocate(key_ids(get_nkeys(yaml_id, misc_block_ids(m))))
+            call get_key_ids(yaml_id, misc_block_ids(m), key_ids)
+            do n = 1, size(key_ids)
+              key_count = key_count + 1
+              call get_key_name(yaml_id, key_ids(n), key_name)
+              call get_key_value(yaml_id, key_ids(n), key_value)
+              print *, "KEY:", trim(key_name), " VALUE:", trim(key_value)
+
+              if (trim(key_name) .ne. trim(keys(key_count))) &
+                call mpp_error(FATAL, "The key is not correct")
+
+              if (trim(key_value) .ne. trim(values(key_count))) &
+                call mpp_error(FATAL, "The value is not correct")
+            enddo
+            deallocate(key_ids)
+          enddo
+          deallocate(misc_block_ids)
+        enddo
+        deallocate(block_ids)
+        print *, "---------"
+      enddo
+      deallocate(varlist_ids)
+    enddo
+    deallocate(modlist_ids)
+  enddo
+  call fms_end()
+#endif
+end program generic_blocks

test_fms/parser/test_yaml_parser.sh

@@ -268,4 +268,30 @@ test_expect_failure "wrong buffer size block id" '
   mpirun -n 1 ./check_crashes
 '
 
+cat <<_EOF > sample.yaml
+field_table:
+- field_type: tracer
+  modlist:
+  - model_type: atmos_mod
+    varlist:
+    - variable: sphum
+      longname: specific humidity
+      units: kg/kg
+      profile_type:
+      - value: fixed
+        surface_value: 3.0e-06
+    - variable: soa
+      longname: SOA tracer
+      units: mmr
+      convection: all
+      chem_param:
+      - value: aerosol
+      profile_type:
+      - value: fixed
+        surface_value: 1.0e-32
+_EOF
+
+test_expect_success "Generic blocks names" '
+  mpirun -n 1 ./generic_blocks
+'
 test_done