test_12 Subroutine

Source File

Subroutines

Source Code

test_12

All Procedures

add_variables_to_input annotate_invalid_json compact_real_string default_comp_ucs4 default_join_ucs4 destroy_json_data escape_string get_current_line_from_file_sequential get_current_line_from_file_stream initialize_json_file integer_to_string json_add json_check_for_errors json_clear_exceptions json_count json_create_array json_create_double json_create_integer json_create_logical json_create_null json_create_object json_create_string json_destroy json_failed json_file json_file_destroy json_file_get_double json_file_get_double_vec json_file_get_integer json_file_get_integer_vec json_file_get_logical json_file_get_logical_vec json_file_get_object json_file_get_root json_file_get_string json_file_get_string_vec json_file_load json_file_load_from_string json_file_move_pointer json_file_print_1 json_file_print_2 json_file_print_to_console json_file_print_to_string json_file_update_integer json_file_update_logical json_file_update_real json_file_update_string json_file_update_string_name_ascii json_file_update_string_val_ascii json_file_variable_info json_get json_get_array json_get_array_with_path json_get_by_path json_get_child json_get_double json_get_double_vec json_get_double_vec_with_path json_get_double_with_path json_get_integer json_get_integer_vec json_get_integer_vec_with_path json_get_integer_with_path json_get_logical json_get_logical_vec json_get_logical_vec_with_path json_get_logical_with_path json_get_string json_get_string_vec json_get_string_vec_with_path json_get_string_with_path json_info json_initialize json_parse json_parse_file json_parse_string json_print json_print_1 json_print_2 json_print_error_message json_print_to_string json_remove json_remove_if_present json_throw_exception json_traverse json_update json_update_double json_update_integer json_update_logical json_update_string json_update_string_name_ascii json_update_string_val_ascii json_value_add_double json_value_add_double_vec json_value_add_integer json_value_add_integer_vec json_value_add_logical json_value_add_logical_vec json_value_add_member json_value_add_string json_value_add_string_name_ascii json_value_add_string_val_ascii json_value_add_string_vec json_value_add_string_vec_name_ascii json_value_add_string_vec_val_ascii json_value_create json_value_create_array json_value_create_double json_value_create_integer json_value_create_logical json_value_create_null json_value_create_object json_value_create_string json_value_destroy json_value_get_by_index json_value_get_by_name_chars json_value_print json_value_remove json_value_remove_if_present json_value_to_string parse_array parse_for_chars parse_number parse_object parse_string parse_value pop_char push_char read_file real_to_string rename string_to_double string_to_integer test_1 test_10 test_11 test_12 test_13 test_14 test_2 test_3 test_4 test_5 test_6 test_7 test_8 test_9 throw_exception to_array to_double to_integer to_logical to_null to_object to_string to_uni to_uni_vec to_unicode ucs4_comp_default ucs4_join_default valid_json_hex wrap_json_file_get_double wrap_json_file_get_double_vec wrap_json_file_get_integer wrap_json_file_get_integer_vec wrap_json_file_get_logical wrap_json_file_get_logical_vec wrap_json_file_get_object wrap_json_file_get_string wrap_json_file_get_string_vec wrap_json_file_load_from_string wrap_json_file_update_integer wrap_json_file_update_logical wrap_json_file_update_real wrap_json_file_update_string wrap_json_file_variable_info wrap_json_get_array_with_path wrap_json_get_by_path wrap_json_get_double_vec_with_path wrap_json_get_double_with_path wrap_json_get_integer_vec_with_path wrap_json_get_integer_with_path wrap_json_get_logical_vec_with_path wrap_json_get_logical_with_path wrap_json_get_string_vec_with_path wrap_json_get_string_with_path wrap_json_parse_string wrap_json_throw_exception wrap_json_update_double wrap_json_update_integer wrap_json_update_logical wrap_json_update_string wrap_json_value_add_double wrap_json_value_add_double_vec wrap_json_value_add_integer wrap_json_value_add_integer_vec wrap_json_value_add_logical wrap_json_value_add_logical_vec wrap_json_value_add_string wrap_json_value_add_string_vec wrap_json_value_create_array wrap_json_value_create_double wrap_json_value_create_integer wrap_json_value_create_logical wrap_json_value_create_null wrap_json_value_create_object wrap_json_value_create_string wrap_json_value_get_by_name_chars wrap_json_value_remove_if_present

public subroutine test_12(error_cnt)

Arguments

Type	Intent	Optional	Attributes		Name
integer,	intent(out)			::	error_cnt	report number of errors to caller

Variables

Type	Visibility	Attributes		Name		Initial
integer,	public,	parameter	::	imx	=	5
integer,	public,	parameter	::	jmx	=	3
integer,	public,	parameter	::	kmx	=	4	dimensions for raw work array of primitive type
integer,	public,	dimension(3)	::	shape			shape of work array
integer,	public,	dimension(:), allocatable	::	fetched_shape			retrieved shape
type(json_value),	public,	pointer	::	root
type(json_value),	public,	pointer	::	meta_array			json nodes to work with
type(json_value),	public,	pointer	::	tmp_json_ptr
type(json_file),	public		::	my_file
real(kind=wp),	public,	dimension(imx,jmx,kmx)	::	raw_array			raw work array
real(kind=wp),	public		::	array_element
real(kind=wp),	public,	dimension(:), allocatable	::	fetched_array
character(kind=CK,len=:),	public,	allocatable	::	description
integer,	public		::	i
integer,	public		::	j
integer,	public		::	k			loop indices
integer,	public		::	array_length
integer,	public		::	lun
logical,	public		::	existed
logical,	public,	dimension(:), allocatable	::	SOS

Subroutines

subroutine check_errors(assertion)

Arguments

Type	Intent	Optional	Attributes		Name
logical,	intent(in),	optional		::	assertion

subroutine get_3D_from_array(element, i, count)

Arguments

Type	Intent	Attributes		Name
type(json_value),	intent(in),	pointer	::	element
integer,	intent(in)		::	i	index
integer,	intent(in)		::	count	size of array

Source Code

    subroutine test_12(error_cnt)
    
    implicit none

    integer,intent(out) :: error_cnt !! report number of errors to caller

    integer,parameter :: imx = 5, jmx = 3, kmx = 4 !! dimensions for raw work array of primitive type
    
    integer,dimension(3)                  :: shape             !! shape of work array
    integer, dimension(:), allocatable    :: fetched_shape     !! retrieved shape
    type(json_value), pointer             :: root, meta_array  !! json nodes to work with
    type(json_value), pointer             :: tmp_json_ptr
    type(json_file)                       :: my_file
    real(wp),dimension(imx,jmx,kmx)       :: raw_array         !! raw work array
    real(wp)                              :: array_element
    real(wp), dimension(:), allocatable   :: fetched_array
    character(kind=CK,len=:), allocatable :: description
    integer                               :: i,j,k             !! loop indices
    integer                               :: array_length, lun
    logical                               :: existed
    logical, dimension(:), allocatable    :: SOS

    error_cnt = 0
    call json_initialize(verbose=.true.,real_format='G')
    call check_errors()

    write(error_unit,'(A)') ''
    write(error_unit,'(A)') '================================='
    write(error_unit,'(A)') '   TEST 12'
    write(error_unit,'(A)') '================================='
    write(error_unit,'(A)') ''

    ! populate the raw array
    forall (i=1:imx,j=1:jmx,k=1:kmx) ! could use size(... , dim=...) instead of constants
       raw_array(i,j,k) = i + (j-1)*imx + (k-1)*imx*jmx
    end forall

    call json_create_object(root,dir//file)
    call check_errors()

    call json_create_object(meta_array,'array data')
    call check_errors()

    shape = [size(raw_array,dim=1), size(raw_array,dim=2), size(raw_array,dim=3)]
    call json_add(meta_array, 'shape', shape)
    call check_errors()

    call json_add(meta_array, 'total size', size(raw_array))
    call check_errors()

    call json_update(meta_array, 'total size', size(raw_array), found=existed)
    call check_errors(existed)

    call json_add(meta_array, CK_'description', 'test data')
    call check_errors()

    ! now add the array
    ! N.B. `json_add()` only accepts 1-D arrays and scalars, so transform with `reshape`
    ! N.B. reshape populates new array in "array element order".
    ! C.F. "Modern Fortran Explained", by Metcalf, Cohen and Reid, p. 24.
    ! N.B. Fortran is a column major language

    call json_add( meta_array, 'data', reshape( raw_array, [ size(raw_array) ] ) )
    call check_errors()

    ! now put it all together
    call json_add(root,meta_array)
    call check_errors()

    write(error_unit,'(A)') "Print the JSON object to stderr:"
    call json_print(root,error_unit)
    call check_errors()

    call json_get(root,'$.array data.data(1)',array_element)
    call check_errors(abs(array_element - 1.0_wp) <= TOL)

    call json_get(root,'@.array data.shape',fetched_shape)
    call check_errors(all(fetched_shape == shape))

    call json_update(meta_array,'description',CK_'Test Data',found=existed)
    call check_errors(existed)

    call json_update(meta_array,CK_'description','Test data',found=existed)
    call check_errors(existed)

    call json_get(meta_array,'description',description)
    call check_errors('Test data' == description)

    call json_get(root,'array data.total size',array_length)
    call check_errors(array_length == imx*jmx*kmx)

    sos = [.true.,  .true.,  .true.,  &
           .false., .false., .false., &
           .true., .true., .true.]
    call json_add(root,'SOS',sos)
    call check_errors()

    call json_get(root,'SOS',sos)
    call check_errors()

    call json_add(root,'vector string', [CK_'only one value'])
    call check_errors()

    call json_add(root,CK_'page', ['The quick brown fox     ', 'jumps over the lazy dog.'])
    call check_errors()

    call json_get(root,'SOS',tmp_json_ptr)
    call check_errors()

    call json_get(tmp_json_ptr,sos)
    call check_errors()

    call json_get(meta_array,'shape',tmp_json_ptr)
    call check_errors()

    call json_get(tmp_json_ptr,fetched_shape)
    call check_errors(all(fetched_shape == shape))

    call json_get(meta_array,'data',tmp_json_ptr)
    call check_errors()

    call json_get(tmp_json_ptr,fetched_array)
    call check_errors(all(abs(fetched_array - reshape(raw_array,[size(raw_array)])) <= TOL))

    call json_get(root,'array data.data',fetched_array)
    call check_errors(all(abs(fetched_array - reshape(raw_array,[size(raw_array)])) <= TOL))

    raw_array = 0
    call json_get(me=root,path='array data.data',array_callback=get_3D_from_array)
    call check_errors(all(abs(fetched_array - reshape(raw_array,[size(raw_array)])) <= TOL))

    my_file = json_file(root)

    call my_file%update('array data.description',CK_'vector data',found=existed)
    call check_errors(existed)

    call my_file%update(CK_'array data.description','Vector data',found=existed)
    call check_errors(existed)

    call my_file%get('SOS',sos)
    call check_errors()

    call my_file%get('$array data.data',fetched_array)
    call check_errors(all(abs(fetched_array - reshape(raw_array,[size(raw_array)])) <= TOL))

    call my_file%get(tmp_json_ptr)
    call check_errors(associated(tmp_json_ptr,root))

    open(file=dir//file,newunit=lun,form='formatted',action='write')
    call my_file%print_file(lun)
    call check_errors()
    close(lun)

    contains
    
      subroutine check_errors(assertion)
        logical, optional, intent(in) :: assertion
        if (json_failed()) then
           call json_print_error_message(error_unit)
           error_cnt = error_cnt + 1
        end if
        if (present (assertion)) then
           if (.not. assertion) error_cnt = error_cnt + 1
        end if
      end subroutine check_errors

      subroutine get_3D_from_array(element, i, count)
        type(json_value), pointer , intent(in)   :: element
        integer         , intent(in)             :: i        !!index
        integer         , intent(in)             :: count    !!size of array
        integer :: useless !! assign count to this to silence warnings

        ! let's pretend we're c programmers!
        call json_get( element, raw_array( &
             mod(i-1,imx) + 1, &            ! i index
             mod((i-1)/imx,jmx) + 1, &      ! j index
             mod((i-1)/imx/jmx,kmx) + 1 ) ) ! k inded
        useless = count
      end subroutine get_3D_from_array

    end subroutine test_12