Skip to content

Instantly share code, notes, and snippets.

@zbeekman

zbeekman/json_module.F90.gcov

Created July 16, 2015 19:41
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save zbeekman/d08dc23555db10e2da48 to your computer and use it in GitHub Desktop.
Save zbeekman/d08dc23555db10e2da48 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
json_module.F90.gcov
-: 0:Source:/Users/ibeekman/Sandbox/json-fortran/src/json_module.F90
-: 0:Graph:CMakeFiles/jsonfortran.dir/src/json_module.F90.gcno
-: 0:Data:CMakeFiles/jsonfortran.dir/src/json_module.F90.gcda
-: 0:Runs:11
-: 0:Programs:1
-: 1:!*****************************************************************************************
-: 2:!> author: Jacob Williams
-: 3:! license: BSD
-: 4:!
-: 5:!# JSON-Fortran:
-: 6:! A Fortran 2008 JSON (JavaScript Object Notation) API.
-: 7:!
-: 8:! [TOC]
-: 9:!
-: 10:! This module provides an interface for reading and writing JSON files.
-: 11:!
-: 12:!@note ```-DUSE_UCS4``` is an optional preprocessor flag.
-: 13:! When present, Unicode support is enabled. Note that this
-: 14:! is currently only supported with the gfortran compiler.
-: 15:! Example: ```gfortran -DUSE_UCS4 ... ```
-: 16:#ifdef USE_UCS4
-: 17:# pragma push_macro("USE_UCS4")
-: 18:# undef USE_UCS4
-: 19:! The documentation given here assumes ```USE_UCS4``` **is** defined.
-: 20:# pragma pop_macro("USE_UCS4")
-: 21:#else
-: 22:! The documentation given here assumes ```USE_UCS4``` **is not** defined.
-: 23:#endif
-: 24:!
-: 25:!@warning ```CK``` and ```CDK``` are the JSON-Fortran character kind and JSON-Fortran default
-: 26:! character kind respectively. Client code **MUST** ensure characters of ```kind=CK```
-: 27:! are used for all character variables and strings passed to the JSON-Fortran
-: 28:! library *EXCEPT* for file names which must be of ```'DEFAULT'``` character kind,
-: 29:! provided here as ```CDK```. In particular, any variable that is a: json path, string
-: 30:! value or object name passed to the JSON-Fortran library **MUST** be of type ```CK```.
-: 31:!
-: 32:!@note Most string literal constants of default kind are fine to pass as arguments to
-: 33:! JSON-Fortran procedures since they have been overloaded to accept ```intent(in)```
-: 34:! character arguments of the default (```CDK```) kind. If you find a procedure which does
-: 35:! not accept an ```intent(in)``` literal string argument of default kind, please
-: 36:! [file an issue](https://github.com/jacobwilliams/json-fortran/issues/new) on github.
-: 37:!
-: 38:!## License
-: 39:!
-: 40:! **JSON-Fortran License:**
-: 41:!
-: 42:! JSON-Fortran: A Fortran 2008 JSON API
-: 43:!
-: 44:! http://github.com/jacobwilliams/json-fortran
-: 45:!
-: 46:! Copyright (c) 2014-2015, Jacob Williams
-: 47:!
-: 48:! All rights reserved.
-: 49:!
-: 50:! Redistribution and use in source and binary forms, with or without modification,
-: 51:! are permitted provided that the following conditions are met:
-: 52:! * Redistributions of source code must retain the above copyright notice, this
-: 53:! list of conditions and the following disclaimer.
-: 54:! * Redistributions in binary form must reproduce the above copyright notice, this
-: 55:! list of conditions and the following disclaimer in the documentation and/or
-: 56:! other materials provided with the distribution.
-: 57:! * The names of its contributors may not be used to endorse or promote products
-: 58:! derived from this software without specific prior written permission.
-: 59:! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-: 60:! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-: 61:! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-: 62:! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR
-: 63:! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-: 64:! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-: 65:! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
-: 66:! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-: 67:! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-: 68:! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-: 69:!
-: 70:! **Original FSON License:**
-: 71:!
-: 72:! Copyright (c) 2012 Joseph A. Levin
-: 73:!
-: 74:! Permission is hereby granted, free of charge, to any person obtaining a copy of this
-: 75:! software and associated documentation files (the "Software"), to deal in the Software
-: 76:! without restriction, including without limitation the rights to use, copy, modify, merge,
-: 77:! publish, distribute, sublicense, and/or sell copies of the Software, and to permit
-: 78:! persons to whom the Software is furnished to do so, subject to the following conditions:
-: 79:!
-: 80:! The above copyright notice and this permission notice shall be included in all copies or
-: 81:! substantial portions of the Software.
-: 82:!
-: 83:! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED,
-: 84:! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
-: 85:! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
-: 86:! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT
-: 87:! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
-: 88:! DEALINGS IN THE SOFTWARE.
-: 89:!
-: 90:!## History
-: 91:! * Joseph A. Levin : March 2012 : Original FSON code [retrieved on 12/2/2013].
-: 92:! * Jacob Williams : 2/8/2014 : Extensive modifications to the original FSON code.
-: 93:! The original F95 code was split into four files:
-: 94:! fson_path_m.f95, fson_string_m.f95, fson_value_m.f95, and fson.f95.
-: 95:! The new code has been extensively updated, refactored and combined into this
-: 96:! one module (json_module.f90).
-: 97:! Various Fortran 2003/2008 features are now used
-: 98:! (e.g., allocatable strings, newunit, generic, class, and abstract interface).
-: 99:! * Development continues at: [Github](http://github.com/jacobwilliams/json-fortran)
-: 100:!
-: 101:!## See also
-: 102:! * [json-fortran development site](http://github.com/jacobwilliams/json-fortran)
-: 103:! * [json-fortran online documentation](http://jacobwilliams.github.io/json-fortran)
-: 104:! * [JSON website](http://www.json.org/)
-: 105:! * [JSON validator](http://jsonlint.com/)
-: 106:
-: 107: module json_module
-: 108:
-: 109: use,intrinsic :: iso_fortran_env
-: 110:
-: 111: implicit none
-: 112:
-: 113: private
-: 114:
-: 115: integer,parameter :: RK = real64 !! Default real kind [8 bytes]
-: 116:
-: 117: integer,parameter :: IK = int32 !! Default integer kind [4 bytes].
-: 118:
-: 119: !*********************************************************
-: 120: !>
-: 121: ! Processor dependendant 'DEFAULT' character kind.
-: 122: ! This is 1 byte for the Intel and Gfortran compilers.
-: 123:
-: 124: integer,parameter,public :: CDK = selected_char_kind('DEFAULT')
-: 125: !*********************************************************
-: 126:
-: 127: !*********************************************************
-: 128: !>
-: 129: ! Default logical kind.
-: 130: ! This is 4 bytes for the Intel and Gfortran compilers
-: 131: ! (and perhaps others).
-: 132: ! The declaration ensures a valid kind
-: 133: ! if the compiler doesn't have a logical_kinds(3).
-: 134: !
-: 135: integer,parameter :: LK = logical_kinds(min(3,size(logical_kinds)))
-: 136: !*********************************************************
-: 137:
-: 138: !*********************************************************
-: 139: !>
-: 140: ! String kind preprocessor macro.
-: 141: !
-: 142:#if defined __GFORTRAN__ && defined USE_UCS4
-: 143: ! gfortran compiler AND UCS4 support requested:
-: 144: character(kind=CDK,len=*),parameter :: json_fortran_string_kind = 'ISO_10646'
-: 145:#else
-: 146: ! this is the string kind to use unless compiling with GFortran AND
-: 147: ! UCS4/ISO 10646 support is requested
-: 148: character(kind=CDK,len=*),parameter :: json_fortran_string_kind = 'DEFAULT'
-: 149:#endif
-: 150: !*********************************************************
-: 151:
-: 152: !*********************************************************
-: 153: !>
-: 154: ! Default character kind used by JSON-Fortran.
-: 155: ! If ISO 10646 (UCS4) support is available, use that,
-: 156: ! otherwise, gracefully fall back on 'DEFAULT' characters.
-: 157: ! Currently only gfortran >= 4.9.2 will correctly support
-: 158: ! UCS4 which is stored in 4 bytes.
-: 159: ! (and perhaps others).
-: 160:
-: 161: integer,parameter,public :: CK = selected_char_kind(json_fortran_string_kind)
-: 162: !*********************************************************
-: 163:
-: 164: !*********************************************************
-: 165: ! File encoding preprocessor macro.
-: 166: !
-: 167:#if defined __GFORTRAN__ && defined USE_UCS4
-: 168: ! gfortran compiler AND UCS4 support requested, & silence redefine warning:
-: 169: ! Make sure we output files with utf-8 encoding too
-: 170:#define FILE_ENCODING ,encoding='UTF-8'
-: 171:#else
-: 172: ! don't ask for utf-8 file encoding unless using UCS4
-: 173: ! this may let us use unformatted stream io to read in files more quickly
-: 174: ! even with unicode support turned on `inquire( ... encoding=FL_ENCODING)`
-: 175: ! may be able to detect json files in which each character is exactly one
-: 176: ! byte
-: 177:#define FILE_ENCODING
-: 178:#endif
-: 179: !*********************************************************
-: 180:
-: 181: !*********************************************************
-: 182: ! This C preprocessor macro will take a procedure name as an
-: 183: ! input, and output either that same procedure name if the
-: 184: ! code is compiled without USE_UCS4 being defined or it will
-: 185: ! expand the procedure name to the original procedure name,
-: 186: ! followed by a comma and then the original procedure name
-: 187: ! with 'wrap_' prepended to it. This is suitable for creating
-: 188: ! overloaded interfaces that will accept UCS4 character actual
-: 189: ! arguments as well as DEFAULT/ASCII character arguments,
-: 190: ! based on whether or not ISO 10646 is supported and requested.
-: 191: !
-: 192:# ifdef USE_UCS4
-: 193:# ifdef __GFORTRAN__
-: 194: ! gfortran uses cpp in old-school compatibility mode so
-: 195: ! the # stringify and ## concatenate operators don't work
-: 196: ! but we can use C/C++ style comment to ensure PROCEDURE is
-: 197: ! correctly tokenized and prepended with 'wrap_' when the
-: 198: ! macro is expanded
-: 199:# define MAYBEWRAP(PROCEDURE) PROCEDURE , wrap_/**/PROCEDURE
-: 200:# endif
-: 201:! ifdef __INTEL_COMPILER
-: 202: ! Intel's fpp does support the more contemporary ## concatenation
-: 203: ! operator, but doesn't treat the C/C++ comments the same way.
-: 204: ! If you use the gfortran approach and pass the -noB switch to
-: 205: ! fpp, the macro will expand, but with a space between wrap_ and
-: 206: ! whatever PROCEDURE expands to
-: 207: ! Intel doesn't support ISO 10646 yet, but this is here to
-: 208: ! ease the transition once they do.
-: 209:! define MAYBEWRAP(PROCEDURE) PROCEDURE , wrap_##PROCEDURE
-: 210:! endif
-: 211:# else
-: 212:# define MAYBEWRAP(PROCEDURE) PROCEDURE
-: 213:# endif
-: 214: !*********************************************************
-: 215:
-: 216: !*********************************************************
-: 217: !>
-: 218: ! If Unicode is not enabled, then
-: 219: ! JSON files are opened using access='STREAM' and
-: 220: ! form='UNFORMATTED'. This allows the file to
-: 221: ! be read faster.
-: 222: !
-: 223:#ifdef USE_UCS4
-: 224: logical,parameter :: use_unformatted_stream = .false.
-: 225:#else
-: 226: logical,parameter :: use_unformatted_stream = .true.
-: 227:#endif
-: 228: !*********************************************************
-: 229:
-: 230: !*********************************************************
-: 231: !>
-: 232: ! If Unicode is not enabled, then
-: 233: ! JSON files are opened using access='STREAM' and
-: 234: ! form='UNFORMATTED'. This allows the file to
-: 235: ! be read faster.
-: 236: !
-: 237:#ifdef USE_UCS4
-: 238: character(kind=CDK,len=*),parameter :: access_spec = 'SEQUENTIAL'
-: 239:#else
-: 240: character(kind=CDK,len=*),parameter :: access_spec = 'STREAM'
-: 241:#endif
-: 242: !*********************************************************
-: 243:
-: 244: !*********************************************************
-: 245: !>
-: 246: ! If Unicode is not enabled, then
-: 247: ! JSON files are opened using access='STREAM' and
-: 248: ! form='UNFORMATTED'. This allows the file to
-: 249: ! be read faster.
-: 250: !
-: 251:#ifdef USE_UCS4
-: 252: character(kind=CDK,len=*),parameter :: form_spec = 'FORMATTED'
-: 253:#else
-: 254: character(kind=CDK,len=*),parameter :: form_spec = 'UNFORMATTED'
-: 255:#endif
-: 256: !*********************************************************
-: 257:
-: 258: !*********************************************************
-: 259: !
-: 260: ! The types of JSON data.
-: 261: !
-: 262: integer(IK),parameter,public :: json_unknown = 0 !! Unknown JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 263: integer(IK),parameter,public :: json_null = 1 !! Null JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 264: integer(IK),parameter,public :: json_object = 2 !! Object JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 265: integer(IK),parameter,public :: json_array = 3 !! Array JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 266: integer(IK),parameter,public :: json_logical = 4 !! Logical JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 267: integer(IK),parameter,public :: json_integer = 5 !! Integer JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 268: integer(IK),parameter,public :: json_double = 6 !! Double JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 269: integer(IK),parameter,public :: json_string = 7 !! String JSON data type (see [[json_file_variable_info]] and [[json_info]])
-: 270: !*********************************************************
-: 271:
-: 272: !*********************************************************
-: 273: !>
-: 274: ! Type used to construct the linked-list JSON structure.
-: 275: ! Normally, this should always be a pointer variable.
-: 276: !
-: 277: !# Example
-: 278: !
-: 279: !```fortran
-: 280: ! type(json_value),pointer :: p
-: 281: ! call json_create_object(p,'') !root
-: 282: ! call json_add(p,'year',1805)
-: 283: ! call json_add(p,'value',1.0d0)
-: 284: ! call json_print(p,'test.json')
-: 285: ! call json_destroy(p)
-: 286: !```
-: 287: !
-: 288: type,public :: json_value
-: 289:
-: 290: !force the constituents to be stored contiguously
-: 291: ![note: on Intel, the order of the variables below
-: 292: ! is significant to avoid the misaligned field warnings]
-: 293: sequence
-: 294:
-: 295: private
-: 296:
-: 297: !for the linked list:
-: 298: type(json_value),pointer :: previous => null() !! previous item in the list
-: 299: type(json_value),pointer :: next => null() !! next item in the list
-: 300: type(json_value),pointer :: parent => null() !! parent item of this
-: 301: type(json_value),pointer :: children => null() !! first child item of this
-: 302: type(json_value),pointer :: tail => null() !! last child item of this
-: 303:
-: 304: character(kind=CK,len=:),allocatable :: name !! variable name
-: 305:
-: 306: real(RK),allocatable :: dbl_value !! real data for this variable
-: 307: logical(LK),allocatable :: log_value !! logical data for this variable
-: 308: character(kind=CK,len=:),allocatable :: str_value !! string data for this variable
-: 309: integer(IK),allocatable :: int_value !! integer data for this variable
-: 310:
-: 311: integer(IK) :: var_type = json_unknown !! variable type
-: 312:
-: 313: integer(IK),private :: n_children = 0 !! number of children
-: 314:
-: 315: end type json_value
-: 316: !*********************************************************
-: 317:
-: 318: !*********************************************************
-: 319: !> author: Jacob Williams
-: 320: ! date: 12/9/2013
-: 321: !
-: 322: ! The json_file is the main public class that is
-: 323: ! used to open a file and get data from it.
-: 324: !
-: 325: !# Example
-: 326: !
-: 327: !```fortran
-: 328: ! type(json_file) :: json
-: 329: ! integer :: ival
-: 330: ! real(real64) :: rval
-: 331: ! character(len=:),allocatable :: cval
-: 332: ! logical :: found
-: 333: ! call json%load_file(filename='myfile.json')
-: 334: ! call json%print_file() !print to the console
-: 335: ! call json%get('var.i',ival,found)
-: 336: ! call json%get('var.r(3)',rval,found)
-: 337: ! call json%get('var.c',cval,found)
-: 338: ! call json%destroy()
-: 339: !```
-: 340:
-: 341: type,public :: json_file
-: 342:
-: 343: private
-: 344:
-: 345: !the JSON structure read from the file:
-: 346: type(json_value),pointer :: p => null()
-: 347:
-: 348: contains
-: 349:
-: 350: procedure,public :: load_file => json_file_load
-: 351:
-: 352: generic, public :: load_from_string => MAYBEWRAP(json_file_load_from_string)
-: 353:
-: 354: procedure,public :: destroy => json_file_destroy
-: 355: procedure,public :: move => json_file_move_pointer
-: 356: generic,public :: info => MAYBEWRAP(json_file_variable_info)
-: 357:
-: 358: procedure,public :: print_to_string => json_file_print_to_string
-: 359:
-: 360: generic,public :: print_file => json_file_print_to_console, &
-: 361: json_file_print_1, &
-: 362: json_file_print_2
-: 363:
-: 364: generic,public :: get => MAYBEWRAP(json_file_get_object), &
-: 365: MAYBEWRAP(json_file_get_integer), &
-: 366: MAYBEWRAP(json_file_get_double), &
-: 367: MAYBEWRAP(json_file_get_logical), &
-: 368: MAYBEWRAP(json_file_get_string), &
-: 369: MAYBEWRAP(json_file_get_integer_vec), &
-: 370: MAYBEWRAP(json_file_get_double_vec), &
-: 371: MAYBEWRAP(json_file_get_logical_vec), &
-: 372: MAYBEWRAP(json_file_get_string_vec)
-: 373:
-: 374: generic,public :: update => MAYBEWRAP(json_file_update_integer), &
-: 375: MAYBEWRAP(json_file_update_logical), &
-: 376: MAYBEWRAP(json_file_update_real), &
-: 377: MAYBEWRAP(json_file_update_string)
-: 378:# ifdef USE_UCS4
-: 379: generic,public :: update => json_file_update_string_name_ascii, &
-: 380: json_file_update_string_val_ascii
-: 381:# endif
-: 382:
-: 383: !load from string:
-: 384: procedure :: MAYBEWRAP(json_file_load_from_string)
-: 385:
-: 386: !git info:
-: 387: procedure :: MAYBEWRAP(json_file_variable_info)
-: 388:
-: 389: !get:
-: 390: procedure :: MAYBEWRAP(json_file_get_object)
-: 391: procedure :: MAYBEWRAP(json_file_get_integer)
-: 392: procedure :: MAYBEWRAP(json_file_get_double)
-: 393: procedure :: MAYBEWRAP(json_file_get_logical)
-: 394: procedure :: MAYBEWRAP(json_file_get_string)
-: 395: procedure :: MAYBEWRAP(json_file_get_integer_vec)
-: 396: procedure :: MAYBEWRAP(json_file_get_double_vec)
-: 397: procedure :: MAYBEWRAP(json_file_get_logical_vec)
-: 398: procedure :: MAYBEWRAP(json_file_get_string_vec)
-: 399:
-: 400: !update:
-: 401: procedure :: MAYBEWRAP(json_file_update_integer)
-: 402: procedure :: MAYBEWRAP(json_file_update_logical)
-: 403: procedure :: MAYBEWRAP(json_file_update_real)
-: 404: procedure :: MAYBEWRAP(json_file_update_string)
-: 405:# ifdef USE_UCS4
-: 406: procedure :: json_file_update_string_name_ascii
-: 407: procedure :: json_file_update_string_val_ascii
-: 408:# endif
-: 409:
-: 410: !print_file:
-: 411: procedure :: json_file_print_to_console
-: 412: procedure :: json_file_print_1
-: 413: procedure :: json_file_print_2
-: 414:
-: 415: end type json_file
-: 416: !*********************************************************
-: 417:
-: 418: !*************************************************************************************
-: 419: !>
-: 420: ! Array element callback function. Used by [[json_get_array]].
-: 421:
-: 422: abstract interface
-: 423: subroutine array_callback_func(element, i, count)
-: 424: import :: json_value,IK
-: 425: implicit none
-: 426: type(json_value), pointer,intent(in) :: element
-: 427: integer(IK),intent(in) :: i !index
-: 428: integer(IK),intent(in) :: count !size of array
-: 429: end subroutine array_callback_func
-: 430: end interface
-: 431: !*************************************************************************************
-: 432:
-: 433:# ifdef USE_UCS4
-: 434: ! Provide a means to convert to UCS4 while concatenating UCS4 and default strings
-: 435: interface operator(//)
-: 436: module procedure ucs4_join_default, default_join_ucs4
-: 437: end interface
-: 438:
-: 439: ! Provide a string comparison operator that works with mixed kinds
-: 440: interface operator(==)
-: 441: module procedure ucs4_comp_default, default_comp_ucs4
-: 442: end interface
-: 443:# endif
-: 444:
-: 445: !*************************************************************************************
-: 446: !>
-: 447: ! Get a child, either by index or name string.
-: 448: ! Both of these return a [[json_value]] pointer.
-: 449: !
-: 450: !@note Formerly, this was called json_value_get_child
-: 451:
-: 452: interface json_get_child
-: 453: module procedure json_value_get_by_index
-: 454: module procedure MAYBEWRAP(json_value_get_by_name_chars)
-: 455: end interface json_get_child
-: 456: !*************************************************************************************
-: 457:
-: 458: !*************************************************************************************
-: 459: !>
-: 460: ! Add objects to a linked list of [[json_value]]s.
-: 461: !
-: 462: !@note Formerly, this was called json_value_add
-: 463:
-: 464: interface json_add
-: 465: module procedure json_value_add_member
-: 466: module procedure MAYBEWRAP(json_value_add_integer)
-: 467: module procedure MAYBEWRAP(json_value_add_integer_vec)
-: 468: module procedure MAYBEWRAP(json_value_add_double)
-: 469: module procedure MAYBEWRAP(json_value_add_double_vec)
-: 470: module procedure MAYBEWRAP(json_value_add_logical)
-: 471: module procedure MAYBEWRAP(json_value_add_logical_vec)
-: 472: module procedure MAYBEWRAP(json_value_add_string)
-: 473: module procedure MAYBEWRAP(json_value_add_string_vec)
-: 474:# ifdef USE_UCS4
-: 475: module procedure json_value_add_string_name_ascii
-: 476: module procedure json_value_add_string_val_ascii
-: 477: module procedure json_value_add_string_vec_name_ascii
-: 478: module procedure json_value_add_string_vec_val_ascii
-: 479:# endif
-: 480: end interface json_add
-: 481: !*************************************************************************************
-: 482:
-: 483: !*************************************************************************************
-: 484: !>
-: 485: ! These are like [[json_add]], except if a child with the same name is
-: 486: ! already present, then its value is simply updated.
-: 487: ! Note that currently, these only work for scalar variables.
-: 488: ! These routines can also change the variable's type (but an error will be
-: 489: ! thrown if the existing variable is not a scalar).
-: 490: !
-: 491: !@note It should not be used to change the type of a variable in an array,
-: 492: ! or it may result in an invalid JSON file.
-: 493:
-: 494: interface json_update
-: 495: module procedure MAYBEWRAP(json_update_logical),&
-: 496: MAYBEWRAP(json_update_double),&
-: 497: MAYBEWRAP(json_update_integer),&
-: 498: MAYBEWRAP(json_update_string)
-: 499:# ifdef USE_UCS4
-: 500: module procedure json_update_string_name_ascii
-: 501: module procedure json_update_string_val_ascii
-: 502:# endif
-: 503: end interface json_update
-: 504: !*************************************************************************************
-: 505:
-: 506: !*************************************************************************************
-: 507: !>
-: 508: ! Get data from a [[json_value]] linked list.
-: 509: !
-: 510: !@note There are two versions (e.g. [[json_get_integer]] and [[json_get_integer_with_path]]).
-: 511: ! The first one gets the value from the [[json_value]] passed into the routine,
-: 512: ! while the second one gets the value from the [[json_value]] found by parsing the
-: 513: ! path. The path version is split up into unicode and non-unicode versions.
-: 514:
-: 515: interface json_get
-: 516: module procedure MAYBEWRAP(json_get_by_path)
-: 517: module procedure json_get_integer, MAYBEWRAP(json_get_integer_with_path)
-: 518: module procedure json_get_integer_vec, MAYBEWRAP(json_get_integer_vec_with_path)
-: 519: module procedure json_get_double, MAYBEWRAP(json_get_double_with_path)
-: 520: module procedure json_get_double_vec, MAYBEWRAP(json_get_double_vec_with_path)
-: 521: module procedure json_get_logical, MAYBEWRAP(json_get_logical_with_path)
-: 522: module procedure json_get_logical_vec, MAYBEWRAP(json_get_logical_vec_with_path)
-: 523: module procedure json_get_string, MAYBEWRAP(json_get_string_with_path)
-: 524: module procedure json_get_string_vec, MAYBEWRAP(json_get_string_vec_with_path)
-: 525: module procedure json_get_array, MAYBEWRAP(json_get_array_with_path)
-: 526: end interface json_get
-: 527: !*************************************************************************************
-: 528:
-: 529: !*************************************************************************************
-: 530: !>
-: 531: ! Print the json_value structure to an allocatable string.
-: 532:
-: 533: interface json_print_to_string
-: 534: module procedure json_value_to_string
-: 535: end interface
-: 536: !*************************************************************************************
-: 537:
-: 538: !*************************************************************************************
-: 539: !>
-: 540: ! Print the [[json_value]] to a file.
-: 541: !
-: 542: !# Example
-: 543: !
-: 544: !```fortran
-: 545: ! type(json_value) :: p
-: 546: ! !...
-: 547: ! call json_print(p,'test.json') !this is [[json_print_2]]
-: 548: !```
-: 549:
-: 550: interface json_print
-: 551: module procedure json_print_1 !input is unit number
-: 552: module procedure json_print_2 !input is file name
-: 553: end interface
-: 554: !*************************************************************************************
-: 555:
-: 556: !*************************************************************************************
-: 557: !>
-: 558: ! Destructor routine for a [[json_value]] pointer.
-: 559: ! This must be called explicitly if it is no longer needed,
-: 560: ! before it goes out of scope. Otherwise, a memory leak will result.
-: 561: !
-: 562: !# Example
-: 563: !
-: 564: ! Destroy the [[json_value]] pointer before the variable goes out of scope:
-: 565: !```fortran
-: 566: ! subroutine example1()
-: 567: ! type(json_value),pointer :: p
-: 568: ! call json_create_object(p,'')
-: 569: ! call json_add(p,'year',2015)
-: 570: ! call json_print(p)
-: 571: ! call json_destroy(p)
-: 572: ! end subroutine example1
-: 573: !```
-: 574: !
-: 575: ! Note: it should NOT be called for a [[json_value]] pointer than has already been
-: 576: ! added to another [[json_value]] structure, since doing so may render the
-: 577: ! other structure invalid. Consider the following example:
-: 578: !```fortran
-: 579: ! subroutine example2(p)
-: 580: ! type(json_value),pointer,intent(out) :: p
-: 581: ! type(json_value),pointer :: q
-: 582: ! call json_create_object(p,'')
-: 583: ! call json_add(p,'year',2015)
-: 584: ! call json_create_object(q,'q')
-: 585: ! call json_add(q,'val',1)
-: 586: ! call json_add(p, q) !add q to p structure
-: 587: ! ! do NOT call json_destroy(q) here, because q is
-: 588: ! ! now part of the output structure p. p should be destroyed
-: 589: ! ! somewhere upstream by the caller of this routine.
-: 590: ! nullify(q) !OK, but not strictly necessary
-: 591: ! end subroutine example2
-: 592: !```
-: 593:
-: 594: interface json_destroy
-: 595: module procedure json_value_destroy
-: 596: end interface
-: 597: !*************************************************************************************
-: 598:
-: 599: !*************************************************************************************
-: 600: !>
-: 601: ! Remove a [[json_value]] from a linked-list structure.
-: 602:
-: 603: interface json_remove
-: 604: module procedure json_value_remove
-: 605: end interface
-: 606: !*************************************************************************************
-: 607:
-: 608: !*************************************************************************************
-: 609: !>
-: 610: ! If the child variable is present, then remove it.
-: 611:
-: 612: interface json_remove_if_present
-: 613: module procedure MAYBEWRAP(json_value_remove_if_present)
-: 614: end interface
-: 615: !*************************************************************************************
-: 616:
-: 617: !*************************************************************************************
-: 618: !>
-: 619: ! Allocate a [[json_value]] pointer and make it a double variable.
-: 620: ! The pointer should not already be allocated.
-: 621: !
-: 622: !# Example
-: 623: !
-: 624: !```fortran
-: 625: ! type(json_value),pointer :: p
-: 626: ! call json_create_double(p,'value',1.0d0)
-: 627: !```
-: 628:
-: 629: interface json_create_double
-: 630: module procedure MAYBEWRAP(json_value_create_double)
-: 631: end interface
-: 632: !*************************************************************************************
-: 633:
-: 634: !*************************************************************************************
-: 635: !>
-: 636: ! Allocate a [[json_value]] pointer and make it an array variable.
-: 637: ! The pointer should not already be allocated.
-: 638: !
-: 639: !# Example
-: 640: !
-: 641: !```fortran
-: 642: ! type(json_value),pointer :: p
-: 643: ! call json_create(p,'arrayname')
-: 644: !```
-: 645:
-: 646: interface json_create_array
-: 647: module procedure MAYBEWRAP(json_value_create_array)
-: 648: end interface
-: 649: !*************************************************************************************
-: 650:
-: 651: !*************************************************************************************
-: 652: !>
-: 653: ! Allocate a [[json_value]] pointer and make it an object variable.
-: 654: ! The pointer should not already be allocated.
-: 655: !
-: 656: !# Example
-: 657: !
-: 658: !```fortran
-: 659: ! type(json_value),pointer :: p
-: 660: ! call json_create(p,'objectname')
-: 661: !```
-: 662: !
-: 663: !@note The name is not significant for the root structure or an array element.
-: 664: ! In those cases, an empty string can be used.
-: 665:
-: 666: interface json_create_object
-: 667: module procedure MAYBEWRAP(json_value_create_object)
-: 668: end interface
-: 669: !*************************************************************************************
-: 670:
-: 671: !*************************************************************************************
-: 672: !>
-: 673: ! Allocate a json_value pointer and make it a null variable.
-: 674: ! The pointer should not already be allocated.
-: 675: !
-: 676: !# Example
-: 677: !
-: 678: !```fortran
-: 679: ! type(json_value),pointer :: p
-: 680: ! call json_create_null(p,'value')
-: 681: !```
-: 682:
-: 683: interface json_create_null
-: 684: module procedure MAYBEWRAP(json_value_create_null)
-: 685: end interface
-: 686: !*************************************************************************************
-: 687:
-: 688: !*************************************************************************************
-: 689: !>
-: 690: ! Allocate a json_value pointer and make it a string variable.
-: 691: ! The pointer should not already be allocated.
-: 692: !
-: 693: !# Example
-: 694: !
-: 695: !```fortran
-: 696: ! type(json_value),pointer :: p
-: 697: ! call json_create_string(p,'value','foobar')
-: 698: !```
-: 699:
-: 700: interface json_create_string
-: 701: module procedure MAYBEWRAP(json_value_create_string)
-: 702: end interface
-: 703: !*************************************************************************************
-: 704:
-: 705: !*************************************************************************************
-: 706: !>
-: 707: ! Allocate a json_value pointer and make it an integer variable.
-: 708: ! The pointer should not already be allocated.
-: 709: !
-: 710: !# Example
-: 711: !
-: 712: !```fortran
-: 713: ! type(json_value),pointer :: p
-: 714: ! call json_create_integer(p,'value',42)
-: 715: !```
-: 716:
-: 717: interface json_create_integer
-: 718: module procedure MAYBEWRAP(json_value_create_integer)
-: 719: end interface
-: 720: !*************************************************************************************
-: 721:
-: 722: !*************************************************************************************
-: 723: !>
-: 724: ! Allocate a json_value pointer and make it a logical variable.
-: 725: ! The pointer should not already be allocated.
-: 726: !
-: 727: !# Example
-: 728: !
-: 729: !```fortran
-: 730: ! type(json_value),pointer :: p
-: 731: ! call json_create_logical(p,'value',.true.)
-: 732: !```
-: 733:
-: 734: interface json_create_logical
-: 735: module procedure MAYBEWRAP(json_value_create_logical)
-: 736: end interface
-: 737: !*************************************************************************************
-: 738:
-: 739: !*************************************************************************************
-: 740: !>
-: 741: ! Parse the JSON file and populate the [[json_value]] tree.
-: 742:
-: 743: interface json_parse
-: 744: module procedure json_parse_file, MAYBEWRAP(json_parse_string)
-: 745: end interface
-: 746: !*************************************************************************************
-: 747:
-: 748: !*************************************************************************************
-: 749: !>
-: 750: ! Convert a 'DEFAULT' kind character input to 'ISO_10646' kind and return it
-: 751:
-: 752: interface to_unicode
-: 753: module procedure to_uni, to_uni_vec
-: 754: end interface
-: 755: !*************************************************************************************
-: 756:
-: 757: !*************************************************************************************
-: 758: !>
-: 759: ! Throw an exception.
-: 760:
-: 761: interface throw_exception
-: 762: module procedure MAYBEWRAP(json_throw_exception)
-: 763: end interface throw_exception
-: 764: !*************************************************************************************
-: 765:
-: 766: !public routines:
-: 767: public :: json_add ! add data to a JSON structure
-: 768: public :: json_check_for_errors ! check for error and get error message
-: 769: public :: json_clear_exceptions ! clear exceptions
-: 770: public :: json_count ! count the number of children
-: 771: public :: json_create_array ! allocate a json_value array
-: 772: public :: json_create_double ! allocate a json_value double
-: 773: public :: json_create_integer ! allocate a json_value integer
-: 774: public :: json_create_logical ! allocate a json_value logical
-: 775: public :: json_create_null ! allocate a json_value null
-: 776: public :: json_create_object ! allocate a json_value object
-: 777: public :: json_create_string ! allocate a json_value string
-: 778: public :: json_destroy ! clear a JSON structure (destructor)
-: 779: public :: json_failed ! check for error
-: 780: public :: json_get ! get data from the JSON structure
-: 781: public :: json_get_child ! get a child of a json_value
-: 782: public :: json_info ! get info about a json_value
-: 783: public :: json_initialize ! to initialize the module
-: 784: public :: json_parse ! read a JSON file and populate the structure
-: 785: public :: json_print ! print the JSON structure to a file
-: 786: public :: json_print_to_string ! write the JSON structure to a string
-: 787: public :: json_remove ! remove from a JSON structure
-: 788: public :: json_remove_if_present ! remove from a JSON structure (if it is present)
-: 789: public :: json_update ! update a value in a JSON structure
-: 790: public :: json_print_error_message !
-: 791: public :: to_unicode ! Function to convert from 'DEFAULT' to 'ISO_10646' strings
-: 792:
-: 793:# ifdef USE_UCS4
-: 794: public :: operator(//)
-: 795: public :: operator(==)
-: 796:# endif
-: 797:
-: 798: character(kind=CDK,len=*),parameter,public :: json_ext = '.json' !! JSON file extension
-: 799:
-: 800: !special JSON characters
-: 801: character(kind=CK,len=*),parameter :: space = ' '
-: 802: character(kind=CK,len=*),parameter :: start_object = '{'
-: 803: character(kind=CK,len=*),parameter :: end_object = '}'
-: 804: character(kind=CK,len=*),parameter :: start_array = '['
-: 805: character(kind=CK,len=*),parameter :: end_array = ']'
-: 806: character(kind=CK,len=*),parameter :: delimiter = ','
-: 807: character(kind=CK,len=*),parameter :: colon_char = ':'
-: 808: character(kind=CK,len=*),parameter :: bspace = achar(8)
-: 809: character(kind=CK,len=*),parameter :: horizontal_tab = achar(9)
-: 810: character(kind=CK,len=*),parameter :: newline = achar(10)
-: 811: character(kind=CK,len=*),parameter :: formfeed = achar(12)
-: 812: character(kind=CK,len=*),parameter :: carriage_return = achar(13)
-: 813: character(kind=CK,len=*),parameter :: quotation_mark = achar(34)
-: 814: character(kind=CK,len=*),parameter :: slash = achar(47)
-: 815: character(kind=CK,len=*),parameter :: backslash = achar(92)
-: 816:
-: 817: !These were parameters, but gfortran bug (https://gcc.gnu.org/bugzilla/show_bug.cgi?id=65141)
-: 818: !necessitates moving them here to be variables
-: 819: character(kind=CK,len=4) :: null_str = 'null'
-: 820: character(kind=CK,len=4) :: true_str = 'true'
-: 821: character(kind=CK,len=5) :: false_str = 'false'
-: 822:
-: 823: ! Control characters, possibly in unicode
-: 824: integer, private :: i_
-: 825: character(kind=CK,len=*),parameter :: control_chars(32) = [(achar(i_),i_=1,31), achar(127)]
-: 826:
-: 827: !for indenting (Note: jsonlint.com uses 4 spaces)
-: 828: integer(IK),parameter :: spaces_per_tab = 2
-: 829:
-: 830: !find out the precision of the floating point number system
-: 831: !and set safety factors
-: 832: integer(IK),parameter :: rp_safety_factor = 1
-: 833: integer(IK),parameter :: rp_addl_safety = 1
-: 834: integer(IK),parameter :: real_precision = rp_safety_factor*precision(1.0_RK) + &
-: 835: rp_addl_safety
-: 836:
-: 837: !Get the number of possible digits in the exponent when using decimal number system
-: 838: integer(IK),parameter :: maxexp = maxexponent(1.0_RK)
-: 839: integer(IK),parameter :: minexp = minexponent(1.0_RK)
-: 840: integer(IK),parameter :: real_exponent_digits = floor( 1 + log10( &
-: 841: real(max(maxexp,abs(maxexp)),&
-: 842: kind=RK) ) )
-: 843:
-: 844: !6 = sign + leading 0 + decimal + 'E' + exponent sign + 1 extra
-: 845: integer(IK),parameter :: max_numeric_str_len = real_precision + real_exponent_digits + 6
-: 846: ! real format set by library initialization
-: 847: character(kind=CDK,len=*),parameter :: int_fmt = '(ss,I0)' !minimum width format for integers
-: 848: character(kind=CK, len=*),parameter :: star = '*' !for invalid numbers
-: 849:
-: 850: !real string printing:
-: 851: character(kind=CDK,len=:),allocatable :: real_fmt !the format string to use for real numbers
-: 852: ! [set in json_initialize]
-: 853: logical(LK) :: compact_real = .true. !to use the "compact" form of real numbers for output
-: 854:
-: 855: !
-: 856: ! Note: the following global variables make this module non thread safe.
-: 857: !
-: 858:
-: 859: !exception handling [private variables]
-: 860: logical(LK) :: is_verbose = .false. !if true, all exceptions are immediately printed to console
-: 861: logical(LK) :: exception_thrown = .false. !the error flag
-: 862: character(kind=CK,len=:),allocatable :: err_message !the error message
-: 863:
-: 864: !temp vars used when parsing lines in file [private variables]
-: 865: integer(IK) :: char_count = 0 !character position in the current line
-: 866: integer(IK) :: line_count = 1 !lines read counter
-: 867: integer(IK) :: pushed_index = 0
-: 868: character(kind=CK,len=10) :: pushed_char = '' !JW : what is this magic number 10??
-: 869:
-: 870: integer(IK),parameter :: chunk_size = 100 !! for allocatable strings: allocate chunks of this size
-: 871: integer(IK) :: ipos = 1 !! for allocatable strings: next character to read
-: 872:
-: 873: integer(IK),parameter :: unit2str = -1 !! unit number to cause stuff to be
-: 874: !! output to strings rather than files.
-: 875: !! See 9.5.6.12 in the F2003/08 standard
-: 876:
-: 877: contains
-: 878:!*****************************************************************************************
-: 879:
-: 880:!*****************************************************************************************
-: 881:!> author: Jacob Williams
-: 882:!
-: 883:! Destroy the data within a [[json_value]], and rest type to json_unknown.
-: 884:
-: 885: subroutine destroy_json_data(d)
777164: 886:
-: 887: implicit none
-: 888:
-: 889: type(json_value),intent(inout) :: d
-: 890:
-: 891: d%var_type = json_unknown
777164: 892:
-: 893: if (allocated(d%log_value)) deallocate(d%log_value)
777164: 894: if (allocated(d%int_value)) deallocate(d%int_value)
777164: 895: if (allocated(d%dbl_value)) deallocate(d%dbl_value)
777164: 896: if (allocated(d%str_value)) deallocate(d%str_value)
777164: 897:
-: 898: end subroutine destroy_json_data
777164: 899:!*****************************************************************************************
-: 900:
-: 901:!*****************************************************************************************
-: 902:!> author: Jacob Williams
-: 903:! date: 12/9/2013
-: 904:!
-: 905:! Destroy the [[json_file]].
-: 906:
-: 907: subroutine json_file_destroy(me)
11: 908:
-: 909: implicit none
-: 910:
-: 911: class(json_file),intent(inout) :: me
-: 912:
-: 913: if (associated(me%p)) call json_value_destroy(me%p)
11: 914:
-: 915: end subroutine json_file_destroy
11: 916:!*****************************************************************************************
-: 917:
-: 918:!*****************************************************************************************
-: 919:!> author: Jacob Williams
-: 920:! date: 12/5/2014
-: 921:!
-: 922:! Move the [[json_value]] pointer from one [[json_file]] to another.
-: 923:! The "from" pointer is then nullified, but not destroyed.
-: 924:!
-: 925:!@note If "from%p" is not associated, then an error is thrown.
-: 926:
-: 927: subroutine json_file_move_pointer(to,from)
1: 928:
-: 929: implicit none
-: 930:
-: 931: class(json_file),intent(inout) :: to
-: 932: class(json_file),intent(inout) :: from
-: 933:
-: 934: if (associated(from%p)) then
1: 935: to%p => from%p
1: 936: nullify(from%p)
1: 937: else
-: 938: call throw_exception('Error in json_file_move_pointer: '//&
-: 939: 'pointer is not associated.')
#####: 940: end if
-: 941:
-: 942: end subroutine json_file_move_pointer
1: 943:
-: 944:!*****************************************************************************************
-: 945:!> author: Jacob Williams
-: 946:! date: 12/9/2013
-: 947:!
-: 948:! Load the JSON data from a file.
-: 949:!
-: 950:!# Example
-: 951:!
-: 952:!```fortran
-: 953:! type(json_file) :: f
-: 954:! call f%load_file('my_file.json')
-: 955:!```
-: 956:
-: 957: subroutine json_file_load(me, filename, unit)
10: 958:
-: 959: implicit none
-: 960:
-: 961: class(json_file),intent(inout) :: me
-: 962: character(kind=CDK,len=*),intent(in) :: filename !! the filename to open
-: 963: integer(IK),intent(in),optional :: unit !! the unit number to use
-: 964:
-: 965: call json_parse(file=filename, p=me%p, unit=unit)
10: 966:
-: 967: end subroutine json_file_load
20: 968:!*****************************************************************************************
-: 969:
-: 970:!*****************************************************************************************
-: 971:!> author: Jacob Williams
-: 972:! date: 1/13/2015
-: 973:!
-: 974:! Load the JSON data from a string.
-: 975:!
-: 976:!# Example
-: 977:!
-: 978:! Load JSON from a string:
-: 979:!```fortran
-: 980:! type(json_file) :: f
-: 981:! call f%load_from_string('{ "name": "Leonidas" }')
-: 982:!```
-: 983:
-: 984: subroutine json_file_load_from_string(me, str)
3: 985:
-: 986: implicit none
-: 987:
-: 988: class(json_file),intent(inout) :: me
-: 989: character(kind=CK,len=*),intent(in) :: str !! string to load JSON data from
-: 990:
-: 991: call json_parse(str=str, p=me%p)
3: 992:
-: 993: end subroutine json_file_load_from_string
6: 994:!*****************************************************************************************
-: 995:
-: 996:!*****************************************************************************************
-: 997:!>
-: 998:! Alternate version of [[json_file_load_from_string]], where "str" is kind=CDK.
-: 999:
-: 1000: subroutine wrap_json_file_load_from_string(me, str)
2: 1001:
-: 1002: implicit none
-: 1003:
-: 1004: class(json_file),intent(inout) :: me
-: 1005: character(kind=CDK,len=*),intent(in) :: str
-: 1006:
-: 1007: call json_file_load_from_string(me,to_unicode(str))
2: 1008:
-: 1009: end subroutine wrap_json_file_load_from_string
4: 1010:!*****************************************************************************************
-: 1011:
-: 1012:!*****************************************************************************************
-: 1013:!> author: Jacob Williams
-: 1014:! date: 1/11/2015
-: 1015:!
-: 1016:! Print the JSON file to the console.
-: 1017:
-: 1018: subroutine json_file_print_to_console(me)
4: 1019:
-: 1020: implicit none
-: 1021:
-: 1022: class(json_file),intent(inout) :: me
-: 1023:
-: 1024: character(kind=CK,len=:),allocatable :: dummy
4: 1025:
-: 1026: call json_value_print(me%p,iunit=output_unit,str=dummy,indent=1,colon=.true.)
4: 1027:
-: 1028: end subroutine json_file_print_to_console
4: 1029:!*****************************************************************************************
-: 1030:
-: 1031:!*****************************************************************************************
-: 1032:!> author: Jacob Williams
-: 1033:! date: 12/9/2013
-: 1034:!
-: 1035:! Prints the JSON file to the specified file unit number.
-: 1036:
-: 1037: subroutine json_file_print_1(me, iunit)
4: 1038:
-: 1039: implicit none
-: 1040:
-: 1041: class(json_file),intent(inout) :: me
-: 1042: integer(IK),intent(in) :: iunit !! file unit number (must not be -1)
-: 1043:
-: 1044: integer(IK) :: i
-: 1045: character(kind=CK,len=:),allocatable :: dummy
4: 1046:
-: 1047: if (iunit/=unit2str) then
4: 1048: i = iunit
4: 1049: call json_value_print(me%p,iunit=i,str=dummy,indent=1,colon=.true.)
4: 1050: else
-: 1051: call throw_exception('Error in json_file_print_1: iunit must not be -1.')
#####: 1052: end if
-: 1053:
-: 1054: end subroutine json_file_print_1
4: 1055:!*****************************************************************************************
-: 1056:
-: 1057:!*****************************************************************************************
-: 1058:!> author: Jacob Williams
-: 1059:! date: 1/11/2015
-: 1060:!
-: 1061:! Print the JSON structure to the specified filename.
-: 1062:! The file is opened, printed, and then closed.
-: 1063:!
-: 1064:!# Example
-: 1065:! Example loading a JSON file, changing a value, and then printing
-: 1066:! result to a new file:
-: 1067:!```fortran
-: 1068:! type(json_file) :: f
-: 1069:! logical :: found
-: 1070:! call f%load_file('my_file.json') !open the original file
-: 1071:! call f%update('version',4,found) !change the value of a variable
-: 1072:! call f%print_file('my_file_2.json') !save file as new name
-: 1073:!```
-: 1074:
-: 1075: subroutine json_file_print_2(me,filename)
2: 1076:
-: 1077: implicit none
-: 1078:
-: 1079: class(json_file),intent(inout) :: me
-: 1080: character(kind=CDK,len=*),intent(in) :: filename !! filename to print to
-: 1081:
-: 1082: integer(IK) :: iunit,istat
-: 1083:
-: 1084: open(newunit=iunit,file=filename,status='REPLACE',iostat=istat FILE_ENCODING )
2: 1085: if (istat==0) then
2: 1086: call me%print_file(iunit) !call the other routine
2: 1087: close(iunit,iostat=istat)
2: 1088: else
-: 1089: call throw_exception('Error in json_file_print_2: could not open file: '//&
-: 1090: trim(filename))
#####: 1091: end if
-: 1092:
-: 1093: end subroutine json_file_print_2
4: 1094:!*****************************************************************************************
-: 1095:
-: 1096:!*****************************************************************************************
-: 1097:!> author: Jacob Williams
-: 1098:! date: 1/11/2015
-: 1099:!
-: 1100:! Print the JSON file to a string.
-: 1101:!
-: 1102:!# Example
-: 1103:!
-: 1104:! Open a JSON file, and then print the contents to a string:
-: 1105:!```fortran
-: 1106:! type(json_file) :: f
-: 1107:! character(kind=CK,len=:),allocatable :: str
-: 1108:! call f%load_file('my_file.json')
-: 1109:! call f%print_file(str)
-: 1110:!```
-: 1111:
-: 1112: subroutine json_file_print_to_string(me,str)
3: 1113:
-: 1114: implicit none
-: 1115:
-: 1116: class(json_file),intent(inout) :: me
-: 1117: character(kind=CK,len=:),allocatable,intent(out) :: str !! string to print JSON data to
-: 1118:
-: 1119: call json_value_to_string(me%p,str)
3: 1120:
-: 1121: end subroutine json_file_print_to_string
3: 1122:!*****************************************************************************************
-: 1123:
-: 1124:!*****************************************************************************************
-: 1125:!> author: Jacob Williams
-: 1126:! date: 2/3/2014
-: 1127:!
-: 1128:! Returns information about a variable in a [[json_file]].
-: 1129:
-: 1130: subroutine json_file_variable_info(me,path,found,var_type,n_children)
1: 1131:
-: 1132: implicit none
-: 1133:
-: 1134: class(json_file),intent(inout) :: me
-: 1135: character(kind=CK,len=*),intent(in) :: path !! path to the variable
-: 1136: logical(LK),intent(out) :: found !! the variable exists in the structure
-: 1137: integer(IK),intent(out) :: var_type !! variable type
-: 1138: integer(IK),intent(out) :: n_children !! number of children
-: 1139:
-: 1140: type(json_value),pointer :: p
-: 1141:
-: 1142: !initialize:
-: 1143: nullify(p)
1: 1144:
-: 1145: !get a pointer to the variable (if it is there):
-: 1146: call me%get(path,p,found)
1: 1147:
-: 1148: if (found) then
1: 1149:
-: 1150: !get info:
-: 1151: call json_info(p,var_type,n_children)
1: 1152:
-: 1153: else
-: 1154:
-: 1155: !set to dummy values:
-: 1156: var_type = json_unknown
#####: 1157: n_children = 0
#####: 1158:
-: 1159: end if
-: 1160:
-: 1161: !cleanup:
-: 1162: nullify(p)
1: 1163:
-: 1164: end subroutine json_file_variable_info
2: 1165:!*****************************************************************************************
-: 1166:
-: 1167:!*****************************************************************************************
-: 1168:!>
-: 1169:! Alternate version of [[json_file_variable_info]], where "path" is kind=CDK.
-: 1170:
-: 1171: subroutine wrap_json_file_variable_info(me,path,found,var_type,n_children)
1: 1172:
-: 1173: implicit none
-: 1174:
-: 1175: class(json_file),intent(inout) :: me
-: 1176: character(kind=CDK,len=*),intent(in) :: path
-: 1177: logical(LK),intent(out) :: found
-: 1178: integer(IK),intent(out) :: var_type
-: 1179: integer(IK),intent(out) :: n_children
-: 1180:
-: 1181: call json_file_variable_info(me,to_unicode(path),found,var_type,n_children)
1: 1182:
-: 1183: end subroutine wrap_json_file_variable_info
2: 1184:!*****************************************************************************************
-: 1185:
-: 1186:!*****************************************************************************************
-: 1187:!> author: Jacob Williams
-: 1188:! date: 2/13/2014
-: 1189:!
-: 1190:! Returns information about a [[json_value]].
-: 1191:
-: 1192: subroutine json_info(p,var_type,n_children)
9: 1193:
-: 1194: implicit none
-: 1195:
-: 1196: type(json_value),pointer :: p
-: 1197: integer(IK),intent(out),optional :: var_type !! variable type
-: 1198: integer(IK),intent(out),optional :: n_children !! number of children
-: 1199:
-: 1200: if (present(var_type)) var_type = p%var_type !variable type
9: 1201: if (present(n_children)) n_children = json_count(p) !number of children
9: 1202:
-: 1203: end subroutine json_info
9: 1204:!*****************************************************************************************
-: 1205:
-: 1206:!*****************************************************************************************
-: 1207:!> author: Jacob Williams
-: 1208:! date: 2/3/2014
-: 1209:!
-: 1210:! Get a [[json_value]] pointer to an object from a JSON file.
-: 1211:
-: 1212: subroutine json_file_get_object(me, path, p, found)
6: 1213:
-: 1214: implicit none
-: 1215:
-: 1216: class(json_file),intent(inout) :: me
-: 1217: character(kind=CK,len=*),intent(in) :: path !! the path to the variable
-: 1218: type(json_value),pointer,intent(out) :: p !! pointer to the variable
-: 1219: logical(LK),intent(out),optional :: found !! if it was really found
-: 1220:
-: 1221: call json_get_by_path(me%p, path=path, p=p, found=found)
6: 1222:
-: 1223: end subroutine json_file_get_object
12: 1224:!*****************************************************************************************
-: 1225:
-: 1226:!*****************************************************************************************
-: 1227:!>
-: 1228:! Alternate version of [[json_file_get_object]], where "path" is kind=CDK.
-: 1229:
-: 1230: subroutine wrap_json_file_get_object(me, path, p, found)
5: 1231:
-: 1232: implicit none
-: 1233:
-: 1234: class(json_file),intent(inout) :: me
-: 1235: character(kind=CDK,len=*),intent(in) :: path
-: 1236: type(json_value),pointer,intent(out) :: p
-: 1237: logical(LK),intent(out),optional :: found
-: 1238:
-: 1239: call json_file_get_object(me, to_unicode(path), p, found)
5: 1240:
-: 1241: end subroutine wrap_json_file_get_object
10: 1242:!*****************************************************************************************
-: 1243:
-: 1244:!*****************************************************************************************
-: 1245:!> author: Jacob Williams
-: 1246:! date: 12/9/2013
-: 1247:!
-: 1248:! Get an integer value from a JSON file.
-: 1249:
-: 1250: subroutine json_file_get_integer(me, path, val, found)
4: 1251:
-: 1252: implicit none
-: 1253:
-: 1254: class(json_file),intent(inout) :: me
-: 1255: character(kind=CK,len=*),intent(in) :: path !! the path to the variable
-: 1256: integer(IK),intent(out) :: val !! value
-: 1257: logical(LK),intent(out),optional :: found !! if it was really found
-: 1258:
-: 1259: call json_get(me%p, path=path, value=val, found=found)
4: 1260:
-: 1261: end subroutine json_file_get_integer
8: 1262:!*****************************************************************************************
-: 1263:
-: 1264:!*****************************************************************************************
-: 1265:!>
-: 1266:! Alternate version of [[json_file_get_integer]], where "path" is kind=CDK.
-: 1267:
-: 1268: subroutine wrap_json_file_get_integer(me, path, val, found)
4: 1269:
-: 1270: implicit none
-: 1271:
-: 1272: class(json_file),intent(inout) :: me
-: 1273: character(kind=CDK,len=*),intent(in) :: path
-: 1274: integer(IK),intent(out) :: val
-: 1275: logical(LK),intent(out),optional :: found
-: 1276:
-: 1277: call json_file_get_integer(me, to_unicode(path), val, found)
4: 1278:
-: 1279: end subroutine wrap_json_file_get_integer
8: 1280:!*****************************************************************************************
-: 1281:
-: 1282:!*****************************************************************************************
-: 1283:!> author: Jacob Williams
-: 1284:! date: 1/20/2014
-: 1285:!
-: 1286:! Get an integer vector from a JSON file.
-: 1287:
-: 1288: subroutine json_file_get_integer_vec(me, path, vec, found)
1: 1289:
-: 1290: implicit none
-: 1291:
-: 1292: class(json_file),intent(inout) :: me
-: 1293: character(kind=CK,len=*),intent(in) :: path !! the path to the variable
-: 1294: integer(IK),dimension(:),allocatable,intent(out) :: vec !! the value vector
-: 1295: logical(LK),intent(out),optional :: found !! if it was really found
-: 1296:
-: 1297: call json_get(me%p, path, vec, found)
1: 1298:
-: 1299: end subroutine json_file_get_integer_vec
2: 1300:!*****************************************************************************************
-: 1301:
-: 1302:!*****************************************************************************************
-: 1303:!>
-: 1304:! Alternate version of [[json_file_get_integer_vec]], where "path" is kind=CDK.
-: 1305:
-: 1306: subroutine wrap_json_file_get_integer_vec(me, path, vec, found)
1: 1307:
-: 1308: implicit none
-: 1309:
-: 1310: class(json_file),intent(inout) :: me
-: 1311: character(kind=CDK,len=*),intent(in) :: path
-: 1312: integer(IK),dimension(:),allocatable,intent(out) :: vec
-: 1313: logical(LK),intent(out),optional :: found
-: 1314:
-: 1315: call json_file_get_integer_vec(me, to_unicode(path), vec, found)
1: 1316:
-: 1317: end subroutine wrap_json_file_get_integer_vec
2: 1318:!*****************************************************************************************
-: 1319:
-: 1320:!*****************************************************************************************
-: 1321:!> author: Jacob Williams
-: 1322:! date: 12/9/2013
-: 1323:!
-: 1324:! Get a real(RK) variable value from a JSON file.
-: 1325:
-: 1326: subroutine json_file_get_double (me, path, val, found)
3: 1327:
-: 1328: implicit none
-: 1329:
-: 1330: class(json_file),intent(inout) :: me
-: 1331: character(kind=CK,len=*),intent(in) :: path
-: 1332: real(RK),intent(out) :: val
-: 1333: logical(LK),intent(out),optional :: found
-: 1334:
-: 1335: call json_get(me%p, path=path, value=val, found=found)
3: 1336:
-: 1337: end subroutine json_file_get_double
6: 1338:!*****************************************************************************************
-: 1339:
-: 1340:!*****************************************************************************************
-: 1341:!>
-: 1342:! Alternate version of [[json_file_get_double]], where "path" is kind=CDK.
-: 1343:
-: 1344: subroutine wrap_json_file_get_double (me, path, val, found)
3: 1345:
-: 1346: implicit none
-: 1347:
-: 1348: class(json_file),intent(inout) :: me
-: 1349: character(kind=CDK,len=*),intent(in) :: path
-: 1350: real(RK),intent(out) :: val
-: 1351: logical(LK),intent(out),optional :: found
-: 1352:
-: 1353: call json_file_get_double(me, to_unicode(path), val, found)
3: 1354:
-: 1355: end subroutine wrap_json_file_get_double
6: 1356:!*****************************************************************************************
-: 1357:
-: 1358:!*****************************************************************************************
-: 1359:!> author: Jacob Williams
-: 1360:! date: 1/19/2014
-: 1361:!
-: 1362:! Get a real(RK) vector from a JSON file.
-: 1363:
-: 1364: subroutine json_file_get_double_vec(me, path, vec, found)
4: 1365:
-: 1366: implicit none
-: 1367:
-: 1368: class(json_file),intent(inout) :: me
-: 1369: character(kind=CK,len=*),intent(in) :: path
-: 1370: real(RK),dimension(:),allocatable,intent(out) :: vec
-: 1371: logical(LK),intent(out),optional :: found
-: 1372:
-: 1373: call json_get(me%p, path, vec, found)
4: 1374:
-: 1375: end subroutine json_file_get_double_vec
8: 1376:!*****************************************************************************************
-: 1377:
-: 1378:!*****************************************************************************************
-: 1379:!>
-: 1380:! Alternate version of [[json_file_get_double_vec]], where "path" is kind=CDK.
-: 1381:
-: 1382: subroutine wrap_json_file_get_double_vec(me, path, vec, found)
#####: 1383:
-: 1384: implicit none
-: 1385:
-: 1386: class(json_file),intent(inout) :: me
-: 1387: character(kind=CDK,len=*),intent(in) :: path
-: 1388: real(RK),dimension(:),allocatable,intent(out) :: vec
-: 1389: logical(LK),intent(out),optional :: found
-: 1390:
-: 1391: call json_file_get_double_vec(me, to_unicode(path), vec, found)
#####: 1392:
-: 1393: end subroutine wrap_json_file_get_double_vec
#####: 1394:!*****************************************************************************************
-: 1395:
-: 1396:!*****************************************************************************************
-: 1397:!> author: Jacob Williams
-: 1398:! date: 12/9/2013
-: 1399:!
-: 1400:! Get a logical(LK) value from a JSON file.
-: 1401:
-: 1402: subroutine json_file_get_logical(me,path,val,found)
1: 1403:
-: 1404: implicit none
-: 1405:
-: 1406: class(json_file),intent(inout) :: me
-: 1407: character(kind=CK,len=*),intent(in) :: path
-: 1408: logical(LK),intent(out) :: val
-: 1409: logical(LK),intent(out),optional :: found
-: 1410:
-: 1411: call json_get(me%p, path=path, value=val, found=found)
1: 1412:
-: 1413: end subroutine json_file_get_logical
2: 1414:!*****************************************************************************************
-: 1415:
-: 1416:!*****************************************************************************************
-: 1417:!>
-: 1418:! Alternate version of [[json_file_get_logical]], where "path" is kind=CDK.
-: 1419:
-: 1420: subroutine wrap_json_file_get_logical(me,path,val,found)
1: 1421:
-: 1422: implicit none
-: 1423:
-: 1424: class(json_file),intent(inout) :: me
-: 1425: character(kind=CDK,len=*),intent(in) :: path
-: 1426: logical(LK),intent(out) :: val
-: 1427: logical(LK),intent(out),optional :: found
-: 1428:
-: 1429: call json_file_get_logical(me, to_unicode(path), val, found)
1: 1430:
-: 1431: end subroutine wrap_json_file_get_logical
2: 1432:!*****************************************************************************************
-: 1433:
-: 1434:!*****************************************************************************************
-: 1435:!> author: Jacob Williams
-: 1436:! date: 1/20/2014
-: 1437:!
-: 1438:! Get a logical(LK) vector from a JSON file.
-: 1439:
-: 1440: subroutine json_file_get_logical_vec(me, path, vec, found)
#####: 1441:
-: 1442: implicit none
-: 1443:
-: 1444: class(json_file),intent(inout) :: me
-: 1445: character(kind=CK,len=*),intent(in) :: path
-: 1446: logical(LK),dimension(:),allocatable,intent(out) :: vec
-: 1447: logical(LK),intent(out),optional :: found
-: 1448:
-: 1449: call json_get(me%p, path, vec, found)
#####: 1450:
-: 1451: end subroutine json_file_get_logical_vec
#####: 1452:!*****************************************************************************************
-: 1453:
-: 1454:!*****************************************************************************************
-: 1455:!>
-: 1456:! Alternate version of [[json_file_get_logical_vec]], where "path" is kind=CDK.
-: 1457:
-: 1458: subroutine wrap_json_file_get_logical_vec(me, path, vec, found)
#####: 1459:
-: 1460: implicit none
-: 1461:
-: 1462: class(json_file),intent(inout) :: me
-: 1463: character(kind=CDK,len=*),intent(in) :: path
-: 1464: logical(LK),dimension(:),allocatable,intent(out) :: vec
-: 1465: logical(LK),intent(out),optional :: found
-: 1466:
-: 1467: call json_file_get_logical_vec(me, to_unicode(path), vec, found)
#####: 1468:
-: 1469: end subroutine wrap_json_file_get_logical_vec
#####: 1470:!*****************************************************************************************
-: 1471:
-: 1472:!*****************************************************************************************
-: 1473:!> author: Jacob Williams
-: 1474:! date: 12/9/2013
-: 1475:!
-: 1476:! Get a character string from a json file.
-: 1477:! The output val is an allocatable character string.
-: 1478:
-: 1479: subroutine json_file_get_string(me, path, val, found)
46: 1480:
-: 1481: implicit none
-: 1482:
-: 1483: class(json_file),intent(inout) :: me
-: 1484: character(kind=CK,len=*),intent(in) :: path
-: 1485: character(kind=CK,len=:),allocatable,intent(out) :: val
-: 1486: logical(LK),intent(out),optional :: found
-: 1487:
-: 1488: call json_get(me%p, path=path, value=val, found=found)
23: 1489:
-: 1490: end subroutine json_file_get_string
46: 1491:!*****************************************************************************************
-: 1492:
-: 1493:!*****************************************************************************************
-: 1494:!>
-: 1495:! Alternate version of [[json_file_get_string]], where "path" is kind=CDK.
-: 1496:
-: 1497: subroutine wrap_json_file_get_string(me, path, val, found)
38: 1498:
-: 1499: implicit none
-: 1500:
-: 1501: class(json_file),intent(inout) :: me
-: 1502: character(kind=CDK,len=*),intent(in) :: path
-: 1503: character(kind=CK,len=:),allocatable,intent(out) :: val
-: 1504: logical(LK),intent(out),optional :: found
-: 1505:
-: 1506: call json_file_get_string(me, to_unicode(path), val, found)
19: 1507:
-: 1508: end subroutine wrap_json_file_get_string
38: 1509:!*****************************************************************************************
-: 1510:
-: 1511:!*****************************************************************************************
-: 1512:!> author: Jacob Williams
-: 1513:! date: 1/19/2014
-: 1514:!
-: 1515:! Get a string vector from a JSON file.
-: 1516:
-: 1517: subroutine json_file_get_string_vec(me, path, vec, found)
1: 1518:
-: 1519: implicit none
-: 1520:
-: 1521: class(json_file),intent(inout) :: me
-: 1522: character(kind=CK,len=*),intent(in) :: path
-: 1523: character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
-: 1524: logical(LK),intent(out),optional :: found
-: 1525:
-: 1526: call json_get(me%p, path, vec, found)
1: 1527:
-: 1528: end subroutine json_file_get_string_vec
2: 1529:!*****************************************************************************************
-: 1530:
-: 1531:!*****************************************************************************************
-: 1532:!>
-: 1533:! Alternate version of [[json_file_get_string_vec]], where "path" is kind=CDK.
-: 1534:
-: 1535: subroutine wrap_json_file_get_string_vec(me, path, vec, found)
1: 1536:
-: 1537: implicit none
-: 1538:
-: 1539: class(json_file),intent(inout) :: me
-: 1540: character(kind=CDK,len=*),intent(in) :: path
-: 1541: character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
-: 1542: logical(LK),intent(out),optional :: found
-: 1543:
-: 1544: call json_file_get_string_vec(me, to_unicode(path), vec, found)
1: 1545:
-: 1546: end subroutine wrap_json_file_get_string_vec
2: 1547:!*****************************************************************************************
-: 1548:
-: 1549:!*****************************************************************************************
-: 1550:!> author: Jacob Williams
-: 1551:! date: 12/4/2013
-: 1552:!
-: 1553:! Initialize the JSON-Fortran module.
-: 1554:! The routine must be called before any of the routines are used.
-: 1555:! It can also be called after using the module and encountering exceptions.
-: 1556:!
-: 1557:!# Modified
-: 1558:! * Izaak Beekman : 02/24/2015
-: 1559:
-: 1560: subroutine json_initialize(verbose,compact_reals,print_signs,real_format)
27: 1561:
-: 1562: implicit none
-: 1563:
-: 1564: logical(LK),intent(in),optional :: verbose !! mainly useful for debugging (default is false)
-: 1565: logical(LK),intent(in),optional :: compact_reals !! to compact the real number strings for output
-: 1566: logical(LK),intent(in),optional :: print_signs !! always print numeric sign (default is false)
-: 1567: character(len=*,kind=CDK),intent(in),optional :: real_format
-: 1568: !! exponential (default), scientific, engineering or general
-: 1569:
-: 1570: character(kind=CDK,len=10) :: w,d,e
-: 1571: character(kind=CDK,len=2) :: sgn, rl_edit_desc
-: 1572: integer(IK) :: istat
-: 1573: logical(LK) :: sgn_prnt
-: 1574:
-: 1575:
-: 1576: !clear any errors from previous runs:
-: 1577: call json_clear_exceptions()
27: 1578:
-: 1579: !set defaults
-: 1580: sgn_prnt = .false.
27: 1581: if ( present( print_signs) ) sgn_prnt = print_signs
27: 1582: if ( sgn_prnt ) then
27: 1583: sgn = 'sp'
#####: 1584: else
-: 1585: sgn = 'ss'
27: 1586: end if
-: 1587:
-: 1588: rl_edit_desc = 'E'
27: 1589: if ( present( real_format ) ) then
27: 1590: select case ( real_format )
-: 1591: case ('g','G','e','E','en','EN','es','ES')
-: 1592: rl_edit_desc = real_format
#####: 1593: case default
-: 1594: call throw_exception('Invalid real format, "' // trim(real_format) // '", passed to json_initialize.'// &
-: 1595: new_line('a') // 'Acceptable formats are: "G", "E", "EN", and "ES".' )
#####: 1596: end select
-: 1597: end if
-: 1598:
-: 1599:# ifdef USE_UCS4
-: 1600: ! reopen stdout and stderr with utf-8 encoding
-: 1601: open(output_unit,encoding='utf-8')
27: 1602: open(error_unit, encoding='utf-8')
27: 1603:# endif
-: 1604:
-: 1605: !Ensure gfortran bug work around "parameters" are set properly
-: 1606: null_str = 'null'
27: 1607: true_str = 'true'
27: 1608: false_str = 'false'
27: 1609:
-: 1610: !optional inputs (if not present, values remains unchanged):
-: 1611: if (present(verbose)) is_verbose = verbose
27: 1612: if (present(compact_reals)) compact_real = compact_reals
27: 1613:
-: 1614: ! set the default output/input format for reals:
-: 1615: ! [this only needs to be done once, since it can't change]
-: 1616: if (.not. allocated(real_fmt)) then
27: 1617: write(w,'(ss,I0)',iostat=istat) max_numeric_str_len
11: 1618: if (istat==0) write(d,'(ss,I0)',iostat=istat) real_precision
11: 1619: if (istat==0) write(e,'(ss,I0)',iostat=istat) real_exponent_digits
11: 1620: if (istat==0) then
11: 1621: real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // trim(w) // '.' // trim(d) // 'E' // trim(e) // ')'
11: 1622: else
-: 1623: real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // '30.16E3)' !just use this one (should never happen)
#####: 1624: end if
-: 1625: end if
-: 1626:
-: 1627: !Just in case, clear these global variables also:
-: 1628: pushed_index = 0
27: 1629: pushed_char = ''
27: 1630: char_count = 0
27: 1631: line_count = 1
27: 1632: ipos = 1
27: 1633:
-: 1634: end subroutine json_initialize
54: 1635:!*****************************************************************************************
-: 1636:
-: 1637:!*****************************************************************************************
-: 1638:!> author: Jacob Williams
-: 1639:! date: 12/4/2013
-: 1640:!
-: 1641:! Clear exceptions in the JSON module.
-: 1642:
-: 1643: subroutine json_clear_exceptions()
35: 1644:
-: 1645: implicit none
-: 1646:
-: 1647: !clear the flag and message:
-: 1648: exception_thrown = .false.
35: 1649: err_message = ''
35: 1650:
-: 1651: end subroutine json_clear_exceptions
35: 1652:!*****************************************************************************************
-: 1653:
-: 1654:!*****************************************************************************************
-: 1655:!> author: Jacob Williams
-: 1656:! date: 12/4/2013
-: 1657:!
-: 1658:! Throw an exception in the JSON module.
-: 1659:! This routine sets the error flag, and prevents any subsequent routine
-: 1660:! from doing anything, until [[json_clear_exceptions]] is called.
-: 1661:
-: 1662: subroutine json_throw_exception(msg)
14: 1663:
-: 1664: implicit none
-: 1665:
-: 1666: character(kind=CK,len=*),intent(in) :: msg !the error message
-: 1667:
-: 1668: exception_thrown = .true.
14: 1669: err_message = trim(msg)
14: 1670:
-: 1671: if (is_verbose) then
14: 1672: write(*,'(A)') '***********************'
#####: 1673: write(*,'(A)') 'JSON-Fortran EXCEPTION: '//trim(msg)
#####: 1674: !call backtrace() ! gfortran (use -fbacktrace -fall-intrinsics flags)
-: 1675: !call tracebackqq(-1) ! intel (requires "use ifcore" in this routine)
-: 1676: write(*,'(A)') '***********************'
#####: 1677: end if
-: 1678:
-: 1679: end subroutine json_throw_exception
28: 1680:!*****************************************************************************************
-: 1681:
-: 1682:!*****************************************************************************************
-: 1683:!>
-: 1684:! Alternate version of [[json_throw_exception]], where "msg" is kind=CDK.
-: 1685:
-: 1686: subroutine wrap_json_throw_exception(msg)
3: 1687:
-: 1688: implicit none
-: 1689:
-: 1690: character(kind=CDK,len=*),intent(in) :: msg !the error message
-: 1691:
-: 1692: call json_throw_exception(to_unicode(msg))
3: 1693:
-: 1694: end subroutine wrap_json_throw_exception
6: 1695:!*****************************************************************************************
-: 1696:
-: 1697:!*****************************************************************************************
-: 1698:!> author: Jacob Williams
-: 1699:! date: 12/4/2013
-: 1700:!
-: 1701:! Retrieve error code from the module.
-: 1702:! This should be called after [[json_parse]] to check for errors.
-: 1703:! If an error is thrown, before using the module again, [[json_initialize]]
-: 1704:! should be called to clean up before it is used again.
-: 1705:!
-: 1706:!# Example
-: 1707:!
-: 1708:!```fortran
-: 1709:! type(json_file) :: json
-: 1710:! logical :: status_ok
-: 1711:! character(kind=CK,len=:),allocatable :: error_msg
-: 1712:! call json%load_file(filename='myfile.json')
-: 1713:! call json_check_for_errors(status_ok, error_msg)
-: 1714:! if (.not. status_ok) then
-: 1715:! write(*,*) 'Error: '//error_msg
-: 1716:! call json_clear_exceptions()
-: 1717:! call json%destroy()
-: 1718:! end if
-: 1719:!```
-: 1720:!
-: 1721:!# See also
-: 1722:! * [[json_failed]]
-: 1723:
-: 1724: subroutine json_check_for_errors(status_ok, error_msg)
3: 1725:
-: 1726: implicit none
-: 1727:
-: 1728: logical(LK),intent(out) :: status_ok !! true if there were no errors
-: 1729: character(kind=CK,len=:),allocatable,intent(out) :: error_msg !! the error message (if there were errors)
-: 1730:
-: 1731: status_ok = .not. exception_thrown
3: 1732:
-: 1733: if (.not. status_ok) then
3: 1734: if (allocated(err_message)) then
3: 1735: error_msg = err_message
3: 1736: else
-: 1737: error_msg = 'Unknown Error'
#####: 1738: end if
-: 1739: else
-: 1740: error_msg = ''
#####: 1741: end if
-: 1742:
-: 1743: end subroutine json_check_for_errors
3: 1744:!*****************************************************************************************
-: 1745:
-: 1746:!*****************************************************************************************
-: 1747:!> author: Jacob Williams
-: 1748:! date: 12/5/2013
-: 1749:!
-: 1750:! Logical function to indicate if an exception has been thrown.
-: 1751:!
-: 1752:!# Example
-: 1753:!
-: 1754:!```fortran
-: 1755:! type(json_file) :: json
-: 1756:! logical :: status_ok
-: 1757:! character(len=:),allocatable :: error_msg
-: 1758:! call json%load_file(filename='myfile.json')
-: 1759:! if (json_failed()) then
-: 1760:! call json_check_for_errors(status_ok, error_msg)
-: 1761:! write(*,*) 'Error: '//error_msg
-: 1762:! call json_clear_exceptions()
-: 1763:! call json%destroy()
-: 1764:! end if
-: 1765:!```
-: 1766:!
-: 1767:!# See also
-: 1768:! * [[json_check_for_errors]]
-: 1769:!
-: 1770: function json_failed() result(failed)
302: 1771:
-: 1772: implicit none
-: 1773:
-: 1774: logical(LK) :: failed
-: 1775:
-: 1776: failed = exception_thrown
302: 1777:
-: 1778: end function json_failed
302: 1779:!*****************************************************************************************
-: 1780:
-: 1781:!*****************************************************************************************
-: 1782:!>
-: 1783:! Allocate a [[json_value]] pointer variable.
-: 1784:! This should be called before adding data to it.
-: 1785:!
-: 1786:!# Example
-: 1787:!
-: 1788:!```fortran
-: 1789:! type(json_value),pointer :: var
-: 1790:! call json_value_create(var)
-: 1791:! call to_double(var,1.0d0)
-: 1792:!```
-: 1793:!
-: 1794:!# Notes
-: 1795:! 1. This routine does not check for exceptions.
-: 1796:! 2. The pointer should not already be allocated.
-: 1797:
-: 1798: subroutine json_value_create(p)
388584: 1799:
-: 1800: implicit none
-: 1801:
-: 1802: type(json_value),pointer :: p
-: 1803:
-: 1804: nullify(p)
388584: 1805: allocate(p)
388584: 1806:
-: 1807: end subroutine json_value_create
388584: 1808:!*****************************************************************************************
-: 1809:
-: 1810:!*****************************************************************************************
-: 1811:!> author: Jacob Williams
-: 1812:! date: 1/22/2014
-: 1813:!
-: 1814:! Destroy a [[json_value]] linked-list structure.
-: 1815:!
-: 1816:!@note The original FSON version of this
-: 1817:! routine was not properly freeing the memory.
-: 1818:! It was rewritten.
-: 1819:
-: 1820: recursive subroutine json_value_destroy(me,destroy_next)
388577: 1821:
-: 1822: implicit none
-: 1823:
-: 1824: type(json_value),pointer :: me
-: 1825: logical(LK),intent(in),optional :: destroy_next !! if true, then me%next is also destroyed (default is true)
-: 1826:
-: 1827: logical(LK) :: des_next
-: 1828: type(json_value), pointer :: p
-: 1829:
-: 1830: if (associated(me)) then
388577: 1831:
-: 1832: if (present(destroy_next)) then
388577: 1833: des_next = destroy_next
388547: 1834: else
-: 1835: des_next = .true.
30: 1836: end if
-: 1837:
-: 1838: if (allocated(me%name)) deallocate(me%name)
388577: 1839:
-: 1840: call destroy_json_data(me)
388577: 1841:
-: 1842: if (associated(me%children)) then
388577: 1843: do while (me%n_children > 0)
836881: 1844: p => me%children
388547: 1845: me%children => me%children%next
388547: 1846: me%n_children = me%n_children - 1
388547: 1847: call json_value_destroy(p,.false.)
388547: 1848: end do
-: 1849: nullify(me%children)
59787: 1850: nullify(p)
59787: 1851: end if
-: 1852:
-: 1853: if (associated(me%next) .and. des_next) call json_value_destroy(me%next)
388577: 1854:
-: 1855: if (associated(me%previous)) nullify(me%previous)
388577: 1856: if (associated(me%parent)) nullify(me%parent)
388577: 1857: if (associated(me%tail)) nullify(me%tail)
388577: 1858:
-: 1859: deallocate(me)
388577: 1860:
-: 1861: nullify(me)
388577: 1862:
-: 1863: end if
-: 1864:
-: 1865: end subroutine json_value_destroy
388577: 1866:!*****************************************************************************************
-: 1867:
-: 1868:!*****************************************************************************************
-: 1869:!> author: Jacob Williams
-: 1870:! date: 9/9/2014
-: 1871:!
-: 1872:! Remove a [[json_value]] (and all its children)
-: 1873:! from a linked-list structure, preserving the rest of the structure.
-: 1874:!
-: 1875:!# Examples
-: 1876:!
-: 1877:! To extract an object from one JSON structure, and add it to another:
-: 1878:!```fortran
-: 1879:! type(json_value),pointer :: json1,json2,p
-: 1880:! logical :: found
-: 1881:! !create and populate json1 and json2
-: 1882:! call json_get(json1,'name',p,found) ! get pointer to name element of json1
-: 1883:! call json_remove(p,destroy=.false.) ! remove it from json1 (don't destroy)
-: 1884:! call json_add(json2,p) ! add it to json2
-: 1885:!```
-: 1886:!
-: 1887:! To remove an object from a JSON structure (and destroy it):
-: 1888:!```fortran
-: 1889:! type(json_value),pointer :: json1,p
-: 1890:! logical :: found
-: 1891:! !create and populate json1
-: 1892:! call json_get(json1,'name',p,found) ! get pointer to name element of json1
-: 1893:! call json_remove(p) ! remove and destroy it
-: 1894:!```
-: 1895:!
-: 1896:!# History
-: 1897:! * Jacob Williams : 12/28/2014 : added destroy optional argument.
-: 1898:!
-: 1899:
-: 1900: subroutine json_value_remove(me,destroy)
5: 1901:
-: 1902: implicit none
-: 1903:
-: 1904: type(json_value),pointer :: me
-: 1905: logical(LK),intent(in),optional :: destroy !! If destroy is not present, it is also destroyed.
-: 1906: !! If destroy is present and true, it is destroyed.
-: 1907: !! If destroy is present and false, it is not destroyed.
-: 1908:
-: 1909: type(json_value),pointer :: parent,previous,next
-: 1910: logical(LK) :: destroy_it
-: 1911:
-: 1912: if (associated(me)) then
5: 1913:
-: 1914: !optional input argument:
-: 1915: if (present(destroy)) then
5: 1916: destroy_it = destroy
1: 1917: else
-: 1918: destroy_it = .true.
4: 1919: end if
-: 1920:
-: 1921: if (associated(me%parent)) then
5: 1922:
-: 1923: parent => me%parent
5: 1924:
-: 1925: if (associated(me%next)) then
5: 1926:
-: 1927: !there are later items in the list:
-: 1928:
-: 1929: next => me%next
4: 1930: nullify(me%next)
4: 1931:
-: 1932: if (associated(me%previous)) then
4: 1933: !there are earlier items in the list
-: 1934: previous => me%previous
3: 1935: previous%next => next
3: 1936: next%previous => previous
3: 1937: else
-: 1938: !this is the first item in the list
-: 1939: parent%children => next
1: 1940: nullify(next%previous)
1: 1941: end if
-: 1942:
-: 1943: else
-: 1944:
-: 1945: if (associated(me%previous)) then
1: 1946: !there are earlier items in the list:
-: 1947: previous => me%previous
1: 1948: nullify(previous%next)
1: 1949: parent%tail => previous
1: 1950: else
-: 1951: !this is the only item in the list:
-: 1952: nullify(parent%children)
#####: 1953: nullify(parent%tail)
#####: 1954: end if
-: 1955:
-: 1956: end if
-: 1957:
-: 1958: parent%n_children = parent%n_children - 1
5: 1959:
-: 1960: end if
-: 1961:
-: 1962: if (destroy_it) call json_value_destroy(me)
5: 1963:
-: 1964: end if
-: 1965:
-: 1966: end subroutine json_value_remove
5: 1967:!*****************************************************************************************
-: 1968:
-: 1969:!*****************************************************************************************
-: 1970:!> author: Jacob Williams
-: 1971:! date: 12/6/2014
-: 1972:!
-: 1973:! Given the path string, remove the variable from
-: 1974:! the [[json_value]] structure, if it exists.
-: 1975:
-: 1976: subroutine json_value_remove_if_present(p,name)
1: 1977:
-: 1978: implicit none
-: 1979:
-: 1980: type(json_value),pointer :: p
-: 1981: character(kind=CK,len=*),intent(in) :: name
-: 1982:
-: 1983: type(json_value),pointer :: p_var
-: 1984: logical(LK) :: found
-: 1985:
-: 1986: call json_get(p,name,p_var,found)
1: 1987: if (found) call json_remove(p_var)
1: 1988:
-: 1989: end subroutine json_value_remove_if_present
2: 1990:!*****************************************************************************************
-: 1991:
-: 1992:!*****************************************************************************************
-: 1993:!>
-: 1994:! Alternate version of [[json_value_remove_if_present]], where "name" is kind=CDK.
-: 1995:
-: 1996: subroutine wrap_json_value_remove_if_present(p,name)
1: 1997:
-: 1998: implicit none
-: 1999:
-: 2000: type(json_value),pointer :: p
-: 2001: character(kind=CDK,len=*),intent(in) :: name
-: 2002:
-: 2003: call json_value_remove_if_present(p,to_unicode(name))
1: 2004:
-: 2005: end subroutine wrap_json_value_remove_if_present
2: 2006:!*****************************************************************************************
-: 2007:
-: 2008:!*****************************************************************************************
-: 2009:!> author: Jacob Williams
-: 2010:! date:1/10/2015
-: 2011:!
-: 2012:! Given the path string, if the variable is present in the file,
-: 2013:! and is a scalar, then update its value.
-: 2014:! If it is not present, then create it and set its value.
-: 2015:!
-: 2016:!# See also
-: 2017:! * [[json_update_integer]]
-: 2018:
-: 2019: subroutine json_file_update_integer(me,name,val,found)
1: 2020: implicit none
-: 2021:
-: 2022: class(json_file),intent(inout) :: me
-: 2023: character(kind=CK,len=*),intent(in) :: name
-: 2024: integer(IK),intent(in) :: val
-: 2025: logical(LK),intent(out) :: found
-: 2026:
-: 2027: if (.not. exception_thrown) call json_update(me%p,name,val,found)
1: 2028:
-: 2029: end subroutine json_file_update_integer
2: 2030:!*****************************************************************************************
-: 2031:
-: 2032:!*****************************************************************************************
-: 2033:!>
-: 2034:! Alternate version of [[json_file_update_integer]], where "name" is kind=CDK.
-: 2035:
-: 2036: subroutine wrap_json_file_update_integer(me,name,val,found)
1: 2037: implicit none
-: 2038:
-: 2039: class(json_file),intent(inout) :: me
-: 2040: character(kind=CDK,len=*),intent(in) :: name
-: 2041: integer(IK),intent(in) :: val
-: 2042: logical(LK),intent(out) :: found
-: 2043:
-: 2044: call json_file_update_integer(me,to_unicode(name),val,found)
1: 2045:
-: 2046: end subroutine wrap_json_file_update_integer
2: 2047:!*****************************************************************************************
-: 2048:
-: 2049:!*****************************************************************************************
-: 2050:!> author: Jacob Williams
-: 2051:! date: 1/10/2015
-: 2052:!
-: 2053:! Given the path string, if the variable is present in the file,
-: 2054:! and is a scalar, then update its value.
-: 2055:! If it is not present, then create it and set its value.
-: 2056:!
-: 2057:!# See also
-: 2058:! * [[json_update_logical]]
-: 2059:
-: 2060: subroutine json_file_update_logical(me,name,val,found)
2: 2061: implicit none
-: 2062:
-: 2063: class(json_file),intent(inout) :: me
-: 2064: character(kind=CK,len=*),intent(in) :: name
-: 2065: logical(LK),intent(in) :: val
-: 2066: logical(LK),intent(out) :: found
-: 2067:
-: 2068: if (.not. exception_thrown) call json_update(me%p,name,val,found)
2: 2069:
-: 2070: end subroutine json_file_update_logical
4: 2071:!*****************************************************************************************
-: 2072:
-: 2073:!*****************************************************************************************
-: 2074:!>
-: 2075:! Alternate version of [[json_file_update_logical]], where "name" is kind=CDK.
-: 2076:
-: 2077: subroutine wrap_json_file_update_logical(me,name,val,found)
2: 2078: implicit none
-: 2079:
-: 2080: class(json_file),intent(inout) :: me
-: 2081: character(kind=CDK,len=*),intent(in) :: name
-: 2082: logical(LK),intent(in) :: val
-: 2083: logical(LK),intent(out) :: found
-: 2084:
-: 2085: call json_file_update_logical(me,to_unicode(name),val,found)
2: 2086:
-: 2087: end subroutine wrap_json_file_update_logical
4: 2088:!*****************************************************************************************
-: 2089:
-: 2090:!*****************************************************************************************
-: 2091:!> author: Jacob Williams
-: 2092:! date: 1/10/2015
-: 2093:!
-: 2094:! Given the path string, if the variable is present in the file,
-: 2095:! and is a scalar, then update its value.
-: 2096:! If it is not present, then create it and set its value.
-: 2097:!
-: 2098:!# See also
-: 2099:! * [[json_update_double]]
-: 2100:
-: 2101: subroutine json_file_update_real(me,name,val,found)
2: 2102: implicit none
-: 2103:
-: 2104: class(json_file),intent(inout) :: me
-: 2105: character(kind=CK,len=*),intent(in) :: name
-: 2106: real(RK),intent(in) :: val
-: 2107: logical(LK),intent(out) :: found
-: 2108:
-: 2109: if (.not. exception_thrown) call json_update(me%p,name,val,found)
2: 2110:
-: 2111: end subroutine json_file_update_real
4: 2112:!*****************************************************************************************
-: 2113:
-: 2114:!*****************************************************************************************
-: 2115:!>
-: 2116:! Alternate version of [[json_file_update_real]], where "name" is kind=CDK.
-: 2117:
-: 2118: subroutine wrap_json_file_update_real(me,name,val,found)
2: 2119: implicit none
-: 2120:
-: 2121: class(json_file),intent(inout) :: me
-: 2122: character(kind=CDK,len=*),intent(in) :: name
-: 2123: real(RK),intent(in) :: val
-: 2124: logical(LK),intent(out) :: found
-: 2125:
-: 2126: call json_file_update_real(me,to_unicode(name),val,found)
2: 2127:
-: 2128: end subroutine wrap_json_file_update_real
4: 2129:!*****************************************************************************************
-: 2130:
-: 2131:!*****************************************************************************************
-: 2132:!> author: Jacob Williams
-: 2133:! date: 1/10/2015
-: 2134:!
-: 2135:! Given the path string, if the variable is present in the file,
-: 2136:! and is a scalar, then update its value.
-: 2137:! If it is not present, then create it and set its value.
-: 2138:!
-: 2139:!# See also
-: 2140:! * [[json_update_string]]
-: 2141:
-: 2142: subroutine json_file_update_string(me,name,val,found)
2: 2143: implicit none
-: 2144:
-: 2145: class(json_file),intent(inout) :: me
-: 2146: character(kind=CK,len=*),intent(in) :: name
-: 2147: character(kind=CK,len=*),intent(in) :: val
-: 2148: logical(LK),intent(out) :: found
-: 2149:
-: 2150: if (.not. exception_thrown) call json_update(me%p,name,val,found)
2: 2151:
-: 2152: end subroutine json_file_update_string
4: 2153:!*****************************************************************************************
-: 2154:
-: 2155:!*****************************************************************************************
-: 2156:!>
-: 2157:! Alternate version of [[json_file_update_string]], where "name" and "val" are kind=CDK.
-: 2158:
-: 2159: subroutine wrap_json_file_update_string(me,name,val,found)
2: 2160: implicit none
-: 2161:
-: 2162: class(json_file),intent(inout) :: me
-: 2163: character(kind=CDK,len=*),intent(in) :: name
-: 2164: character(kind=CDK,len=*),intent(in) :: val
-: 2165: logical(LK),intent(out) :: found
-: 2166:
-: 2167: call json_file_update_string(me,to_unicode(name),to_unicode(val),found)
2: 2168:
-: 2169: end subroutine wrap_json_file_update_string
4: 2170:!*****************************************************************************************
-: 2171:
-: 2172:!*****************************************************************************************
-: 2173:!>
-: 2174:! Alternate version of [[json_file_update_string]], where "name" is kind=CDK.
-: 2175:
-: 2176: subroutine json_file_update_string_name_ascii(me,name,val,found)
#####: 2177: implicit none
-: 2178:
-: 2179: class(json_file),intent(inout) :: me
-: 2180: character(kind=CDK,len=*),intent(in) :: name
-: 2181: character(kind=CK, len=*),intent(in) :: val
-: 2182: logical(LK),intent(out) :: found
-: 2183:
-: 2184: call json_file_update_string(me,to_unicode(name),val,found)
#####: 2185:
-: 2186: end subroutine json_file_update_string_name_ascii
#####: 2187:!*****************************************************************************************
-: 2188:
-: 2189:!*****************************************************************************************
-: 2190:!>
-: 2191:! Alternate version of [[json_file_update_string]], where "val" is kind=CDK.
-: 2192:
-: 2193: subroutine json_file_update_string_val_ascii(me,name,val,found)
#####: 2194: implicit none
-: 2195:
-: 2196: class(json_file),intent(inout) :: me
-: 2197: character(kind=CK, len=*),intent(in) :: name
-: 2198: character(kind=CDK,len=*),intent(in) :: val
-: 2199: logical(LK),intent(out) :: found
-: 2200:
-: 2201: call json_file_update_string(me,name,to_unicode(val),found)
#####: 2202:
-: 2203: end subroutine json_file_update_string_val_ascii
#####: 2204:!*****************************************************************************************
-: 2205:
-: 2206:!*****************************************************************************************
-: 2207:!> author: Jacob Williams
-: 2208:! date: 12/6/2014
-: 2209:!
-: 2210:! Given the path string, if the variable is present,
-: 2211:! and is a scalar, then update its value.
-: 2212:! If it is not present, then create it and set its value.
-: 2213:
-: 2214: subroutine json_update_logical(p,name,val,found)
3: 2215:
-: 2216: implicit none
-: 2217:
-: 2218: type(json_value),pointer :: p
-: 2219: character(kind=CK,len=*),intent(in) :: name
-: 2220: logical(LK),intent(in) :: val
-: 2221: logical(LK),intent(out) :: found
-: 2222:
-: 2223: type(json_value),pointer :: p_var
-: 2224: integer(IK) :: var_type
-: 2225:
-: 2226: call json_get(p,name,p_var,found)
3: 2227: if (found) then
3: 2228:
-: 2229: call json_info(p_var,var_type)
2: 2230: select case (var_type)
-: 2231: case (json_null,json_logical,json_integer,json_double,json_string)
-: 2232: call to_logical(p_var,val) !update the value
2: 2233: case default
-: 2234: found = .false.
#####: 2235: call throw_exception('Error in json_update_logical: '//&
-: 2236: 'the variable is not a scalar value')
2: 2237: end select
-: 2238:
-: 2239: else
-: 2240: call json_add(p,name,val) !add the new element
1: 2241: end if
-: 2242:
-: 2243: end subroutine json_update_logical
6: 2244:!*****************************************************************************************
-: 2245:
-: 2246:!*****************************************************************************************
-: 2247:!>
-: 2248:! Alternate version of [[json_update_logical]], where "name" is kind=CDK.
-: 2249:
-: 2250: subroutine wrap_json_update_logical(p,name,val,found)
1: 2251:
-: 2252: implicit none
-: 2253:
-: 2254: type(json_value),pointer :: p
-: 2255: character(kind=CDK,len=*),intent(in) :: name
-: 2256: logical(LK),intent(in) :: val
-: 2257: logical(LK),intent(out) :: found
-: 2258:
-: 2259: call json_update_logical(p,to_unicode(name),val,found)
1: 2260:
-: 2261: end subroutine wrap_json_update_logical
2: 2262:!*****************************************************************************************
-: 2263:
-: 2264:!*****************************************************************************************
-: 2265:!> author: Jacob Williams
-: 2266:! date: 12/6/2014
-: 2267:!
-: 2268:! Given the path string, if the variable is present,
-: 2269:! and is a scalar, then update its value.
-: 2270:! If it is not present, then create it and set its value.
-: 2271:
-: 2272: subroutine json_update_double(p,name,val,found)
3: 2273:
-: 2274: implicit none
-: 2275:
-: 2276: type(json_value),pointer :: p
-: 2277: character(kind=CK,len=*),intent(in) :: name
-: 2278: real(RK),intent(in) :: val
-: 2279: logical(LK),intent(out) :: found
-: 2280:
-: 2281: type(json_value),pointer :: p_var
-: 2282: integer(IK) :: var_type
-: 2283:
-: 2284: call json_get(p,name,p_var,found)
3: 2285: if (found) then
3: 2286:
-: 2287: call json_info(p_var,var_type)
2: 2288: select case (var_type)
-: 2289: case (json_null,json_logical,json_integer,json_double,json_string)
-: 2290: call to_double(p_var,val) !update the value
2: 2291: case default
-: 2292: found = .false.
#####: 2293: call throw_exception('Error in json_update_double: '//&
-: 2294: 'the variable is not a scalar value')
2: 2295: end select
-: 2296:
-: 2297: else
-: 2298: call json_add(p,name,val) !add the new element
1: 2299: end if
-: 2300:
-: 2301: end subroutine json_update_double
6: 2302:!*****************************************************************************************
-: 2303:
-: 2304:!*****************************************************************************************
-: 2305:!>
-: 2306:! Alternate version of [[json_update_double]], where "name" is kind=CDK.
-: 2307:
-: 2308: subroutine wrap_json_update_double(p,name,val,found)
1: 2309:
-: 2310: implicit none
-: 2311:
-: 2312: type(json_value),pointer :: p
-: 2313: character(kind=CDK,len=*),intent(in) :: name
-: 2314: real(RK),intent(in) :: val
-: 2315: logical(LK),intent(out) :: found
-: 2316:
-: 2317: call json_update_double(p,to_unicode(name),val,found)
1: 2318:
-: 2319: end subroutine wrap_json_update_double
2: 2320:!*****************************************************************************************
-: 2321:
-: 2322:!*****************************************************************************************
-: 2323:!> author: Jacob Williams
-: 2324:! date: 12/6/2014
-: 2325:!
-: 2326:! Given the path string, if the variable is present,
-: 2327:! and is a scalar, then update its value.
-: 2328:! If it is not present, then create it and set its value.
-: 2329:
-: 2330: subroutine json_update_integer(p,name,val,found)
1: 2331:
-: 2332: implicit none
-: 2333:
-: 2334: type(json_value),pointer :: p
-: 2335: character(kind=CK,len=*),intent(in) :: name
-: 2336: integer(IK),intent(in) :: val
-: 2337: logical(LK),intent(out) :: found
-: 2338:
-: 2339: type(json_value),pointer :: p_var
-: 2340: integer(IK) :: var_type
-: 2341:
-: 2342: call json_get(p,name,p_var,found)
1: 2343: if (found) then
1: 2344:
-: 2345: call json_info(p_var,var_type)
1: 2346: select case (var_type)
-: 2347: case (json_null,json_logical,json_integer,json_double,json_string)
-: 2348: call to_integer(p_var,val) !update the value
1: 2349: case default
-: 2350: found = .false.
#####: 2351: call throw_exception('Error in json_update_integer: '//&
-: 2352: 'the variable is not a scalar value')
1: 2353: end select
-: 2354:
-: 2355: else
-: 2356: call json_add(p,name,val) !add the new element
#####: 2357: end if
-: 2358:
-: 2359: end subroutine json_update_integer
2: 2360:!*****************************************************************************************
-: 2361:
-: 2362:!*****************************************************************************************
-: 2363:!>
-: 2364:! Alternate version of [[json_update_integer]], where "name" is kind=CDK.
-: 2365:
-: 2366: subroutine wrap_json_update_integer(p,name,val,found)
#####: 2367:
-: 2368: implicit none
-: 2369:
-: 2370: type(json_value),pointer :: p
-: 2371: character(kind=CDK,len=*),intent(in) :: name
-: 2372: integer(IK),intent(in) :: val
-: 2373: logical(LK),intent(out) :: found
-: 2374:
-: 2375: call json_update_integer(p,to_unicode(name),val,found)
#####: 2376:
-: 2377: end subroutine wrap_json_update_integer
#####: 2378:!*****************************************************************************************
-: 2379:
-: 2380:!*****************************************************************************************
-: 2381:!> author: Jacob Williams
-: 2382:! date: 12/6/2014
-: 2383:!
-: 2384:! Given the path string, if the variable is present,
-: 2385:! and is a scalar, then update its value.
-: 2386:! If it is not present, then create it and set its value.
-: 2387:
-: 2388: subroutine json_update_string(p,name,val,found)
3: 2389:
-: 2390: implicit none
-: 2391:
-: 2392: type(json_value),pointer :: p
-: 2393: character(kind=CK,len=*),intent(in) :: name
-: 2394: character(kind=CK,len=*),intent(in) :: val
-: 2395: logical(LK),intent(out) :: found
-: 2396:
-: 2397: type(json_value),pointer :: p_var
-: 2398: integer(IK) :: var_type
-: 2399:
-: 2400: call json_get(p,name,p_var,found)
3: 2401: if (found) then
3: 2402:
-: 2403: call json_info(p_var,var_type)
2: 2404: select case (var_type)
-: 2405: case (json_null,json_logical,json_integer,json_double,json_string)
-: 2406: call to_string(p_var,val) !update the value
2: 2407: case default
-: 2408: found = .false.
#####: 2409: call throw_exception('Error in json_update_string: '//&
-: 2410: 'the variable is not a scalar value')
2: 2411: end select
-: 2412:
-: 2413: else
-: 2414: call json_add(p,name,val) !add the new element
1: 2415: end if
-: 2416:
-: 2417: end subroutine json_update_string
6: 2418:!*****************************************************************************************
-: 2419:
-: 2420:!*****************************************************************************************
-: 2421:!>
-: 2422:! Alternate version of [[json_update_string]], where "name" and "value" are kind=CDK.
-: 2423:
-: 2424: subroutine wrap_json_update_string(p,name,val,found)
1: 2425:
-: 2426: implicit none
-: 2427:
-: 2428: type(json_value),pointer :: p
-: 2429: character(kind=CDK,len=*),intent(in) :: name
-: 2430: character(kind=CDK,len=*),intent(in) :: val
-: 2431: logical(LK),intent(out) :: found
-: 2432:
-: 2433: call json_update_string(p,to_unicode(name),to_unicode(val),found)
1: 2434:
-: 2435: end subroutine wrap_json_update_string
2: 2436:!*****************************************************************************************
-: 2437:
-: 2438:!*****************************************************************************************
-: 2439:!>
-: 2440:! Alternate version of [[json_update_string]], where "name" is kind=CDK.
-: 2441:
-: 2442: subroutine json_update_string_name_ascii(p,name,val,found)
#####: 2443:
-: 2444: implicit none
-: 2445:
-: 2446: type(json_value),pointer :: p
-: 2447: character(kind=CDK,len=*),intent(in) :: name
-: 2448: character(kind=CK, len=*),intent(in) :: val
-: 2449: logical(LK),intent(out) :: found
-: 2450:
-: 2451: call json_update_string(p,to_unicode(name),val,found)
#####: 2452:
-: 2453: end subroutine json_update_string_name_ascii
#####: 2454:!*****************************************************************************************
-: 2455:
-: 2456:!*****************************************************************************************
-: 2457:!>
-: 2458:! Alternate version of [[json_update_string]], where "val" is kind=CDK.
-: 2459:
-: 2460: subroutine json_update_string_val_ascii(p,name,val,found)
#####: 2461:
-: 2462: implicit none
-: 2463:
-: 2464: type(json_value),pointer :: p
-: 2465: character(kind=CK, len=*),intent(in) :: name
-: 2466: character(kind=CDK,len=*),intent(in) :: val
-: 2467: logical(LK),intent(out) :: found
-: 2468:
-: 2469: call json_update_string(p,name,to_unicode(val),found)
#####: 2470:
-: 2471: end subroutine json_update_string_val_ascii
#####: 2472:!*****************************************************************************************
-: 2473:
-: 2474:!*****************************************************************************************
-: 2475:!>
-: 2476:! Adds "member" as a child of "me".
-: 2477:
-: 2478: subroutine json_value_add_member(me, member)
388553: 2479:
-: 2480: implicit none
-: 2481:
-: 2482: type(json_value),pointer :: me
-: 2483: type(json_value),pointer :: member !! the child member to add
-: 2484:
-: 2485: if (.not. exception_thrown) then
388553: 2486:
-: 2487: ! associate the parent
-: 2488: member%parent => me
388553: 2489:
-: 2490: ! add to linked list
-: 2491: if (associated(me%children)) then
388553: 2492:
-: 2493: me%tail%next => member
328765: 2494: member%previous => me%tail
328765: 2495:
-: 2496: else
-: 2497:
-: 2498: me%children => member
59788: 2499: member%previous => null() !first in the list
59788: 2500:
-: 2501: end if
-: 2502:
-: 2503: ! new member is now the last one in the list
-: 2504: me%tail => member
388553: 2505: me%n_children = me%n_children + 1
388553: 2506:
-: 2507: end if
-: 2508:
-: 2509: end subroutine json_value_add_member
388553: 2510:!*****************************************************************************************
-: 2511:
-: 2512:!*****************************************************************************************
-: 2513:!> author: Jacob Williams
-: 2514:! date: 1/19/2014
-: 2515:!
-: 2516:! Add a real value child to the [[json_value]] variable
-: 2517:!
-: 2518:!@note This routine is part of the public API that can be
-: 2519:! used to build a JSON structure using [[json_value]] pointers.
-: 2520:
-: 2521: subroutine json_value_add_double(me, name, val)
22: 2522:
-: 2523: implicit none
-: 2524:
-: 2525: type(json_value),pointer :: me
-: 2526: character(kind=CK,len=*),intent(in) :: name !! variable name
-: 2527: real(RK),intent(in) :: val !! real value
-: 2528:
-: 2529: type(json_value),pointer :: var
-: 2530:
-: 2531: !create the variable:
-: 2532: call json_value_create(var)
22: 2533: call to_double(var,val,name)
22: 2534:
-: 2535: !add it:
-: 2536: call json_add(me, var)
22: 2537:
-: 2538: !cleanup:
-: 2539: nullify(var)
22: 2540:
-: 2541: end subroutine json_value_add_double
44: 2542:!*****************************************************************************************
-: 2543:
-: 2544:!*****************************************************************************************
-: 2545:!>
-: 2546:! Alternate version of [[json_value_add_double]] where "name" is kind=CDK.
-: 2547:
-: 2548: subroutine wrap_json_value_add_double(me, name, val)
21: 2549:
-: 2550: implicit none
-: 2551:
-: 2552: type(json_value),pointer :: me
-: 2553: character(kind=CDK,len=*),intent(in) :: name !! variable name
-: 2554: real(RK),intent(in) :: val !! real value
-: 2555:
-: 2556: call json_value_add_double(me, to_unicode(name), val)
21: 2557:
-: 2558: end subroutine wrap_json_value_add_double
42: 2559:!*****************************************************************************************
-: 2560:
-: 2561:!*****************************************************************************************
-: 2562:!> author: Jacob Williams
-: 2563:! date: 1/20/2014
-: 2564:!
-: 2565:! Add a real vector to the structure.
-: 2566:!
-: 2567:!@note This routine is part of the public API that can be
-: 2568:! used to build a JSON structure using [[json_value]] pointers.
-: 2569:
-: 2570: subroutine json_value_add_double_vec(me, name, val)
12: 2571:
-: 2572: implicit none
-: 2573:
-: 2574: type(json_value),pointer :: me
-: 2575: character(kind=CK,len=*),intent(in) :: name
-: 2576: real(RK),dimension(:),intent(in) :: val
-: 2577:
-: 2578: type(json_value),pointer :: var
-: 2579: integer(IK) :: i
-: 2580:
-: 2581: !create the variable as an array:
-: 2582: call json_value_create(var)
6: 2583: call to_array(var,name)
6: 2584:
-: 2585: !populate the array:
-: 2586: do i=1,size(val)
24: 2587: call json_add(var, '', val(i))
18: 2588: end do
-: 2589:
-: 2590: !add it:
-: 2591: call json_add(me, var)
6: 2592:
-: 2593: !cleanup:
-: 2594: nullify(var)
6: 2595:
-: 2596: end subroutine json_value_add_double_vec
12: 2597:!*****************************************************************************************
-: 2598:
-: 2599:!*****************************************************************************************
-: 2600:!>
-: 2601:! Alternate version of [[json_value_add_double_vec]] where "name" is kind=CDK.
-: 2602:
-: 2603: subroutine wrap_json_value_add_double_vec(me, name, val)
12: 2604:
-: 2605: implicit none
-: 2606:
-: 2607: type(json_value),pointer :: me
-: 2608: character(kind=CDK,len=*),intent(in) :: name
-: 2609: real(RK),dimension(:),intent(in) :: val
-: 2610:
-: 2611: call json_value_add_double_vec(me, to_unicode(name), val)
6: 2612:
-: 2613: end subroutine wrap_json_value_add_double_vec
12: 2614:!*****************************************************************************************
-: 2615:
-: 2616:!*****************************************************************************************
-: 2617:!> author: Jacob Williams
-: 2618:! date: 1/20/2014
-: 2619:!
-: 2620:! Add an integer value child to the [[json_value]] variable
-: 2621:!
-: 2622:!@note This routine is part of the public API that can be
-: 2623:! used to build a JSON structure using [[json_value]] pointers.
-: 2624:
-: 2625: subroutine json_value_add_integer(me, name, val)
112: 2626:
-: 2627: implicit none
-: 2628:
-: 2629: type(json_value),pointer :: me
-: 2630: character(kind=CK,len=*),intent(in) :: name
-: 2631: integer(IK),intent(in) :: val
-: 2632:
-: 2633: type(json_value),pointer :: var
-: 2634:
-: 2635: !create the variable:
-: 2636: call json_value_create(var)
112: 2637: call to_integer(var,val,name)
112: 2638:
-: 2639: !add it:
-: 2640: call json_add(me, var)
112: 2641:
-: 2642: !cleanup:
-: 2643: nullify(var)
112: 2644:
-: 2645: end subroutine json_value_add_integer
224: 2646:!*****************************************************************************************
-: 2647:
-: 2648:!*****************************************************************************************
-: 2649:!>
-: 2650:! Alternate version of [[json_value_add_integer]] where "name" is kind=CDK.
-: 2651:
-: 2652: subroutine wrap_json_value_add_integer(me, name, val)
12: 2653:
-: 2654: implicit none
-: 2655:
-: 2656: type(json_value),pointer :: me
-: 2657: character(kind=CDK,len=*),intent(in) :: name !! name of the variable
-: 2658: integer(IK),intent(in) :: val !! value
-: 2659:
-: 2660: call json_value_add_integer(me, to_unicode(name), val)
12: 2661:
-: 2662: end subroutine wrap_json_value_add_integer
24: 2663:!*****************************************************************************************
-: 2664:
-: 2665:!*****************************************************************************************
-: 2666:!> author: Jacob Williams
-: 2667:! date: 1/20/2014
-: 2668:!
-: 2669:! Add an integer vector to the structure.
-: 2670:!
-: 2671:!@note This routine is part of the public API that can be
-: 2672:! used to build a JSON structure using [[json_value]] pointers.
-: 2673:
-: 2674: subroutine json_value_add_integer_vec(me, name, val)
4: 2675:
-: 2676: implicit none
-: 2677:
-: 2678: type(json_value),pointer :: me
-: 2679: character(kind=CK,len=*),intent(in) :: name !! name of the variable
-: 2680: integer(IK),dimension(:),intent(in) :: val !! value
-: 2681:
-: 2682: type(json_value),pointer :: var
-: 2683: integer(IK) :: i !counter
-: 2684:
-: 2685: !create the variable as an array:
-: 2686: call json_value_create(var)
2: 2687: call to_array(var,name)
2: 2688:
-: 2689: !populate the array:
-: 2690: do i=1,size(val)
8: 2691: call json_add(var, '', val(i))
6: 2692: end do
-: 2693:
-: 2694: !add it:
-: 2695: call json_add(me, var)
2: 2696:
-: 2697: !cleanup:
-: 2698: nullify(var)
2: 2699:
-: 2700: end subroutine json_value_add_integer_vec
4: 2701:!*****************************************************************************************
-: 2702:
-: 2703:!*****************************************************************************************
-: 2704:!>
-: 2705:! Alternate version of [[json_value_add_integer_vec]] where "name" is kind=CDK.
-: 2706:
-: 2707: subroutine wrap_json_value_add_integer_vec(me, name, val)
4: 2708:
-: 2709: implicit none
-: 2710:
-: 2711: type(json_value),pointer :: me
-: 2712: character(kind=CDK,len=*),intent(in) :: name !! name of the variable
-: 2713: integer(IK),dimension(:),intent(in) :: val !! value
-: 2714:
-: 2715: call json_value_add_integer_vec(me, to_unicode(name), val)
2: 2716:
-: 2717: end subroutine wrap_json_value_add_integer_vec
4: 2718:!*****************************************************************************************
-: 2719:
-: 2720:!*****************************************************************************************
-: 2721:!> author: Jacob Williams
-: 2722:! date: 1/20/2014
-: 2723:!
-: 2724:! Add a logical value child to the [[json_value]] variable
-: 2725:!
-: 2726:!@note This routine is part of the public API that can be
-: 2727:! used to build a JSON structure using [[json_value]] pointers.
-: 2728:
-: 2729: subroutine json_value_add_logical(me, name, val)
5: 2730:
-: 2731: implicit none
-: 2732:
-: 2733: type(json_value),pointer :: me
-: 2734: character(kind=CK,len=*),intent(in) :: name !! name of the variable
-: 2735: logical(LK),intent(in) :: val !! value
-: 2736:
-: 2737: type(json_value),pointer :: var
-: 2738:
-: 2739: !create the variable:
-: 2740: call json_value_create(var)
5: 2741: call to_logical(var,val,name)
5: 2742:
-: 2743: !add it:
-: 2744: call json_add(me, var)
5: 2745:
-: 2746: !cleanup:
-: 2747: nullify(var)
5: 2748:
-: 2749: end subroutine json_value_add_logical
10: 2750:!*****************************************************************************************
-: 2751:
-: 2752:!*****************************************************************************************
-: 2753:!>
-: 2754:! Alternate version of [[json_value_add_logical]] where "name" is kind=CDK.
-: 2755:
-: 2756: subroutine wrap_json_value_add_logical(me, name, val)
4: 2757:
-: 2758: implicit none
-: 2759:
-: 2760: type(json_value),pointer :: me
-: 2761: character(kind=CDK,len=*),intent(in) :: name !! name of the variable
-: 2762: logical(LK),intent(in) :: val !! value
-: 2763:
-: 2764: call json_value_add_logical(me, to_unicode(name), val)
4: 2765:
-: 2766: end subroutine wrap_json_value_add_logical
8: 2767:!*****************************************************************************************
-: 2768:
-: 2769:!*****************************************************************************************
-: 2770:!> author: Jacob Williams
-: 2771:! date: 1/20/2014
-: 2772:!
-: 2773:! Add a logical vector to the structure.
-: 2774:!
-: 2775:!@note This routine is part of the public API that can be
-: 2776:! used to build a JSON structure using [[json_value]] pointers.
-: 2777:
-: 2778: subroutine json_value_add_logical_vec(me, name, val)
2: 2779:
-: 2780: implicit none
-: 2781:
-: 2782: type(json_value),pointer :: me
-: 2783: character(kind=CK,len=*),intent(in) :: name !! name of the vector
-: 2784: logical(LK),dimension(:),intent(in) :: val !! value
-: 2785:
-: 2786: type(json_value),pointer :: var
-: 2787: integer(IK) :: i !counter
-: 2788:
-: 2789: !create the variable as an array:
-: 2790: call json_value_create(var)
1: 2791: call to_array(var,name)
1: 2792:
-: 2793: !populate the array:
-: 2794: do i=1,size(val)
4: 2795: call json_add(var, '', val(i))
3: 2796: end do
-: 2797:
-: 2798: !add it:
-: 2799: call json_add(me, var)
1: 2800:
-: 2801: !cleanup:
-: 2802: nullify(var)
1: 2803:
-: 2804: end subroutine json_value_add_logical_vec
2: 2805:!*****************************************************************************************
-: 2806:
-: 2807:!*****************************************************************************************
-: 2808:!>
-: 2809:! Alternate version of [[json_value_add_logical_vec]] where "name" is kind=CDK.
-: 2810:
-: 2811: subroutine wrap_json_value_add_logical_vec(me, name, val)
2: 2812:
-: 2813: implicit none
-: 2814:
-: 2815: type(json_value),pointer :: me
-: 2816: character(kind=CDK,len=*),intent(in) :: name !! name of the variable
-: 2817: logical(LK),dimension(:),intent(in) :: val !! value
-: 2818:
-: 2819: call json_value_add_logical_vec(me, to_unicode(name), val)
1: 2820:
-: 2821: end subroutine wrap_json_value_add_logical_vec
2: 2822:!*****************************************************************************************
-: 2823:
-: 2824:!*****************************************************************************************
-: 2825:!> author: Jacob Williams
-: 2826:! date: 1/19/2014
-: 2827:!
-: 2828:! Add a character string child to the [[json_value]] variable.
-: 2829:!
-: 2830:!@note This routine is part of the public API that can be
-: 2831:! used to build a JSON structure using [[json_value]] pointers.
-: 2832:
-: 2833: subroutine json_value_add_string(me, name, val)
36: 2834:
-: 2835: implicit none
-: 2836:
-: 2837: type(json_value),pointer :: me
-: 2838: character(kind=CK,len=*),intent(in) :: name !! name of the variable
-: 2839: character(kind=CK,len=*),intent(in) :: val !! value
-: 2840:
-: 2841: type(json_value),pointer :: var
-: 2842: character(kind=CK,len=:),allocatable :: str
36: 2843:
-: 2844: !add escape characters if necessary:
-: 2845: call escape_string(val, str)
36: 2846:
-: 2847: !create the variable:
-: 2848: call json_value_create(var)
36: 2849: call to_string(var,str,name)
36: 2850:
-: 2851: !add it:
-: 2852: call json_add(me, var)
36: 2853:
-: 2854: !cleanup:
-: 2855: nullify(var)
36: 2856:
-: 2857: end subroutine json_value_add_string
72: 2858:!*****************************************************************************************
-: 2859:
-: 2860:!*****************************************************************************************
-: 2861:!>
-: 2862:! Alternate version of [[json_value_add_string]] where "name" and "val" are kind=CDK.
-: 2863:
-: 2864: subroutine wrap_json_value_add_string(me, name, val)
25: 2865:
-: 2866: implicit none
-: 2867:
-: 2868: type(json_value),pointer :: me
-: 2869: character(kind=CDK,len=*),intent(in) :: name !! name of the variable
-: 2870: character(kind=CDK,len=*),intent(in) :: val !! value
-: 2871:
-: 2872: call json_value_add_string(me, to_unicode(name), to_unicode(val))
25: 2873:
-: 2874: end subroutine wrap_json_value_add_string
50: 2875:!*****************************************************************************************
-: 2876:
-: 2877:!*****************************************************************************************
-: 2878:!>
-: 2879:! Alternate version of [[json_value_add_string]] where "name" is kind=CDK.
-: 2880:
-: 2881: subroutine json_value_add_string_name_ascii(me, name, val)
10: 2882:
-: 2883: implicit none
-: 2884:
-: 2885: type(json_value),pointer :: me
-: 2886: character(kind=CDK,len=*),intent(in) :: name !! name of the variable
-: 2887: character(kind=CK, len=*),intent(in) :: val !! value
-: 2888:
-: 2889: call json_value_add_string(me, to_unicode(name), val)
10: 2890:
-: 2891: end subroutine json_value_add_string_name_ascii
20: 2892:!*****************************************************************************************
-: 2893:
-: 2894:!*****************************************************************************************
-: 2895:!>
-: 2896:! Alternate version of [[json_value_add_string]] where "val" is kind=CDK.
-: 2897:
-: 2898: subroutine json_value_add_string_val_ascii(me, name, val)
#####: 2899:
-: 2900: implicit none
-: 2901:
-: 2902: type(json_value),pointer :: me
-: 2903: character(kind=CK, len=*),intent(in) :: name !! name of the variable
-: 2904: character(kind=CDK,len=*),intent(in) :: val !! value
-: 2905:
-: 2906: call json_value_add_string(me, name, to_unicode(val))
#####: 2907:
-: 2908: end subroutine json_value_add_string_val_ascii
#####: 2909:!*****************************************************************************************
-: 2910:
-: 2911:!*****************************************************************************************
-: 2912:!> author: Jacob Williams
-: 2913:! date: 1/21/2014
-: 2914:!
-: 2915:! Add the escape characters to a string for adding to JSON.
-: 2916:
-: 2917: subroutine escape_string(str_in, str_out)
72: 2918:
-: 2919: implicit none
-: 2920:
-: 2921: character(kind=CK,len=*),intent(in) :: str_in
-: 2922: character(kind=CK,len=:),allocatable,intent(out) :: str_out
-: 2923:
-: 2924: integer(IK) :: i,ipos
-: 2925: character(kind=CK,len=1) :: c
-: 2926:
-: 2927: character(kind=CK,len=*),parameter :: specials = quotation_mark//&
-: 2928: backslash//&
-: 2929: slash//&
-: 2930: bspace//&
-: 2931: formfeed//&
-: 2932: newline//&
-: 2933: carriage_return//&
-: 2934: horizontal_tab
-: 2935:
-: 2936: !Do a quick scan for the special characters,
-: 2937: ! if any are present, then process the string,
-: 2938: ! otherwise, return the string as is.
-: 2939: if (scan(str_in,specials)>0) then
36: 2940:
-: 2941: str_out = repeat(space,chunk_size)
4: 2942: ipos = 1
4: 2943:
-: 2944: !go through the string and look for special characters:
-: 2945: do i=1,len(str_in)
23: 2946:
-: 2947: c = str_in(i:i) !get next character in the input string
19: 2948:
-: 2949: !if the string is not big enough, then add another chunk:
-: 2950: if (ipos+3>len(str_out)) str_out = str_out // repeat(space, chunk_size)
19: 2951:
-: 2952: select case(c)
-: 2953: case(quotation_mark,backslash,slash)
-: 2954: str_out(ipos:ipos+1) = backslash//c
5: 2955: ipos = ipos + 2
5: 2956: case(bspace)
-: 2957: str_out(ipos:ipos+1) = '\b'
1: 2958: ipos = ipos + 2
1: 2959: case(formfeed)
-: 2960: str_out(ipos:ipos+1) = '\f'
1: 2961: ipos = ipos + 2
1: 2962: case(newline)
-: 2963: str_out(ipos:ipos+1) = '\n'
1: 2964: ipos = ipos + 2
1: 2965: case(carriage_return)
-: 2966: str_out(ipos:ipos+1) = '\r'
1: 2967: ipos = ipos + 2
1: 2968: case(horizontal_tab)
-: 2969: str_out(ipos:ipos+1) = '\t'
1: 2970: ipos = ipos + 2
1: 2971: case default
-: 2972: str_out(ipos:ipos) = c
9: 2973: ipos = ipos + 1
28: 2974: end select
-: 2975:
-: 2976: end do
-: 2977:
-: 2978: !trim the string if necessary:
-: 2979: if (ipos<len(str_out)+1) then
4: 2980: if (ipos==1) then
4: 2981: str_out = ''
#####: 2982: else
-: 2983: str_out = str_out(1:ipos-1)
4: 2984: end if
-: 2985: end if
-: 2986:
-: 2987: else
-: 2988:
-: 2989: str_out = str_in
32: 2990:
-: 2991: end if
-: 2992:
-: 2993: end subroutine escape_string
72: 2994:!*****************************************************************************************
-: 2995:
-: 2996:!*****************************************************************************************
-: 2997:!> author: Jacob Williams
-: 2998:! date: 1/19/2014
-: 2999:!
-: 3000:! Add an array of character strings to the structure.
-: 3001:!
-: 3002:!@note This routine is part of the public API that can be
-: 3003:! used to build a JSON structure using [[json_value]] pointers.
-: 3004:
-: 3005: subroutine json_value_add_string_vec(me, name, val, trim_str, adjustl_str)
6: 3006:
-: 3007: implicit none
-: 3008:
-: 3009: type(json_value),pointer :: me
-: 3010: character(kind=CK,len=*),intent(in) :: name !! variable name
-: 3011: character(kind=CK,len=*),dimension(:),intent(in) :: val !! array of strings
-: 3012: logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
-: 3013: logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-: 3014:
-: 3015: type(json_value),pointer :: var
-: 3016: integer(IK) :: i
-: 3017: logical(LK) :: trim_string, adjustl_string
-: 3018: character(kind=CK,len=:),allocatable :: str
3: 3019:
-: 3020: !if the string is to be trimmed or not:
-: 3021: if (present(trim_str)) then
3: 3022: trim_string = trim_str
1: 3023: else
-: 3024: trim_string = .false.
2: 3025: end if
-: 3026: if (present(adjustl_str)) then
3: 3027: adjustl_string = adjustl_str
1: 3028: else
-: 3029: adjustl_string = .false.
2: 3030: end if
-: 3031:
-: 3032: !create the variable as an array:
-: 3033: call json_value_create(var)
3: 3034: call to_array(var,name)
3: 3035:
-: 3036: !populate the array:
-: 3037: do i=1,size(val)
13: 3038:
-: 3039: !the string to write:
-: 3040: str = val(i)
10: 3041: if (adjustl_string) str = adjustl(str)
10: 3042: if (trim_string) str = trim(str)
10: 3043:
-: 3044: !write it:
-: 3045: call json_add(var, '', str)
10: 3046:
-: 3047: !cleanup
-: 3048: deallocate(str)
10: 3049:
-: 3050: end do
-: 3051:
-: 3052: !add it:
-: 3053: call json_add(me, var)
3: 3054:
-: 3055: !cleanup:
-: 3056: nullify(var)
3: 3057:
-: 3058: end subroutine json_value_add_string_vec
6: 3059:!*****************************************************************************************
-: 3060:
-: 3061:!*****************************************************************************************
-: 3062:!>
-: 3063:! Alternate version of [[json_value_add_string_vec]] where "name" and "val" are kind=CDK.
-: 3064:
-: 3065: subroutine wrap_json_value_add_string_vec(me, name, val, trim_str, adjustl_str)
6: 3066:
-: 3067: implicit none
-: 3068:
-: 3069: type(json_value),pointer :: me
-: 3070: character(kind=CDK,len=*),intent(in) :: name
-: 3071: character(kind=CDK,len=*),dimension(:),intent(in) :: val
-: 3072: logical(LK),intent(in),optional :: trim_str
-: 3073: logical(LK),intent(in),optional :: adjustl_str
-: 3074:
-: 3075: call json_value_add_string_vec(me, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
3: 3076:
-: 3077: end subroutine wrap_json_value_add_string_vec
6: 3078:!*****************************************************************************************
-: 3079:
-: 3080:!*****************************************************************************************
-: 3081:!>
-: 3082:! Alternate version of [[json_value_add_string_vec]] where "name" is kind=CDK.
-: 3083:
-: 3084: subroutine json_value_add_string_vec_name_ascii(me, name, val, trim_str, adjustl_str)
#####: 3085:
-: 3086: implicit none
-: 3087:
-: 3088: type(json_value),pointer :: me
-: 3089: character(kind=CDK,len=*),intent(in) :: name
-: 3090: character(kind=CK, len=*),dimension(:),intent(in) :: val
-: 3091: logical(LK),intent(in),optional :: trim_str
-: 3092: logical(LK),intent(in),optional :: adjustl_str
-: 3093:
-: 3094: call json_value_add_string_vec(me, to_unicode(name), val, trim_str, adjustl_str)
#####: 3095:
-: 3096: end subroutine json_value_add_string_vec_name_ascii
#####: 3097:!*****************************************************************************************
-: 3098:
-: 3099:!*****************************************************************************************
-: 3100:!>
-: 3101:! Alternate version of [[json_value_add_string_vec]] where "val" is kind=CDK.
-: 3102:
-: 3103: subroutine json_value_add_string_vec_val_ascii(me, name, val, trim_str, adjustl_str)
#####: 3104:
-: 3105: implicit none
-: 3106:
-: 3107: type(json_value),pointer :: me
-: 3108: character(kind=CK, len=*),intent(in) :: name
-: 3109: character(kind=CDK,len=*),dimension(:),intent(in) :: val
-: 3110: logical(LK),intent(in),optional :: trim_str
-: 3111: logical(LK),intent(in),optional :: adjustl_str
-: 3112:
-: 3113: call json_value_add_string_vec(me, name, to_unicode(val), trim_str, adjustl_str)
#####: 3114:
-: 3115: end subroutine json_value_add_string_vec_val_ascii
#####: 3116:!*****************************************************************************************
-: 3117:
-: 3118:!*****************************************************************************************
-: 3119:!>
-: 3120:! Count the number of children.
-: 3121:!
-: 3122:!# History
-: 3123:! * JW : 1/4/2014 : Original routine removed.
-: 3124:! Now using n_children variable.
-: 3125:! Renamed from json_value_count.
-: 3126:
-: 3127: pure function json_count(me) result(count)
208: 3128:
-: 3129: implicit none
-: 3130:
-: 3131: integer(IK) :: count !! number of children
-: 3132: type(json_value),pointer,intent(in) :: me
-: 3133:
-: 3134: count = me%n_children
208: 3135:
-: 3136: end function json_count
208: 3137:!*****************************************************************************************
-: 3138:
-: 3139:!*****************************************************************************************
-: 3140:!>
-: 3141:! Returns a child in the object or array given the index.
-: 3142:
-: 3143: subroutine json_value_get_by_index(me, idx, p)
29: 3144:
-: 3145: implicit none
-: 3146:
-: 3147: type(json_value),pointer,intent(in) :: me !! object or array JSON data
-: 3148: integer(IK),intent(in) :: idx !! index of the child
-: 3149: type(json_value),pointer :: p !! pointer to the child
-: 3150:
-: 3151: integer(IK) :: i
-: 3152:
-: 3153: nullify(p)
29: 3154:
-: 3155: if (.not. exception_thrown) then
29: 3156:
-: 3157: if (associated(me%children)) then
29: 3158:
-: 3159: p => me%children
29: 3160:
-: 3161: do i = 1, idx - 1
63: 3162:
-: 3163: if (associated(p%next)) then
35: 3164: p => p%next
34: 3165: else
-: 3166: call throw_exception('Error in json_value_get_by_index:'//&
-: 3167: ' p%next is not associated.')
1: 3168: nullify(p)
1: 3169: return
1: 3170: end if
-: 3171:
-: 3172: end do
-: 3173:
-: 3174: else
-: 3175:
-: 3176: call throw_exception('Error in json_value_get_by_index:'//&
-: 3177: ' me%children is not associated.')
#####: 3178:
-: 3179: end if
-: 3180:
-: 3181: end if
-: 3182:
-: 3183: end subroutine json_value_get_by_index
-: 3184:!*****************************************************************************************
-: 3185:
-: 3186:!*****************************************************************************************
-: 3187:!>
-: 3188:! Returns a child in the object or array given the name string.
-: 3189:!
-: 3190:! It is a case-sensitive search, and the name string is not trimmed.
-: 3191:! So, for example,
-: 3192:!```fortran
-: 3193:! 'a ' /= 'A ' /= 'a '
-: 3194:!```
-: 3195:!
-: 3196:!@note The "name" input is not a path, and is not parsed like it is in [[json_get_by_path]].
-: 3197:
-: 3198: subroutine json_value_get_by_name_chars(me, name, p)
95: 3199:
-: 3200: implicit none
-: 3201:
-: 3202: type(json_value),pointer,intent(in) :: me
-: 3203: character(kind=CK,len=*),intent(in) :: name !! the name of a child of "me"
-: 3204: type(json_value),pointer :: p !! pointer to the child
-: 3205:
-: 3206: integer(IK) :: i,n_children
-: 3207:
-: 3208: nullify(p)
95: 3209:
-: 3210: if (.not. exception_thrown) then
95: 3211:
-: 3212: if (associated(me)) then
95: 3213:
-: 3214: if (me%var_type==json_object) then
95: 3215: n_children = json_count(me)
95: 3216: p => me%children !start with first one
95: 3217: do i=1, n_children
380: 3218: if (allocated(p%name)) then
376: 3219: if (p%name == name) return
376: 3220: end if
-: 3221: p => p%next
285: 3222: end do
-: 3223: end if
-: 3224:
-: 3225: !did not find anything:
-: 3226: call throw_exception('Error in json_value_get_by_name_chars: '//&
-: 3227: 'child variable '//trim(name)//' was not found.')
4: 3228: nullify(p)
4: 3229:
-: 3230: else
-: 3231: call throw_exception('Error in json_value_get_by_name_chars: '//&
-: 3232: 'pointer is not associated.')
#####: 3233: end if
-: 3234:
-: 3235: end if
-: 3236:
-: 3237: end subroutine json_value_get_by_name_chars
95: 3238:!*****************************************************************************************
-: 3239:
-: 3240:!*****************************************************************************************
-: 3241:!>
-: 3242:! Alternate version of [[json_value_get_by_name_chars]] where "name" is kind=CDK.
-: 3243:
-: 3244: subroutine wrap_json_value_get_by_name_chars(me, name, p)
1: 3245:
-: 3246: implicit none
-: 3247:
-: 3248: type(json_value),pointer,intent(in) :: me
-: 3249: character(kind=CDK,len=*),intent(in) :: name
-: 3250: type(json_value),pointer :: p
-: 3251:
-: 3252: call json_value_get_by_name_chars(me,to_unicode(name),p)
1: 3253:
-: 3254: end subroutine wrap_json_value_get_by_name_chars
2: 3255:!*****************************************************************************************
-: 3256:
-: 3257:!*****************************************************************************************
-: 3258:!> author: Jacob Williams
-: 3259:! date: 2/12/2014
-: 3260:!
-: 3261:! Print the [[json_value]] structure to an allocatable string.
-: 3262:
-: 3263: subroutine json_value_to_string(me,str)
4: 3264:
-: 3265: implicit none
-: 3266:
-: 3267: type(json_value),pointer,intent(in) :: me
-: 3268: character(kind=CK,len=:),intent(out),allocatable :: str !! prints structure to this string
-: 3269:
-: 3270: str = ''
4: 3271: call json_value_print(me, iunit=unit2str, str=str, indent=1, colon=.true.)
4: 3272:
-: 3273: end subroutine json_value_to_string
4: 3274:!*****************************************************************************************
-: 3275:
-: 3276:!*****************************************************************************************
-: 3277:!> author: Jacob Williams
-: 3278:! date: 6/20/2014
-: 3279:!
-: 3280:! Print the [[json_value]] structure to a file.
-: 3281:
-: 3282: subroutine json_print_1(me,iunit)
7: 3283:
-: 3284: implicit none
-: 3285:
-: 3286: type(json_value),pointer,intent(in) :: me
-: 3287: integer(IK),intent(in) :: iunit !! the file unit (the file must already have been opened, can't be -1).
-: 3288:
-: 3289: character(kind=CK,len=:),allocatable :: dummy
7: 3290:
-: 3291: if (iunit/=unit2str) then
7: 3292: call json_value_print(me,iunit,str=dummy, indent=1, colon=.true.)
7: 3293: else
-: 3294: call throw_exception('Error in json_print: iunit must not be -1.')
#####: 3295: end if
-: 3296:
-: 3297: end subroutine json_print_1
7: 3298:!*****************************************************************************************
-: 3299:
-: 3300:!*****************************************************************************************
-: 3301:!> author: Jacob Williams
-: 3302:! date: 12/23/2014
-: 3303:!
-: 3304:! Print the [[json_value]] structure to a file.
-: 3305:
-: 3306: subroutine json_print_2(me,filename)
1: 3307:
-: 3308: implicit none
-: 3309:
-: 3310: type(json_value),pointer,intent(in) :: me
-: 3311: character(kind=CDK,len=*),intent(in) :: filename !! the filename to print to (should not already be open)
-: 3312:
-: 3313: integer(IK) :: iunit,istat
-: 3314:
-: 3315: open(newunit=iunit,file=filename,status='REPLACE',iostat=istat FILE_ENCODING )
1: 3316: if (istat==0) then
1: 3317: call json_print(me,iunit)
1: 3318: close(iunit,iostat=istat)
1: 3319: else
-: 3320: call throw_exception('Error in json_print: could not open file: '//&
-: 3321: trim(filename))
#####: 3322: end if
-: 3323:
-: 3324: end subroutine json_print_2
2: 3325:!*****************************************************************************************
-: 3326:
-: 3327:!*****************************************************************************************
-: 3328:!>
-: 3329:! Print the JSON structure to a string or a file.
-: 3330:!
-: 3331:!# Notes
-: 3332:! * This is an internal routine called by the wrapper routines
-: 3333:! [[json_print]] and [[json_value_to_string]].
-: 3334:! * The reason the str argument is non-optional is because of a
-: 3335:! bug in v4.9 of the gfortran compiler.
-: 3336:
-: 3337: recursive subroutine json_value_print(me,iunit,str,indent,need_comma,colon,is_array_element)
604: 3338:
-: 3339: implicit none
-: 3340:
-: 3341: type(json_value),pointer,intent(in) :: me
-: 3342: integer(IK),intent(in) :: iunit !! file unit to write to (6=console)
-: 3343: integer(IK),intent(in),optional :: indent !! indention level
-: 3344: logical(LK),intent(in),optional :: is_array_element !! if this is an array element
-: 3345: logical(LK),intent(in),optional :: need_comma !! if it needs a comma after it
-: 3346: logical(LK),intent(in),optional :: colon !! if the colon was just written
-: 3347: character(kind=CK,len=:),intent(inout),allocatable :: str
-: 3348: !! if iunit==unit2str (-1) then the structure is
-: 3349: !! printed to this string rather than
-: 3350: !! a file. This mode is used by
-: 3351: !! [[json_value_to_string]].
-: 3352:
-: 3353: character(kind=CK,len=max_numeric_str_len) :: tmp !for val to string conversions
-: 3354: character(kind=CK,len=:),allocatable :: s
604: 3355: type(json_value),pointer :: element
-: 3356: integer(IK) :: tab, i, count, spaces
-: 3357: logical(LK) :: print_comma
-: 3358: logical(LK) :: write_file, write_string
-: 3359: logical(LK) :: is_array
-: 3360:
-: 3361: if (.not. exception_thrown) then
1208: 3362:
-: 3363: !whether to write a string or a file (one or the other):
-: 3364: write_string = (iunit==unit2str)
604: 3365: write_file = .not. write_string
604: 3366:
-: 3367: !if the comma will be printed after the value
-: 3368: ! [comma not printed for the last elements]
-: 3369: if (present(need_comma)) then
604: 3370: print_comma = need_comma
585: 3371: else
-: 3372: print_comma = .false.
19: 3373: end if
-: 3374:
-: 3375: !number of "tabs" to indent:
-: 3376: if (present(indent)) then
604: 3377: tab = indent
604: 3378: else
-: 3379: tab = 0
#####: 3380: end if
-: 3381: !convert to number of spaces:
-: 3382: spaces = tab*spaces_per_tab
604: 3383:
-: 3384: !if this is an element in an array:
-: 3385: if (present(is_array_element)) then
604: 3386: is_array = is_array_element
94: 3387: else
-: 3388: is_array = .false.
510: 3389: end if
-: 3390:
-: 3391: !if the colon was the last thing written
-: 3392: if (present(colon)) then
604: 3393: s = ''
510: 3394: else
-: 3395: s = repeat(space, spaces)
94: 3396: end if
-: 3397:
-: 3398: select case (me%var_type)
604: 3399:
-: 3400: case (json_object)
-: 3401:
-: 3402: count = json_count(me)
67: 3403:
-: 3404: if (count==0) then !special case for empty object
134: 3405:
-: 3406: call write_it( s//start_object//end_object, comma=print_comma )
4: 3407:
-: 3408: else
-: 3409:
-: 3410: call write_it( s//start_object )
63: 3411:
-: 3412: !if an object is in an array, there is an extra tab:
-: 3413: if (is_array) then
63: 3414: tab = tab+1
23: 3415: spaces = tab*spaces_per_tab
23: 3416: end if
-: 3417:
-: 3418: nullify(element)
63: 3419: element => me%children
63: 3420: do i = 1, count
554: 3421:
-: 3422: ! print the name
-: 3423: if (allocated(element%name)) then
491: 3424: call write_it(repeat(space, spaces)//quotation_mark//&
982: 3425: element%name//quotation_mark//colon_char//space,&
-: 3426: advance=.false.)
1473: 3427: else
-: 3428: call throw_exception('Error in json_value_print:'//&
-: 3429: ' element%name not allocated')
#####: 3430: nullify(element)
#####: 3431: return
#####: 3432: end if
-: 3433:
-: 3434: ! recursive print of the element
-: 3435: call json_value_print(element, iunit=iunit, indent=tab + 1, &
-: 3436: need_comma=i<count, colon=.true., str=str)
491: 3437:
-: 3438: ! get the next child the list:
-: 3439: element => element%next
491: 3440:
-: 3441: end do
-: 3442:
-: 3443: ! [one fewer tab if it isn't an array element]
-: 3444: if (.not. is_array) s = repeat(space, max(0,spaces-spaces_per_tab))
63: 3445: call write_it( s//end_object, comma=print_comma )
63: 3446: nullify(element)
63: 3447:
-: 3448: end if
-: 3449:
-: 3450: case (json_array)
-: 3451:
-: 3452: count = json_count(me)
36: 3453:
-: 3454: if (count==0) then !special case for empty array
72: 3455:
-: 3456: call write_it( s//start_array//end_array, comma=print_comma )
4: 3457:
-: 3458: else
-: 3459:
-: 3460: call write_it( start_array )
32: 3461:
-: 3462: nullify(element)
32: 3463: element => me%children
32: 3464: do i = 1, count
126: 3465:
-: 3466: ! recursive print of the element
-: 3467: call json_value_print(element, iunit=iunit, indent=tab,&
-: 3468: need_comma=i<count, is_array_element=.true., str=str)
94: 3469:
-: 3470: ! get the next child the list:
-: 3471: element => element%next
94: 3472:
-: 3473: end do
-: 3474:
-: 3475: !indent the closing array character:
-: 3476: call write_it( repeat(space, max(0,spaces-spaces_per_tab))//end_array,&
64: 3477: comma=print_comma )
96: 3478: nullify(element)
32: 3479:
-: 3480: end if
-: 3481:
-: 3482: case (json_null)
-: 3483:
-: 3484: call write_it( s//null_str, comma=print_comma )
4: 3485:
-: 3486: case (json_string)
-: 3487:
-: 3488: if (allocated(me%str_value)) then
376: 3489: call write_it( s//quotation_mark// &
-: 3490: trim(me%str_value)//quotation_mark, comma=print_comma )
188: 3491: else
-: 3492: call throw_exception('Error in json_value_print:'//&
-: 3493: ' me%value_string not allocated')
#####: 3494: return
#####: 3495: end if
-: 3496:
-: 3497: case (json_logical)
-: 3498:
-: 3499: if (me%log_value) then
20: 3500: call write_it( s//true_str, comma=print_comma )
6: 3501: else
-: 3502: call write_it( s//false_str, comma=print_comma )
4: 3503: end if
-: 3504:
-: 3505: case (json_integer)
-: 3506:
-: 3507: call integer_to_string(me%int_value,tmp)
261: 3508:
-: 3509: call write_it( s//trim(tmp), comma=print_comma )
261: 3510:
-: 3511: case (json_double)
-: 3512:
-: 3513: call real_to_string(me%dbl_value,tmp)
38: 3514:
-: 3515: call write_it( s//trim(tmp), comma=print_comma )
38: 3516:
-: 3517: case default
-: 3518:
-: 3519: call throw_exception('Error in json_value_print: unknown data type')
604: 3520:
-: 3521: end select
-: 3522:
-: 3523: !cleanup:
-: 3524: if (allocated(s)) deallocate(s)
604: 3525:
-: 3526: end if
-: 3527:
-: 3528: contains
-: 3529:
-: 3530: !
-: 3531: ! write the string to the file (or the output string)
-: 3532: !
-: 3533: subroutine write_it(s,advance,comma)
1190: 3534:
-: 3535: implicit none
-: 3536:
-: 3537: character(kind=CK,len=*),intent(in) :: s !string to print
-: 3538: logical(LK),intent(in),optional :: advance !to add line break or not
-: 3539: logical(LK),intent(in),optional :: comma !print comma after the string
-: 3540:
-: 3541: logical(LK) :: add_line_break, add_comma
-: 3542: character(kind=CK,len=:),allocatable :: s2
1190: 3543:
-: 3544: if (present(comma)) then
1190: 3545: add_comma = comma
604: 3546: else
-: 3547: add_comma = .false. !default is not to add comma
586: 3548: end if
-: 3549:
-: 3550: if (present(advance)) then
1190: 3551: add_line_break = advance
491: 3552: else
-: 3553: add_line_break = .true. !default is to advance
699: 3554: end if
-: 3555:
-: 3556: !string to print:
-: 3557: s2 = s
1190: 3558: if (add_comma) s2 = s2 // delimiter
1190: 3559:
-: 3560: if (write_file) then
1190: 3561:
-: 3562: if (add_line_break) then
895: 3563: write(iunit,fmt='(A)') s2
546: 3564: else
-: 3565: write(iunit,fmt='(A)',advance='NO') s2
349: 3566: end if
-: 3567:
-: 3568: else !write string
-: 3569:
-: 3570: str = str // s2
295: 3571: if (add_line_break) str = str // newline
295: 3572:
-: 3573: end if
-: 3574:
-: 3575: !cleanup:
-: 3576: if (allocated(s2)) deallocate(s2)
1190: 3577:
-: 3578: end subroutine write_it
2380: 3579:
-: 3580: end subroutine json_value_print
-: 3581:!*****************************************************************************************
-: 3582:
-: 3583:!*****************************************************************************************
-: 3584:!>
-: 3585:! Returns the [[json_value]] pointer given the path string.
-: 3586:!
-: 3587:!# Example
-: 3588:!
-: 3589:!```fortran
-: 3590:! type(json_value),pointer :: dat,p
-: 3591:! logical :: found
-: 3592:! !...
-: 3593:! call json_get(dat,'data(2).version',p,found)
-: 3594:!```
-: 3595:!
-: 3596:!# Notes
-: 3597:! The following special characters are used to denote paths:
-: 3598:!
-: 3599:!```
-: 3600:! $ - root
-: 3601:! @ - this
-: 3602:! . - child object member
-: 3603:! [] or () - child array element
-: 3604:!```
-: 3605:!
-: 3606:! Thus, if any of these characters are present in the name key,
-: 3607:! this routine cannot be used to get the value.
-: 3608:! In that case, the [[json_get_child]] routines would need to be used.
-: 3609:
-: 3610: subroutine json_get_by_path(me, path, p, found)
57: 3611:
-: 3612: implicit none
-: 3613:
-: 3614: type(json_value),pointer,intent(in) :: me
-: 3615: character(kind=CK,len=*),intent(in) :: path
-: 3616: type(json_value),pointer,intent(out) :: p
-: 3617: logical(LK),intent(out),optional :: found !! true if it was found
-: 3618:
-: 3619: character(kind=CK,len=1),parameter :: start_array_alt = '('
-: 3620: character(kind=CK,len=1),parameter :: end_array_alt = ')'
-: 3621:
-: 3622: integer(IK) :: i,length,child_i
-: 3623: character(kind=CK,len=1) :: c
-: 3624: logical(LK) :: array
-: 3625: type(json_value),pointer :: tmp
-: 3626:
-: 3627: if (.not. exception_thrown) then
57: 3628:
-: 3629: nullify(p)
57: 3630:
-: 3631: ! default to assuming relative to this
-: 3632: p => me
57: 3633:
-: 3634: child_i = 1
57: 3635:
-: 3636: array = .false.
57: 3637:
-: 3638: length = len_trim(path)
57: 3639:
-: 3640: do i=1, length
813: 3641:
-: 3642: c = path(i:i)
756: 3643:
-: 3644: select case (c)
-: 3645: case (CK_'$')
-: 3646:
-: 3647: ! root
-: 3648: do while (associated (p%parent))
1: 3649: p => p%parent
#####: 3650: end do
-: 3651: child_i = i + 1
1: 3652:
-: 3653: case (CK_'@')
-: 3654:
-: 3655: ! this
-: 3656: p => me
#####: 3657: child_i = i + 1
#####: 3658:
-: 3659: case (CK_'.')
-: 3660:
-: 3661: ! get child member from p
-: 3662: if (child_i < i) then
38: 3663: nullify(tmp)
18: 3664: call json_get_child(p, path(child_i:i-1), tmp)
18: 3665: p => tmp
18: 3666: nullify(tmp)
18: 3667: else
-: 3668: child_i = i + 1
20: 3669: cycle
20: 3670: end if
-: 3671:
-: 3672: if (.not. associated(p)) then
18: 3673: call throw_exception('Error in json_get_by_path:'//&
-: 3674: ' Error getting child member.')
#####: 3675: exit
#####: 3676: end if
-: 3677:
-: 3678: child_i = i+1
18: 3679:
-: 3680: case (start_array,start_array_alt)
-: 3681:
-: 3682: !....Modified to allow for 'var[3]' style syntax
-: 3683: !Note: jmozmoz/fson has a slightly different version of this...
-: 3684:
-: 3685: ! start looking for the array element index
-: 3686: array = .true.
29: 3687:
-: 3688: ! get child member from p
-: 3689: if (child_i < i) then
29: 3690: nullify(tmp)
29: 3691: call json_get_child(p, path(child_i:i-1), tmp)
29: 3692: p => tmp
29: 3693: nullify(tmp)
29: 3694: else
-: 3695: child_i = i + 1
#####: 3696: cycle
#####: 3697: end if
-: 3698: if (.not. associated(p)) then
29: 3699: call throw_exception('Error in json_get_by_path:'//&
-: 3700: ' Error getting array element')
#####: 3701: exit
#####: 3702: end if
-: 3703: child_i = i + 1
29: 3704:
-: 3705: case (end_array,end_array_alt)
-: 3706:
-: 3707: if (.not.array) then
29: 3708: call throw_exception('Error in json_get_by_path: Unexpected ]')
#####: 3709: exit
#####: 3710: end if
-: 3711: array = .false.
29: 3712: child_i = string_to_integer(path(child_i:i-1))
29: 3713:
-: 3714: nullify(tmp)
29: 3715: call json_get_child(p, child_i, tmp)
29: 3716: p => tmp
29: 3717: nullify(tmp)
29: 3718:
-: 3719: child_i= i + 1
785: 3720:
-: 3721: end select
-: 3722:
-: 3723: end do
-: 3724:
-: 3725: if (exception_thrown) then
57: 3726:
-: 3727: if (present(found)) then
1: 3728: found = .false.
#####: 3729: call json_clear_exceptions()
#####: 3730: end if
-: 3731:
-: 3732: else
-: 3733:
-: 3734: ! grab the last child if present in the path
-: 3735: if (child_i <= length) then
56: 3736: nullify(tmp)
47: 3737: call json_get_child(p, path(child_i:i-1), tmp)
47: 3738: p => tmp
47: 3739: nullify(tmp)
47: 3740: end if
-: 3741: if (associated(p)) then
56: 3742: if (present(found)) found = .true. !everything seems to be ok
52: 3743: else
-: 3744: call throw_exception('Error in json_get_by_path:'//&
-: 3745: ' variable not found: '//trim(path))
4: 3746: if (present(found)) then
4: 3747: found = .false.
3: 3748: call json_clear_exceptions()
3: 3749: end if
-: 3750: end if
-: 3751:
-: 3752: end if
-: 3753:
-: 3754: else
-: 3755: if (present(found)) found = .false.
#####: 3756: end if
-: 3757:
-: 3758: end subroutine json_get_by_path
114: 3759:!*****************************************************************************************
-: 3760:
-: 3761:!*****************************************************************************************
-: 3762:!>
-: 3763:! Alternate version of [[json_get_by_path]] where "path" is kind=CDK.
-: 3764:
-: 3765: subroutine wrap_json_get_by_path(me, path, p, found)
1: 3766:
-: 3767: implicit none
-: 3768:
-: 3769: type(json_value),pointer,intent(in) :: me
-: 3770: character(kind=CDK,len=*),intent(in) :: path
-: 3771: type(json_value),pointer,intent(out) :: p
-: 3772: logical(LK),intent(out),optional :: found
-: 3773:
-: 3774: call json_get_by_path(me, to_unicode(path), p, found)
1: 3775:
-: 3776: end subroutine wrap_json_get_by_path
2: 3777:!*****************************************************************************************
-: 3778:
-: 3779:!*****************************************************************************************
-: 3780:!>
-: 3781:! Convert a string into an integer.
-: 3782:!
-: 3783:!# History
-: 3784:! * Jacob Williams : 12/10/2013 : Rewrote routine. Added error checking.
-: 3785:! * Modified by Izaak Beekman
-: 3786:!
-: 3787:!@note Replacement for the parse_integer function in the original code.
-: 3788:
-: 3789: function string_to_integer(str) result(ival)
49916: 3790:
-: 3791: implicit none
-: 3792:
-: 3793: character(kind=CK,len=*),intent(in) :: str
-: 3794: integer(IK) :: ival
-: 3795:
-: 3796: character(kind=CDK,len=:),allocatable :: digits
49916: 3797: integer(IK) :: ndigits_digits,ndigits,ierr
-: 3798:
-: 3799: if (.not. exception_thrown) then
49916: 3800:
-: 3801: ! Compute how many digits we need to read
-: 3802: ndigits = 2*len_trim(str)
49916: 3803: ndigits_digits = floor(log10(real(ndigits)))+1
49916: 3804: allocate(character(kind=CDK,len=ndigits_digits) :: digits)
49916: 3805: write(digits,'(I0)') ndigits !gfortran will have a runtime error with * edit descriptor here
49916: 3806: ! gfortran bug: '*' edit descriptor for ISO_10646 strings does bad stuff.
-: 3807: read(str,'(I'//trim(digits)//')',iostat=ierr) ival !string to integer
49916: 3808:
-: 3809: if (ierr/=0) then !if there was an error
49916: 3810: ival = 0
#####: 3811: call throw_exception('Error in string_to_integer:'//&
-: 3812: ' string cannot be converted to an integer: '//trim(str))
#####: 3813: end if
-: 3814:
-: 3815: else
-: 3816: ival = 0
#####: 3817: end if
-: 3818:
-: 3819: end function string_to_integer
99832: 3820:!*****************************************************************************************
-: 3821:
-: 3822:!*****************************************************************************************
-: 3823:!> author: Jacob Williams
-: 3824:! date: 1/19/2014
-: 3825:!
-: 3826:! Convert a string into a double.
-: 3827:
-: 3828: function string_to_double(str) result(rval)
19933: 3829:
-: 3830: implicit none
-: 3831:
-: 3832: real(RK) :: rval
-: 3833: character(kind=CK,len=*),intent(in) :: str
-: 3834:
-: 3835: integer(IK) :: ierr
-: 3836:
-: 3837: if (.not. exception_thrown) then
19933: 3838:
-: 3839: read(str,fmt=real_fmt,iostat=ierr) rval !string to double
19933: 3840:
-: 3841: if (ierr/=0) then !if there was an error
19933: 3842: rval = 0.0_RK
#####: 3843: call throw_exception('Error in string_to_double:'//&
-: 3844: ' string cannot be converted to a double: '//trim(str))
#####: 3845: end if
-: 3846:
-: 3847: end if
-: 3848:
-: 3849: end function string_to_double
39866: 3850:!*****************************************************************************************
-: 3851:
-: 3852:!*****************************************************************************************
-: 3853:!>
-: 3854:! Get an integer value from a [[json_value]].
-: 3855:
-: 3856: subroutine json_get_integer(me, value)
5: 3857:
-: 3858: implicit none
-: 3859:
-: 3860: type(json_value),pointer,intent(in) :: me
-: 3861: integer(IK),intent(out) :: value
-: 3862:
-: 3863: value = 0
5: 3864: if ( exception_thrown ) return
5: 3865:
-: 3866: select case(me%var_type)
5: 3867: case (json_integer)
-: 3868: value = me%int_value
5: 3869: case (json_double)
-: 3870: value = int(me%dbl_value)
#####: 3871: case (json_logical)
-: 3872: if (me%log_value) then
#####: 3873: value = 1
#####: 3874: else
-: 3875: value = 0
#####: 3876: end if
-: 3877: case default
-: 3878: call throw_exception('Error in get_integer:'//&
-: 3879: ' Unable to resolve value to integer: '//me%name)
5: 3880: end select
-: 3881:
-: 3882: end subroutine json_get_integer
-: 3883:!*****************************************************************************************
-: 3884:
-: 3885:!*****************************************************************************************
-: 3886:!>
-: 3887:! Get an integer value from a [[json_value]], given the path string.
-: 3888:
-: 3889: subroutine json_get_integer_with_path(me, path, value, found)
4: 3890:
-: 3891: implicit none
-: 3892:
-: 3893: type(json_value),pointer,intent(in) :: me
-: 3894: character(kind=CK,len=*),intent(in) :: path
-: 3895: integer(IK),intent(out) :: value
-: 3896: logical(LK),intent(out),optional :: found
-: 3897:
-: 3898: type(json_value),pointer :: p
-: 3899:
-: 3900: value = 0
4: 3901: if ( exception_thrown ) then
4: 3902: if ( present(found) ) found = .false.
#####: 3903: return
#####: 3904: end if
-: 3905:
-: 3906: nullify(p)
4: 3907:
-: 3908: call json_get_by_path(me=me, path=path, p=p)
4: 3909:
-: 3910: if (.not. associated(p)) then
4: 3911: call throw_exception('Error in json_get_integer:'//&
-: 3912: ' Unable to resolve path: '// trim(path))
1: 3913: else
-: 3914: call json_get_integer(p,value)
3: 3915: nullify(p)
3: 3916: end if
-: 3917: if ( exception_thrown ) then
4: 3918: if ( present(found) ) then
1: 3919: found = .false.
1: 3920: call json_clear_exceptions()
1: 3921: end if
-: 3922: else
-: 3923: if ( present(found) ) found = .true.
3: 3924: end if
-: 3925:
-: 3926: end subroutine json_get_integer_with_path
4: 3927:!*****************************************************************************************
-: 3928:
-: 3929:!*****************************************************************************************
-: 3930:!>
-: 3931:! Alternate version of [[json_get_integer_with_path]], where "path" is kind=CDK.
-: 3932:
-: 3933: subroutine wrap_json_get_integer_with_path(me, path, value, found)
#####: 3934:
-: 3935: implicit none
-: 3936:
-: 3937: type(json_value),pointer,intent(in) :: me
-: 3938: character(kind=CDK,len=*),intent(in) :: path
-: 3939: integer(IK),intent(out) :: value
-: 3940: logical(LK),intent(out),optional :: found
-: 3941:
-: 3942: call json_get_integer_with_path(me, to_unicode(path), value, found)
#####: 3943:
-: 3944: end subroutine wrap_json_get_integer_with_path
#####: 3945:!*****************************************************************************************
-: 3946:
-: 3947:!*****************************************************************************************
-: 3948:!> author: Jacob Williams
-: 3949:! date: 5/14/2014
-: 3950:!
-: 3951:! Get an integer vector from a [[json_value]].
-: 3952:
-: 3953: subroutine json_get_integer_vec(me, vec)
#####: 3954:
-: 3955: implicit none
-: 3956:
-: 3957: type(json_value),pointer :: me
-: 3958: integer(IK),dimension(:),allocatable,intent(out) :: vec
-: 3959:
-: 3960: logical(LK) :: initialized
-: 3961:
-: 3962: initialized = .false.
#####: 3963:
-: 3964: if (allocated(vec)) deallocate(vec)
#####: 3965:
-: 3966: !the callback function is called for each element of the array:
-: 3967: call json_get(me, array_callback=get_int_from_array)
#####: 3968:
-: 3969: contains
-: 3970:
-: 3971: ! callback function for integer
-: 3972: subroutine get_int_from_array(element, i, count)
#####: 3973: implicit none
-: 3974:
-: 3975: type(json_value),pointer,intent(in) :: element
-: 3976: integer(IK),intent(in) :: i !index
-: 3977: integer(IK),intent(in) :: count !size of array
-: 3978:
-: 3979: !size the output array:
-: 3980: if (.not. initialized) then
#####: 3981: allocate(vec(count))
#####: 3982: initialized = .true.
#####: 3983: end if
-: 3984:
-: 3985: !populate the elements:
-: 3986: call json_get(element, value=vec(i))
#####: 3987:
-: 3988: end subroutine get_int_from_array
#####: 3989:
-: 3990: end subroutine json_get_integer_vec
-: 3991:!*****************************************************************************************
-: 3992:
-: 3993:!*****************************************************************************************
-: 3994:!>
-: 3995:! Get an integer vector from a [[json_value]], given the path string.
-: 3996:
-: 3997: subroutine json_get_integer_vec_with_path(me, path, vec, found)
1: 3998:
-: 3999: implicit none
-: 4000:
-: 4001: type(json_value),pointer :: me
-: 4002: character(kind=CK,len=*),intent(in) :: path
-: 4003: integer(IK),dimension(:),allocatable,intent(out) :: vec
-: 4004: logical(LK),intent(out),optional :: found
-: 4005:
-: 4006: logical(LK) :: initialized
-: 4007:
-: 4008: initialized = .false.
1: 4009:
-: 4010: call json_get(me, path=path, array_callback=get_int_from_array, found=found)
2: 4011:
-: 4012: ! need to duplicate callback function, no other way
-: 4013: contains
-: 4014:
-: 4015: ! callback function for integer
-: 4016: subroutine get_int_from_array(element, i, count)
2: 4017: implicit none
-: 4018:
-: 4019: type(json_value),pointer,intent(in) :: element
-: 4020: integer(IK),intent(in) :: i !index
-: 4021: integer(IK),intent(in) :: count !size of array
-: 4022:
-: 4023: !size the output array:
-: 4024: if (.not. initialized) then
2: 4025: allocate(vec(count))
1: 4026: initialized = .true.
1: 4027: end if
-: 4028:
-: 4029: !populate the elements:
-: 4030: call json_get(element, value=vec(i))
2: 4031:
-: 4032: end subroutine get_int_from_array
2: 4033:
-: 4034: end subroutine json_get_integer_vec_with_path
-: 4035:!*****************************************************************************************
-: 4036:
-: 4037:!*****************************************************************************************
-: 4038:!>
-: 4039:! Alternate version of [[json_get_integer_vec_with_path]], where "path" is kind=CDK
-: 4040:
-: 4041: subroutine wrap_json_get_integer_vec_with_path(me, path, vec, found)
#####: 4042:
-: 4043: implicit none
-: 4044:
-: 4045: type(json_value),pointer :: me
-: 4046: character(kind=CDK,len=*),intent(in) :: path
-: 4047: integer(IK),dimension(:),allocatable,intent(out) :: vec
-: 4048: logical(LK),intent(out),optional :: found
-: 4049:
-: 4050: call json_get_integer_vec_with_path(me,path=to_unicode(path),vec=vec,found=found)
#####: 4051:
-: 4052: end subroutine wrap_json_get_integer_vec_with_path
#####: 4053:!*****************************************************************************************
-: 4054:
-: 4055:!*****************************************************************************************
-: 4056:!>
-: 4057:! Get a double value from a [[json_value]].
-: 4058:
-: 4059: subroutine json_get_double(me, value)
15: 4060:
-: 4061: implicit none
-: 4062:
-: 4063: type(json_value),pointer :: me
-: 4064: real(RK),intent(out) :: value
-: 4065:
-: 4066: value = 0.0_RK
15: 4067: if ( exception_thrown ) return
15: 4068:
-: 4069: select case (me%var_type)
15: 4070: case (json_integer)
-: 4071: value = me%int_value
#####: 4072: case (json_double)
-: 4073: value = me%dbl_value
15: 4074: case (json_logical)
-: 4075: if (me%log_value) then
#####: 4076: value = 1.0_RK
#####: 4077: else
-: 4078: value = 0.0_RK
#####: 4079: end if
-: 4080: case default
-: 4081:
-: 4082: call throw_exception('Error in json_get_double:'//&
-: 4083: ' Unable to resolve value to double: '//me%name)
15: 4084:
-: 4085: end select
-: 4086:
-: 4087: end subroutine json_get_double
-: 4088:!*****************************************************************************************
-: 4089:
-: 4090:!*****************************************************************************************
-: 4091:!>
-: 4092:! Get a double value from a [[json_value]], given the path.
-: 4093:
-: 4094: subroutine json_get_double_with_path(me, path, value, found)
3: 4095:
-: 4096: implicit none
-: 4097:
-: 4098: type(json_value),pointer :: me
-: 4099: character(kind=CK,len=*),intent(in) :: path
-: 4100: real(RK),intent(out) :: value
-: 4101: logical(LK),intent(out),optional :: found
-: 4102:
-: 4103: type(json_value),pointer :: p
-: 4104:
-: 4105: value = 0.0_RK
3: 4106: if ( exception_thrown ) then
3: 4107: if ( present(found) ) found = .false.
#####: 4108: return
#####: 4109: end if
-: 4110:
-: 4111: nullify(p)
3: 4112:
-: 4113: call json_get_by_path(me=me, path=path, p=p)
3: 4114:
-: 4115: if (.not. associated(p)) then
3: 4116:
-: 4117: call throw_exception('Error in json_get_double:'//&
-: 4118: ' Unable to resolve path: '//trim(path))
#####: 4119:
-: 4120: else
-: 4121:
-: 4122: call json_get_double(p,value)
3: 4123: nullify(p)
3: 4124:
-: 4125: end if
-: 4126:
-: 4127: if (exception_thrown) then
3: 4128: if (present(found)) then
#####: 4129: found = .false.
#####: 4130: call json_clear_exceptions()
#####: 4131: end if
-: 4132: else
-: 4133: if (present(found)) found = .true.
3: 4134: end if
-: 4135:
-: 4136: end subroutine json_get_double_with_path
3: 4137:!*****************************************************************************************
-: 4138:
-: 4139:!*****************************************************************************************
-: 4140:!>
-: 4141:! Alternate version of [[json_get_double_with_path]], where "path" is kind=CDK
-: 4142:
-: 4143: subroutine wrap_json_get_double_with_path(me, path, value, found)
#####: 4144:
-: 4145: implicit none
-: 4146:
-: 4147: type(json_value),pointer :: me
-: 4148: character(kind=CDK,len=*),intent(in) :: path
-: 4149: real(RK),intent(out) :: value
-: 4150: logical(LK),intent(out),optional :: found
-: 4151:
-: 4152: call json_get_double_with_path(me,to_unicode(path),value,found)
#####: 4153:
-: 4154: end subroutine wrap_json_get_double_with_path
#####: 4155:!*****************************************************************************************
-: 4156:
-: 4157:!*****************************************************************************************
-: 4158:!> author: Jacob Williams
-: 4159:! date: 5/14/2014
-: 4160:!
-: 4161:! Get a double vector from a [[json_value]].
-: 4162:
-: 4163: subroutine json_get_double_vec(me, vec)
#####: 4164:
-: 4165: implicit none
-: 4166:
-: 4167: type(json_value),pointer :: me
-: 4168: real(RK),dimension(:),allocatable,intent(out) :: vec
-: 4169:
-: 4170: logical(LK) :: initialized
-: 4171:
-: 4172: initialized = .false.
#####: 4173:
-: 4174: if (allocated(vec)) deallocate(vec)
#####: 4175:
-: 4176: !the callback function is called for each element of the array:
-: 4177: call json_get(me, array_callback=get_double_from_array)
#####: 4178:
-: 4179: contains
-: 4180:
-: 4181: ! callback function for double
-: 4182: subroutine get_double_from_array(element, i, count)
#####: 4183: implicit none
-: 4184:
-: 4185: type(json_value),pointer,intent(in) :: element
-: 4186: integer(IK),intent(in) :: i !index
-: 4187: integer(IK),intent(in) :: count !size of array
-: 4188:
-: 4189: !size the output array:
-: 4190: if (.not. initialized) then
#####: 4191: allocate(vec(count))
#####: 4192: initialized = .true.
#####: 4193: end if
-: 4194:
-: 4195: !populate the elements:
-: 4196: call json_get(element, value=vec(i))
#####: 4197:
-: 4198: end subroutine get_double_from_array
#####: 4199:
-: 4200: end subroutine json_get_double_vec
-: 4201:!*****************************************************************************************
-: 4202:
-: 4203:!*****************************************************************************************
-: 4204:!>
-: 4205:! Get a double vector from a [[json_value]], given the path.
-: 4206:
-: 4207: subroutine json_get_double_vec_with_path(me, path, vec, found)
4: 4208:
-: 4209: implicit none
-: 4210:
-: 4211: type(json_value),pointer :: me
-: 4212: character(kind=CK,len=*),intent(in) :: path
-: 4213: real(RK),dimension(:),allocatable,intent(out) :: vec
-: 4214: logical(LK),intent(out),optional :: found
-: 4215:
-: 4216: logical(LK) :: initialized
-: 4217:
-: 4218: initialized = .false.
4: 4219:
-: 4220: if (allocated(vec)) deallocate(vec)
4: 4221:
-: 4222: !the callback function is called for each element of the array:
-: 4223: call json_get(me, path=path, array_callback=get_double_from_array, found=found)
8: 4224:
-: 4225: contains
-: 4226:
-: 4227: ! callback function for double
-: 4228: subroutine get_double_from_array(element, i, count)
12: 4229: implicit none
-: 4230:
-: 4231: type(json_value),pointer,intent(in) :: element
-: 4232: integer(IK),intent(in) :: i !index
-: 4233: integer(IK),intent(in) :: count !size of array
-: 4234:
-: 4235: !size the output array:
-: 4236: if (.not. initialized) then
12: 4237: allocate(vec(count))
4: 4238: initialized = .true.
4: 4239: end if
-: 4240:
-: 4241: !populate the elements:
-: 4242: call json_get(element, value=vec(i))
12: 4243:
-: 4244: end subroutine get_double_from_array
12: 4245:
-: 4246: end subroutine json_get_double_vec_with_path
-: 4247:!*****************************************************************************************
-: 4248:
-: 4249:!*****************************************************************************************
-: 4250:!>
-: 4251:! Alternate version of [[json_get_double_vec_with_path]], where "path" is kind=CDK
-: 4252:
-: 4253: subroutine wrap_json_get_double_vec_with_path(me, path, vec, found)
#####: 4254:
-: 4255: implicit none
-: 4256:
-: 4257: type(json_value),pointer :: me
-: 4258: character(kind=CDK,len=*),intent(in) :: path
-: 4259: real(RK),dimension(:),allocatable,intent(out) :: vec
-: 4260: logical(LK),intent(out),optional :: found
-: 4261:
-: 4262: call json_get_double_vec_with_path(me, to_unicode(path), vec, found)
#####: 4263:
-: 4264: end subroutine wrap_json_get_double_vec_with_path
#####: 4265:!*****************************************************************************************
-: 4266:
-: 4267:!*****************************************************************************************
-: 4268:!>
-: 4269:! Get a logical value from a [[json_value]].
-: 4270:
-: 4271: subroutine json_get_logical(me, value)
2: 4272:
-: 4273: implicit none
-: 4274:
-: 4275: type(json_value),pointer,intent(in) :: me
-: 4276: logical(LK) :: value
-: 4277:
-: 4278: value = .false.
2: 4279: if ( exception_thrown ) return
2: 4280:
-: 4281: select case (me%var_type)
2: 4282: case (json_integer)
-: 4283: value = (me%int_value > 0)
#####: 4284: case (json_logical)
-: 4285: value = me % log_value
2: 4286: case default
-: 4287: call throw_exception('Error in json_get_logical:'//&
-: 4288: ' Unable to resolve value to logical: '//me%name)
2: 4289: end select
-: 4290:
-: 4291: end subroutine json_get_logical
-: 4292:!*****************************************************************************************
-: 4293:
-: 4294:!*****************************************************************************************
-: 4295:!>
-: 4296:! Get a logical value from a [[json_value]], given the path.
-: 4297:
-: 4298: subroutine json_get_logical_with_path(me, path, value, found)
2: 4299:
-: 4300: implicit none
-: 4301:
-: 4302: type(json_value),pointer,intent(in) :: me
-: 4303: character(kind=CK,len=*),intent(in) :: path
-: 4304: logical(LK) :: value
-: 4305: logical(LK),intent(out),optional :: found
-: 4306:
-: 4307: type(json_value),pointer :: p
-: 4308:
-: 4309: value = .false.
2: 4310: if ( exception_thrown) then
2: 4311: if ( present(found) ) found = .false.
#####: 4312: return
#####: 4313: end if
-: 4314:
-: 4315: nullify(p)
2: 4316:
-: 4317: call json_get_by_path(me=me, path=path, p=p)
2: 4318:
-: 4319: if (.not. associated(p)) then
2: 4320:
-: 4321: call throw_exception('Error in json_get_logical:'//&
-: 4322: ' Unable to resolve path: '//trim(path))
#####: 4323:
-: 4324: else
-: 4325:
-: 4326: call json_get_logical(p,value)
2: 4327: nullify(p)
2: 4328:
-: 4329: end if
-: 4330:
-: 4331: if (exception_thrown) then
2: 4332: if (present(found)) then
#####: 4333: found = .false.
#####: 4334: call json_clear_exceptions()
#####: 4335: end if
-: 4336: else
-: 4337: if (present(found)) found = .true.
2: 4338: end if
-: 4339:
-: 4340: end subroutine json_get_logical_with_path
2: 4341:!*****************************************************************************************
-: 4342:
-: 4343:!*****************************************************************************************
-: 4344:!>
-: 4345:! Alternate version of [[json_get_logical_with_path]], where "path" is kind=CDK
-: 4346:
-: 4347: subroutine wrap_json_get_logical_with_path(me, path, value, found)
1: 4348:
-: 4349: implicit none
-: 4350:
-: 4351: type(json_value),pointer,intent(in) :: me
-: 4352: character(kind=CDK,len=*),intent(in) :: path
-: 4353: logical(LK) :: value
-: 4354: logical(LK),intent(out),optional :: found
-: 4355:
-: 4356: call json_get_logical_with_path(me,to_unicode(path),value,found)
1: 4357:
-: 4358: end subroutine wrap_json_get_logical_with_path
2: 4359:!*****************************************************************************************
-: 4360:
-: 4361:!*****************************************************************************************
-: 4362:!> author: Jacob Williams
-: 4363:! date: 5/14/2014
-: 4364:!
-: 4365:! Get a logical vector from [[json_value]].
-: 4366:
-: 4367: subroutine json_get_logical_vec(me, vec)
#####: 4368:
-: 4369: implicit none
-: 4370:
-: 4371: type(json_value),pointer,intent(in) :: me
-: 4372: logical(LK),dimension(:),allocatable,intent(out) :: vec
-: 4373:
-: 4374: logical(LK) :: initialized
-: 4375:
-: 4376: initialized = .false.
#####: 4377:
-: 4378: if (allocated(vec)) deallocate(vec)
#####: 4379:
-: 4380: !the callback function is called for each element of the array:
-: 4381: call json_get(me, array_callback=get_logical_from_array)
#####: 4382:
-: 4383: contains
-: 4384:
-: 4385: ! callback function for logical
-: 4386: subroutine get_logical_from_array(element, i, count)
#####: 4387: implicit none
-: 4388:
-: 4389: type(json_value),pointer,intent(in) :: element
-: 4390: integer(IK),intent(in) :: i !index
-: 4391: integer(IK),intent(in) :: count !size of array
-: 4392:
-: 4393: !size the output array:
-: 4394: if (.not. initialized) then
#####: 4395: allocate(vec(count))
#####: 4396: initialized = .true.
#####: 4397: end if
-: 4398:
-: 4399: !populate the elements:
-: 4400: call json_get(element, value=vec(i))
#####: 4401:
-: 4402: end subroutine get_logical_from_array
#####: 4403:
-: 4404: end subroutine json_get_logical_vec
-: 4405:!*****************************************************************************************
-: 4406:
-: 4407:!*****************************************************************************************
-: 4408:!>
-: 4409:! Get a logical vector from a [[json_value]], given the path.
-: 4410:
-: 4411: subroutine json_get_logical_vec_with_path(me, path, vec, found)
#####: 4412:
-: 4413: implicit none
-: 4414:
-: 4415: type(json_value),pointer,intent(in) :: me
-: 4416: character(kind=CK,len=*),intent(in) :: path
-: 4417: logical(LK),dimension(:),allocatable,intent(out) :: vec
-: 4418: logical(LK),intent(out),optional :: found
-: 4419:
-: 4420: logical(LK) :: initialized
-: 4421:
-: 4422: initialized = .false.
#####: 4423:
-: 4424: if (allocated(vec)) deallocate(vec)
#####: 4425:
-: 4426: !the callback function is called for each element of the array:
-: 4427: call json_get(me, path=path, array_callback=get_logical_from_array, found=found)
#####: 4428:
-: 4429: contains
-: 4430:
-: 4431: ! callback function for logical
-: 4432: subroutine get_logical_from_array(element, i, count)
#####: 4433: implicit none
-: 4434:
-: 4435: type(json_value),pointer,intent(in) :: element
-: 4436: integer(IK),intent(in) :: i !index
-: 4437: integer(IK),intent(in) :: count !size of array
-: 4438:
-: 4439: !size the output array:
-: 4440: if (.not. initialized) then
#####: 4441: allocate(vec(count))
#####: 4442: initialized = .true.
#####: 4443: end if
-: 4444:
-: 4445: !populate the elements:
-: 4446: call json_get(element, value=vec(i))
#####: 4447:
-: 4448: end subroutine get_logical_from_array
#####: 4449:
-: 4450: end subroutine json_get_logical_vec_with_path
-: 4451:!*****************************************************************************************
-: 4452:
-: 4453:!*****************************************************************************************
-: 4454:!>
-: 4455:! Alternate version of [[json_get_logical_vec_with_path]], where "path" is kind=CDK
-: 4456:
-: 4457: subroutine wrap_json_get_logical_vec_with_path(me, path, vec, found)
#####: 4458:
-: 4459: implicit none
-: 4460:
-: 4461: type(json_value),pointer,intent(in) :: me
-: 4462: character(kind=CDK,len=*),intent(in) :: path
-: 4463: logical(LK),dimension(:),allocatable,intent(out) :: vec
-: 4464: logical(LK),intent(out),optional :: found
-: 4465:
-: 4466: call json_get_logical_vec_with_path(me,to_unicode(path),vec,found)
#####: 4467:
-: 4468: end subroutine wrap_json_get_logical_vec_with_path
#####: 4469:!*****************************************************************************************
-: 4470:
-: 4471:!*****************************************************************************************
-: 4472:!>
-: 4473:! Get a character string from a [[json_value]].
-: 4474:
-: 4475: subroutine json_get_string(me, value)
36: 4476:
-: 4477: implicit none
-: 4478:
-: 4479: type(json_value),pointer,intent(in) :: me
-: 4480: character(kind=CK,len=:),allocatable,intent(out) :: value
-: 4481:
-: 4482: character(kind=CK ,len=:),allocatable :: s,pre,post
36: 4483: integer(IK) :: j,jprev,n
-: 4484: character(kind=CK,len=1) :: c
-: 4485:
-: 4486: value = ''
36: 4487: if ( exception_thrown) return
36: 4488:
-: 4489: select case (me%var_type)
36: 4490:
-: 4491: case (json_string)
-: 4492:
-: 4493: if (allocated(me%str_value)) then
72: 4494:
-: 4495: !get the value as is:
-: 4496: s = me%str_value
36: 4497:
-: 4498: ! Now, have to remove the escape characters:
-: 4499: !
-: 4500: ! '\"' quotation mark
-: 4501: ! '\\' reverse solidus
-: 4502: ! '\/' solidus
-: 4503: ! '\b' backspace
-: 4504: ! '\f' formfeed
-: 4505: ! '\n' newline (LF)
-: 4506: ! '\r' carriage return (CR)
-: 4507: ! '\t' horizontal tab
-: 4508: ! '\uXXXX' 4 hexadecimal digits
-: 4509: !
-: 4510:
-: 4511: !initialize:
-: 4512: n = len(s)
36: 4513: j = 1
36: 4514:
-: 4515: do
88: 4516:
-: 4517: jprev = j !initialize
124: 4518: j = index(s(j:n),backslash) !look for an escape character
124: 4519:
-: 4520: if (j>0) then !an escape character was found
124: 4521:
-: 4522: !index in full string of the escape character:
-: 4523: j = j + (jprev-1)
94: 4524:
-: 4525: if (j<n) then
94: 4526:
-: 4527: !save the bit before the escape character:
-: 4528: if (j>1) then
94: 4529: pre = s( 1 : j-1 )
88: 4530: else
-: 4531: pre = ''
6: 4532: end if
-: 4533:
-: 4534: !character after the escape character:
-: 4535: c = s( j+1 : j+1 )
94: 4536:
-: 4537: if (any(c == [quotation_mark,backslash,slash, &
94: 4538: to_unicode(['b','f','n','r','t'])])) then
-: 4539:
-: 4540: !save the bit after the escape characters:
-: 4541: if (j+2<n) then
43: 4542: post = s(j+2:n)
42: 4543: else
-: 4544: post = ''
1: 4545: end if
-: 4546:
-: 4547: select case(c)
38: 4548: case (quotation_mark,backslash,slash)
-: 4549: !use c as is
-: 4550: case (CK_'b')
-: 4551: c = bspace
1: 4552: case (CK_'f')
-: 4553: c = formfeed
1: 4554: case (CK_'n')
-: 4555: c = newline
1: 4556: case (CK_'r')
-: 4557: c = carriage_return
1: 4558: case (CK_'t')
-: 4559: c = horizontal_tab
44: 4560: end select
-: 4561:
-: 4562: s = pre//c//post
43: 4563:
-: 4564: n = n-1 !backslash character has been
43: 4565: ! removed from the string
-: 4566:
-: 4567: else if (c == 'u') then !expecting 4 hexadecimal digits after
51: 4568: !the escape character [\uXXXX]
-: 4569:
-: 4570: !for now, we are just printing them as is
-: 4571: ![not checking to see if it is a valid hex value]
-: 4572:
-: 4573: if (j+5<=n) then
51: 4574: j=j+4
51: 4575: else
-: 4576: call throw_exception('Error in json_get_string:'//&
-: 4577: ' Invalid hexadecimal sequence'//&
-: 4578: ' in string: '//trim(c))
#####: 4579: exit
#####: 4580: end if
-: 4581:
-: 4582: else
-: 4583: !unknown escape character
-: 4584: call throw_exception('Error in json_get_string:'//&
-: 4585: ' unknown escape sequence in string "'//&
-: 4586: trim(s)//'" ['//backslash//c//']')
#####: 4587: exit
#####: 4588: end if
-: 4589:
-: 4590: j=j+1 !go to the next character
94: 4591:
-: 4592: if (j>=n) exit !finished
94: 4593:
-: 4594: else
-: 4595: !an escape character is the last character in
-: 4596: ! the string [this may not be valid syntax,
-: 4597: ! but just keep it]
-: 4598: exit
#####: 4599: end if
-: 4600:
-: 4601: else
-: 4602: exit !no more escape characters in the string
30: 4603: end if
-: 4604:
-: 4605: end do
-: 4606:
-: 4607: if (exception_thrown) then
36: 4608: if (allocated(value)) deallocate(value)
#####: 4609: else
-: 4610: value = s
36: 4611: end if
-: 4612:
-: 4613: else
-: 4614: call throw_exception('Error in json_get_string:'//&
-: 4615: ' me%value not allocated')
#####: 4616: end if
-: 4617:
-: 4618: case default
-: 4619: call throw_exception('Error in json_get_string:'//&
-: 4620: ' Unable to resolve value to characters: '//me%name)
36: 4621:
-: 4622: ! Note: for the other cases, we could do val to string conversions.
-: 4623:
-: 4624: end select
-: 4625:
-: 4626: !cleanup:
-: 4627: if (allocated(s)) deallocate(s)
36: 4628: if (allocated(pre)) deallocate(pre)
36: 4629: if (allocated(post)) deallocate(post)
36: 4630:
-: 4631: end subroutine json_get_string
36: 4632:!*****************************************************************************************
-: 4633:
-: 4634:!*****************************************************************************************
-: 4635:!>
-: 4636:! Get a character string from a [[json_value]], given the path.
-: 4637:
-: 4638: subroutine json_get_string_with_path(me, path, value, found)
46: 4639:
-: 4640: implicit none
-: 4641:
-: 4642: type(json_value),pointer,intent(in) :: me
-: 4643: character(kind=CK,len=*),intent(in) :: path
-: 4644: character(kind=CK,len=:),allocatable,intent(out) :: value
-: 4645: logical(LK),intent(out),optional :: found
-: 4646:
-: 4647: type(json_value),pointer :: p
-: 4648:
-: 4649: value = ''
23: 4650: if ( exception_thrown ) then
23: 4651: if ( present(found) ) found = .false.
#####: 4652: return
#####: 4653: end if
-: 4654:
-: 4655: nullify(p)
23: 4656:
-: 4657: call json_get_by_path(me=me, path=path, p=p)
23: 4658:
-: 4659: if (.not. associated(p)) then
45: 4660: call throw_exception('Error in json_get_string:'//&
-: 4661: ' Unable to resolve path: '//trim(path))
1: 4662:
-: 4663: else
-: 4664:
-: 4665: call json_get_string(p,value)
22: 4666: nullify(p)
22: 4667:
-: 4668: end if
-: 4669:
-: 4670: if (allocated(value) .and. .not. exception_thrown) then
23: 4671: if (present(found)) found = .true.
22: 4672: else
-: 4673: if (present(found)) then
1: 4674: found = .false.
1: 4675: call json_clear_exceptions()
1: 4676: end if
-: 4677: end if
-: 4678:
-: 4679: !cleanup:
-: 4680: if (associated(p)) nullify(p)
23: 4681:
-: 4682: end subroutine json_get_string_with_path
46: 4683:!*****************************************************************************************
-: 4684:
-: 4685:!*****************************************************************************************
-: 4686:!>
-: 4687:! Alternate version of [[json_get_string_with_path]], where "path" is kind=CDK
-: 4688:
-: 4689: subroutine wrap_json_get_string_with_path(me, path, value, found)
#####: 4690:
-: 4691: implicit none
-: 4692:
-: 4693: type(json_value),pointer,intent(in) :: me
-: 4694: character(kind=CDK,len=*),intent(in) :: path
-: 4695: character(kind=CK,len=:),allocatable,intent(out) :: value
-: 4696: logical(LK),intent(out),optional :: found
-: 4697:
-: 4698: call json_get_string_with_path(me,to_unicode(path),value,found)
#####: 4699:
-: 4700: end subroutine wrap_json_get_string_with_path
#####: 4701:!*****************************************************************************************
-: 4702:
-: 4703:!*****************************************************************************************
-: 4704:!> author: Jacob Williams
-: 4705:! date: 5/14/2014
-: 4706:!
-: 4707:! Get a string vector from a [[json_file]].
-: 4708:
-: 4709: subroutine json_get_string_vec(me, vec)
1: 4710:
-: 4711: implicit none
-: 4712:
-: 4713: type(json_value),pointer,intent(in) :: me
-: 4714: character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
-: 4715:
-: 4716: logical(LK) :: initialized
-: 4717:
-: 4718: initialized = .false.
1: 4719:
-: 4720: if (allocated(vec)) deallocate(vec)
1: 4721:
-: 4722: !the callback function is called for each element of the array:
-: 4723: call json_get(me, array_callback=get_chars_from_array)
2: 4724:
-: 4725: contains
-: 4726:
-: 4727: ! callback function for chars
-: 4728: subroutine get_chars_from_array(element, i, count)
3: 4729:
-: 4730: implicit none
-: 4731:
-: 4732: type(json_value),pointer,intent(in) :: element
-: 4733: integer(IK),intent(in) :: i !index
-: 4734: integer(IK),intent(in) :: count !size of array
-: 4735:
-: 4736: character(kind=CK,len=:),allocatable :: cval
3: 4737:
-: 4738: !size the output array:
-: 4739: if (.not. initialized) then
3: 4740: allocate(vec(count))
1: 4741: initialized = .true.
1: 4742: end if
-: 4743:
-: 4744: !populate the elements:
-: 4745: call json_get(element, value=cval)
3: 4746: if (allocated(cval)) then
3: 4747: vec(i) = cval
3: 4748: deallocate(cval)
3: 4749: else
-: 4750: vec(i) = ''
#####: 4751: end if
-: 4752:
-: 4753: end subroutine get_chars_from_array
3: 4754:
-: 4755: end subroutine json_get_string_vec
-: 4756:!*****************************************************************************************
-: 4757:
-: 4758:!*****************************************************************************************
-: 4759:!>
-: 4760:! Get a string vector from a [[json_file]], given the path.
-: 4761:
-: 4762: subroutine json_get_string_vec_with_path(me, path, vec, found)
2: 4763:
-: 4764: implicit none
-: 4765:
-: 4766: type(json_value),pointer,intent(in) :: me
-: 4767: character(kind=CK,len=*),intent(in) :: path
-: 4768: character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
-: 4769: logical(LK),intent(out),optional :: found
-: 4770:
-: 4771: logical(LK) :: initialized
-: 4772:
-: 4773: initialized = .false.
2: 4774:
-: 4775: if (allocated(vec)) deallocate(vec)
2: 4776:
-: 4777: !the callback function is called for each element of the array:
-: 4778: call json_get(me, path=path, array_callback=get_chars_from_array, found=found)
4: 4779:
-: 4780: contains
-: 4781:
-: 4782: ! callback function for chars
-: 4783: subroutine get_chars_from_array(element, i, count)
10: 4784:
-: 4785: implicit none
-: 4786:
-: 4787: type(json_value),pointer,intent(in) :: element
-: 4788: integer(IK),intent(in) :: i !index
-: 4789: integer(IK),intent(in) :: count !size of array
-: 4790:
-: 4791: character(kind=CK,len=:),allocatable :: cval
10: 4792:
-: 4793: !size the output array:
-: 4794: if (.not. initialized) then
10: 4795: allocate(vec(count))
2: 4796: initialized = .true.
2: 4797: end if
-: 4798:
-: 4799: !populate the elements:
-: 4800: call json_get(element, value=cval)
10: 4801: if (allocated(cval)) then
10: 4802: vec(i) = cval
10: 4803: deallocate(cval)
10: 4804: else
-: 4805: vec(i) = ''
#####: 4806: end if
-: 4807:
-: 4808: end subroutine get_chars_from_array
10: 4809:
-: 4810: end subroutine json_get_string_vec_with_path
-: 4811:!*****************************************************************************************
-: 4812:
-: 4813:!*****************************************************************************************
-: 4814:!>
-: 4815:! Alternate version of [[json_get_string_vec_with_path]], where "path" is kind=CDK
-: 4816:
-: 4817: subroutine wrap_json_get_string_vec_with_path(me, path, vec, found)
1: 4818:
-: 4819: implicit none
-: 4820:
-: 4821: type(json_value),pointer,intent(in) :: me
-: 4822: character(kind=CDK,len=*),intent(in) :: path
-: 4823: character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
-: 4824: logical(LK),intent(out),optional :: found
-: 4825:
-: 4826: call json_get_string_vec_with_path(me,to_unicode(path),vec,found)
1: 4827:
-: 4828: end subroutine wrap_json_get_string_vec_with_path
2: 4829:!*****************************************************************************************
-: 4830:
-: 4831:!*****************************************************************************************
-: 4832:!>
-: 4833:! This routine calls the user-supplied [[array_callback_func]] subroutine
-: 4834:! for each element in the array.
-: 4835:!
-: 4836:!@note For integer, double, logical, and character arrays,
-: 4837:! higher-level routines are provided (see [[json_get]]), so
-: 4838:! this routine does not have to be used for those cases.
-: 4839:
-: 4840: subroutine json_get_array(me, array_callback)
8: 4841:
-: 4842: implicit none
-: 4843:
-: 4844: type(json_value),pointer,intent(in) :: me
-: 4845: procedure(array_callback_func) :: array_callback
-: 4846:
-: 4847: type(json_value),pointer :: element
-: 4848: integer(IK) :: i, count
-: 4849:
-: 4850: if ( exception_thrown ) return
8: 4851:
-: 4852: nullify(element)
8: 4853:
-: 4854: select case (me%var_type)
8: 4855: case (json_array)
-: 4856: count = json_count(me)
8: 4857: element => me%children
8: 4858: do i = 1, count ! callback for each child
35: 4859: call array_callback(element, i, count)
27: 4860: element => element%next
27: 4861: end do
-: 4862: case default
-: 4863:
-: 4864: call throw_exception('Error in json_get_array:'//&
-: 4865: ' Resolved value is not an array ')
8: 4866:
-: 4867: end select
-: 4868:
-: 4869: !cleanup:
-: 4870: if (associated(element)) nullify(element)
8: 4871:
-: 4872: end subroutine json_get_array
-: 4873:!*****************************************************************************************
-: 4874:
-: 4875:!*****************************************************************************************
-: 4876:!>
-: 4877:! This routine calls the user-supplied array_callback subroutine
-: 4878:! for each element in the array (specified by the path).
-: 4879:
-: 4880: subroutine json_get_array_with_path(me, path, array_callback, found)
7: 4881:
-: 4882: implicit none
-: 4883:
-: 4884: type(json_value),pointer,intent(in) :: me
-: 4885: character(kind=CK,len=*),intent(in) :: path
-: 4886: procedure(array_callback_func) :: array_callback
-: 4887: logical(LK),intent(out),optional :: found
-: 4888:
-: 4889: type(json_value),pointer :: p
-: 4890:
-: 4891: if ( exception_thrown ) then
7: 4892: if ( present(found) ) found = .false.
#####: 4893: return
#####: 4894: end if
-: 4895:
-: 4896: nullify(p)
7: 4897:
-: 4898: ! resolve the path to the value
-: 4899: call json_get_by_path(me=me, path=path, p=p)
7: 4900:
-: 4901: if (.not. associated(p)) then
7: 4902: call throw_exception('Error in json_get_array:'//&
-: 4903: ' Unable to resolve path: '//trim(path))
#####: 4904: else
-: 4905: call json_get_array(me=p,array_callback=array_callback)
7: 4906: nullify(p)
7: 4907: end if
-: 4908: if ( exception_thrown ) then
7: 4909: if ( present(found) ) then
#####: 4910: found = .false.
#####: 4911: call json_clear_exceptions()
#####: 4912: end if
-: 4913: else
-: 4914: if ( present(found) ) found = .true.
7: 4915: end if
-: 4916:
-: 4917: end subroutine json_get_array_with_path
7: 4918:!*****************************************************************************************
-: 4919:
-: 4920:!*****************************************************************************************
-: 4921:!>
-: 4922:! Alternate version of [[json_get_array_with_path]], where "path" is kind=CDK
-: 4923:
-: 4924: subroutine wrap_json_get_array_with_path(me, path, array_callback, found)
#####: 4925:
-: 4926: implicit none
-: 4927:
-: 4928: type(json_value),pointer,intent(in) :: me
-: 4929: character(kind=CDK,len=*),intent(in) :: path
-: 4930: procedure(array_callback_func) :: array_callback
-: 4931: logical(LK),intent(out),optional :: found
-: 4932:
-: 4933: call json_get_array_with_path(me, to_unicode(path), array_callback, found)
#####: 4934:
-: 4935: end subroutine wrap_json_get_array_with_path
#####: 4936:!*****************************************************************************************
-: 4937:
-: 4938:!*****************************************************************************************
-: 4939:!>
-: 4940:! Parse the JSON file and populate the [[json_value]] tree.
-: 4941:!
-: 4942:!# Inputs
-: 4943:!
-: 4944:! The inputs can be:
-: 4945:!
-: 4946:! * file and unit : the specified unit is used to read JSON from file.
-: 4947:! [note if unit is already open, then the filename is ignored]
-: 4948:! * file : JSON is read from file using internal unit number
-: 4949:!
-: 4950:!# Example
-: 4951:!
-: 4952:!```fortran
-: 4953:! type(json_value),pointer :: p
-: 4954:! call json_parse(file='myfile.json', p=p)
-: 4955:!```
-: 4956:!
-: 4957:!# History
-: 4958:! * Jacob Williams : 01/13/2015 : added read from string option.
-: 4959:! * Izaak Beekman : 03/08/2015 : moved read from string to separate
-: 4960:! subroutine, and error annotation
-: 4961:! to separate subroutine.
-: 4962:!
-: 4963:!@note When calling this routine, any exceptions thrown from previous
-: 4964:! calls will automatically be cleared.
-: 4965:
-: 4966: subroutine json_parse_file(file, p, unit)
10: 4967:
-: 4968: implicit none
-: 4969:
-: 4970: character(kind=CDK,len=*),intent(in) :: file !! JSON file name
-: 4971: type(json_value),pointer :: p !! output structure
-: 4972: integer(IK),intent(in),optional :: unit !! file unit number (/= 0)
-: 4973:
-: 4974: integer(IK) :: iunit, istat
-: 4975: logical(LK) :: is_open
-: 4976:
-: 4977: !clear any exceptions and initialize:
-: 4978: call json_initialize()
10: 4979:
-: 4980: if ( present(unit) ) then
10: 4981:
-: 4982: if (unit==0) then
#####: 4983: call throw_exception('Error in json_parse_file: unit number must not be 0.')
#####: 4984: return
#####: 4985: end if
-: 4986:
-: 4987: iunit = unit
#####: 4988:
-: 4989: !check to see if the file is already open
-: 4990: ! if it is, then use it, otherwise open the file with the name given.
-: 4991: inquire(unit=iunit, opened=is_open, iostat=istat)
#####: 4992: if (istat==0 .and. .not. is_open) then
#####: 4993: ! open the file
-: 4994: open ( unit = iunit, &
-: 4995: file = file, &
-: 4996: status = 'OLD', &
-: 4997: action = 'READ', &
-: 4998: form = form_spec, &
-: 4999: access = access_spec, &
-: 5000: iostat = istat &
-: 5001: FILE_ENCODING )
#####: 5002: else
-: 5003: !if the file is already open, then we need to make sure
-: 5004: ! that it is open with the correct form/access/etc...
-: 5005: end if
-: 5006:
-: 5007: else
-: 5008:
-: 5009: ! open the file with a new unit number:
-: 5010: open ( newunit = iunit, &
-: 5011: file = file, &
-: 5012: status = 'OLD', &
-: 5013: action = 'READ', &
-: 5014: form = form_spec, &
-: 5015: access = access_spec, &
-: 5016: iostat = istat &
-: 5017: FILE_ENCODING )
10: 5018:
-: 5019: end if
-: 5020:
-: 5021: if (istat==0) then
10: 5022:
-: 5023: ! create the value and associate the pointer
-: 5024: call json_value_create(p)
10: 5025:
-: 5026: ! Note: the name of the root json_value doesn't really matter,
-: 5027: ! but we'll allocate something here just in case.
-: 5028: p%name = trim(file) !use the file name
10: 5029:
-: 5030: ! parse as a value
-: 5031: call parse_value(unit=iunit, str=CK_'', value=p)
10: 5032: if (exception_thrown) call annotate_invalid_json(iunit,CK_'')
10: 5033:
-: 5034: ! close the file if necessary
-: 5035: close(unit=iunit, iostat=istat)
10: 5036:
-: 5037: else
-: 5038:
-: 5039: call throw_exception('Error in json_parse_file: Error opening file: '//trim(file))
#####: 5040: nullify(p)
#####: 5041:
-: 5042: end if
-: 5043:
-: 5044: end subroutine json_parse_file
10: 5045:!*****************************************************************************************
-: 5046:
-: 5047:!*****************************************************************************************
-: 5048:!>
-: 5049:! Parse the JSON string and populate the [[json_value]] tree.
-: 5050:!
-: 5051:!# See also
-: 5052:! * [[json_parse_file]]
-: 5053:
-: 5054: subroutine json_parse_string(p, str)
6: 5055:
-: 5056: implicit none
-: 5057:
-: 5058: type(json_value),pointer :: p !! output structure
-: 5059: character(kind=CK,len=*),intent(in) :: str !! string with JSON data
-: 5060:
-: 5061: integer(IK),parameter :: iunit = 0 !indicates that json data will be read from buffer
-: 5062:
-: 5063: if ( .not. exception_thrown ) then
6: 5064:
-: 5065: !clear any exceptions and initialize:
-: 5066: call json_initialize()
6: 5067:
-: 5068: ! create the value and associate the pointer
-: 5069: call json_value_create(p)
6: 5070:
-: 5071: ! Note: the name of the root json_value doesn't really matter,
-: 5072: ! but we'll allocate something here just in case.
-: 5073: p%name = ''
6: 5074:
-: 5075: ! parse as a value
-: 5076: call parse_value(unit=iunit, str=str, value=p)
6: 5077:
-: 5078: if (exception_thrown) call annotate_invalid_json(iunit,str)
6: 5079:
-: 5080: end if
-: 5081:
-: 5082: end subroutine json_parse_string
12: 5083:!*****************************************************************************************
-: 5084:
-: 5085:!*****************************************************************************************
-: 5086:!>
-: 5087:! Alternate version of [[json_parse_string]], where "str" is kind=CDK.
-: 5088:
-: 5089: subroutine wrap_json_parse_string(p, str)
3: 5090:
-: 5091: implicit none
-: 5092:
-: 5093: type(json_value),pointer :: p !! output structure
-: 5094: character(kind=CDK,len=*),intent(in) :: str !! string with JSON data
-: 5095:
-: 5096: call json_parse_string(p,to_unicode(str))
3: 5097:
-: 5098: end subroutine wrap_json_parse_string
6: 5099:!*****************************************************************************************
-: 5100:
-: 5101:!*****************************************************************************************
-: 5102:!>
-: 5103:! Generate a warning message if there was an error parsing a JSON
-: 5104:! file or string.
-: 5105:
-: 5106: subroutine annotate_invalid_json(iunit,str)
3: 5107:
-: 5108: implicit none
-: 5109:
-: 5110: integer(IK),intent(in) :: iunit !! file unit number
-: 5111: character(kind=CK,len=*),intent(in) :: str !! string with JSON data
-: 5112:
-: 5113: character(kind=CK,len=:),allocatable :: line, arrow_str
3: 5114: character(kind=CK,len=10) :: line_str, char_str
-: 5115: integer(IK) :: i, i_nl_prev, i_nl
-: 5116:
-: 5117: !
-: 5118: ! If there was an error reading the file, then
-: 5119: ! print the line where the error occurred:
-: 5120: !
-: 5121: if (exception_thrown) then
3: 5122:
-: 5123: !the counters for the current line and the last character read:
-: 5124: call integer_to_string(line_count, line_str)
3: 5125: call integer_to_string(char_count, char_str)
3: 5126:
-: 5127: !draw the arrow string that points to the current character:
-: 5128: arrow_str = repeat('-',max( 0, char_count - 1) )//'^'
3: 5129:
-: 5130: if (line_count>0 .and. char_count>0) then
3: 5131:
-: 5132: if (iunit/=0) then
3: 5133:
-: 5134: if (use_unformatted_stream) then
-: 5135: call get_current_line_from_file_stream(iunit,line)
-: 5136: else
-: 5137: call get_current_line_from_file_sequential(iunit,line)
1: 5138: end if
-: 5139:
-: 5140: else
-: 5141:
-: 5142: !get the current line from the string:
-: 5143: ! [this is done by counting the newline characters]
-: 5144: i_nl_prev = 0 !index of previous newline character
1: 5145: i_nl = 2 !just in case line_count = 0
1: 5146: do i=1,line_count
2: 5147: i_nl = index(str(i_nl_prev+1:),newline)
2: 5148: if (i_nl==0) then !last line - no newline character
2: 5149: i_nl = len(str)+1
1: 5150: exit
1: 5151: end if
-: 5152: i_nl = i_nl + i_nl_prev !index of current newline character
1: 5153: i_nl_prev = i_nl !update for next iteration
1: 5154: end do
-: 5155: line = str(i_nl_prev+1 : i_nl-1) !extract current line
1: 5156:
-: 5157: end if
-: 5158:
-: 5159: else
-: 5160: !in this case, it was an empty line or file
-: 5161: line = ''
1: 5162: end if
-: 5163:
-: 5164: !create the error message:
-: 5165: err_message = err_message//newline//&
-: 5166: 'line: '//trim(adjustl(line_str))//', '//&
-: 5167: 'character: '//trim(adjustl(char_str))//newline//&
-: 5168: trim(line)//newline//arrow_str
3: 5169:
-: 5170: if (allocated(line)) deallocate(line)
3: 5171:
-: 5172: end if
-: 5173:
-: 5174: end subroutine annotate_invalid_json
6: 5175:!*****************************************************************************************
-: 5176:
-: 5177:!*****************************************************************************************
-: 5178:!> author: Jacob Williams
-: 5179:!
-: 5180:! Rewind the file to the beginning of the current line, and return this line.
-: 5181:! The file is assumed to be opened.
-: 5182:! This is the SEQUENTIAL version (see also [[get_current_line_from_file_stream]]).
-: 5183:
-: 5184: subroutine get_current_line_from_file_sequential(iunit,line)
1: 5185:
-: 5186: implicit none
-: 5187:
-: 5188: integer(IK),intent(in) :: iunit !! file unit number
-: 5189: character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
-: 5190:
-: 5191: integer(IK),parameter :: n_chunk = 256 ! chunk size [arbitrary]
-: 5192: character(kind=CDK,len=*),parameter :: nfmt = '(A256)' ! corresponding format statement
-: 5193:
-: 5194: character(kind=CK,len=n_chunk) :: chunk
-: 5195: integer(IK) :: istat,isize
-: 5196:
-: 5197: !initialize:
-: 5198: line = ''
1: 5199:
-: 5200: !rewind to beginning of the current record:
-: 5201: backspace(iunit, iostat=istat)
1: 5202:
-: 5203: !loop to read in all the characters in the current record.
-: 5204: ![the line is read in chunks until the end of the line is reached]
-: 5205: if (istat==0) then
1: 5206: do
#####: 5207: isize=0
1: 5208: read(iunit,fmt=nfmt,advance='NO',size=isize,iostat=istat) chunk
1: 5209: if (istat==0) then
1: 5210: line = line//chunk
#####: 5211: else
-: 5212: if (isize>0 .and. isize<=n_chunk) line = line//chunk(1:isize)
1: 5213: exit
1: 5214: end if
-: 5215: end do
-: 5216: end if
-: 5217:
-: 5218: end subroutine get_current_line_from_file_sequential
1: 5219:!*****************************************************************************************
-: 5220:
-: 5221:!*****************************************************************************************
-: 5222:!> author: Jacob Williams
-: 5223:!
-: 5224:! Rewind the file to the beginning of the current line, and return this line.
-: 5225:! The file is assumed to be opened.
-: 5226:! This is the STREAM version (see also [[get_current_line_from_file_sequential]]).
-: 5227:
-: 5228: subroutine get_current_line_from_file_stream(iunit,line)
#####: 5229:
-: 5230: implicit none
-: 5231:
-: 5232: integer(IK),intent(in) :: iunit !! file unit number
-: 5233: character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
-: 5234:
-: 5235: integer(IK) :: istart,iend,ios
-: 5236: character(kind=CK,len=1) :: c
-: 5237:
-: 5238: !updated for the new STREAM version:
-: 5239:
-: 5240: istart = ipos
#####: 5241: do
#####: 5242: if (istart<=1) then
#####: 5243: istart = 1
#####: 5244: exit
#####: 5245: end if
-: 5246: read(iunit,pos=istart,iostat=ios) c
#####: 5247: if (c==newline .or. ios/=0) then
#####: 5248: if (istart/=1) istart = istart - 1
#####: 5249: exit
#####: 5250: end if
-: 5251: istart = istart-1 !rewind until the beginning of the line
#####: 5252: end do
-: 5253: iend = ipos
#####: 5254: do
#####: 5255: read(iunit,pos=iend,iostat=ios) c
#####: 5256: if (c==newline .or. ios/=0) exit
#####: 5257: iend=iend+1
#####: 5258: end do
-: 5259: allocate( character(kind=CK,len=iend-istart+1) :: line )
#####: 5260: read(iunit,pos=istart,iostat=ios) line
#####: 5261:
-: 5262: end subroutine get_current_line_from_file_stream
#####: 5263:!*****************************************************************************************
-: 5264:
-: 5265:!*****************************************************************************************
-: 5266:!>
-: 5267:! Core parsing routine.
-: 5268:
-: 5269: recursive subroutine parse_value(unit, str, value)
388371: 5270:
-: 5271: implicit none
-: 5272:
-: 5273: integer(IK),intent(in) :: unit !! file unit number
-: 5274: character(kind=CK,len=*),intent(in) :: str !! string containing JSON data (only used if unit=0)
-: 5275: type(json_value),pointer :: value !! JSON data that is extracted
-: 5276:
-: 5277: logical(LK) :: eof
-: 5278: character(kind=CK,len=1) :: c
-: 5279: character(kind=CK,len=:),allocatable :: tmp !this is a work-around for a bug
388371: 5280: ! in the gfortran 4.9 compiler.
-: 5281:
-: 5282: if (.not. exception_thrown) then
388371: 5283:
-: 5284: !the routine is being called incorrectly.
-: 5285: if (.not. associated(value)) then
388371: 5286: call throw_exception('Error in parse_value: value pointer not associated.')
#####: 5287: end if
-: 5288:
-: 5289: ! pop the next non whitespace character off the file
-: 5290: c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
388371: 5291:
-: 5292: if (eof) then
388371: 5293: return
#####: 5294: else
-: 5295: select case (c)
-: 5296: case (start_object)
-: 5297:
-: 5298: ! start object
-: 5299: call to_object(value) !allocate class
39836: 5300: call parse_object(unit, str, value)
39836: 5301:
-: 5302: case (start_array)
-: 5303:
-: 5304: ! start array
-: 5305: call to_array(value) !allocate class
19927: 5306: call parse_array(unit, str, value)
19927: 5307:
-: 5308: case (end_array)
-: 5309:
-: 5310: ! end an empty array
-: 5311: call push_char(c)
3: 5312: nullify(value)
3: 5313:
-: 5314: case (quotation_mark)
-: 5315:
-: 5316: ! string
-: 5317: call to_string(value) !allocate class
248825: 5318:
-: 5319: select case (value%var_type)
497650: 5320: case (json_string)
-: 5321: call parse_string(unit, str, tmp) !write to a tmp variable because of
248825: 5322: value%str_value = tmp ! a bug in 4.9 gfortran compiler.
248825: 5323: deallocate(tmp) !
746475: 5324: end select
-: 5325:
-: 5326: case (CK_'t') !true_str(1:1) gfortran bug work around
-: 5327:
-: 5328: !true
-: 5329: call parse_for_chars(unit, str, true_str(2:))
5125: 5330: !allocate class and set value:
-: 5331: if (.not. exception_thrown) call to_logical(value,.true.)
5125: 5332:
-: 5333: case (CK_'f') !false_str(1:1) gfortran bug work around
-: 5334:
-: 5335: !false
-: 5336: call parse_for_chars(unit, str, false_str(2:))
4831: 5337: !allocate class and set value:
-: 5338: if (.not. exception_thrown) call to_logical(value,.false.)
4831: 5339:
-: 5340: case (CK_'n') !null_str(1:1) gfortran bug work around
-: 5341:
-: 5342: !null
-: 5343: call parse_for_chars(unit, str, null_str(2:))
4: 5344: if (.not. exception_thrown) call to_null(value) !allocate class
4: 5345:
-: 5346: case(CK_'-', CK_'0': CK_'9')
-: 5347:
-: 5348: call push_char(c)
69820: 5349: call parse_number(unit, str, value)
69820: 5350:
-: 5351: case default
-: 5352:
-: 5353: call throw_exception('Error in parse_value:'//&
-: 5354: ' Unexpected character while parsing value. "'//&
-: 5355: c//'"')
388371: 5356:
-: 5357: end select
-: 5358: end if
-: 5359:
-: 5360: end if
-: 5361:
-: 5362: end subroutine parse_value
776742: 5363:!*****************************************************************************************
-: 5364:
-: 5365:!*****************************************************************************************
-: 5366:!> author: Jacob Williams
-: 5367:!
-: 5368:! Allocate a [[json_value]] pointer and make it a logical(LK) variable.
-: 5369:! The pointer should not already be allocated.
-: 5370:!
-: 5371:!# Example
-: 5372:!```fortran
-: 5373:! type(json_value),pointer :: p
-: 5374:! call json_create(p,'value',.true.)
-: 5375:!```
-: 5376:
-: 5377: subroutine json_value_create_logical(me,val,name)
1: 5378:
-: 5379: implicit none
-: 5380:
-: 5381: type(json_value),pointer :: me
-: 5382: character(kind=CK,len=*),intent(in) :: name !! variable name
-: 5383: logical(LK),intent(in) :: val !! variable value
-: 5384:
-: 5385: call json_value_create(me)
1: 5386: call to_logical(me,val,name)
1: 5387:
-: 5388: end subroutine json_value_create_logical
2: 5389:!*****************************************************************************************
-: 5390:
-: 5391:!*****************************************************************************************
-: 5392:!> author: Izaak Beekman
-: 5393:!
-: 5394:! Wrapper for [[json_value_create_logical]] so [[json_create_logical]] can
-: 5395:! be called with name of character kind 'DEFAULT' or 'ISO_10646'
-: 5396:
-: 5397: subroutine wrap_json_value_create_logical(me,val,name)
1: 5398:
-: 5399: implicit none
-: 5400:
-: 5401: type(json_value),pointer :: me
-: 5402: character(kind=CDK,len=*),intent(in) :: name
-: 5403: logical(LK),intent(in) :: val
-: 5404:
-: 5405: call json_value_create_logical(me,val,to_unicode(name))
1: 5406:
-: 5407: end subroutine wrap_json_value_create_logical
2: 5408:!*****************************************************************************************
-: 5409:
-: 5410:!*****************************************************************************************
-: 5411:!> author: Jacob Williams
-: 5412:!
-: 5413:! Allocate a [[json_value]] pointer and make it an integer(IK) variable.
-: 5414:! The pointer should not already be allocated.
-: 5415:!
-: 5416:!# Example
-: 5417:!```fortran
-: 5418:! type(json_value),pointer :: p
-: 5419:! call json_create(p,'value',1)
-: 5420:!```
-: 5421:
-: 5422: subroutine json_value_create_integer(me,val,name)
1: 5423:
-: 5424: implicit none
-: 5425:
-: 5426: type(json_value),pointer :: me
-: 5427: character(kind=CK,len=*),intent(in) :: name
-: 5428: integer(IK),intent(in) :: val
-: 5429:
-: 5430: call json_value_create(me)
1: 5431: call to_integer(me,val,name)
1: 5432:
-: 5433: end subroutine json_value_create_integer
2: 5434:!*****************************************************************************************
-: 5435:
-: 5436:!*****************************************************************************************
-: 5437:!> author: Izaak Beekman
-: 5438:!
-: 5439:! A wrapper procedure for [[json_value_create_integer]] so that [[json_create_integer]]
-: 5440:! may be called with either a 'DEFAULT' or 'ISO_10646' character kind 'name'
-: 5441:! actual argument.
-: 5442:
-: 5443: subroutine wrap_json_value_create_integer(me,val,name)
1: 5444:
-: 5445: implicit none
-: 5446:
-: 5447: type(json_value),pointer :: me
-: 5448: character(kind=CDK,len=*),intent(in) :: name
-: 5449: integer(IK),intent(in) :: val
-: 5450:
-: 5451: call json_value_create_integer(me,val,to_unicode(name))
1: 5452:
-: 5453: end subroutine wrap_json_value_create_integer
2: 5454:!*****************************************************************************************
-: 5455:
-: 5456:!*****************************************************************************************
-: 5457:!> author: Jacob Williams
-: 5458:!
-: 5459:! Allocate a [[json_value]] pointer and make it a real(RK) variable.
-: 5460:! The pointer should not already be allocated.
-: 5461:!
-: 5462:!# Example
-: 5463:!```fortran
-: 5464:! type(json_value),pointer :: p
-: 5465:! call json_create(p,'value',1.0d0)
-: 5466:!```
-: 5467:
-: 5468: subroutine json_value_create_double(me,val,name)
1: 5469:
-: 5470: implicit none
-: 5471:
-: 5472: type(json_value),pointer :: me
-: 5473: character(kind=CK,len=*),intent(in) :: name
-: 5474: real(RK),intent(in) :: val
-: 5475:
-: 5476: call json_value_create(me)
1: 5477: call to_double(me,val,name)
1: 5478:
-: 5479: end subroutine json_value_create_double
2: 5480:!*****************************************************************************************
-: 5481:
-: 5482:!*****************************************************************************************
-: 5483:!> author: Izaak Beekman
-: 5484:!
-: 5485:! A wrapper for [[json_value_create_double]] so that [[json_create_double]] may be
-: 5486:! called with an actual argument corresponding to the dummy argument, 'name'
-: 5487:! that may be of 'DEFAULT' or 'ISO_10646' character kind.
-: 5488:
-: 5489: subroutine wrap_json_value_create_double(me,val,name)
1: 5490:
-: 5491: implicit none
-: 5492:
-: 5493: type(json_value),pointer :: me
-: 5494: character(kind=CDK,len=*),intent(in) :: name
-: 5495: real(RK),intent(in) :: val
-: 5496:
-: 5497: call json_value_create_double(me,val,to_unicode(name))
1: 5498:
-: 5499: end subroutine wrap_json_value_create_double
2: 5500:!*****************************************************************************************
-: 5501:
-: 5502:!*****************************************************************************************
-: 5503:!> author: Jacob Williams
-: 5504:!
-: 5505:! Allocate a json_value pointer and make it a string variable.
-: 5506:! The pointer should not already be allocated.
-: 5507:!
-: 5508:!# Example
-: 5509:!```fortran
-: 5510:! type(json_value),pointer :: p
-: 5511:! call json_create(p,'value','hello')
-: 5512:!```
-: 5513:
-: 5514: subroutine json_value_create_string(me,val,name)
1: 5515:
-: 5516: implicit none
-: 5517:
-: 5518: type(json_value),pointer :: me
-: 5519: character(kind=CK,len=*),intent(in) :: name
-: 5520: character(kind=CK,len=*),intent(in) :: val
-: 5521:
-: 5522: call json_value_create(me)
1: 5523: call to_string(me,val,name)
1: 5524:
-: 5525: end subroutine json_value_create_string
2: 5526:!*****************************************************************************************
-: 5527:
-: 5528:!*****************************************************************************************
-: 5529:!> author: Izaak Beekman
-: 5530:!
-: 5531:! Wrap [[json_value_create_string]] so that [[json_create_string]] may be called with actual
-: 5532:! character string arguments for 'name' and 'val' that are BOTH of 'DEFAULT' or
-: 5533:! 'ISO_10646' character kind.
-: 5534:
-: 5535: subroutine wrap_json_value_create_string(me,val,name)
1: 5536:
-: 5537: implicit none
-: 5538:
-: 5539: type(json_value),pointer :: me
-: 5540: character(kind=CDK,len=*),intent(in) :: name
-: 5541: character(kind=CDK,len=*),intent(in) :: val
-: 5542:
-: 5543: call json_value_create_string(me,to_unicode(val),to_unicode(name))
1: 5544:
-: 5545: end subroutine wrap_json_value_create_string
2: 5546:!*****************************************************************************************
-: 5547:
-: 5548:!*****************************************************************************************
-: 5549:!> author: Jacob Williams
-: 5550:!
-: 5551:! Allocate a json_value pointer and make it a null variable.
-: 5552:! The pointer should not already be allocated.
-: 5553:!
-: 5554:!# Example
-: 5555:!```fortran
-: 5556:! type(json_value),pointer :: p
-: 5557:! call json_create(p,'value')
-: 5558:!```
-: 5559:
-: 5560: subroutine json_value_create_null(me,name)
1: 5561:
-: 5562: implicit none
-: 5563:
-: 5564: type(json_value),pointer :: me
-: 5565: character(kind=CK,len=*),intent(in) :: name
-: 5566:
-: 5567: call json_value_create(me)
1: 5568: call to_null(me,name)
1: 5569:
-: 5570: end subroutine json_value_create_null
2: 5571:!*****************************************************************************************
-: 5572:
-: 5573:!*****************************************************************************************
-: 5574:!> author: Izaak Beekman
-: 5575:!
-: 5576:! Wrap [[json_value_create_null]] so that [[json_create_null]] may be called with an actual
-: 5577:! argument corresponding to the dummy argument 'name' that is either of 'DEFAULT' or
-: 5578:! 'ISO_10646' character kind.
-: 5579:
-: 5580: subroutine wrap_json_value_create_null(me,name)
1: 5581:
-: 5582: implicit none
-: 5583:
-: 5584: type(json_value),pointer :: me
-: 5585: character(kind=CDK,len=*),intent(in) :: name
-: 5586:
-: 5587: call json_value_create_null(me,to_unicode(name))
1: 5588:
-: 5589: end subroutine wrap_json_value_create_null
2: 5590:!*****************************************************************************************
-: 5591:
-: 5592:!*****************************************************************************************
-: 5593:!> author: Jacob Williams
-: 5594:!
-: 5595:! Allocate a [[json_value]] pointer and make it an object variable.
-: 5596:! The pointer should not already be allocated.
-: 5597:!
-: 5598:!# Example
-: 5599:!```fortran
-: 5600:! type(json_value),pointer :: p
-: 5601:! call json_create(p,'objectname')
-: 5602:!```
-: 5603:!
-: 5604:!@note The name is not significant for the root structure or an array element.
-: 5605:! In those cases, an empty string can be used.
-: 5606:
-: 5607: subroutine json_value_create_object(me,name)
18: 5608:
-: 5609: implicit none
-: 5610:
-: 5611: type(json_value),pointer :: me
-: 5612: character(kind=CK,len=*),intent(in) :: name
-: 5613:
-: 5614: call json_value_create(me)
18: 5615: call to_object(me,name)
18: 5616:
-: 5617: end subroutine json_value_create_object
36: 5618:!*****************************************************************************************
-: 5619:
-: 5620:!*****************************************************************************************
-: 5621:!> author: Izaak Beekman
-: 5622:!
-: 5623:! Wrap [[json_value_create_object]] so that [[json_create_object]] may be called with an actual
-: 5624:! argument corresponding to the dummy argument 'name' that is of either 'DEFAULT' or
-: 5625:! 'ISO_10646' character kind.
-: 5626:
-: 5627: subroutine wrap_json_value_create_object(me,name)
18: 5628:
-: 5629: implicit none
-: 5630:
-: 5631: type(json_value),pointer :: me
-: 5632: character(kind=CDK,len=*),intent(in) :: name
-: 5633:
-: 5634: call json_value_create_object(me,to_unicode(name))
18: 5635:
-: 5636: end subroutine wrap_json_value_create_object
36: 5637:!*****************************************************************************************
-: 5638:
-: 5639:!*****************************************************************************************
-: 5640:!> author: Jacob Williams
-: 5641:!
-: 5642:! Allocate a [[json_value]] pointer and make it an array variable.
-: 5643:! The pointer should not already be allocated.
-: 5644:!
-: 5645:!# Example
-: 5646:!```fortran
-: 5647:! type(json_value),pointer :: p
-: 5648:! call json_create(p,'arrayname')
-: 5649:!```
-: 5650:
-: 5651: subroutine json_value_create_array(me,name)
2: 5652:
-: 5653: implicit none
-: 5654:
-: 5655: type(json_value),pointer :: me
-: 5656: character(kind=CK,len=*),intent(in) :: name
-: 5657:
-: 5658: call json_value_create(me)
2: 5659: call to_array(me,name)
2: 5660:
-: 5661: end subroutine json_value_create_array
4: 5662:!*****************************************************************************************
-: 5663:
-: 5664:!*****************************************************************************************
-: 5665:!> author: Izaak Beekman
-: 5666:!
-: 5667:! A wrapper for [[json_value_create_array]] so that [[json_create_array]] may be called with
-: 5668:! an actual argument, corresponding to the dummy argument 'name', that is either of
-: 5669:! 'DEFAULT' or 'ISO_10646' character kind.
-: 5670:
-: 5671: subroutine wrap_json_value_create_array(me,name)
2: 5672:
-: 5673: implicit none
-: 5674:
-: 5675: type(json_value),pointer :: me
-: 5676: character(kind=CDK,len=*),intent(in) :: name
-: 5677:
-: 5678: call json_value_create_array(me,to_unicode(name))
2: 5679:
-: 5680: end subroutine wrap_json_value_create_array
4: 5681:!*****************************************************************************************
-: 5682:
-: 5683:!*****************************************************************************************
-: 5684:!> author: Jacob Williams
-: 5685:!
-: 5686:! Change the [[json_value]] variable to a logical.
-: 5687:
-: 5688: subroutine to_logical(me,val,name)
9964: 5689:
-: 5690: implicit none
-: 5691:
-: 5692: type(json_value),intent(inout) :: me
-: 5693: logical(LK),intent(in),optional :: val !! if the value is also to be set (if not present, then .false. is used).
-: 5694: character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-: 5695:
-: 5696: !set type and value:
-: 5697: call destroy_json_data(me)
9964: 5698: me%var_type = json_logical
9964: 5699: allocate(me%log_value)
9964: 5700: if (present(val)) then
9964: 5701: me%log_value = val
9964: 5702: else
-: 5703: me%log_value = .false. !default value
#####: 5704: end if
-: 5705:
-: 5706: !name:
-: 5707: if (present(name)) me%name = trim(name)
9964: 5708:
-: 5709: end subroutine to_logical
19928: 5710:!*****************************************************************************************
-: 5711:
-: 5712:!*****************************************************************************************
-: 5713:!> author: Jacob Williams
-: 5714:!
-: 5715:! Change the [[json_value]] variable to an integer.
-: 5716:
-: 5717: subroutine to_integer(me,val,name)
50001: 5718:
-: 5719: implicit none
-: 5720:
-: 5721: type(json_value),intent(inout) :: me
-: 5722: integer(IK),intent(in),optional :: val !! if the value is also to be set (if not present, then 0 is used).
-: 5723: character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-: 5724:
-: 5725: !set type and value:
-: 5726: call destroy_json_data(me)
50001: 5727: me%var_type = json_integer
50001: 5728: allocate(me%int_value)
50001: 5729: if (present(val)) then
50001: 5730: me%int_value = val
50001: 5731: else
-: 5732: me%int_value = 0 !default value
#####: 5733: end if
-: 5734:
-: 5735: !name:
-: 5736: if (present(name)) me%name = trim(name)
50001: 5737:
-: 5738: end subroutine to_integer
100002: 5739:!*****************************************************************************************
-: 5740:
-: 5741:!*****************************************************************************************
-: 5742:!> author: Jacob Williams
-: 5743:!
-: 5744:! Change the [[json_value]] variable to a double.
-: 5745:
-: 5746: subroutine to_double(me,val,name)
19958: 5747:
-: 5748: implicit none
-: 5749:
-: 5750: type(json_value),intent(inout) :: me
-: 5751: real(RK),intent(in),optional :: val !! if the value is also to be set (if not present, then 0.0_rk is used).
-: 5752: character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-: 5753:
-: 5754: !set type and value:
-: 5755: call destroy_json_data(me)
19958: 5756: me%var_type = json_double
19958: 5757: allocate(me%dbl_value)
19958: 5758: if (present(val)) then
19958: 5759: me%dbl_value = val
19958: 5760: else
-: 5761: me%dbl_value = 0.0_RK !default value
#####: 5762: end if
-: 5763:
-: 5764: !name:
-: 5765: if (present(name)) me%name = trim(name)
19958: 5766:
-: 5767: end subroutine to_double
39916: 5768:!*****************************************************************************************
-: 5769:
-: 5770:!*****************************************************************************************
-: 5771:!> author: Jacob Williams
-: 5772:!
-: 5773:! Change the [[json_value]] variable to a string.
-: 5774:!
-: 5775:!# Modified
-: 5776:! * Izaak Beekman : 02/24/2015
-: 5777:!
-: 5778:
-: 5779: subroutine to_string(me,val,name)
248864: 5780:
-: 5781: implicit none
-: 5782:
-: 5783: type(json_value),intent(inout) :: me
-: 5784: character(kind=CK,len=*),intent(in),optional :: val !! if the value is also to be set (if not present, then '' is used).
-: 5785: character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-: 5786:
-: 5787: !set type and value:
-: 5788: call destroy_json_data(me)
248864: 5789: me%var_type = json_string
248864: 5790: if (present(val)) then
248864: 5791: me%str_value = val
39: 5792: else
-: 5793: me%str_value = '' !default value
248825: 5794: end if
-: 5795:
-: 5796: !name:
-: 5797: if (present(name)) me%name = trim(name)
248864: 5798:
-: 5799: end subroutine to_string
497728: 5800:!*****************************************************************************************
-: 5801:
-: 5802:!*****************************************************************************************
-: 5803:!> author: Jacob Williams
-: 5804:!
-: 5805:! Change the [[json_value]] variable to a null.
-: 5806:
-: 5807: subroutine to_null(me,name)
5: 5808:
-: 5809: implicit none
-: 5810:
-: 5811: type(json_value),intent(inout) :: me
-: 5812: character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-: 5813:
-: 5814: !set type and value:
-: 5815: call destroy_json_data(me)
5: 5816: me%var_type = json_null
5: 5817:
-: 5818: !name:
-: 5819: if (present(name)) me%name = trim(name)
5: 5820:
-: 5821: end subroutine to_null
10: 5822:!*****************************************************************************************
-: 5823:
-: 5824:!*****************************************************************************************
-: 5825:!> author: Jacob Williams
-: 5826:!
-: 5827:! Change the [[json_value]] variable to an object.
-: 5828:
-: 5829: subroutine to_object(me,name)
39854: 5830:
-: 5831: implicit none
-: 5832:
-: 5833: type(json_value),intent(inout) :: me
-: 5834: character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-: 5835:
-: 5836: !set type and value:
-: 5837: call destroy_json_data(me)
39854: 5838: me%var_type = json_object
39854: 5839:
-: 5840: !name:
-: 5841: if (present(name)) me%name = trim(name)
39854: 5842:
-: 5843: end subroutine to_object
79708: 5844:!*****************************************************************************************
-: 5845:
-: 5846:!*****************************************************************************************
-: 5847:!> author: Jacob Williams
-: 5848:!
-: 5849:! Change the [[json_value]] variable to an array.
-: 5850:
-: 5851: subroutine to_array(me,name)
19941: 5852:
-: 5853: implicit none
-: 5854:
-: 5855: type(json_value),intent(inout) :: me
-: 5856: character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-: 5857:
-: 5858: !set type and value:
-: 5859: call destroy_json_data(me)
19941: 5860: me%var_type = json_array
19941: 5861:
-: 5862: !name:
-: 5863: if (present(name)) me%name = trim(name)
19941: 5864:
-: 5865: end subroutine to_array
39882: 5866:!*****************************************************************************************
-: 5867:
-: 5868:!*****************************************************************************************
-: 5869:!>
-: 5870:! Core parsing routine.
-: 5871:
-: 5872: recursive subroutine parse_object(unit, str, parent)
278850: 5873:
-: 5874: implicit none
-: 5875:
-: 5876: integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
-: 5877: character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
-: 5878: type(json_value),pointer :: parent !! the parsed object will be added as a child of this
-: 5879:
-: 5880: type(json_value),pointer :: pair
-: 5881: logical(LK) :: eof
-: 5882: character(kind=CK,len=1) :: c
-: 5883: character(kind=CK,len=:),allocatable :: tmp !! this is a work-around for a bug
278850: 5884: !! in the gfortran 4.9 compiler.
-: 5885:
-: 5886: if (.not. exception_thrown) then
278850: 5887:
-: 5888: !the routine is being called incorrectly.
-: 5889: if (.not. associated(parent)) then
278850: 5890: call throw_exception('Error in parse_object: parent pointer not associated.')
#####: 5891: end if
-: 5892:
-: 5893: nullify(pair) !probably not necessary
278850: 5894:
-: 5895: ! pair name
-: 5896: c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
278850: 5897: if (eof) then
278850: 5898: call throw_exception('Error in parse_object:'//&
-: 5899: ' Unexpected end of file while parsing start of object.')
1: 5900: return
1: 5901: else if (end_object == c) then
278849: 5902: ! end of an empty object
-: 5903: return
3: 5904: else if (quotation_mark == c) then
557692: 5905: call json_value_create(pair)
278846: 5906: call parse_string(unit, str, tmp) !write to a tmp variable because of
278846: 5907: pair % name = tmp ! a bug in 4.9 gfortran compiler.
278846: 5908: deallocate(tmp)
278846: 5909: if (exception_thrown) then
278846: 5910: call json_destroy(pair)
#####: 5911: return
#####: 5912: end if
-: 5913: else
-: 5914: call throw_exception('Error in parse_object: Expecting string: "'//c//'"')
#####: 5915: return
#####: 5916: end if
-: 5917:
-: 5918: ! pair value
-: 5919: c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
278846: 5920: if (eof) then
278846: 5921: call throw_exception('Error in parse_object:'//&
-: 5922: ' Unexpected end of file while parsing object member.')
#####: 5923: return
#####: 5924: else if (colon_char == c) then
278846: 5925: ! parse the value
-: 5926: call parse_value(unit, str, pair)
278845: 5927: if (exception_thrown) then
278845: 5928: call json_destroy(pair)
2: 5929: return
2: 5930: else
-: 5931: call json_add(parent, pair)
278843: 5932: end if
-: 5933: else
-: 5934: call throw_exception('Error in parse_object:'//&
-: 5935: ' Expecting : and then a value: '//c)
1: 5936: return
1: 5937: end if
-: 5938:
-: 5939: ! another possible pair
-: 5940: c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
278843: 5941: if (eof) then
278843: 5942: call throw_exception('Error in parse_object: '//&
-: 5943: 'End of file encountered when parsing an object')
#####: 5944: return
#####: 5945: else if (delimiter == c) then
278843: 5946: ! read the next member
-: 5947: call parse_object(unit = unit, str=str, parent = parent)
239014: 5948: else if (end_object == c) then
39829: 5949: ! end of object
-: 5950: return
39829: 5951: else
-: 5952: call throw_exception('Error in parse_object: Expecting end of object: '//c)
#####: 5953: return
#####: 5954: end if
-: 5955:
-: 5956: end if
-: 5957:
-: 5958: end subroutine parse_object
557700: 5959:!*****************************************************************************************
-: 5960:
-: 5961:!*****************************************************************************************
-: 5962:!>
-: 5963:! Core parsing routine.
-: 5964:
-: 5965: recursive subroutine parse_array(unit, str, array)
19927: 5966:
-: 5967: implicit none
-: 5968:
-: 5969: integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
-: 5970: character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
-: 5971: type(json_value),pointer :: array
-: 5972:
-: 5973: type(json_value),pointer :: element
-: 5974: logical(LK) :: eof
-: 5975: character(kind=CK,len=1) :: c
-: 5976:
-: 5977: do
89583: 5978:
-: 5979: if (exception_thrown) exit
109510: 5980:
-: 5981: ! try to parse an element value
-: 5982: nullify(element)
109510: 5983: call json_value_create(element)
109510: 5984: call parse_value(unit, str, element)
109510: 5985: if (exception_thrown) then
109510: 5986: if (associated(element)) call json_destroy(element)
#####: 5987: exit
#####: 5988: end if
-: 5989:
-: 5990: ! parse value will disassociate an empty array value
-: 5991: if (associated(element)) call json_add(array, element)
109510: 5992:
-: 5993: ! popped the next character
-: 5994: c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
109510: 5995:
-: 5996: if (eof) then
109510: 5997: ! The file ended before array was finished:
-: 5998: call throw_exception('Error in parse_array: '//&
-: 5999: 'End of file encountered when parsing an array.')
#####: 6000: exit
#####: 6001: else if (delimiter == c) then
109510: 6002: ! parse the next element
-: 6003: cycle
89583: 6004: else if (end_array == c) then
19927: 6005: ! end of array
-: 6006: exit
19926: 6007: else
-: 6008: call throw_exception('Error in parse_array: '//&
-: 6009: 'Unexpected character encountered when parsing array.')
1: 6010: exit
1: 6011: end if
-: 6012:
-: 6013: end do
-: 6014:
-: 6015: end subroutine parse_array
39854: 6016:!*****************************************************************************************
-: 6017:
-: 6018:!*****************************************************************************************
-: 6019:!>
-: 6020:! Parses a string while reading a JSON file.
-: 6021:!
-: 6022:!# History
-: 6023:! * Jacob Williams : 6/16/2014 : Added hex validation.
-: 6024:
-: 6025: subroutine parse_string(unit, str, string)
1055342: 6026:
-: 6027: implicit none
-: 6028:
-: 6029: integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
-: 6030: character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
-: 6031: character(kind=CK,len=:),allocatable,intent(out) :: string
-: 6032:
-: 6033: logical(LK) :: eof, is_hex, escape
-: 6034: character(kind=CK,len=1) :: c, last
-: 6035: character(kind=CK,len=4) :: hex
-: 6036: integer(IK) :: i
-: 6037: integer(IK) :: ip !! index to put next character,
-: 6038: !! to speed up by reducing the number of character string reallocations.
-: 6039:
-: 6040: !at least return a blank string if there is a problem:
-: 6041: string = repeat(space, chunk_size)
527671: 6042:
-: 6043: if (.not. exception_thrown) then
527671: 6044:
-: 6045: !initialize:
-: 6046: ip = 1
527671: 6047: last = space
527671: 6048: is_hex = .false.
527671: 6049: escape = .false.
527671: 6050: i = 0
527671: 6051:
-: 6052: do
8655574: 6053:
-: 6054: !get the next character from the file:
-: 6055: c = pop_char(unit, str=str, eof = eof, skip_ws = .false.)
9183245: 6056:
-: 6057: if (eof) then
9183245: 6058:
-: 6059: call throw_exception('Error in parse_string: Expecting end of string')
#####: 6060: return
#####: 6061:
-: 6062: else if (c==quotation_mark .and. last /= backslash) then
9183245: 6063:
-: 6064: if (is_hex) call throw_exception('Error in parse_string:'//&
527671: 6065: ' incomplete hex string: \u'//trim(hex))
#####: 6066: exit
527671: 6067:
-: 6068: else
-: 6069:
-: 6070: !if the string is not big enough, then add another chunk:
-: 6071: if (ip>len(string)) string = string // repeat(space, chunk_size)
8655574: 6072:
-: 6073: !append to string:
-: 6074: string(ip:ip) = c
8655574: 6075: ip = ip + 1
8655574: 6076:
-: 6077: !hex validation:
-: 6078: if (is_hex) then !accumulate the four characters after '\u'
8655574: 6079:
-: 6080: i=i+1
444: 6081: hex(i:i) = c
444: 6082: if (i==4) then
444: 6083: if (valid_json_hex(hex)) then
111: 6084: i = 0
111: 6085: hex = ''
111: 6086: is_hex = .false.
111: 6087: else
-: 6088: call throw_exception('Error in parse_string:'//&
-: 6089: ' invalid hex string: \u'//trim(hex))
#####: 6090: exit
#####: 6091: end if
-: 6092: end if
-: 6093:
-: 6094: else
-: 6095:
-: 6096: !when the '\u' string is encountered, then
-: 6097: ! start accumulating the hex string (should be the next 4 characters)
-: 6098: if (escape) then
8655130: 6099: escape = .false.
20046: 6100: is_hex = (c=='u') !the next four characters are the hex string
20046: 6101: else
-: 6102: escape = (c==backslash)
8635084: 6103: end if
-: 6104:
-: 6105: end if
-: 6106:
-: 6107: !update for next char:
-: 6108: last = c
8655574: 6109:
-: 6110: end if
-: 6111:
-: 6112: end do
-: 6113:
-: 6114: !trim the string if necessary:
-: 6115: if (ip<len(string)+1) then
527671: 6116: if (ip==1) then
527563: 6117: string = ''
2: 6118: else
-: 6119: string = string(1:ip-1)
527561: 6120: end if
-: 6121: end if
-: 6122:
-: 6123: end if
-: 6124:
-: 6125: end subroutine parse_string
1055342: 6126:!*****************************************************************************************
-: 6127:
-: 6128:!*****************************************************************************************
-: 6129:!>
-: 6130:! Core parsing routine.
-: 6131:
-: 6132: subroutine parse_for_chars(unit, str, chars)
9960: 6133:
-: 6134: implicit none
-: 6135:
-: 6136: integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
-: 6137: character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
-: 6138: character(kind=CK,len=*),intent(in) :: chars !! the string to check for.
-: 6139:
-: 6140: integer(IK) :: i, length
-: 6141: logical(LK) :: eof
-: 6142: character(kind=CK,len=1) :: c
-: 6143:
-: 6144: if (.not. exception_thrown) then
9960: 6145:
-: 6146: length = len_trim(chars)
9960: 6147:
-: 6148: do i = 1, length
44671: 6149: c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
34711: 6150: if (eof) then
34711: 6151: call throw_exception('Error in parse_for_chars:'//&
-: 6152: ' Unexpected end of file while parsing array.')
#####: 6153: return
#####: 6154: else if (c /= chars(i:i)) then
34711: 6155: call throw_exception('Error in parse_for_chars:'//&
-: 6156: ' Unexpected character.: "'//c//'" '//chars(i:i))
#####: 6157: return
#####: 6158: end if
-: 6159: end do
-: 6160:
-: 6161: end if
-: 6162:
-: 6163: end subroutine parse_for_chars
9960: 6164:!*****************************************************************************************
-: 6165:
-: 6166:!*****************************************************************************************
-: 6167:!> author: Jacob Williams
-: 6168:! date: 1/20/2014
-: 6169:!
-: 6170:! Read a numerical value from the file (or string).
-: 6171:! The routine will determine if it is an integer or a double, and
-: 6172:! allocate the type accordingly.
-: 6173:!
-: 6174:!@note Complete rewrite of the original FSON routine, which had some problems.
-: 6175:
-: 6176: subroutine parse_number(unit, str, value)
69820: 6177:
-: 6178: implicit none
-: 6179:
-: 6180: integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
-: 6181: character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
-: 6182: type(json_value),pointer :: value
-: 6183:
-: 6184: character(kind=CK,len=:),allocatable :: tmp
69820: 6185: character(kind=CK,len=1) :: c
-: 6186: logical(LK) :: eof
-: 6187: real(RK) :: rval
-: 6188: integer(IK) :: ival
-: 6189: logical(LK) :: first
-: 6190: logical(LK) :: is_integer
-: 6191:
-: 6192: !to speed up by reducing the number of character string reallocations:
-: 6193: integer(IK) :: ip !index to put next character
-: 6194:
-: 6195: if (.not. exception_thrown) then
69820: 6196:
-: 6197: tmp = repeat(space, chunk_size)
69820: 6198: ip = 1
69820: 6199: first = .true.
69820: 6200: is_integer = .true. !assume it may be an integer, unless otherwise determined
69820: 6201:
-: 6202: !read one character at a time and accumulate the string:
-: 6203: do
277340: 6204:
-: 6205: !get the next character:
-: 6206: c = pop_char(unit, str=str, eof = eof, skip_ws = .true.)
347160: 6207:
-: 6208: if (eof) then
347160: 6209: call throw_exception('Error in parse_number:'//&
-: 6210: ' Unexpected end of file while parsing number.')
#####: 6211: return
#####: 6212: else
-: 6213:
-: 6214: select case (c)
-: 6215: case(CK_'-',CK_'+') !note: allowing a '+' as the first character here.
-: 6216:
-: 6217: if (is_integer .and. (.not. first)) is_integer = .false.
9787: 6218:
-: 6219: !add it to the string:
-: 6220: !tmp = tmp // c !...original
-: 6221: if (ip>len(tmp)) tmp = tmp // repeat(space, chunk_size)
9787: 6222: tmp(ip:ip) = c
9787: 6223: ip = ip + 1
9787: 6224:
-: 6225: case(CK_'.',CK_'E',CK_'e') !can be present in real numbers
-: 6226:
-: 6227: if (is_integer) is_integer = .false.
19970: 6228:
-: 6229: !add it to the string:
-: 6230: !tmp = tmp // c !...original
-: 6231: if (ip>len(tmp)) tmp = tmp // repeat(space, chunk_size)
19970: 6232: tmp(ip:ip) = c
19970: 6233: ip = ip + 1
19970: 6234:
-: 6235: case(CK_'0':CK_'9') !valid characters for numbers
-: 6236:
-: 6237: !add it to the string:
-: 6238: !tmp = tmp // c !...original
-: 6239: if (ip>len(tmp)) tmp = tmp // repeat(space, chunk_size)
247583: 6240: tmp(ip:ip) = c
247583: 6241: ip = ip + 1
247583: 6242:
-: 6243: case default
-: 6244:
-: 6245: !push back the last character read:
-: 6246: call push_char(c)
69820: 6247:
-: 6248: !string to value:
-: 6249: if (is_integer) then
69820: 6250: ival = string_to_integer(tmp)
49887: 6251: call to_integer(value,ival)
49887: 6252: else
-: 6253: rval = string_to_double(tmp)
19933: 6254: call to_double(value,rval)
19933: 6255: end if
-: 6256:
-: 6257: exit !finished
416980: 6258:
-: 6259: end select
-: 6260:
-: 6261: end if
-: 6262: if (first) first = .false.
277340: 6263:
-: 6264: end do
-: 6265:
-: 6266: !cleanup:
-: 6267: if (allocated(tmp)) deallocate(tmp)
69820: 6268:
-: 6269: end if
-: 6270:
-: 6271: end subroutine parse_number
139640: 6272:!*****************************************************************************************
-: 6273:
-: 6274:!*****************************************************************************************
-: 6275:!>
-: 6276:! Get the next character from the file (or string).
-: 6277:!
-: 6278:!# See also
-: 6279:! * [[push_char]]
-: 6280:!
-: 6281:!@note This routine ignores non-printing ASCII characters (iachar<=31) that are in strings.
-: 6282:
-: 6283: recursive function pop_char(unit, str, eof, skip_ws) result(popped)
10899536: 6284:
-: 6285: implicit none
-: 6286:
-: 6287: character(kind=CK,len=1) :: popped !! the popped character.
-: 6288: integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
-: 6289: character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string) -- only used if unit=0
-: 6290: logical(LK),intent(out) :: eof !! true if the end of the file has been reached.
-: 6291: logical(LK),intent(in),optional :: skip_ws !! to ignore whitespace.
-: 6292:
-: 6293: integer(IK) :: ios,str_len
-: 6294: character(kind=CK,len=1) :: c
-: 6295: logical(LK) :: ignore
-: 6296:
-: 6297: if (.not. exception_thrown) then
10899536: 6298:
-: 6299: eof = .false.
10899536: 6300: if (.not. present(skip_ws)) then
10899536: 6301: ignore = .false.
#####: 6302: else
-: 6303: ignore = skip_ws
10899536: 6304: end if
-: 6305:
-: 6306: do
2976960: 6307:
-: 6308: if (pushed_index > 0) then
13876496: 6309:
-: 6310: ! there is a character pushed back on, most likely from the number parsing
-: 6311: ! NOTE: this can only occur if reading from a file when use_unformatted_stream=.false.
-: 6312: c = pushed_char(pushed_index:pushed_index)
139643: 6313: pushed_index = pushed_index - 1
139643: 6314:
-: 6315: else
-: 6316:
-: 6317: if (unit/=0) then !read from the file
13736853: 6318:
-: 6319: !read the next character:
-: 6320: if (use_unformatted_stream) then
-: 6321: read(unit=unit,pos=ipos,iostat=ios) c
-: 6322: else
-: 6323: read(unit=unit,fmt='(A1)',advance='NO',iostat=ios) c
6871798: 6324: end if
-: 6325: ipos = ipos + 1
6871798: 6326:
-: 6327: !....note: maybe try read the file in chunks...
-: 6328: !.... or use asynchronous read with double buffering
-: 6329: ! (see Modern Fortran: Style and Usage)
-: 6330:
-: 6331: else !read from the string
-: 6332:
-: 6333: str_len = len(str) !length of the string
6865055: 6334: if (ipos<=str_len) then
6865055: 6335: c = str(ipos:ipos)
6865055: 6336: ios = 0
6865055: 6337: else
-: 6338: ios = IOSTAT_END !end of the string
#####: 6339: end if
-: 6340: ipos = ipos + 1
6865055: 6341:
-: 6342: end if
-: 6343:
-: 6344: char_count = char_count + 1 !character count in the current line
13736853: 6345:
-: 6346: if (IS_IOSTAT_END(ios)) then !end of file
13736853: 6347:
-: 6348: char_count = 0
1: 6349: eof = .true.
1: 6350: exit
1: 6351:
-: 6352: elseif (IS_IOSTAT_EOR(ios) .or. c==newline) then !end of record
13736852: 6353:
-: 6354: char_count = 0
448105: 6355: line_count = line_count + 1
448105: 6356: cycle
448105: 6357:
-: 6358: end if
-: 6359:
-: 6360: end if
-: 6361:
-: 6362: if (any(c == control_chars)) then
13428390: 6363:
-: 6364: ! non printing ascii characters
-: 6365: cycle
#####: 6366:
-: 6367: else if (ignore .and. c == space) then
13428390: 6368:
-: 6369: cycle
-: 6370:
-: 6371: else
-: 6372:
-: 6373: popped = c
10899535: 6374: exit
10899535: 6375:
-: 6376: end if
-: 6377:
-: 6378: end do
-: 6379:
-: 6380: end if
-: 6381:
-: 6382: end function pop_char
21799072: 6383:!*****************************************************************************************
-: 6384:
-: 6385:!*****************************************************************************************
-: 6386:!>
-: 6387:! Core routine.
-: 6388:!
-: 6389:!# See also
-: 6390:! * [[pop_char]]
-: 6391:!
-: 6392:!# History
-: 6393:! * Jacob Williams : 5/3/2015 : replaced original version of this routine.
-: 6394:
-: 6395: subroutine push_char(c)
139643: 6396:
-: 6397: implicit none
-: 6398:
-: 6399: character(kind=CK,len=1),intent(in) :: c
-: 6400:
-: 6401: character(kind=CK,len=max_numeric_str_len) :: istr
-: 6402:
-: 6403: if (.not. exception_thrown) then
139643: 6404:
-: 6405: if (use_unformatted_stream) then
-: 6406:
-: 6407: !in this case, c is ignored, and we just
-: 6408: !decrement the stream position counter:
-: 6409: ipos = ipos - 1
-: 6410:
-: 6411: else
-: 6412:
-: 6413: pushed_index = pushed_index + 1
139643: 6414:
-: 6415: if (pushed_index>0 .and. pushed_index<=len(pushed_char)) then
139643: 6416: pushed_char(pushed_index:pushed_index) = c
139643: 6417: else
-: 6418: call integer_to_string(pushed_index,istr)
#####: 6419: call throw_exception('Error in push_char: '//&
-: 6420: 'invalid valid of pushed_index: '//trim(istr))
#####: 6421: end if
-: 6422:
-: 6423: end if
-: 6424:
-: 6425: end if
-: 6426:
-: 6427: end subroutine push_char
139643: 6428:!*****************************************************************************************
-: 6429:
-: 6430:!*****************************************************************************************
-: 6431:!> author: Jacob Williams
-: 6432:! date: 12/4/2013
-: 6433:!
-: 6434:! Convert an integer to a string.
-: 6435:
-: 6436: pure subroutine integer_to_string(ival,str)
267: 6437:
-: 6438: implicit none
-: 6439:
-: 6440: integer(IK),intent(in) :: ival !! integer value.
-: 6441: character(kind=CK,len=*),intent(out) :: str !! ival converted to a string.
-: 6442:
-: 6443: integer(IK) :: istat
-: 6444:
-: 6445: write(str,fmt=int_fmt,iostat=istat) ival
267: 6446:
-: 6447: if (istat==0) then
267: 6448: str = adjustl(str)
267: 6449: else
-: 6450: str = repeat(star,len(str))
#####: 6451: end if
-: 6452:
-: 6453: end subroutine integer_to_string
534: 6454:!*****************************************************************************************
-: 6455:
-: 6456:!*****************************************************************************************
-: 6457:!> author: Jacob Williams
-: 6458:! date: 12/4/2013
-: 6459:!
-: 6460:! Convert a real value to a string.
-: 6461:!
-: 6462:!# Modified
-: 6463:! * Izaak Beekman : 02/24/2015 : added the compact option.
-: 6464:
-: 6465: subroutine real_to_string(rval,str)
38: 6466:
-: 6467: implicit none
-: 6468:
-: 6469: real(RK),intent(in) :: rval !! real value.
-: 6470: character(kind=CK,len=*),intent(out) :: str !! rval converted to a string.
-: 6471:
-: 6472: integer(IK) :: istat
-: 6473:
-: 6474: !default format:
-: 6475: write(str,fmt=real_fmt,iostat=istat) rval
38: 6476:
-: 6477: if (istat==0) then
38: 6478:
-: 6479: !in this case, the default string will be compacted,
-: 6480: ! so that the same value is displayed with fewer characters.
-: 6481: if (compact_real) call compact_real_string(str)
38: 6482:
-: 6483: else
-: 6484: str = repeat(star,len(str))
#####: 6485: end if
-: 6486:
-: 6487: end subroutine real_to_string
76: 6488:!*****************************************************************************************
-: 6489:
-: 6490:!*****************************************************************************************
-: 6491:!> author: Izaak Beekman
-: 6492:! date: 02/24/2015
-: 6493:!
-: 6494:! Compact a string representing a real number, so that
-: 6495:! the same value is displayed with fewer characters.
-: 6496:!
-: 6497:!# See also
-: 6498:! * [[real_to_string]]
-: 6499:
-: 6500: subroutine compact_real_string(str)
38: 6501:
-: 6502: implicit none
-: 6503:
-: 6504: character(kind=CK,len=*),intent(inout) :: str !! string representation of a real number.
-: 6505:
-: 6506: character(kind=CK,len=len(str)) :: significand, expnt
38: 6507: character(kind=CK,len=2) :: separator
-: 6508: integer(IK) :: exp_start,decimal_pos,sig_trim,exp_trim,i
-: 6509:
-: 6510: str = adjustl(str)
38: 6511: exp_start = scan(str,CK_'eEdD')
38: 6512: if (exp_start == 0) exp_start = scan(str,CK_'-+',back=.true.)
38: 6513: decimal_pos = scan(str,CK_'.')
38: 6514: if (exp_start /= 0) separator = str(exp_start:exp_start)
38: 6515:
-: 6516: if ( exp_start < decimal_pos ) then !possibly signed, exponent-less float
38: 6517:
-: 6518: significand = str
#####: 6519: sig_trim = len(trim(significand))
#####: 6520: do i = len(trim(significand)),decimal_pos+2,-1 !look from right to left at 0s
#####: 6521: !but save one after the decimal place
-: 6522: if (significand(i:i) == '0') then
#####: 6523: sig_trim = i-1
#####: 6524: else
-: 6525: exit
#####: 6526: end if
-: 6527: end do
-: 6528: str = trim(significand(1:sig_trim))
#####: 6529:
-: 6530: else if (exp_start > decimal_pos) then !float has exponent
38: 6531:
-: 6532: significand = str(1:exp_start-1)
38: 6533: sig_trim = len(trim(significand))
38: 6534: do i = len(trim(significand)),decimal_pos+2,-1 !look from right to left at 0s
594: 6535: if (significand(i:i) == '0') then
562: 6536: sig_trim = i-1
556: 6537: else
-: 6538: exit
6: 6539: end if
-: 6540: end do
-: 6541: expnt = adjustl(str(exp_start+1:))
38: 6542: if (expnt(1:1) == '+' .or. expnt(1:1) == '-') then
38: 6543: separator = trim(adjustl(separator))//expnt(1:1)
38: 6544: exp_start = exp_start + 1
38: 6545: expnt = adjustl(str(exp_start+1:))
38: 6546: end if
-: 6547: exp_trim = 1
38: 6548: do i = 1,(len(trim(expnt))-1) !look at exponent leading zeros saving last
152: 6549: if (expnt(i:i) == '0') then
114: 6550: exp_trim = i+1
114: 6551: else
-: 6552: exit
#####: 6553: end if
-: 6554: end do
-: 6555: str = trim(adjustl(significand(1:sig_trim)))// &
-: 6556: trim(adjustl(separator))// &
-: 6557: trim(adjustl(expnt(exp_trim:)))
38: 6558:
-: 6559: !else ! mal-formed real, BUT this code should be unreachable
-: 6560:
-: 6561: end if
-: 6562:
-: 6563: end subroutine compact_real_string
76: 6564:!*****************************************************************************************
-: 6565:
-: 6566:!*****************************************************************************************
-: 6567:!> author: Jacob Williams
-: 6568:! date:6/14/2014
-: 6569:!
-: 6570:! Returns true if the string is a valid 4-digit hex string.
-: 6571:!
-: 6572:!# Examples
-: 6573:!```fortran
-: 6574:! valid_json_hex('0000') !returns true
-: 6575:! valid_json_hex('ABC4') !returns true
-: 6576:! valid_json_hex('AB') !returns false (< 4 characters)
-: 6577:! valid_json_hex('WXYZ') !returns false (invalid characters)
-: 6578:!```
-: 6579:
-: 6580: pure function valid_json_hex(str) result(valid)
111: 6581:
-: 6582: implicit none
-: 6583:
-: 6584: logical(LK) :: valid !! is str a value 4-digit hex string
-: 6585: character(kind=CK,len=*),intent(in) :: str !! the string to check.
-: 6586:
-: 6587: integer(IK) :: n,i
-: 6588:
-: 6589: !an array of the valid hex characters:
-: 6590: character(kind=CK,len=1),dimension(22),parameter :: valid_chars = &
-: 6591: [ (achar(i),i=48,57), & ! decimal digits
-: 6592: (achar(i),i=65,70), & ! capital A-F
-: 6593: (achar(i),i=97,102) ] ! lowercase a-f
-: 6594:
-: 6595: !initialize
-: 6596: valid = .false.
111: 6597:
-: 6598: !check all the characters in the string:
-: 6599: n = len(str)
111: 6600: if (n==4) then
111: 6601: do i=1,n
555: 6602: if (.not. any(str(i:i)==valid_chars)) return
444: 6603: end do
-: 6604: valid = .true. !all are in the set, so it is OK
111: 6605: end if
-: 6606:
-: 6607: end function valid_json_hex
222: 6608:!*****************************************************************************************
-: 6609:
-: 6610:!*****************************************************************************************
-: 6611:!> author: Izaak Beekman
-: 6612:!
-: 6613:! Convert string to unicode (CDK to CK).
-: 6614:
-: 6615: pure function to_uni(str)
21193: 6616:
-: 6617: implicit none
-: 6618:
-: 6619: character(kind=CDK,len=*), intent(in) :: str
-: 6620: character(kind=CK,len=len(str)) :: to_uni
-: 6621:
-: 6622: to_uni = str
21193: 6623:
-: 6624: end function to_uni
42386: 6625:!*****************************************************************************************
-: 6626:
-: 6627:!*****************************************************************************************
-: 6628:!> author: Izaak Beekman
-: 6629:!
-: 6630:! Convert array of strings to unicode (CDK to CK).
-: 6631:!
-: 6632:!@note JW: may be able to remove this by making [[to_uni]] PURE ELEMENTAL ?
-: 6633:
-: 6634: pure function to_uni_vec(str)
194: 6635:
-: 6636: implicit none
-: 6637:
-: 6638: character(kind=CDK,len=*), dimension(:), intent(in) :: str
-: 6639: character(kind=CK,len=len(str)), dimension(size(str)) :: to_uni_vec
-: 6640:
-: 6641: to_uni_vec = str
97: 6642:
-: 6643: end function to_uni_vec
194: 6644:!*****************************************************************************************
-: 6645:
-: 6646:!*****************************************************************************************
-: 6647:!> author: Izaak Beekman
-: 6648:!
-: 6649:! CK//CDK operator.
-: 6650:
-: 6651: function ucs4_join_default(ucs4_str,def_str) result(res)
58: 6652:
-: 6653: implicit none
-: 6654:
-: 6655: character(kind=CK, len=*), intent(in) :: ucs4_str
-: 6656: character(kind=CDK,len=*), intent(in) :: def_str
-: 6657: character(kind=CK,len=(len(ucs4_str)+len(def_str))) :: res
-: 6658:
-: 6659: res = ucs4_str//to_unicode(def_str)
29: 6660:
-: 6661: end function ucs4_join_default
58: 6662:!*****************************************************************************************
-: 6663:
-: 6664:!*****************************************************************************************
-: 6665:!> author: Izaak Beekman
-: 6666:!
-: 6667:! CDK//CK operator.
-: 6668:
-: 6669: function default_join_ucs4(def_str,ucs4_str) result(res)
292: 6670:
-: 6671: implicit none
-: 6672:
-: 6673: character(kind=CDK,len=*), intent(in) :: def_str
-: 6674: character(kind=CK, len=*), intent(in) :: ucs4_str
-: 6675: character(kind=CK,len=(len(def_str)+len(ucs4_str))) :: res
-: 6676:
-: 6677: res = to_unicode(def_str)//ucs4_str
146: 6678:
-: 6679: end function default_join_ucs4
292: 6680:!*****************************************************************************************
-: 6681:
-: 6682:!*****************************************************************************************
-: 6683:!> author: Izaak Beekman
-: 6684:!
-: 6685:! CK==CDK operator.
-: 6686:
-: 6687: function ucs4_comp_default(ucs4_str,def_str) result(res)
20822: 6688:
-: 6689: implicit none
-: 6690:
-: 6691: character(kind=CK, len=*), intent(in) :: ucs4_str
-: 6692: character(kind=CDK,len=*), intent(in) :: def_str
-: 6693: logical(LK) :: res
-: 6694:
-: 6695: res = ( ucs4_str == to_unicode(def_str) )
20822: 6696:
-: 6697: end function ucs4_comp_default
41644: 6698:!*****************************************************************************************
-: 6699:
-: 6700:!*****************************************************************************************
-: 6701:!> author: Izaak Beekman
-: 6702:!
-: 6703:! CDK==CK operator.
-: 6704:
-: 6705: function default_comp_ucs4(def_str,ucs4_str) result(res)
#####: 6706:
-: 6707: implicit none
-: 6708:
-: 6709: character(kind=CDK,len=*), intent(in) :: def_str
-: 6710: character(kind=CK, len=*), intent(in) :: ucs4_str
-: 6711: logical(LK) :: res
-: 6712:
-: 6713: res = ( to_unicode(def_str) == ucs4_str)
#####: 6714:
-: 6715: end function default_comp_ucs4
#####: 6716:!*****************************************************************************************
-: 6717:
-: 6718:!*****************************************************************************************
-: 6719:!> author: Jacob Williams
-: 6720:!
-: 6721:! Print any error message, and then clear the exceptions.
-: 6722:!
-: 6723:!@note This routine is used by the unit tests.
-: 6724:! It was originally in json_example.f90, and was
-: 6725:! moved here 2/26/2015 by Izaak Beekman.
-: 6726:
-: 6727: subroutine json_print_error_message(io_unit)
3: 6728:
-: 6729: implicit none
-: 6730:
-: 6731: integer, intent(in), optional :: io_unit
-: 6732:
-: 6733: character(kind=CK,len=:),allocatable :: error_msg
3: 6734: logical :: status_ok
-: 6735:
-: 6736: !get error message:
-: 6737: call json_check_for_errors(status_ok, error_msg)
3: 6738:
-: 6739: !print it if there is one:
-: 6740: if (.not. status_ok) then
3: 6741: if (present(io_unit)) then
3: 6742: write(io_unit,'(A)') error_msg
3: 6743: else
-: 6744: write(*,'(A)') error_msg
#####: 6745: end if
-: 6746: deallocate(error_msg)
3: 6747: call json_clear_exceptions()
3: 6748: end if
-: 6749:
-: 6750: end subroutine json_print_error_message
3: 6751:!*****************************************************************************************
-: 6752:
-: 6753:!*****************************************************************************************
-: 6754: end module json_module
#####: 6755:!*****************************************************************************************
@zbeekman
Copy link
Author

Fix it with:

awk -F':' '{line=""; for(i=2;i<=NF;i++){line=line":"$i}; if (NR > 1) print $1 prevline; prevline=line}; END{print "        -"prevline}' json_module.F90.gcov

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment