parser/yaml_parser.F90

   1 !***********************************************************************
   2 !*                   GNU Lesser General Public License
   3 !*
   4 !* This file is part of the GFDL Flexible Modeling System (FMS).
   5 !*
   6 !* FMS is free software: you can redistribute it and/or modify it under
   7 !* the terms of the GNU Lesser General Public License as published by
   8 !* the Free Software Foundation, either version 3 of the License, or (at
   9 !* your option) any later version.
  10 !*
  11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
  12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 !* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 !* for more details.
  15 !*
  16 !* You should have received a copy of the GNU Lesser General Public
  17 !* License along with FMS.  If not, see <http://www.gnu.org/licenses/>.
  18 !***********************************************************************
  19
  20 !> @defgroup yaml_parser_mod yaml_parser_mod
  21 !> @ingroup parser
  22 !> @brief Routines to use for parsing yaml files
  23
  24 !> @file
  25 !> @brief File for @ref yaml_parser_mod
  26
  27 !> @addtogroup yaml_parser_mod
  28 !> @{
  29 module yaml_parser_mod
  30
  31 #ifdef use_yaml
  32 use fms_mod, only: fms_c2f_string
  33 use fms_string_utils_mod, only: string_copy
  34 use platform_mod
  35 use mpp_mod
  36 use iso_c_binding
  37
  38 implicit none
  39 private
  40
  41 public :: open_and_parse_file
  42 public :: get_num_blocks
  43 public :: get_block_ids
  44 public :: get_value_from_key
  45 public :: get_nkeys
  46 public :: get_key_ids
  47 public :: get_key_name
  48 public :: get_key_value
  49 !public :: clean_up
  50 !> @}
  51
  52 !> @brief Dermine the value of a key from a keyname
  53 !> @ingroup yaml_parser_mod
  54 interface get_value_from_key
  55   module procedure get_value_from_key_0d
  56   module procedure get_value_from_key_1d
  57 end interface get_value_from_key
  58
  59 !> @brief c functions binding
  60 !> @ingroup yaml_parser_mod
  61 interface
  62
  63 !> @brief Private c function that opens and parses a yaml file (see yaml_parser_binding.c)
  64 !! @return Flag indicating if the read was successful
  65 function open_and_parse_file_wrap(filename, file_id) bind(c) &
  66    result(success)
  67    use iso_c_binding, only: c_char, c_int, c_bool
  68    character(kind=c_char), intent(in) :: filename(*) !< Filename of the yaml file
  69    integer(kind=c_int), intent(out) :: file_id !< File id corresponding to the yaml file that was opened
  70    logical(kind=c_bool) :: success !< Flag indicating if the read was successful
  71 end function open_and_parse_file_wrap
  72
  73 !> @brief Private c function that checks if a file_id is valid (see yaml_parser_binding.c)
  74 !! @return Flag indicating if the file_id is valid
  75 function is_valid_file_id(file_id) bind(c) &
  76    result(is_valid)
  77    use iso_c_binding, only: c_char, c_int, c_bool
  78    integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened
  79    logical(kind=c_bool) :: is_valid !< Flag indicating if the file_id is valid
  80 end function is_valid_file_id
  81
  82 !> @brief Private c function that gets the number of key-value pairs in a block (see yaml_parser_binding.c)
  83 !! @return Number of key-value pairs in this block
  84 function get_nkeys_binding(file_id, block_id) bind(c) &
  85    result(nkeys)
  86    use iso_c_binding, only: c_char, c_int, c_bool
  87    integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened
  88    integer(kind=c_int), intent(in) :: block_id !< Id of the parent_block
  89    integer(kind=c_int) :: nkeys
  90 end function get_nkeys_binding
  91
  92 !> @brief Private c function that gets the ids of the key-value pairs in a block (see yaml_parser_binding.c)
  93 subroutine get_key_ids_binding(file_id, block_id, key_ids) bind(c)
  94    use iso_c_binding, only: c_char, c_int, c_bool
  95    integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened
  96    integer(kind=c_int), intent(in) :: block_id !< Id of the parent_block
  97    integer(kind=c_int), intent(inout) :: key_ids(*) !< Ids of the key-value pairs
  98 end subroutine get_key_ids_binding
  99
 100 !> @brief Private c function that checks if a key_id is valid (see yaml_parser_binding.c)
 101 !! @return Flag indicating if the key_id is valid
 102 function is_valid_key_id(file_id, key_id) bind(c) &
 103    result(is_valid)
 104    use iso_c_binding, only: c_char, c_int, c_bool
 105    integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened
 106    integer(kind=c_int), intent(in) :: key_id !< Key id to check if valid
 107    logical(kind=c_bool) :: is_valid !< Flag indicating if the file_id is valid
 108 end function is_valid_key_id
 109
 110 !> @brief Private c function that get the key from a key_id in a yaml file
 111 !! @return Name of the key obtained
 112 function get_key(file_id, key_id) bind(c) &
 113    result(key_name)
 114    use iso_c_binding, only: c_ptr, c_int, c_bool
 115    integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened
 116    integer(kind=c_int), intent(in) :: key_id !< Id of the key-value pair of interest
 117    type(c_ptr) :: key_name
 118 end function get_key
 119
 120 !> @brief Private c function that get the value from a key_id in a yaml file
 121 !! @return String containing the value obtained
 122 function get_value(file_id, key_id) bind(c) &
 123    result(key_value)
 124    use iso_c_binding, only: c_ptr, c_int, c_bool
 125    integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened
 126    integer(kind=c_int), intent(in) :: key_id !< Id of the key-value pair of interest
 127    type(c_ptr) :: key_value
 128 end function get_value
 129
 130 !> @brief Private c function that determines the value of a key in yaml_file (see yaml_parser_binding.c)
 131 !! @return c pointer with the value obtained
 132 function get_value_from_key_wrap(file_id, block_id, key_name, success) bind(c) &
 133    result(key_value2)
 134
 135    use iso_c_binding, only: c_ptr, c_char, c_int, c_bool
 136    integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search
 137    integer(kind=c_int), intent(in) :: block_id !< ID corresponding to the block you want the key for
 138    character(kind=c_char), intent(in) :: key_name(*) !< Name of the key you want the value for
 139    integer(kind=c_int), intent(out) :: success !< Flag indicating if the call was successful
 140    type(c_ptr) :: key_value2
 141 end function get_value_from_key_wrap
 142
 143 !> @brief Private c function that determines the number of blocks with block_name in the yaml file
 144 !! (see yaml_parser_binding.c)
 145 !! @return Number of blocks with block_name
 146 function get_num_blocks_all(file_id, block_name) bind(c) &
 147    result(nblocks)
 148    use iso_c_binding, only: c_char, c_int, c_bool
 149    integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search
 150    character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for
 151
 152    integer(kind=c_int) :: nblocks
 153 end function get_num_blocks_all
 154
 155 !> @brief Private c function that determines the number of blocks with block_name that belong to
 156 !! a parent block with parent_block_id in the yaml file (see yaml_parser_binding.c)
 157 !! @return Number of blocks with block_name
 158 function get_num_blocks_child(file_id, block_name, parent_block_id) bind(c) &
 159    result(nblocks)
 160    use iso_c_binding, only: c_char, c_int, c_bool
 161    integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search
 162    character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for
 163    integer(kind=c_int) :: parent_block_id !< Id of the parent block
 164
 165    integer(kind=c_int) :: nblocks
 166 end function get_num_blocks_child
 167
 168 !> @brief Private c function that gets the the ids of the blocks with block_name in the yaml file
 169 !! (see yaml_parser_binding.c)
 170 subroutine get_block_ids_all(file_id, block_name, block_ids) bind(c)
 171    use iso_c_binding, only: c_char, c_int, c_bool
 172    integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search
 173    character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for
 174    integer(kind=c_int), intent(inout) :: block_ids(*) !< Id of the parent_block
 175 end subroutine get_block_ids_all
 176
 177 !> @brief Private c function that gets the the ids of the blocks with block_name and that
 178 !! belong to a parent block id in the yaml file (see yaml_parser_binding.c)
 179 subroutine get_block_ids_child(file_id, block_name, block_ids, parent_block_id) bind(c)
 180    use iso_c_binding, only: c_char, c_int, c_bool
 181    integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search
 182    character(kind=c_char), intent(in) :: block_name(*) !< The name of the block you are looking for
 183    integer(kind=c_int), intent(inout) :: block_ids(*) !< Id of the parent_block
 184    integer(kind=c_int) :: parent_block_id !< Id of the parent block
 185 end subroutine get_block_ids_child
 186
 187 !> @brief Private c function that checks if a block_id is valid (see yaml_parser_binding.c)
 188 !! @return Flag indicating if the block_id is valid
 189 function is_valid_block_id(file_id, block_id) bind(c) &
 190    result(is_valid)
 191    use iso_c_binding, only: c_char, c_int, c_bool
 192    integer(kind=c_int), intent(in) :: file_id !< File id corresponding to the yaml file that was opened
 193    integer(kind=c_int), intent(in) :: block_id !< Block id to check if valid
 194    logical(kind=c_bool) :: is_valid !< Flag indicating if the file_id is valid
 195 end function is_valid_block_id
 196
 197 end interface
 198
 199 !> @addtogroup yaml_parser_mod
 200 !> @{
 201 contains
 202
 203 !> @brief Opens and parses a yaml file
 204 !! @return A file id corresponding to the file that was opened
 205 function open_and_parse_file(filename) &
 206    result(file_id)
 207
 208    character(len=*), intent(in) :: filename !< Filename of the yaml file
 209    logical :: success !< Flag indicating if the read was successful
 210    logical :: yaml_exists !< Flag indicating whether the yaml exists
 211
 212    integer :: file_id
 213
 214    inquire(file=trim(filename), EXIST=yaml_exists)
 215    if (.not. yaml_exists) then
 216       file_id = 999
 217       call mpp_error(NOTE, "The yaml file:"//trim(filename)//" does not exist, hopefully this is your intent!")
 218       return
 219    end if
 220    success = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id)
 221    if (.not. success) call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)//". Check the file!")
 222
 223 end function open_and_parse_file
 224
 225 !> @brief Gets the key from a file id
 226 subroutine get_key_name(file_id, key_id, key_name)
 227    integer, intent(in) :: key_id !< Id of the key-value pair of interest
 228    integer, intent(in) :: file_id !< File id of the yaml file to search
 229    character(len=*), intent(out) :: key_name
 230
 231    if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 232        &  "The file id in your get_key_name call is invalid! Check your call.")
 233    if (.not. is_valid_key_id(file_id, key_id)) call mpp_error(FATAL, &
 234        &  "The key id in your get_key_name call is invalid! Check your call.")
 235
 236    key_name = fms_c2f_string(get_key(file_id, key_id))
 237
 238 end subroutine get_key_name
 239
 240 !> @brief Gets the value from a file id
 241 subroutine get_key_value(file_id, key_id, key_value)
 242    integer, intent(in) :: key_id !< Id of the key-value pair of interest
 243    integer, intent(in) :: file_id !< File id of the yaml file to search
 244    character(len=*), intent(out) :: key_value
 245
 246    if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 247        &  "The file id in your get_key_value call is invalid! Check your call.")
 248    if (.not. is_valid_key_id(file_id, key_id)) call mpp_error(FATAL, &
 249        &  "The key id in your get_key_value call is invalid! Check your call.")
 250
 251    key_value = fms_c2f_string(get_value(file_id, key_id))
 252
 253 end subroutine get_key_value
 254
 255 !> @brief Used to dermine the value of a key from a keyname
 256 subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_optional)
 257    integer, intent(in) :: file_id !< File id of the yaml file to search
 258    integer, intent(in) :: block_id !< ID corresponding to the block you want the key for
 259    character(len=*), intent(in) :: key_name !< Name of the key you want the value for
 260    class(*), intent(inout):: key_value !< Value of the key
 261    logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for the key to not exist.
 262                                                 !! If the key does not exist key_value will not be set, so it
 263                                                 !! is the user's responsibility to initialize it before the call
 264
 265    character(len=255) :: buffer !< String buffer with the value
 266
 267    type(c_ptr) :: c_buffer !< c pointer with the value
 268    integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully
 269    logical :: optional_flag !< Flag indicating that the key was optional
 270    integer :: err_unit !< integer with io error
 271
 272    optional_flag = .false.
 273    if (present(is_optional)) optional_flag = is_optional
 274
 275    if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 276        &  "The file id in your get_value_from_key call is invalid! Check your call.")
 277    if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, &
 278        &  "The block id in your get_value_from_key call is invalid! Check your call.")
 279
 280    c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, success)
 281    if (success == 1) then
 282      buffer = fms_c2f_string(c_buffer)
 283
 284      select type (key_value)
 285        type is (integer(kind=i4_kind))
 286           read(buffer,*, iostat=err_unit) key_value
 287           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 288               & trim(key_name)//" Error converting '"//trim(buffer)//"' to i4")
 289        type is (integer(kind=i8_kind))
 290           read(buffer,*, iostat=err_unit) key_value
 291           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 292               & trim(key_name)//" Error converting '"//trim(buffer)//"' to i8")
 293        type is (real(kind=r4_kind))
 294           read(buffer,*, iostat=err_unit) key_value
 295           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 296               & trim(key_name)//" Error converting '"//trim(buffer)//"' to r4")
 297        type is (real(kind=r8_kind))
 298           read(buffer,*, iostat=err_unit) key_value
 299           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 300               & trim(key_name)//" Error converting '"//trim(buffer)//"' to r8")
 301        type is (character(len=*))
 302           call string_copy(key_value, buffer)
 303        type is (logical)
 304           if (lowercase(trim(buffer)) == "false") then
 305             key_value = .false.
 306           elseif (lowercase(trim(buffer)) == "true") then
 307             key_value = .true.
 308           else
 309             call mpp_error(FATAL, "Key:"//trim(key_name)//" Error converting '"//trim(buffer)//"' to logical")
 310           endif
 311      class default
 312        call mpp_error(FATAL, "The type of your buffer in your get_value_from_key call for key "//trim(key_name)//&
 313                             &" is not supported. Only i4, i8, r4, r8 and strings are supported.")
 314      end select
 315    else
 316      if(.not. optional_flag) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name))
 317    endif
 318
 319 end subroutine get_value_from_key_0d
 320
 321 !> @brief Used' to dermine the 1D value of a key from a keyname
 322 subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_optional)
 323    integer, intent(in) :: file_id !< File id of the yaml file to search
 324    integer, intent(in) :: block_id !< ID corresponding to the block you want the key for
 325    character(len=*), intent(in) :: key_name !< Name of the key you want the value for
 326    class(*), intent(inout):: key_value(:) !< Value of the key
 327    logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for the key' to not exist.
 328                                                 !! If the key does not exist key_value will not be set, so it
 329                                                 !! is the user's responsibility to initialize it before the call
 330
 331    character(len=255) :: buffer !< String buffer with the value
 332
 333    type(c_ptr) :: c_buffer !< c pointer with the value
 334    integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully
 335    logical :: optional_flag !< Flag indicating that the key was optional
 336    integer :: err_unit !< integer with io error
 337
 338    optional_flag=.false.
 339    if (present(is_optional)) optional_flag = is_optional
 340
 341    if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 342        &  "The file id in your get_value_from_key call is invalid! Check your call.")
 343    if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, &
 344        &  "The block id in your get_value_from_key call is invalid! Check your call.")
 345
 346    c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, success)
 347    if (success == 1) then
 348      buffer = fms_c2f_string(c_buffer)
 349
 350      select type (key_value)
 351        type is (integer(kind=i4_kind))
 352           read(buffer,*, iostat=err_unit) key_value
 353           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 354               & trim(key_name)//" Error converting '"//trim(buffer)//"' to i4")
 355        type is (integer(kind=i8_kind))
 356           read(buffer,*, iostat=err_unit) key_value
 357           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 358               & trim(key_name)//" Error converting '"//trim(buffer)//"' to i8")
 359        type is (real(kind=r4_kind))
 360           read(buffer,*, iostat=err_unit) key_value
 361           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 362               & trim(key_name)//" Error converting '"//trim(buffer)//"' to r4")
 363        type is (real(kind=r8_kind))
 364           read(buffer,*, iostat=err_unit) key_value
 365           if (err_unit .ne. 0) call mpp_error(FATAL, "Key:"// &
 366               & trim(key_name)//" Error converting '"//trim(buffer)//"' to r8")
 367        type is (character(len=*))
 368           call mpp_error(FATAL, "get_value_from_key 1d string variables are not supported. Contact developers")
 369      class default
 370        call mpp_error(FATAL, "The type of your buffer in your get_value_from_key call for key "//trim(key_name)//&
 371                             &" is not supported. Only i4, i8, r4, r8 and strings are supported.")
 372      end select
 373    else
 374      if(.not. optional_flag) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name))
 375    endif
 376 end subroutine get_value_from_key_1d
 377
 378 !> @brief Determines the number of blocks with block_name in the yaml file
 379 !! If parent_block_id is present, it only counts those that belong to that block
 380 !! @return Number of blocks with block_name
 381 function get_num_blocks(file_id, block_name, parent_block_id) &
 382     result(nblocks)
 383
 384     integer, intent(in) :: file_id !< File id of the yaml file to search
 385     character(len=*), intent(in) :: block_name !< The name of the block you are looking for
 386     integer, intent(in), optional :: parent_block_id !< Id of the parent block
 387     integer :: nblocks
 388
 389     if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 390         &  "The file id in your get_num_blocks call is invalid! Check your call.")
 391
 392     if (.not. present(parent_block_id)) then
 393        nblocks=get_num_blocks_all(file_id, trim(block_name)//c_null_char)
 394     else
 395        if (.not. is_valid_block_id(file_id, parent_block_id)) call mpp_error(FATAL, &
 396            &  "The parent_block id in your get_num_blocks call is invalid! Check your call.")
 397        nblocks=get_num_blocks_child(file_id, trim(block_name)//c_null_char, parent_block_id)
 398     endif
 399 end function get_num_blocks
 400
 401 !> @brief Gets the the ids of the blocks with block_name in the yaml file
 402 !! If parent_block_id is present, it only gets those that belong to that block
 403 subroutine get_block_ids(file_id, block_name, block_ids, parent_block_id)
 404
 405     integer, intent(in) :: file_id !< File id of the yaml file to search
 406     character(len=*), intent(in) :: block_name !< The name of the block you are looking for
 407     integer, intent(inout) :: block_ids(:) !< Id of blocks with block_name
 408     integer, intent(in), optional :: parent_block_id !< Id of the parent_block
 409     integer :: nblocks_id
 410     integer :: nblocks
 411
 412     if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 413         &  "The file id in your get_block_ids call is invalid! Check your call.")
 414
 415     nblocks_id = size(block_ids)
 416     nblocks = get_num_blocks(file_id, block_name, parent_block_id)
 417     if (nblocks .ne. nblocks_id) call mpp_error(FATAL, "The size of your block_ids array is not correct")
 418
 419     if (.not. present(parent_block_id)) then
 420        call get_block_ids_all(file_id, trim(block_name)//c_null_char, block_ids)
 421     else
 422        if (.not. is_valid_block_id(file_id, parent_block_id)) call mpp_error(FATAL, &
 423            &  "The parent_block id in your get_block_ids call is invalid! Check your call.")
 424        call get_block_ids_child(file_id, trim(block_name)//c_null_char, block_ids, parent_block_id)
 425     endif
 426 end subroutine get_block_ids
 427
 428 !> @brief Gets the number of key-value pairs in a block
 429 !! @return Number of key-value pairs in this block
 430 function get_nkeys(file_id, block_id) &
 431    result(nkeys)
 432    integer, intent(in) :: file_id !< File id corresponding to the yaml file that was opened
 433    integer, intent(in) :: block_id !< Id of the parent_block
 434    integer :: nkeys
 435
 436     if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 437         &  "The file id in your get_nkeys call is invalid! Check your call.")
 438     if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, &
 439         &  "The block id in your get_nkeys call is invalid! Check your call.")
 440
 441     nkeys = get_nkeys_binding(file_id, block_id)
 442 end function get_nkeys
 443
 444 !> @brief Gets the ids of the key-value pairs in a block
 445 subroutine get_key_ids (file_id, block_id, key_ids)
 446    integer, intent(in) :: file_id !< File id corresponding to the yaml file that was opened
 447    integer, intent(in) :: block_id !< Id of the parent_block
 448    integer, intent(inout) :: key_ids(:) !< Ids of the key-value pairs
 449
 450    integer :: nkey_ids !< Size of key_ids
 451    integer :: nkeys !< Actual number of keys
 452
 453    if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, &
 454        &  "The file id in your get_key_ids call is invalid! Check your call.")
 455    if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, &
 456        &  "The block id in your get_key_ids call is invalid! Check your call.")
 457
 458    nkey_ids = size(key_ids)
 459    nkeys = get_nkeys(file_id, block_id)
 460
 461    if (nkeys .ne. nkey_ids) call mpp_error(FATAL, "The size of your key_ids array is not correct.")
 462
 463    call get_key_ids_binding (file_id, block_id, key_ids)
 464 end subroutine get_key_ids
 465
 466 #endif
 467 end module yaml_parser_mod
 468 !> @}
 469 ! close documentation grouping