module tests
    use assert
    implicit none
contains
    subroutine test_data_basic_types
        use libmuscle

        implicit none

        integer, parameter :: int1 = LIBMUSCLE_int1
        integer, parameter :: int2 = LIBMUSCLE_int2
        integer, parameter :: int4 = LIBMUSCLE_int4
        integer, parameter :: int8 = LIBMUSCLE_int8
        type(LIBMUSCLE_Data) :: d1, d2
        integer :: xi, err_code
        logical :: l1
        character(len=:), allocatable :: c1, err_msg
        integer (int1) :: xi1
        integer (int2) :: xi2
        integer (int4) :: xi4
        integer (int8) :: xi8
        real (LIBMUSCLE_real4) :: xr4
        real (LIBMUSCLE_real8) :: xr8

        print *, '[  RUN     ] data.nil'
        d1 = LIBMUSCLE_Data_create()
        call assert_true(LIBMUSCLE_Data_is_nil(d1))
        call assert_false(LIBMUSCLE_Data_is_a_int4(d1))
        call LIBMUSCLE_Data_set(d1, 10)
        call assert_false(LIBMUSCLE_Data_is_nil(d1))
        call LIBMUSCLE_Data_set_nil(d1)
        call assert_true(LIBMUSCLE_Data_is_nil(d1))
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.nil'

        print *, '[  RUN     ] data.logical'
        d1 = LIBMUSCLE_Data_create(.true.)
        call assert_true(LIBMUSCLE_Data_is_a_logical(d1))
        call assert_false(LIBMUSCLE_Data_is_a_int4(d1))
        l1 = LIBMUSCLE_Data_as_logical(d1)
        call assert_eq_logical(l1, .true.)
        c1 = LIBMUSCLE_Data_as_character(d1, err_code, err_msg)
        call assert_eq_integer(err_code, LIBMUSCLE_runtime_error)
        deallocate(err_msg)
        call LIBMUSCLE_Data_set(d1, .false.)
        call assert_eq_logical(LIBMUSCLE_Data_as_logical(d1), .false.)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.logical'

        print *, '[  RUN     ] data.character'
        d1 = LIBMUSCLE_Data_create('Testing')
        call assert_true(LIBMUSCLE_Data_is_a_character(d1))
        call assert_false(LIBMUSCLE_Data_is_a_logical(d1))
        c1 = LIBMUSCLE_Data_as_character(d1)
        call assert_eq_character(c1, 'Testing')
        deallocate(c1)
        xi4 = LIBMUSCLE_Data_as_int4(d1, err_code)
        call assert_eq_int4(err_code, LIBMUSCLE_runtime_error)
        call LIBMUSCLE_Data_set(d1, 'Something else')
        c1 = LIBMUSCLE_Data_as_character(d1)
        call assert_eq_character(LIBMUSCLE_Data_as_character(d1), 'Something else')
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.character'

        print *, '[  RUN     ] data.integer'
        d1 = LIBMUSCLE_Data_create(13)
        call assert_true(LIBMUSCLE_Data_is_a_int(d1))
        call assert_false(LIBMUSCLE_Data_is_a_logical(d1))
        xi = LIBMUSCLE_Data_as_int(d1)
        call assert_eq_integer(xi, 13)
        call LIBMUSCLE_Data_set(d1, 242424)
        call assert_eq_integer(LIBMUSCLE_Data_as_int(d1), 242424)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.integer'

        print *, '[  RUN     ] data.int1'
        d1 = LIBMUSCLE_Data_create(121_int1)
        call assert_true(LIBMUSCLE_Data_is_a_int1(d1))
        call assert_true(LIBMUSCLE_Data_is_a_int4(d1))
        call assert_false(LIBMUSCLE_Data_is_a_character(d1))
        xi1 = LIBMUSCLE_Data_as_int1(d1)
        call assert_eq_int1(xi1, 121_int1)
        call LIBMUSCLE_Data_set(d1, 43_int1)
        call assert_eq_int1(LIBMUSCLE_Data_as_int1(d1), 43_int1)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.int1'

        print *, '[  RUN     ] data.int2'
        d1 = LIBMUSCLE_Data_create(1313_int2)
        call assert_true(LIBMUSCLE_Data_is_a_int2(d1))
        xi2 = LIBMUSCLE_Data_as_int2(d1)
        call assert_eq_int2(xi2, 1313_int2)
        call LIBMUSCLE_Data_set(d1, 24242_int2)
        call assert_eq_int2(LIBMUSCLE_Data_as_int2(d1), 24242_int2)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.int2'

        print *, '[  RUN     ] data.int8'
        d1 = LIBMUSCLE_Data_create(131313131313131313_int8)
        call assert_true(LIBMUSCLE_Data_is_a_int8(d1))
        call assert_false(LIBMUSCLE_Data_is_a_character(d1))
        xi8 = LIBMUSCLE_Data_as_int8(d1)
        call assert_eq_int8(xi8, 131313131313131313_int8)
        call LIBMUSCLE_Data_set(d1, 242424242424242424_int8)
        call assert_eq_int8(LIBMUSCLE_Data_as_int8(d1), 242424242424242424_int8)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.int8'

        print *, '[  RUN     ] data.real4'
        d1 = LIBMUSCLE_Data_create(42.0)
        call assert_true(LIBMUSCLE_Data_is_a_real4(d1))
        call assert_false(LIBMUSCLE_Data_is_a_int(d1))
        xr4 = LIBMUSCLE_Data_as_real4(d1)
        call assert_eq_real4(xr4, 42.0)
        call LIBMUSCLE_Data_set(d1, 3.1415926536)
        call assert_eq_real4(LIBMUSCLE_Data_as_real4(d1), 3.1415926536)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.real4'

        print *, '[  RUN     ] data.real8'
        d1 = LIBMUSCLE_Data_create(42.0d0)
        call assert_true(LIBMUSCLE_Data_is_a_real8(d1))
        call assert_false(LIBMUSCLE_Data_is_a_real4(d1))
        xr8 = LIBMUSCLE_Data_as_real8(d1)
        call assert_eq_real8(xr8, 42.0d0)
        call LIBMUSCLE_Data_set(d1, 3.1415926536d0)
        call assert_eq_real8(LIBMUSCLE_Data_as_real8(d1), 3.1415926536d0)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.real8'
    end subroutine test_data_basic_types

    subroutine test_data_settings
        use ymmsl
        use libmuscle

        implicit none
        integer :: err_code
        type(YMMSL_Settings) :: s1, s2, s3
        type(LIBMUSCLE_Data) :: d1, d2

        print *, '[  RUN     ] data.settings'
        s1 = YMMSL_Settings_create()
        call YMMSL_Settings_set(s1, 'key', 'value')
        d1 = LIBMUSCLE_Data_create(s1)
        d2 = LIBMUSCLE_Data_create(1000)

        call assert_true(LIBMUSCLE_Data_is_a_settings(d1))
        call assert_false(LIBMUSCLE_Data_is_a_settings(d2))

        s2 = LIBMUSCLE_Data_as_settings(d1, err_code)
        call assert_eq_integer(err_code, LIBMUSCLE_success)
        call assert_eq_character(YMMSL_Settings_get_as_character(s2, 'key'), 'value')

        s3 = LIBMUSCLE_Data_as_settings(d2, err_code)
        call assert_eq_integer(err_code, LIBMUSCLE_runtime_error)

        call YMMSL_Settings_free(s1)
        call YMMSL_Settings_free(s2)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.settings'
    end subroutine test_data_settings

    subroutine test_data_copy_assign
        use libmuscle

        implicit none
        type(LIBMUSCLE_Data) :: d1, d2

        print *, '[  RUN     ] data.copy_constructor'
        d1 = LIBMUSCLE_Data_create(42.0d0)
        d2 = LIBMUSCLE_Data_create(d1)
        call LIBMUSCLE_Data_free(d1)
        call assert_true(LIBMUSCLE_Data_is_a_real8(d2))
        call assert_false(LIBMUSCLE_Data_is_a_real4(d2))
        call LIBMUSCLE_Data_free(d2)
        print *, '[       OK ] data.copy_constructor'

        print *, '[  RUN     ] data.assign'
        d1 = LIBMUSCLE_Data_create(42.0d0)
        d2 = LIBMUSCLE_Data_create()
        call LIBMUSCLE_Data_set(d2, d1)
        call LIBMUSCLE_Data_free(d1)
        call assert_true(LIBMUSCLE_Data_is_a_real8(d2))
        call assert_false(LIBMUSCLE_Data_is_a_real4(d2))
        call LIBMUSCLE_Data_free(d2)
        print *, '[       OK ] data.assign'
    end subroutine test_data_copy_assign

    subroutine test_data_dict
        use libmuscle

        implicit none
        integer, parameter :: int1 = LIBMUSCLE_int1
        integer, parameter :: int2 = LIBMUSCLE_int2
        integer, parameter :: int4 = LIBMUSCLE_int4
        integer, parameter :: int8 = LIBMUSCLE_int8
        integer, parameter :: sz = LIBMUSCLE_size
        type(LIBMUSCLE_Data) :: d1, d2

        print *, '[  RUN     ] data.dict'
        d1 = LIBMUSCLE_Data_create_dict()
        call assert_true(LIBMUSCLE_Data_is_a_dict(d1))
        call LIBMUSCLE_Data_set_item(d1, 'key1', 1)
        call assert_eq_size(LIBMUSCLE_Data_size(d1), 1_sz)

        call LIBMUSCLE_Data_set_item(d1, 'key1', .true.)
        d2 = LIBMUSCLE_Data_get_item(d1, 'key1')
        call assert_true(LIBMUSCLE_Data_as_logical(d2))
        call LIBMUSCLE_Data_free(d2)

        call LIBMUSCLE_Data_set_item(d1, 'key2', 'test')
        d2 = LIBMUSCLE_Data_get_item(d1, 'key2')
        call assert_eq_character(LIBMUSCLE_Data_as_character(d2), 'test')
        call LIBMUSCLE_Data_free(d2)

        call LIBMUSCLE_Data_set_item(d1, 'key1', 63_int1)
        d2 = LIBMUSCLE_Data_get_item(d1, 'key1')
        call assert_eq_int1(LIBMUSCLE_Data_as_int1(d2), 63_int1)
        call LIBMUSCLE_Data_free(d2)

        call LIBMUSCLE_Data_set_item(d1, 'key1', 30000_int2)
        d2 = LIBMUSCLE_Data_get_item(d1, 'key1')
        call assert_eq_int2(LIBMUSCLE_Data_as_int2(d2), 30000_int2)
        call LIBMUSCLE_Data_free(d2)

        call LIBMUSCLE_Data_set_item(d1, 'key2', 1000030000_int4)
        d2 = LIBMUSCLE_Data_get_item(d1, 'key2')
        call assert_eq_int4(LIBMUSCLE_Data_as_int4(d2), 1000030000_int4)
        call LIBMUSCLE_Data_free(d2)

        call assert_eq_character(LIBMUSCLE_Data_key(d1, 1_sz), 'key1')
        d2 = LIBMUSCLE_Data_value(d1, 1_sz)
        call assert_eq_int2(LIBMUSCLE_Data_as_int2(d2), 30000_int2)
        call LIBMUSCLE_Data_free(d2)

        call assert_eq_character(LIBMUSCLE_Data_key(d1, 2_sz), 'key2')
        d2 = LIBMUSCLE_Data_value(d1, 2_sz)
        call assert_eq_int4(LIBMUSCLE_Data_as_int(d2), 1000030000_int4)
        call LIBMUSCLE_Data_free(d2)

        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.dict'
    end subroutine test_data_dict

    subroutine test_data_list
        use libmuscle

        implicit none
        integer, parameter :: int1 = LIBMUSCLE_int1
        integer, parameter :: int2 = LIBMUSCLE_int2
        integer, parameter :: int4 = LIBMUSCLE_int4
        integer, parameter :: int8 = LIBMUSCLE_int8
        integer, parameter :: sz = LIBMUSCLE_size
        integer, parameter :: real4 = selected_real_kind(6)
        integer, parameter :: real8 = selected_real_kind(15)
        type(LIBMUSCLE_Data) :: d1, d2

        print *, '[  RUN     ] data.list'
        d1 = LIBMUSCLE_Data_create_list()
        call assert_true(LIBMUSCLE_Data_is_a_list(d1))
        call assert_false(LIBMUSCLE_Data_is_a_real4(d1))
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.list'

        print *, '[  RUN     ] data.nils'
        d1 = LIBMUSCLE_Data_create_nils(100_sz)
        call assert_true(LIBMUSCLE_Data_is_a_list(d1))
        call assert_false(LIBMUSCLE_Data_is_a_real4(d1))
        call assert_eq_size(LIBMUSCLE_Data_size(d1), 100_sz)
        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.nils'

        print *, '[  RUN     ] data.list_get_item'
        d1 = LIBMUSCLE_Data_create_nils(10_sz)
        d2 = LIBMUSCLE_Data_get_item(d1, 1_sz)
        call assert_true(LIBMUSCLE_Data_is_nil(d2))
        call LIBMUSCLE_Data_free(d1)
        call LIBMUSCLE_Data_free(d2)
        print *, '[       OK ] data.list_get_item'

        print *, '[  RUN     ] data.list_set_item'
        d1 = LIBMUSCLE_Data_create_nils(9_sz)
        call LIBMUSCLE_Data_set_item(d1, 1_sz, .true.)
        call LIBMUSCLE_Data_set_item(d1, 2_sz, 'Testing')
        call LIBMUSCLE_Data_set_item(d1, 3_sz, 42_int1)
        call LIBMUSCLE_Data_set_item(d1, 4_sz, 6565_int2)
        call LIBMUSCLE_Data_set_item(d1, 5_sz, 1313131313_int4)
        call LIBMUSCLE_Data_set_item(d1, 6_sz, 100100100100100_int8)
        call LIBMUSCLE_Data_set_item(d1, 7_sz, 12.34_real4)
        call LIBMUSCLE_Data_set_item(d1, 8_sz, 56.78901234_real8)
        d2 = LIBMUSCLE_Data_create_dict()
        call LIBMUSCLE_Data_set_item(d1, 9_sz, d2)
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 1_sz)
        call assert_true(LIBMUSCLE_Data_as_logical(d2))
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 2_sz)
        call assert_eq_character(LIBMUSCLE_Data_as_character(d2), 'Testing')
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 3_sz)
        call assert_eq_int1(LIBMUSCLE_Data_as_int1(d2), 42_int1)
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 4_sz)
        call assert_eq_int2(LIBMUSCLE_Data_as_int2(d2), 6565_int2)
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 5_sz)
        call assert_eq_int4(LIBMUSCLE_Data_as_int4(d2), 1313131313_int4)
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 6_sz)
        call assert_eq_int8(LIBMUSCLE_Data_as_int8(d2), 100100100100100_int8)
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 7_sz)
        call assert_eq_real4(LIBMUSCLE_Data_as_real4(d2), 12.34_real4)
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 8_sz)
        call assert_eq_real8(LIBMUSCLE_Data_as_real8(d2), 56.78901234_real8)
        call LIBMUSCLE_Data_free(d2)

        d2 = LIBMUSCLE_Data_get_item(d1, 9_sz)
        call assert_true(LIBMUSCLE_Data_is_a_dict(d2))
        call assert_eq_int8(LIBMUSCLE_Data_size(d2), 0_sz)
        call LIBMUSCLE_Data_free(d2)

        call LIBMUSCLE_Data_free(d1)
        print *, '[       OK ] data.list_set_item'
    end subroutine test_data_list

    subroutine test_data_grid
        use libmuscle

        implicit none
        integer, parameter :: int4 = LIBMUSCLE_int4
        integer, parameter :: int8 = LIBMUSCLE_int8
        integer, parameter :: sz = LIBMUSCLE_size
        integer, parameter :: real4 = LIBMUSCLE_real4
        integer, parameter :: real8 = LIBMUSCLE_real8

        logical, dimension(3) :: ad1, ad1_b
        logical, dimension(2, 2, 2, 2, 2, 2, 2) :: ad7, ad7_b
        integer (int4), dimension(1, 2, 1, 1, 1) :: ai45, ai45_b
        integer (int8), dimension(2, 3, 4) :: ai83, ai83_b
        real (real4), dimension(2, 3) :: ar42, ar42_b
        real (real8), dimension(2, 2, 2, 2, 2, 3) :: ar86, ar86_b

        integer (sz), dimension(7) :: shp

        type(LIBMUSCLE_DataConstRef) :: d1
        type(LIBMUSCLE_Data) :: d2

        print *, '[  RUN     ] data.create_grid'
        ad1 = (/.true., .false., .false./)
        d1 = LIBMUSCLE_DataConstRef_create_grid(ad1)
        call assert_true(LIBMUSCLE_DataConstRef_is_a_grid_of_logical(d1))
        call assert_false(LIBMUSCLE_DataConstRef_is_a_grid_of_int4(d1))
        call assert_eq_size(LIBMUSCLE_DataConstRef_num_dims(d1), 1_sz)
        call LIBMUSCLE_DataConstRef_shape(d1, shp)
        call assert_eq_size(shp(1), 3_sz)
        call assert_false(LIBMUSCLE_DataConstRef_has_indexes(d1))
        call LIBMUSCLE_DataConstRef_elements(d1, ad1_b)
        call assert_true(all(ad1_b .eqv. ad1))
        call LIBMUSCLE_DataConstRef_free(d1)

        ad7 = reshape(spread(.true., 1, 128), (/2, 2, 2, 2, 2, 2, 2/))
        d1 = LIBMUSCLE_DataConstRef_create_grid(ad7)
        call assert_true(LIBMUSCLE_DataConstRef_is_a_grid_of_logical(d1))
        call assert_false(LIBMUSCLE_DataConstRef_is_a_dict(d1))
        call assert_eq_size(LIBMUSCLE_DataConstRef_num_dims(d1), 7_sz)
        call LIBMUSCLE_DataConstRef_shape(d1, shp)
        call assert_true(all(shp .eq. (/2, 2, 2, 2, 2, 2, 2/)))
        call assert_false(LIBMUSCLE_DataConstRef_has_indexes(d1))
        call LIBMUSCLE_DataConstRef_elements(d1, ad7_b)
        call assert_true(all(ad7 .eqv. ad7_b))
        call LIBMUSCLE_DataConstRef_free(d1)

        ai45 = reshape((/13_int4, 42_int4/), (/1, 2, 1, 1, 1/))
        d1 = LIBMUSCLE_DataConstRef_create_grid(ai45)
        call assert_true(LIBMUSCLE_DataConstRef_is_a_grid_of_int4(d1))
        call assert_false(LIBMUSCLE_DataConstRef_is_a_int4(d1))
        call assert_eq_size(LIBMUSCLE_DataConstRef_num_dims(d1), 5_sz)
        call LIBMUSCLE_DataConstRef_shape(d1, shp)
        call assert_true(all(shp(1:5) .eq. (/1, 2, 1, 1, 1/)))
        call assert_false(LIBMUSCLE_DataConstRef_has_indexes(d1))
        call LIBMUSCLE_DataConstRef_elements(d1, ai45_b)
        call assert_true(all(ai45 .eq. ai45_b))
        call LIBMUSCLE_DataConstRef_free(d1)

        ai83 = reshape(spread((/7_int8, -3_int8/), 1, 12), (/2, 3, 4/))
        d1 = LIBMUSCLE_DataConstRef_create_grid(ai83)
        call assert_true(LIBMUSCLE_DataConstRef_is_a_grid_of_int8(d1))
        call assert_false(LIBMUSCLE_DataConstRef_is_a_character(d1))
        call assert_eq_size(LIBMUSCLE_DataConstRef_num_dims(d1), 3_sz)
        call LIBMUSCLE_DataConstRef_shape(d1, shp)
        call assert_true(all(shp(1:3) .eq. (/2, 3, 4/)))
        call assert_false(LIBMUSCLE_DataConstRef_has_indexes(d1))
        call LIBMUSCLE_DataConstRef_elements(d1, ai83_b)
        call assert_true(all(ai83 .eq. ai83_b))
        call LIBMUSCLE_DataConstRef_free(d1)

        ar42 = reshape(spread((/3.3_real4, -7.6_real4/), 1, 3), (/2, 3/))
        d1 = LIBMUSCLE_DataConstRef_create_grid(ar42)
        call assert_true(LIBMUSCLE_DataConstRef_is_a_grid_of_real4(d1))
        call assert_false(LIBMUSCLE_DataConstRef_is_a_logical(d1))
        call assert_eq_size(LIBMUSCLE_DataConstRef_num_dims(d1), 2_sz)
        call LIBMUSCLE_DataConstRef_shape(d1, shp)
        call assert_true(all(shp(1:2) .eq. (/2, 3/)))
        call assert_false(LIBMUSCLE_DataConstRef_has_indexes(d1))
        call LIBMUSCLE_DataConstRef_elements(d1, ar42_b)
        call assert_true(all(ar42 .eq. ar42_b))
        call LIBMUSCLE_DataConstRef_free(d1)

        ar86 = reshape(spread(3.14_real8, 1, 96), (/2, 2, 2, 2, 2, 3/))
        d1 = LIBMUSCLE_DataConstRef_create_grid(ar86)
        call assert_true(LIBMUSCLE_DataConstRef_is_a_grid_of_real8(d1))
        call assert_false(LIBMUSCLE_DataConstRef_is_a_byte_array(d1))
        call assert_eq_size(LIBMUSCLE_DataConstRef_num_dims(d1), 6_sz)
        call LIBMUSCLE_DataConstRef_shape(d1, shp)
        call assert_true(all(shp(1:6) .eq. (/2, 2, 2, 2, 2, 3/)))
        call assert_false(LIBMUSCLE_DataConstRef_has_indexes(d1))
        call LIBMUSCLE_DataConstRef_elements(d1, ar86_b)
        call assert_true(all(ar86 .eq. ar86_b))
        call LIBMUSCLE_DataConstRef_free(d1)

        ! Data instead of DataConstRef
        ai83 = reshape(spread((/7_int8, -3_int8/), 1, 12), (/2, 3, 4/))
        d2 = LIBMUSCLE_Data_create_grid(ai83)
        call assert_true(LIBMUSCLE_Data_is_a_grid_of_int8(d2))
        call assert_false(LIBMUSCLE_Data_is_a_character(d2))
        call assert_eq_size(LIBMUSCLE_Data_num_dims(d2), 3_sz)
        call LIBMUSCLE_Data_shape(d2, shp)
        call assert_true(all(shp(1:3) .eq. (/2, 3, 4/)))
        call assert_false(LIBMUSCLE_Data_has_indexes(d2))
        call LIBMUSCLE_Data_elements(d2, ai83_b)
        call assert_true(all(ai83 .eq. ai83_b))
        call LIBMUSCLE_Data_free(d2)

        ! Indexes
        ar42 = reshape(spread((/3.3_real4, -7.6_real4/), 1, 3), (/2, 3/))
        d1 = LIBMUSCLE_DataConstRef_create_grid(ar42, 'x', 'y')
        call assert_true(LIBMUSCLE_DataConstRef_is_a_grid_of_real4(d1))
        call assert_false(LIBMUSCLE_DataConstRef_is_a_logical(d1))
        call assert_eq_size(LIBMUSCLE_DataConstRef_num_dims(d1), 2_sz)
        call LIBMUSCLE_DataConstRef_shape(d1, shp)
        call assert_true(all(shp(1:2) .eq. (/2, 3/)))
        call assert_true(LIBMUSCLE_DataConstRef_has_indexes(d1))
        call assert_eq_character(LIBMUSCLE_DataConstRef_index(d1, 1_sz), 'x')
        call assert_eq_character(LIBMUSCLE_DataConstRef_index(d1, 2_sz), 'y')
        call LIBMUSCLE_DataConstRef_elements(d1, ar42_b)
        call assert_true(all(ar42 .eq. ar42_b))
        call LIBMUSCLE_DataConstRef_free(d1)

        print *, '[       OK ] data.create_grid'
    end subroutine test_data_grid

    subroutine test_data_byte_array
        use libmuscle

        implicit none
        integer, parameter :: sz = LIBMUSCLE_size
        character(len=1), dimension(1024) :: bytes
        character(len=1), dimension(:), allocatable :: buf
        integer :: i, err_code
        type(LIBMUSCLE_Data) :: d1

        print *, '[  RUN     ] data.byte_array'
        d1 = LIBMUSCLE_Data_create_byte_array(1024_sz)
        call assert_true(LIBMUSCLE_Data_is_a_byte_array(d1))
        call assert_false(LIBMUSCLE_Data_is_a_int(d1))
        call assert_eq_size(LIBMUSCLE_Data_size(d1), 1024_sz)

        allocate(buf(LIBMUSCLE_Data_size(d1)))
        call LIBMUSCLE_Data_as_byte_array(d1, buf, err_code)
        call assert_eq_integer(err_code, LIBMUSCLE_success)
        deallocate(buf)

        call LIBMUSCLE_Data_free(d1)

        do i = 1, 1024
            bytes(i) = achar(mod(i, 256))
        end do

        d1 = LIBMUSCLE_Data_create_byte_array(bytes)
        call assert_true(LIBMUSCLE_Data_is_a_byte_array(d1))
        call assert_false(LIBMUSCLE_Data_is_a_int(d1))
        call assert_eq_size(LIBMUSCLE_Data_size(d1), 1024_sz)

        allocate(buf(LIBMUSCLE_Data_size(d1)))
        call LIBMUSCLE_Data_as_byte_array(d1, buf, err_code)
        call assert_eq_integer(err_code, LIBMUSCLE_success)

        do i = 1, 1024
            call assert_eq_integer(mod(i, 256), ichar(buf(i)))
        end do
        deallocate(buf)

        call LIBMUSCLE_Data_free(d1)

        print *, '[       OK ] data.byte_array'
    end subroutine test_data_byte_array
end module tests

program test_data
    use tests
    implicit none

    print *, ''
    print *, '[==========] Fortran API Data'

    call test_data_basic_types
    call test_data_copy_assign
    call test_data_dict
    call test_data_list
    call test_data_grid
    call test_data_byte_array
    call test_data_settings

    print *, '[==========] Fortran API Data'
    print *, '[  PASSED  ] Fortran API Data'
    print *, ''
end program test_data


text:
! ------------------------------------------------------------------------------
! Copyright (c) 2009-13, Thomas P. Robitaille
!
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
!  * Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
!
!  * Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ------------------------------------------------------------------------------

module base_types

  implicit none

  integer,parameter :: idp = selected_int_kind(13)
  integer,parameter :: sp = selected_real_kind(p=6,r=37)
  integer,parameter :: dp = selected_real_kind(p=15,r=307)

end module base_types

max_stars_repo_name: jfitz/code-stat

max_issues_repo_name: jfitz/code-stat

max_forks_repo_name: jfitz/code-stat


!
!  Copyright (C) 2013, Northwestern University
!  See COPYRIGHT notice in top-level directory.
!

      !----< write_savefile >------------------------------------------
      subroutine write_savefile
          ! writes data file for post-processing and restarting
          use mpi
          use runtime_m,      only: time, time_ref, run_title
          use io_profiling_m, only: dir_path
          use pnetcdf_m,      only: pnetcdf_write
          implicit none

          ! local variables
          character*10  time_ext
          character*256 filename

          ! set file extension string
          write(time_ext,'(1pe10.3)') time*time_ref

          ! set file name
          filename = trim(dir_path)//'/'//trim(run_title)//'.'// &
                     trim(adjustl(time_ext))//'.field.nc'

          ! call PnetCDF APIs to write data to file
          call pnetcdf_write(filename)

      end subroutine write_savefile

      !----< read_savefile >-------------------------------------------
      subroutine read_savefile
          ! reads restart file
          use mpi
          use runtime_m,      only: time, time_ref, run_title
          use io_profiling_m, only: dir_path
          use pnetcdf_m,      only: pnetcdf_read
          use topology_m,     only : myid
          implicit none

          ! local variables
          character*10  time_ext
          character*256 filename
          logical exist

          ! set file extension strings
          write(time_ext,'(1pe10.3)') time*time_ref

          ! set file name
          filename = trim(dir_path)//'/'//trim(run_title)//'.'// &
                     trim(adjustl(time_ext))//'.field.nc'

          ! inquire about file existence
          inquire(file=trim(filename),exist=exist)
          if (.NOT. exist) then
              if (myid .EQ. 0) then
                  print*, 'restart file does not exist ', trim(filename)
                  print*, 'skip reading restart files'
              endif
              return
          endif

          ! call PnetCDF APIs to read data from file
          call pnetcdf_read(filename)

      end subroutine read_savefile


text:
      subroutine ptol(word,latt,mult,master,
     1                twiss,gammab,idp,dp,istr,nstr,lfno)
      use tfstk
      use ffs
c     Tor Raubenheimer's analytical estimation (SLAC-PUB-4937)
      use tffitcode
      use ffs_pointer, only:idelc,idvalc,idtypec
      implicit real*8(a-h,o-z)
      logical over,full
      character*(*) word,vo(4)*8,autofg*8,line*79,name*8
      complex*16 ct,cts,cc
      integer*8 latt(nlat),ip
      dimension twiss(nlat,-ndim:ndim,ntwissfun),gammab(nlat),
     1          istr(nstra,4),mult(nlat)
      dimension twisss(ntwissfun),t(10),tt(10),ct(5),cts(5),cc(5),a(10)
      integer*4 master(nlat)
      data ale/0.05/,ndiv/1/,lpmax/50/
      include 'inc/common.inc'
c
      full=.false.
      lp=0
      call getwdl(word)
      if(word.eq.'FULL') then
        full=.true.
        call getwdl(word)
      endif
      do 10 i=1,10
        t(i)=0d0
        tt(i)=0d0
  10  continue
      do 20 i=1,5
        ct(i)=(0d0,0d0)
        cts(i)=(0d0,0d0)
        cc(i)=(0d0,0d0)
  20  continue
      name=' '
      line=' '
      ts2=0d0
      ts4=0d0
      psix=twiss(nlat,idp,3)-twiss(1,idp,3)
      psiy=twiss(nlat,idp,6)-twiss(1,idp,6)
      psix2=0.5d0*psix
      psiy2=0.5d0*psiy
      a(1)=1d0
      a(3)=1d0/4d0
      a(5)=1d0/8d0
      a(6)=1d0/4d0
      a(7)=1d0/16d0
      a(8)=1d0/32d0
      a(9)=1d0/32d0
      ndivt=0
      vs=0.d0
      vsb=0.d0
      if(full) then
        write(lfno,'(2a)')'           <-------- Ey**2/By ------->',
     1                          '<----- Emiy/Emix (LC) ---->'
        write(lfno,'(2a)')' Element   rot_q**2 ym_s**2  yc**2/By ',
     1                          'rot_q**2 ym_s**2  yc**2/By '
      endif
      do 100 j=0,nstr
        if(j.eq.0) then
          is=1
          if(nstr.eq.0) then
            if=nlat-1
          else
            if=max(1,istr(istr(1,2),1)-1)
          endif
        elseif(j.eq.nstr) then
          is=istr(istr(nstr,2),1)
          if=nlat-1
        else
          is=istr(istr(j,2),1)
          if=istr(istr(j+1,2),1)-1
        endif
        ida=0
        do 90 i=is,if
          if(idtypec(i).eq.icquad .or.
     1      idtypec(i).eq.icbend .or.
     1      idtypec(i).eq.icsext ) then
            id=idtypec(i)
            if(id.eq.icbend.and.
     $           rlist(idvalc(i)+8).eq.0d0)goto 90
            if(master(i).gt.0) then
              ndivt=max(ndivt,1)
              if(ida.eq.icbend .or. ida.eq.icquad) then
c10Oct93 vs was replaced with vv in the case of bend or quad.
c     (vsb=K1 of bend)
                if(ida.eq.icbend) then
                  vv=vsb
                else
                  vv=vs
                endif
                t(1)=t(1)+(vv*tt(1)/ndivt)**2
                t(2)=t(2)+vv*tt(2)/ndivt
                ct(1)=ct(1)+vv*cc(1)/ndivt
                t(6)=t(6)+(vv*tt(6)/ndivt)**2
                if(full) then
                  line(10:)=autofg((vv*tt(1)/ndivt)**2*a(1),'8.5')
                  line(37:)=autofg((vv*tt(6)/ndivt)**2*a(6),'8.5')
                endif
                tt(1)=0d0
                tt(2)=0d0
                cc(1)=(0d0,0d0)
                tt(6)=0d0
                ndivt=0
              elseif(ida.eq.icsext) then
                t(3)=t(3)+(vs*tt(3)/ndivt)**2
                t(4)=t(4)+vs*tt(4)/ndivt
                ct(2)=ct(2)+vs*cc(2)/ndivt
                t(7)=t(7)+(vs*tt(7)/ndivt)**2
                ct(3)=ct(3)+vs*cc(3)/ndivt
                ct(4)=ct(4)+vs*cc(4)/ndivt
                ct(5)=ct(5)+vs*cc(5)/ndivt
                if(full) then
                  line(19:)=autofg((vs*tt(3)/ndivt)**2*a(3),'8.5')
                  line(46:)=autofg((vs*tt(7)/ndivt)**2*a(7),'8.5')
                endif
                tt(3)=0d0
                tt(4)=0d0
                cc(2)=(0d0,0d0)
                tt(7)=0d0
                cc(3)=(0d0,0d0)
                cc(4)=(0d0,0d0)
                cc(5)=(0d0,0d0)
                ndivt=0
              endif
              if(full) then
                if(line(1:8).ne.' ') then
                  write(lfno,'(2a)')' ',line
                  lp=lp+1
                  if(lp.gt.lpmax) then
                    write(lfno,'(2a)')
     1               '           <-------- Ey**2/By ------->',
     1                          '<----- Emiy/Emix (LC) ---->'
                    write(lfno,'(2a)')
     1               ' Element   rot_q**2 ym_s**2  yc**2/By ',
     1                          'rot_q**2 ym_s**2  yc**2/By '
                    lp=0
                  endif
                endif
                call elname(i,name)
                line=name
              endif
              ida=idtypec(i)
            endif
            i1=i+1
            if(id.eq.icquad .or. id.eq.icbend) then
              tt(1)=tt(1)+0.5d0*(sqrt(twiss(i,idp,5))*twiss(i,idp,7)
     1                   +sqrt(twiss(i1,idp,5))*twiss(i1,idp,7))
              tt(2)=tt(2)-0.5d0*(twiss(i,idp,5)+twiss(i1,idp,5))
              cc(1)=cc(1)-0.5d0*(twiss(i,idp,5)*dcmplx(
     1               cos(2d0*twiss(i,idp,6)),sin(2d0*twiss(i,idp,6)))
     1                         +twiss(i1,idp,5)*dcmplx(
     1               cos(2d0*twiss(i1,idp,6)),sin(2d0*twiss(i1,idp,6))
     1                                                 ) )
              tt(6)=tt(6)+0.5d0*(sqrt(twiss(i,idp,2)*twiss(i,idp,5))
     1                         +sqrt(twiss(i1,idp,2)*twiss(i1,idp,5)))
            elseif(id.eq.icsext) then
              psi1=twiss(i,idp,3)+2d0*twiss(i,idp,6)
              psi2=twiss(i,idp,3)-2d0*twiss(i,idp,6)
              psi11=twiss(i1,idp,3)+2d0*twiss(i1,idp,6)
              psi21=twiss(i1,idp,3)-2d0*twiss(i1,idp,6)
              tt(3)=tt(3)+0.5d0*(sqrt(twiss(i,idp,5))*twiss(i,idp,7)
     1                         +sqrt(twiss(i1,idp,5))*twiss(i1,idp,7))
              tt(4)=tt(4)+0.5d0*(twiss(i,idp,5)*twiss(i,idp,7)
     1                         +twiss(i1,idp,5)*twiss(i1,idp,7))
              cc(2)=cc(2)+0.5d0*twiss(i,idp,5)*twiss(i,idp,7)*
     1         dcmplx(cos(2d0*twiss(i,idp,6)),sin(2d0*twiss(i,idp,6)))
     1                   +0.5d0*twiss(i1,idp,5)*twiss(i1,idp,7)*
     1         dcmplx(cos(2d0*twiss(i1,idp,6)),sin(2d0*twiss(i1,idp,6)))
              tt(7)=tt(7)+0.5d0*(sqrt(twiss(i,idp,2)*twiss(i,idp,5))
     1                         +sqrt(twiss(i1,idp,2)*twiss(i1,idp,5)))
              cc(3)=cc(3)+0.5d0*sqrt(twiss(i,idp,2))*twiss(i,idp,5)
     1              *dcmplx(cos(psi1),sin(psi1))
     1                   +0.5d0*sqrt(twiss(i1,idp,2))*twiss(i1,idp,5)
     1              *dcmplx(cos(psi11),sin(psi11))
              cc(4)=cc(4)+0.5d0*sqrt(twiss(i,idp,2))*twiss(i,idp,5)
     1              *dcmplx(cos(psi2),sin(psi2))
     1                   +0.5d0*sqrt(twiss(i1,idp,2))*twiss(i1,idp,5)
     1              *dcmplx(cos(psi21),sin(psi21))
              cc(5)=cc(5)+0.5d0*sqrt(twiss(i,idp,2))*twiss(i,idp,5)
     1              *dcmplx(cos(twiss(i,idp,3)),sin(twiss(i,idp,3)))
     1                   +0.5d0*sqrt(twiss(i1,idp,2))*twiss(i1,idp,5)
     1              *dcmplx(cos(twiss(i1,idp,3)),sin(twiss(i1,idp,3)))
            endif
            ip=latt(i)
c           ip=idvalc(i)
            als=rlist(ip+1)
            vs=rlist(ip+2)
            vsa=rlist(idvalc(i)+2)
            vsb=rlist(ip+8)
            e2s=rlist(ip+4)
            ndiv=min(1,int(als/ale)-1)
            ndivt=ndivt+ndiv+1
            do 60 k=1,ntwissfun
              twisss(k)=twiss(i+1,idp,k)
   60       continue
            do 70 n=1,ndiv
              rn=dble(n)/(ndiv+1)
              rlist(ip+1)=als*rn
              if(id .eq. icbend)then
                rlist(idvalc(i)+2)=vsa*rn
                rlist(ip+2)=vs*rn
                rlist(ip+4)=0.d0
                rlist(ip+8)=vsb*rn
              else
                rlist(ip+2)=vs*rn
              endif
              call qtwiss(twiss,idp,i,i+1,over)
              if(id.eq.icquad.or.id.eq.icbend) then
                tt(1)=tt(1)+sqrt(twiss(i1,idp,5))*twiss(i1,idp,7)
                tt(2)=tt(2)-twiss(i1,idp,5)
                cc(1)=cc(1)-twiss(i1,idp,5)*dcmplx(
     1             cos(2d0*twiss(i1,idp,6)),sin(2d0*twiss(i1,idp,6)))
                tt(6)=tt(6)+sqrt(twiss(i1,idp,2)*twiss(i1,idp,5))
              elseif(id.eq.icsext) then
                psi1=twiss(i1,idp,3)+2d0*twiss(i1,idp,6)
                psi2=twiss(i1,idp,3)-2d0*twiss(i1,idp,6)
                tt(3)=tt(3)+sqrt(twiss(i1,idp,5))*twiss(i1,idp,7)
                tt(4)=tt(4)+twiss(i1,idp,5)*twiss(i1,idp,7)
                cc(2)=cc(2)+twiss(i1,idp,5)*twiss(i1,idp,7)*dcmplx(
     1            cos(2d0*twiss(i1,idp,6)),sin(2d0*twiss(i1,idp,6)))
                tt(7)=tt(7)+sqrt(twiss(i1,idp,2)*twiss(i1,idp,5))
                cc(3)=cc(3)+sqrt(twiss(i1,idp,2))*twiss(i1,idp,5)
     1                *dcmplx(cos(psi1),sin(psi1))
                cc(4)=cc(4)+sqrt(twiss(i1,idp,2))*twiss(i1,idp,5)
     1                *dcmplx(cos(psi2),sin(psi2))
                cc(5)=cc(5)+sqrt(twiss(i1,idp,2))*twiss(i1,idp,5)
     1                *dcmplx(cos(twiss(i1,idp,3)),sin(twiss(i1,idp,3)))
              endif
   70       continue
            rlist(ip+1)=als
            if(id .eq. icbend)then
              rlist(ip+2)=vs
              rlist(idvalc(i)+2)=vsa
              rlist(ip+4)=e2s
              rlist(ip+8)=vsb
            else
              rlist(ip+2)=vs
            endif
            do 80 k=1,ntwissfun
              twiss(i+1,idp,k)=twisss(k)
  80        continue
          endif
   90   continue
        if(j.eq.0 .and. nstr.ne.0) then
          do 91 k=1,5
            cts(k)=ct(k)
   91     continue
          ts2=t(2)
          ts4=t(4)
        elseif(j.eq.nstr) then
          t(5)=t(5)+(ts2+ts4+t(2)+t(4))**2
     1                 +abs(cts(1)+cts(2)+ct(1)+ct(2))**2
          t(8)=t(8)+abs(cts(3)+ct(3))**2+abs(cts(5)+ct(5))**2
          t(9)=t(9)+abs(cts(4)+ct(4))**2+abs(cts(5)+ct(5))**2
          if(full) then
            sum1=((ts2+ts4+t(2)+t(4))**2
     1            +abs(cts(1)+cts(2)+ct(1)+ct(2))**2)*a(5)
            sum2=(abs(cts(3)+ct(3))**2 +abs(cts(5)+ct(5))**2)*a(8)
     1          +(abs(cts(4)+ct(4))**2 +abs(cts(5)+ct(5))**2)*a(9)
          endif
        else
          t(5)=t(5)+(t(2)+t(4))**2+abs(ct(1)+ct(2))**2
          t(8)=t(8)+abs(ct(3))**2+abs(ct(5))**2
          t(9)=t(9)+abs(ct(4))**2+abs(ct(5))**2
          if(full) then
            sum1=((t(2)+t(4))**2+abs(ct(1)+ct(2))**2)*a(5)
            sum2= (abs(ct(3))**2+abs(ct(5))**2)*a(8)
     1           +(abs(ct(4))**2+abs(ct(5))**2)*a(9)
          endif
        endif
        if(full) then
          if(j.ne.0 .or. nstr.eq.0) then
            if(line.ne.' ') then
              if(ida.eq.icbend .or. ida.eq.icquad ) then
                if(ida.eq.icbend) then
                  vv=vsb
                else
                  vv=vs
                endif
                t(1)=t(1)+(vv*tt(1)/ndivt)**2
                t(2)=t(2)+vv*tt(2)/ndivt
                ct(1)=ct(1)+vv*cc(1)/ndivt
                t(6)=t(6)+(vv*tt(6)/ndivt)**2
                line(10:)=autofg((vv*tt(1)/ndivt)**2*a(1),'8.5')
                line(37:)=autofg((vv*tt(6)/ndivt)**2*a(6),'8.5')
                write(lfno,'(2a)')' ',line
                line=' '
                tt(1)=0d0
                tt(2)=0d0
                cc(1)=(0d0,0d0)
                tt(6)=0d0
                ndivt=0
              elseif(ida.eq.icsext) then
                t(3)=t(3)+(vs*tt(3)/ndivt)**2
                t(4)=t(4)+vs*tt(4)/ndivt
                ct(2)=ct(2)+vs*cc(2)/ndivt
                t(7)=t(7)+(vs*tt(7)/ndivt)**2
                ct(3)=ct(3)+vs*cc(3)/ndivt
                ct(4)=ct(4)+vs*cc(4)/ndivt
                ct(5)=ct(5)+vs*cc(5)/ndivt
                line(19:)=autofg((vs*tt(3)/ndivt)**2*a(3),'8.5')
                line(46:)=autofg((vs*tt(7)/ndivt)**2*a(7),'8.5')
                write(lfno,'(2a)')' ',line
                line=' '
                tt(3)=0d0
                tt(4)=0d0
                cc(2)=(0d0,0d0)
                tt(7)=0d0
                cc(3)=(0d0,0d0)
                cc(4)=(0d0,0d0)
                cc(5)=(0d0,0d0)
                ndivt=0
              endif
            endif
            call elname(if+1,name)
            line=name
            line(28:)=autofg(sum1,'8.5')
            line(55:)=autofg(sum2,'8.5')
            write(lfno,'(2a)')' ',line
            line=' '
          endif
        endif
        do 92 k=1,5
          ct(k)=(0d0,0d0)
   92   continue
        t(2)=0d0
        t(4)=0d0
  100 continue
c
c ===== Dispersion =====
c ----- Emittance produced by dispersion
      write(lfno,'(a)')' <<< Emittance produced by disersion >>>'
      write(lfno,'(a)')' Emiy = 2Je/Jy(dE/E)^2 Ey**2/By.'
      write(lfno,'(a)')' Ey**2/By :'
c ----- dispersion due to Quad rotation
      vo(1)=autofg(t(1),'8.5')
      write(lfno,'(a)')' --- due to Quad rotation ---'
      write(lfno,'(3a)')' Ey**2/By=',vo(1),
     1                        ' /(2 Sin(Pi nu_y)**2) dtheta(quad)**2'
c ----- dispersion due to Sext misalign
      vo(2)=autofg(t(3)/4d0,'8.5')
      write(lfno,'(a)')' --- due to Sext misalignment ---'
      write(lfno,'(3a)')' Ey**2/By=',vo(2),
     1                        ' /(2 Sin(Pi nu_y)**2) dely(sext)**2'
c ----- dispersion due to Steerings
      t4=pi2/max(1,nstr)
      vo(3)=autofg(t4,'8.5')
      write(lfno,'(a)')' --- due to Correction Dipoles ---'
      write(lfno,'(3a)')' Ey**2/By=',vo(3),' xi_y dy**2/By/Tan(Pi nu_y)'
c ----- dispersion due to Orbit
      vo(4)=autofg(t(5)/8d0,'8.5')
      write(lfno,'(a)')' --- due to Orbit ---'
      write(lfno,'(3a)')' Ey**2/By= (dy**2/By) +',
     1                         vo(4),' /(2 Sin(Pi nu_y)**2 dy**2/By.'
c ----- evaluation for the present tune
      vo(1)=autofg(psix/pi2,'8.5')
      vo(2)=autofg(psiy/pi2,'8.5')
      write(lfno,'(5a)')'   [ For current tunes : nu_x ',vo(1),' nu_y ',
     1             vo(2),' ]'
      write(lfno,'(a)')' Emiy = 2Je/Jy(dE/E)^2 * ('
      vo(1)=autofg(t(1)/2d0/sin(psiy2)**2,'8.5')
      vo(2)=autofg(t(3)/8d0/sin(psiy2)**2,'8.5')
      vo(3)=autofg(t4/tan(psiy2),'8.5')
      vo(4)=autofg(t(5)/16d0/sin(psiy2)**2,'8.5')
      write(lfno,'(5a)')'       ',vo(1),' dtheta(quad)**2 + ',
     1                       vo(2),' dely(sext)**2 + '
      write(lfno,'(5a)')'       (',vo(3),'xi_y + 1) dy**2/By + ',
     1                       vo(4),' dy**2/By. )'
c ===== Linear Coupling =====
c ----- Emittance produced by Linear coupling
      write(lfno,'(a)')' <<< Emittance produced by linear coupling>>>'
      vo(1)=autofg(t(6)/4d0,'8.5')
      vo(2)=autofg(t(7)/16d0,'8.5')
      write(lfno,'(a)')
     1   ' --- Emittance due to Quad rotation Sext misalignment ---'
      write(lfno,'(2a)')' Emiy/Emix = tauy/taux *',
     1   ' (1/Sin(Pi(nu_x+nu_y))**2 + 1/Sin(Pi(nu_x-nu_y))**2)'
      write(lfno,'(5a)')
     1   '     *(',vo(1),' dtheta(quad)**2 + ',vo(2), ' dely(sext)**2 )'
      write(lfno,'(a)')' --- Emittance due to orbit ---'
      write(lfno,'(a)')' Emiy/Emix = tauy/taux * dy**2/By'
      vo(3)=autofg(t(8)/32d0,'8.5')
      vo(4)=autofg(t(9)/32d0,'8.5')
      write(lfno,'(5a)')
     1   '     *(',vo(3),' /Sin(Pi(nu_x+nu_y))**2 + ',
     1             vo(4),' /Sin(Pi(nu_x-nu_y))**2 ).'
c ----- evaluation for the present tune
      vo(1)=autofg(psix/pi2,'8.5')
      vo(2)=autofg(psiy/pi2,'8.5')
      write(lfno,'(5a)')'   [ For current tunes : nu_x ',vo(1),
     $     ' nu_y ',vo(2),' ]'
      vo(1)=autofg(t(6)/4d0*
     1        (1d0/sin(psix2+psiy2)**2+1d0/sin(psix2-psiy2)**2),'8.5')
      vo(2)=autofg(t(7)/16d0*
     1        (1d0/sin(psix2+psiy2)**2+1d0/sin(psix2-psiy2)**2),'8.5')
      vo(3)=autofg(t(8)/32d0/sin(psix2+psiy2)**2+
     1             t(9)/32d0/sin(psix2-psiy2)**2,'8.5')
      write(lfno,'(5a)')' Emiy/Emix = tauy/taux *(',
     1           vo(1),' dtheta(quad)**2 + ',vo(2),' dely(sect)**2 +'
      write(lfno,'(3a)')'                        ',vo(3),' dy**2/By ).'
      return
      end

ext: f

max_stars_repo_name: noboruatkek/SAD

max_issues_repo_name: noboruatkek/SAD

max_forks_repo_name: noboruatkek/SAD


text:
! This file is part of flox.
! SPDX-Identifier: Apache-2.0

!> Main module of the Fortran lox interpreter
module flox_ast
  use flox_constants, only : i8
  use flox_scanner, only : lox_token
  implicit none
  private

  public :: lox_ast
  public :: lox_stmt, lox_block, lox_expr_stmt, lox_print, lox_var, lox_if, lox_while, &
    & lox_fun, lox_return
  public :: lox_expr, lox_assign, lox_logical, lox_binary, lox_grouping, lox_literal, &
    & lox_unary, lox_call
  public :: lox_visitor

  !> Abstract base class for visitor
  type, abstract :: lox_visitor
  contains
    generic :: visit => visit_ast, &
      visit_assign, visit_logical, visit_binary, visit_grouping, visit_literal, visit_unary, &
      visit_call, &
      visit_block, visit_expr_stmt, visit_print, visit_var, visit_if, visit_while, &
      visit_fun, visit_return
    procedure(visit_ast), deferred :: visit_ast
    procedure(visit_assign), deferred :: visit_assign
    procedure(visit_logical), deferred :: visit_logical
    procedure(visit_binary), deferred :: visit_binary
    procedure(visit_grouping), deferred :: visit_grouping
    procedure(visit_literal), deferred :: visit_literal
    procedure(visit_unary), deferred :: visit_unary
    procedure(visit_call), deferred :: visit_call
    procedure(visit_block), deferred :: visit_block
    procedure(visit_expr_stmt), deferred :: visit_expr_stmt
    procedure(visit_print), deferred :: visit_print
    procedure(visit_var), deferred :: visit_var
    procedure(visit_if), deferred :: visit_if
    procedure(visit_while), deferred :: visit_while
    procedure(visit_fun), deferred :: visit_fun
    procedure(visit_return), deferred :: visit_return
  end type lox_visitor

  !> Abstract base class for statements
  type, abstract :: lox_stmt
    integer(i8) :: id
  contains
    !> Accept a visitor
    procedure(accept_stmt), deferred :: accept
    !> Return location of the operator
    procedure :: backtrace => backtrace_stmt
  end type lox_stmt

  !> Abstract base class for expressions
  type, abstract :: lox_expr
    integer(i8) :: id
  contains
    !> Accept a visitor
    procedure(accept_expr), deferred :: accept
    !> Return location of the operator
    procedure :: backtrace => backtrace_expr
  end type lox_expr

  !> Container to hold a statement
  type :: lox_ast_node
    !> Actual statement
    class(lox_stmt), allocatable :: stmt
  end type lox_ast_node

  !> Representation of the abstract syntax tree root
  type :: lox_ast
    !> Number of statements in the tree root
    integer :: nstmt = 0
    !> Statements in this block
    type(lox_ast_node), allocatable :: stmts(:)
  contains
    !> Accept a visitor
    procedure :: accept => accept_ast
    !> Add a statement to the block
    procedure :: add => add_ast
  end type lox_ast

  !> Representation of the block
  type, extends(lox_stmt) :: lox_block
    !> Number of statements in this block
    integer :: nstmt = 0
    !> Statements in this block
    type(lox_ast_node), allocatable :: stmts(:)
  contains
    !> Accept a visitor
    procedure :: accept => accept_block
    !> Add a statement to the block
    procedure :: add => add_block
  end type lox_block

  !> Representation of an expression statement
  type, extends(lox_stmt) :: lox_expr_stmt
    !> Expression to evaluate
    class(lox_expr), allocatable :: expression
  contains
    !> Accept a visitor
    procedure :: accept => accept_expression
  end type lox_expr_stmt

  !> Representation of a print statement
  type, extends(lox_stmt) :: lox_print
    !> Expression to evaluate
    class(lox_expr), allocatable :: expression
  contains
    !> Accept a visitor
    procedure :: accept => accept_print
  end type lox_print

  !> Representation of a variable declaration
  type, extends(lox_stmt) :: lox_var
    !> Name of the variable
    type(lox_token), allocatable :: name
    !> Expression to evaluate
    class(lox_expr), allocatable :: expression
  contains
    !> Accept a visitor
    procedure :: accept => accept_var
    !> Return location of the operator
    procedure :: backtrace => backtrace_var
  end type lox_var

  !> Representation of a conditional statement
  type, extends(lox_stmt) :: lox_if
    !> Expression to evaluate
    class(lox_expr), allocatable :: condition
    !> Block to execute if condition is true
    class(lox_stmt), allocatable :: then_branch
    !> Block to execute if condition is false
    class(lox_stmt), allocatable :: else_branch
  contains
    !> Accept a visitor
    procedure :: accept => accept_if
  end type lox_if

  !> Representation of a while loop
  type, extends(lox_stmt) :: lox_while
    !> Expression to evaluate
    class(lox_expr), allocatable :: condition
    !> Block to execute while condition is true
    class(lox_stmt), allocatable :: body
  contains
    !> Accept a visitor
    procedure :: accept => accept_while
  end type lox_while

  !> Representation of a function declaration
  type, extends(lox_stmt) :: lox_fun
    !> Function name
    type(lox_token), allocatable :: name
    !> Function parameters
    type(lox_token), allocatable :: params(:)
    !> Function body
    class(lox_block), allocatable :: body
  contains
    !> Accept a visitor
    procedure :: accept => accept_fun
  end type lox_fun

  !> Representation of a return statement
  type, extends(lox_stmt) :: lox_return
    !> Token representing the return value
    type(lox_token), allocatable :: keyword
    !> Expression to evaluate
    class(lox_expr), allocatable :: expression
  contains
    !> Accept a visitor
    procedure :: accept => accept_return
  end type lox_return

  !> Representation of an assignment expression
  type, extends(lox_expr) :: lox_assign
    !> Name of the variable
    type(lox_token), allocatable :: name
    !> Expression to evaluate
    class(lox_expr), allocatable :: value
  contains
    !> Accept a visitor
    procedure :: accept => accept_assign
    !> Return location of the operator
    procedure :: backtrace => backtrace_assign
  end type lox_assign

  !> Representation of a logical expression
  type, extends(lox_expr) :: lox_logical
    !> Expression of left operand
    class(lox_expr), allocatable :: left
    !> Token representing the operator
    type(lox_token), allocatable :: operator
    !> Expression of right operand
    class(lox_expr), allocatable :: right
  contains
    !> Accept a visitor
    procedure :: accept => accept_logical
    !> Return location of the operator
    procedure :: backtrace => backtrace_logical
  end type lox_logical

  !> Representation of a binary expression
  type, extends(lox_expr) :: lox_binary
    !> Expression of left operand
    class(lox_expr), allocatable :: left
    !> Token representing the operator
    type(lox_token), allocatable :: operator
    !> Expression of right operand
    class(lox_expr), allocatable :: right
  contains
    !> Accept a visitor
    procedure :: accept => accept_binary
    !> Return location of the operator
    procedure :: backtrace => backtrace_binary
  end type lox_binary

  !> Representation of a grouping expression
  type, extends(lox_expr) :: lox_grouping
    !> Expression in the grouping
    class(lox_expr), allocatable :: expression
  contains
    !> Accept a visitor
    procedure :: accept => accept_grouping
  end type lox_grouping

  !> Representation of a literal expression
  type, extends(lox_expr) :: lox_literal
    !> Value of the literal
    type(lox_token), allocatable :: object
  contains
    !> Accept a visitor
    procedure :: accept => accept_literal
    !> Return location of the literal
    procedure :: backtrace => backtrace_literal
  end type lox_literal

  !> Representation of a unary expression
  type, extends(lox_expr) :: lox_unary
    !> Token representing the operator
    type(lox_token), allocatable :: operator
    !> Expression of the operand
    class(lox_expr), allocatable :: right
  contains
    !> Accept a visitor
    procedure :: accept => accept_unary
    !> Return location of the operator
    procedure :: backtrace => backtrace_unary
  end type lox_unary

  !> Representation of an argument
  type :: lox_arg_expr
    !> Arguments to the function
    class(lox_expr), allocatable :: expr
  end type lox_arg_expr

  !> Representation of a function call
  type, extends(lox_expr) :: lox_call
    !> Name of the function
    class(lox_expr), allocatable :: callee
    !> Token for the opening parenthesis
    type(lox_token), allocatable :: paren
    !> Number of arguments
    integer :: narg = 0
    !> Arguments to the function
    type(lox_arg_expr), allocatable :: args(:)
  contains
    !> Accept a visitor
    procedure :: accept => accept_call
    !> Return location of the operator
    procedure :: backtrace => backtrace_call
    !> Add an argument to the call
    procedure :: add => add_call
  end type lox_call

  abstract interface
    !> Accept a visitor to an abstract statement
    recursive subroutine accept_stmt(self, visitor)
      import :: lox_stmt, lox_visitor
      class(lox_stmt), intent(in) :: self
      class(lox_visitor), intent(inout) :: visitor
    end subroutine accept_stmt

    !> Accept a visitor to an abstract expression
    recursive subroutine accept_expr(self, visitor)
      import :: lox_expr, lox_visitor
      class(lox_expr), intent(in) :: self
      class(lox_visitor), intent(inout) :: visitor
    end subroutine accept_expr

    !> Visit abstract syntax tree root
    recursive subroutine visit_ast(self, ast)
      import :: lox_ast, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_ast), intent(in) :: ast
    end subroutine visit_ast

    !> Visit an assignment expression
    recursive subroutine visit_assign(self, expr)
      import :: lox_assign, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_assign), intent(in) :: expr
    end subroutine visit_assign

    !> Visit a logical expression
    recursive subroutine visit_logical(self, expr)
      import :: lox_logical, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_logical), intent(in) :: expr
    end subroutine visit_logical

    !> Visit a binary expression
    recursive subroutine visit_binary(self, expr)
      import :: lox_binary, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_binary), intent(in) :: expr
    end subroutine visit_binary

    !> Visit a grouping expression
    recursive subroutine visit_grouping(self, expr)
      import :: lox_grouping, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_grouping), intent(in) :: expr
    end subroutine visit_grouping

    !> Visit a literal expression
    recursive subroutine visit_literal(self, expr)
      import :: lox_literal, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_literal), intent(in) :: expr
    end subroutine visit_literal

    !> Visit a unary expression
    recursive subroutine visit_unary(self, expr)
      import :: lox_unary, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_unary), intent(in) :: expr
    end subroutine visit_unary

    !> Visit a function call
    recursive subroutine visit_call(self, expr)
      import :: lox_call, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_call), intent(in) :: expr
    end subroutine visit_call

    !> Visit an expression statement
    recursive subroutine visit_block(self, stmt)
      import :: lox_block, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_block), intent(in) :: stmt
    end subroutine visit_block

    !> Visit an expression statement
    recursive subroutine visit_expr_stmt(self, stmt)
      import :: lox_expr_stmt, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_expr_stmt), intent(in) :: stmt
    end subroutine visit_expr_stmt

    !> Visit a print statement
    recursive subroutine visit_print(self, stmt)
      import :: lox_print, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_print), intent(in) :: stmt
    end subroutine visit_print

    !> Visit a variable declaration
    recursive subroutine visit_var(self, stmt)
      import :: lox_var, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_var), intent(in) :: stmt
    end subroutine visit_var

    !> Visit a conditional statement
    recursive subroutine visit_if(self, stmt)
      import :: lox_if, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_if), intent(in) :: stmt
    end subroutine visit_if

    !> Visit a conditional statement
    recursive subroutine visit_while(self, stmt)
      import :: lox_while, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_while), intent(in) :: stmt
    end subroutine visit_while

    !> Visit a function declaration
    recursive subroutine visit_fun(self, stmt)
      import :: lox_fun, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_fun), intent(in) :: stmt
    end subroutine visit_fun

    !> Visit a return statement
    recursive subroutine visit_return(self, stmt)
      import :: lox_return, lox_visitor
      class(lox_visitor), intent(inout) :: self
      class(lox_return), intent(in) :: stmt
    end subroutine visit_return
  end interface

  interface resize
    module procedure :: resize_ast_node
    module procedure :: resize_arg_expr
  end interface resize

  interface move
    module procedure :: move_ast_node
    module procedure :: move_arg_expr
  end interface move

contains

  subroutine accept_ast(self, visitor)
    class(lox_ast), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_ast

  subroutine accept_assign(self, visitor)
    class(lox_assign), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_assign

  subroutine accept_logical(self, visitor)
    class(lox_logical), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_logical

  subroutine accept_binary(self, visitor)
    class(lox_binary), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_binary

  subroutine accept_grouping(self, visitor)
    class(lox_grouping), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_grouping

  subroutine accept_literal(self, visitor)
    class(lox_literal), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_literal

  subroutine accept_unary(self, visitor)
    class(lox_unary), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_unary

  subroutine accept_call(self, visitor)
    class(lox_call), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_call

  subroutine accept_block(self, visitor)
    class(lox_block), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_block

  subroutine accept_expression(self, visitor)
    class(lox_expr_stmt), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_expression

  subroutine accept_print(self, visitor)
    class(lox_print), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_print

  subroutine accept_var(self, visitor)
    class(lox_var), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_var

  subroutine accept_if(self, visitor)
    class(lox_if), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_if

  subroutine accept_while(self, visitor)
    class(lox_while), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_while

  subroutine accept_fun(self, visitor)
    class(lox_fun), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_fun

  subroutine accept_return(self, visitor)
    class(lox_return), intent(in) :: self
    class(lox_visitor), intent(inout) :: visitor
    call visitor%visit(self)
  end subroutine accept_return

  pure function backtrace_stmt(self) result(token)
    class(lox_stmt), intent(in) :: self
    type(lox_token), allocatable :: token
  end function backtrace_stmt

  pure function backtrace_expr(self) result(token)
    class(lox_expr), intent(in) :: self
    type(lox_token), allocatable :: token
  end function backtrace_expr

  pure function backtrace_var(self) result(token)
    class(lox_var), intent(in) :: self
    type(lox_token), allocatable :: token

    token = self%name
  end function backtrace_var

  pure function backtrace_assign(self) result(token)
    class(lox_assign), intent(in) :: self
    type(lox_token), allocatable :: token

    token = self%name
  end function backtrace_assign

  pure function backtrace_logical(self) result(token)
    class(lox_logical), intent(in) :: self
    type(lox_token), allocatable :: token

    token = self%operator
  end function backtrace_logical

  pure function backtrace_binary(self) result(token)
    class(lox_binary), intent(in) :: self
    type(lox_token), allocatable :: token

    token = self%operator
  end function backtrace_binary

  pure function backtrace_literal(self) result(token)
    class(lox_literal), intent(in) :: self
    type(lox_token), allocatable :: token

    token = self%object
  end function backtrace_literal

  pure function backtrace_unary(self) result(token)
    class(lox_unary), intent(in) :: self
    type(lox_token), allocatable :: token

    token = self%operator
  end function backtrace_unary

  pure function backtrace_call(self) result(token)
    class(lox_call), intent(in) :: self
    type(lox_token), allocatable :: token

    token = self%paren
  end function backtrace_call

  subroutine add_ast(self, stmt)
    class(lox_ast), intent(inout) :: self
    class(lox_stmt), allocatable, intent(inout) :: stmt

    if (.not.allocated(self%stmts)) call resize(self%stmts)
    if (self%nstmt >= size(self%stmts)) call resize(self%stmts)

    self%nstmt = self%nstmt + 1
    associate(new => self%stmts(self%nstmt))
      call move_alloc(stmt, new%stmt)
    end associate
  end subroutine add_ast

  subroutine add_block(self, stmt)
    class(lox_block), intent(inout) :: self
    class(lox_stmt), allocatable, intent(inout) :: stmt

    if (.not.allocated(self%stmts)) call resize(self%stmts)
    if (self%nstmt >= size(self%stmts)) call resize(self%stmts)

    self%nstmt = self%nstmt + 1
    associate(new => self%stmts(self%nstmt))
      call move_alloc(stmt, new%stmt)
    end associate
  end subroutine add_block

  subroutine add_call(self, expr)
    class(lox_call), intent(inout) :: self
    class(lox_expr), allocatable, intent(inout) :: expr

    if (.not.allocated(self%args)) call resize(self%args)
    if (self%narg >= size(self%args)) call resize(self%args)

    self%narg = self%narg + 1
    associate(new => self%args(self%narg))
      call move_alloc(expr, new%expr)
    end associate
  end subroutine add_call

  !> Reallocate list of AST nodes
  subroutine resize_ast_node(list, n)
    !> Instance of the array to be resized
    type(lox_ast_node), allocatable, intent(inout) :: list(:)
    !> Dimension of the final array size
    integer, intent(in), optional :: n

    type(lox_ast_node), allocatable :: tmp(:)
    integer :: this_size, new_size
    integer, parameter :: initial_size = 32

    if (allocated(list)) then
      this_size = size(list, 1)
      call move_alloc(list, tmp)
    else
      this_size = initial_size
    end if

    if (present(n)) then
      new_size = n
    else
      new_size = this_size + this_size/2 + 1
    end if

    allocate(list(new_size))

    if (allocated(tmp)) then
      this_size = min(size(tmp, 1), size(list, 1))
      call move(tmp(:this_size), list(:this_size))
      deallocate(tmp)
    end if
  end subroutine resize_ast_node

  !> Move allocation of an AST node
  elemental subroutine move_ast_node(from, to)
    !> Source node to move allocation from
    type(lox_ast_node), intent(inout) :: from
    !> Target node to move allocation to
    type(lox_ast_node), intent(out) :: to

    call move_alloc(from%stmt, to%stmt)
  end subroutine move_ast_node

  !> Reallocate list of argument expressions
  subroutine resize_arg_expr(list, n)
    !> Instance of the array to be resized
    type(lox_arg_expr), allocatable, intent(inout) :: list(:)
    !> Dimension of the final array size
    integer, intent(in), optional :: n

    type(lox_arg_expr), allocatable :: tmp(:)
    integer :: this_size, new_size
    integer, parameter :: initial_size = 8

    if (allocated(list)) then
      this_size = size(list, 1)
      call move_alloc(list, tmp)
    else
      this_size = initial_size
    end if

    if (present(n)) then
      new_size = n
    else
      new_size = this_size + this_size/2 + 1
    end if

    allocate(list(new_size))

    if (allocated(tmp)) then
      this_size = min(size(tmp, 1), size(list, 1))
      call move(tmp(:this_size), list(:this_size))
      deallocate(tmp)
    end if
  end subroutine resize_arg_expr

  !> Move allocation of an argument expression
  elemental subroutine move_arg_expr(from, to)
    !> Source node to move allocation from
    type(lox_arg_expr), intent(inout) :: from
    !> Target node to move allocation to
    type(lox_arg_expr), intent(out) :: to

    call move_alloc(from%expr, to%expr)
  end subroutine move_arg_expr

end module flox_ast

max_stars_repo_name: awvwgk/flox

max_issues_repo_name: awvwgk/flox

max_forks_repo_name: awvwgk/flox


text:
C SUBROUTINE SQMULT           (NEXT)
      SUBROUTINE SQMULT (A, B, C, N)
C
C     SQUARE MATRIX MULTIPLICATION (COMPANION TO CMPINV IN ANL F103)
C
      DIMENSION A (20, 20), B (20, 20), C (20, 20)
C
      COMMON /PON /INDEX (20, 2), IPIVOT (20), PIVOT (20)
C
C.....C=A*B.............................................................
      IF (N .LT. 1) GO TO 110
      DO 105 J = 1, N
      IF (N .LT. 1) GO TO 115
      DO 100 K = 1, N
 100  PIVOT (K) = B (K, J)
 115  CONTINUE
      IF (N .LT. 1) GO TO 120
      DO 105 I = 1, N
      C (I, J) = 0.0
      IF (N .LT. 1) GO TO 125
      DO 105 L = 1, N
 105  C (I, J) = C (I, J) + A (I, L) * PIVOT (L)
 125  CONTINUE
 120  CONTINUE
 110  CONTINUE
      RETURN
      END

ext: for

max_stars_repo_name: jawatson/voacapl

max_issues_repo_name: jawatson/voacapl

max_forks_repo_name: jawatson/voacapl


text:
module mg_setup_tests

  use mg_mpi
  use mg_tictoc
  use mg_mpi_exchange_ijk
  use mg_netcdf_out

  implicit none

contains

  !-------------------------------------------------------------------------
  subroutine setup_cuc(nx, ny, nz, npxg, npyg, Lx, Ly, Htot, dx, dy, zeta, h)

    integer(kind=ip), intent(in) :: nx,ny,nz  ! local dims
    integer(kind=ip), intent(in) :: npxg,npyg ! nb procs
    real(kind=rp)   , intent(in) :: Lx, Ly, Htot
    real(kind=rp), dimension(:,:), pointer, intent(out) :: dx, dy, zeta, h

    integer(kind=ip):: is_err,nc_id,varid
    integer(kind=ip):: i,j,i0,j0,pi,pj
    real(kind=rp), dimension(:,:), allocatable   :: dummy2d
    integer(kind=ip), dimension(2)   :: starts,counts

    character*80 :: file,varname
    integer(kind=ip) :: ierr

    call mpi_comm_rank(mpi_comm_world, myrank, ierr)

    pj = myrank/npxg
    pi = mod(myrank,npxg)

    ! dummy 2D to read from netcdf
    allocate(dummy2d(1:nx,1:ny))

    i0=2+pi*nx
    j0=2+pj*ny

    starts(1)=i0
    starts(2)=j0
    counts(1)=nx
    counts(2)=ny

    !!------------------------------------------------!!
    !! Here enter the directory where cuc_nhgrd.nc is !!
    !!------------------------------------------------!!
    file='../DATA/cuc_nhgrd.nc'
    !file='/workgpfs/rech/dgw/rdgw004/MGROMS/DATA' ! IDRIS ADA $workdir

    is_err = nf90_open( trim(file), NF90_NOWRITE ,nc_id  )

    if (is_err /= nf90_noerr) then
       write(*,*)'Error: problem to open file: ', trim(file)
       stop
    end if

    ! --- read h ---
    varname='h'
    is_err = nf90_inq_varid(nc_id,trim(varname),varid)
    is_err = nf90_get_var(nc_id,varid,dummy2d,starts,counts)

    do i=1,nx
       do j=1,ny
          h(j,i)=dummy2d((i-1)+1,(j-1)+1)
       enddo
    enddo

    ! --- read pn ---
    varname='pn'
    is_err = nf90_inq_varid(nc_id,trim(varname),varid)
    is_err = nf90_get_var(nc_id,varid,dummy2d,starts,counts)

    do i=1,nx
       do j=1,ny
          dy(j,i)=1._rp/dummy2d((i-1)+1,(j-1)+1)
       enddo
    enddo

    ! --- read pm ---
    varname='pm'
    is_err = nf90_inq_varid(nc_id,trim(varname),varid)
    is_err = nf90_get_var(nc_id,varid,dummy2d,starts,counts)

    do i=1,nx
       do j=1,ny
          dx(j,i)=1._rp/dummy2d((i-1)+1,(j-1)+1)
       enddo
    enddo

    is_err = nf90_close(nc_id)

    call fill_halo_ijk(nx,ny,npxg,npyg,dx)
    call fill_halo_ijk(nx,ny,npxg,npyg,dy)
    call fill_halo_ijk(nx,ny,npxg,npyg, h)

    do i= 1,nx
       do j= 1,ny
          dx(j,i)=max(1._rp,dx(j,i))
          dy(j,i)=max(1._rp,dy(j,i))
       enddo
    enddo

    zeta(:,:) = 0._rp

  end subroutine setup_cuc

  !-------------------------------------------------------------------------
  subroutine setup_seamount(nx, ny, nz, npxg, npyg, Lx, Ly, Htot, dx, dy, zeta, h)

    integer(kind=ip), intent(in) :: nx,ny,nz  ! local dims
    integer(kind=ip), intent(in) :: npxg,npyg ! nb procs
    real(kind=rp)   , intent(in) :: Lx, Ly, Htot

    real(kind=rp), dimension(:,:), pointer, intent(out) :: dx, dy, zeta, h

    integer(kind=ip), parameter :: ip=4, rp=8
    integer(kind=ip):: nxg, nyg  ! global dims
    integer(kind=ip):: pi, pj
    integer(kind=ip):: i,j

    real(kind=rp) :: x, y
    real(kind=rp) :: x0, y0
    integer(kind=ip) :: ierr

    call mpi_comm_rank(mpi_comm_world, myrank, ierr)

    nxg = npxg * nx
    nyg = npyg * ny

    ! grid definition

    dx(:,:) = Lx/real(nxg,kind=rp)
    dy(:,:) = Ly/real(nyg,kind=rp)

    pj = myrank/npxg
    pi = myrank-pj*npxg

    x0 = Lx * 0.5_rp
    y0 = Ly * 0.5_rp
    do i = 0,nx+1 !!!  I need to know my global index range
       do j = 0,ny+1
          x = (real(i+(pi*nx),kind=rp)-0.5_rp) * dx(j,i)
          y = (real(j+(pj*ny),kind=rp)-0.5_rp) * dy(j,i)
          zeta(j,i) = 0._rp
          h(j,i) = Htot * (1._rp - 0.5_rp * exp(-(x-x0)**2._rp/(Lx/5._rp)**2._rp -(y-y0)**2._rp/(Ly/5._rp)**2._rp))
!          h(j,i) = Htot
       enddo
    enddo

    if (netcdf_output) then
       call write_netcdf(dx,vname='dx',netcdf_file_name='dx.nc',rank=myrank)
       call write_netcdf(dy,vname='dy',netcdf_file_name='dy.nc',rank=myrank)
       call write_netcdf(zeta, vname= 'zeta',netcdf_file_name= 'zeta.nc',rank=myrank)
       call write_netcdf(h, vname= 'h',netcdf_file_name= 'h.nc',rank=myrank)
    endif

  end subroutine setup_seamount

  !-------------------------------------------------------------------------
  subroutine setup_rndtopo(nx, ny, nz, npxg, npyg, Lx, Ly, Htot, dx, dy, zeta, h)

    integer(kind=ip), intent(in) :: nx,ny,nz  ! local dims
    integer(kind=ip), intent(in) :: npxg,npyg ! nb procs
    real(kind=rp)   , intent(in) :: Lx, Ly, Htot

    real(kind=rp), dimension(:,:), pointer, intent(out) :: dx, dy, zeta, h

    integer(kind=ip), parameter :: ip=4, rp=8
    integer(kind=ip):: nxg, nyg  ! global dims
    integer(kind=ip):: pi, pj
    integer(kind=ip):: i,j

    real(kind=rp) :: x, y
    real(kind=rp) :: x0, y0
    integer(kind=ip) :: ierr

    call mpi_comm_rank(mpi_comm_world, myrank, ierr)

    nxg = npxg * nx
    nyg = npyg * ny

    ! grid definition

    dx(:,:) = Lx/real(nxg,kind=rp)
    dy(:,:) = Ly/real(nyg,kind=rp)

    pj = myrank/npxg
    pi = myrank-pj*npxg

    call random_number(h(:,:)) ! between 0 and 1

    x0 = Lx * 0.5_rp
    y0 = Ly * 0.5_rp
    do i = 0,nx+1 !!!  I need to know my global index range
       do j = 0,ny+1
          x = (real(i+(pi*nx),kind=rp)-0.5_rp) * dx(j,i)
          y = (real(j+(pj*ny),kind=rp)-0.5_rp) * dy(j,i)
          zeta(j,i) = 0._rp
          h(i,j) = Htot * (20._rp/100._rp) * abs(h(i,j)) ! between 0% and 20% of Htot
          !          h(j,i) = Htot * (1._rp - 0.5_rp * exp(-(x-x0)**2._rp/(Lx/5._rp)**2._rp -(y-y0)**2._rp/(Ly/5._rp)**2._rp))
       enddo
    enddo

    if (netcdf_output) then
       call write_netcdf(dx,vname='dx',netcdf_file_name='dx.nc',rank=myrank)
       call write_netcdf(dy,vname='dy',netcdf_file_name='dy.nc',rank=myrank)
       call write_netcdf(zeta, vname= 'zeta',netcdf_file_name= 'zeta.nc',rank=myrank)
       call write_netcdf(h, vname= 'h',netcdf_file_name= 'h.nc',rank=myrank)
    endif

  end subroutine setup_rndtopo

end module mg_setup_tests

max_stars_repo_name: nmolem/mgroms

max_issues_repo_name: nmolem/mgroms

max_forks_repo_name: nmolem/mgroms


text:
!***********************************************************************
!   Copyright (c) 2019 D. de Vries
!   Original Copyright (c) 2000 Mark Drela
!
!   This file is part of XFoil.
!
!   XFoil is free software: you can redistribute it and/or modify
!   it under the terms of the GNU General Public License as published by
!   the Free Software Foundation, either version 3 of the License, or
!   (at your option) any later version.
!
!   XFoil is distributed in the hope that it will be useful,
!   but WITHOUT ANY WARRANTY; without even the implied warranty of
!   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!   GNU General Public License for more details.
!
!   You should have received a copy of the GNU General Public License
!   along with XFoil.  If not, see <https://www.gnu.org/licenses/>.
!***********************************************************************

module s_xoper
contains
    ! mhinge was originally in xoper between cpdump and vpar
    ! It was moved here to avoid a circular dependency.
    subroutine mhinge
        use m_xgdes, only : getxyf
        use m_spline, only : seval, sinvrt
        use i_xfoil
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Local variables
        !
        real :: botp, bots, botx, boty, dx, dy, frac, pmid, topp, tops, topx, topy, xmid, ymid
        integer :: i
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !----------------------------------------------------
        !     Calculates the hinge moment of the flap about
        !     (XOF,YOF) by integrating surface pressures.
        !----------------------------------------------------
        !
        if (.not.LFLap) then
            !
            call getxyf(X, XP, Y, YP, S, N, tops, bots, XOF, YOF)
            LFLap = .true.
            !
        else
            !
            !------ find top and bottom y at hinge x location
            tops = XOF
            bots = S(N) - XOF
            call sinvrt(tops, XOF, X, XP, S, N)
            call sinvrt(bots, XOF, X, XP, S, N)
            !
        endif
        !
        topx = seval(tops, X, XP, S, N)
        topy = seval(tops, Y, YP, S, N)
        botx = seval(bots, X, XP, S, N)
        boty = seval(bots, Y, YP, S, N)
        !
        !
        HMOm = 0.
        HFX = 0.
        HFY = 0.
        !
        !---- integrate pressures on top and bottom sides of flap
        do i = 2, N
            if (S(i - 1)<tops .or. S(i)>bots) then
                !
                dx = X(i) - X(i - 1)
                dy = Y(i) - Y(i - 1)
                xmid = 0.5 * (X(i) + X(i - 1)) - XOF
                ymid = 0.5 * (Y(i) + Y(i - 1)) - YOF
                if (LVIsc) then
                    pmid = 0.5 * (CPV(i) + CPV(i - 1))
                else
                    pmid = 0.5 * (CPI(i) + CPI(i - 1))
                endif
                HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
                HFX = HFX - pmid * dy
                HFY = HFY + pmid * dx
            endif
        enddo
        !
        !---- find S(I)..S(I-1) interval containing s=TOPS
        do i = 2, N
            if (S(i)>tops) exit
        enddo
        !
        !---- add on top surface chunk TOPS..S(I-1),  missed in the DO 20 loop.
        dx = topx - X(i - 1)
        dy = topy - Y(i - 1)
        xmid = 0.5 * (topx + X(i - 1)) - XOF
        ymid = 0.5 * (topy + Y(i - 1)) - YOF
        if (S(i)/=S(i - 1)) then
            frac = (tops - S(i - 1)) / (S(i) - S(i - 1))
        else
            frac = 0.
        endif
        if (LVIsc) then
            topp = CPV(i) * frac + CPV(i - 1) * (1.0 - frac)
            pmid = 0.5 * (topp + CPV(i - 1))
        else
            topp = CPI(i) * frac + CPI(i - 1) * (1.0 - frac)
            pmid = 0.5 * (topp + CPI(i - 1))
        endif
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- add on inside flap surface contribution from hinge to top surface
        dx = XOF - topx
        dy = YOF - topy
        xmid = 0.5 * (topx + XOF) - XOF
        ymid = 0.5 * (topy + YOF) - YOF
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- find S(I)..S(I-1) interval containing s=BOTS
        do i = N, 2, -1
            if (S(i - 1)<bots) exit
        enddo
        !
        !---- add on bottom surface chunk BOTS..S(I),  missed in the DO 20 loop.
        dx = X(i) - botx
        dy = Y(i) - boty
        xmid = 0.5 * (botx + X(i)) - XOF
        ymid = 0.5 * (boty + Y(i)) - YOF
        if (S(i)/=S(i - 1)) then
            frac = (bots - S(i - 1)) / (S(i) - S(i - 1))
        else
            frac = 0.
        endif
        if (LVIsc) then
            botp = CPV(i) * frac + CPV(i - 1) * (1.0 - frac)
            pmid = 0.5 * (botp + CPV(i))
        else
            botp = CPI(i) * frac + CPI(i - 1) * (1.0 - frac)
            pmid = 0.5 * (botp + CPI(i))
        endif
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- add on inside flap surface contribution from hinge to bottom surface
        dx = botx - XOF
        dy = boty - YOF
        xmid = 0.5 * (botx + XOF) - XOF
        ymid = 0.5 * (boty + YOF) - YOF
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
        !---- add on TE base thickness contribution
        dx = X(1) - X(N)
        dy = Y(1) - Y(N)
        xmid = 0.5 * (X(1) + X(N)) - XOF
        ymid = 0.5 * (Y(1) + Y(N)) - YOF
        if (LVIsc) then
            pmid = 0.5 * (CPV(1) + CPV(N))
        else
            pmid = 0.5 * (CPI(1) + CPI(N))
        endif
        HMOm = HMOm + pmid * (xmid * dx + ymid * dy)
        HFX = HFX - pmid * dy
        HFY = HFY + pmid * dx
        !
    end subroutine mhinge
    !*==VPAR.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
    ! MHINGE
end module s_xoper

max_stars_repo_name: dinlink/inPipeAxialTurbineDesign

max_issues_repo_name: dinlink/inPipeAxialTurbineDesign

max_forks_repo_name: dinlink/inPipeAxialTurbineDesign


text:
Program sort7
!
! This program is used to compare 2 algorithms for sorting
! every successive subset of 7 elements in an array.
! It shows how to call a subroutine with the correct interface
! block in the main program. Interfaces for ORDERPACK routines
! can be found in file interfaces.f90
!
      Interface
         Subroutine oldsub7 (xdont, xwrkt)
            Real, Dimension (:), Intent (In) :: xdont
            Real, Dimension (:), Intent (Out) :: xwrkt
         End Subroutine oldsub7
         Subroutine newsub7 (xdont, xwrkt)
            Real, Dimension (:), Intent (In) :: xdont
            Real, Dimension (:), Intent (Out) :: xwrkt
         End Subroutine newsub7
      End Interface
!
      Real, Dimension (35280) :: xvalt
      Real, Dimension (35280) :: xwrkt
      Real, Dimension (7) :: xval7t
      Real, Dimension (6) :: xval6t
      Real, Dimension (5) :: xval5t
      Real, Dimension (4) :: xval4t
      Real, Dimension (3) :: xval3t
      Real, Dimension (2) :: xval2t
      Real, Dimension (1) :: xval1t
      Real :: x1, x2, x3, x4, x5, x6, x7
      Integer :: i1, i2, i3, i4, i5, i6, ival
!
! generate all 5040 possible permutations of elements 1,...,7
!
      xval7t = (/ 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0 /)
      ival = 0
      Do i1 = 1, 7
         x1 = xval7t (i1)
         xval6t = pack (xval7t, (xval7t /= x1))
         Do i2 = 1, 6
            x2 = xval6t (i2)
            xval5t = pack (xval6t, (xval6t /= x2))
            Do i3 = 1, 5
               x3 = xval5t (i3)
               xval4t = pack (xval5t, (xval5t /= x3))
               Do i4 = 1, 4
                  x4 = xval4t (i4)
                  xval3t = pack (xval4t, (xval4t /= x4))
                  Do i5 = 1, 3
                     x5 = xval3t (i5)
                     xval2t = pack (xval3t, (xval3t /= x5))
                     Do i6 = 1, 2
                        x6 = xval2t (i6)
                        xval1t = pack (xval2t, (xval2t /= x6))
                        x7 = xval1t (1)
                        xvalt (ival+1:ival+7) = (/ x1, x2, x3, x4, x5, &
                       & x6, x7 /)
                        ival = ival + 7
                     End Do
                  End Do
               End Do
            End Do
         End Do
      End Do
      Call newsub7 (xvalt, xwrkt)
      Do i1 = 1, 35280, 7
         If (any(xwrkt(i1:i1+6) /= xval7t)) Then
            Write (*,*) "newsub KO", i1, xwrkt (i1:i1+6)
            Exit
         End If
      End Do
      Call oldsub7 (xvalt, xwrkt)
      Do i1 = 1, 35280, 7
         If (any(xwrkt(i1:i1+6) /= xval7t)) Then
            Write (*,*) "oldsub KO", i1, xwrkt (i1:i1+6)
         End If
      End Do
End Program sort7
Subroutine oldsub7 (xdont, xwrkt)
!
! This subroutine is based on insertion sort, with a first
! pass of selection to bring the smallest value in first
! location, thus avoiding a test in the insertion phase
!
      Real, Dimension (:), Intent (In) :: xdont
      Real, Dimension (:), Intent (Out) :: xwrkt
      Real :: xwrk, xwrk1
      Integer :: ndon, ideb, iwrk, idcr, icrs
!
      ndon = size (xdont)
!
      Do ideb = 1, ndon - 6, 7
         idcr = ideb + 6
         If (xdont(ideb) < xdont(idcr)) Then
            xwrk = xdont (ideb)
            xwrkt (idcr) = xdont (idcr)
         Else
            xwrk = xdont (idcr)
            xwrkt (idcr) = xdont (ideb)
         End If
         Do iwrk = 1, 5
            idcr = idcr - 1
            xwrk1 = xdont (idcr)
            If (xwrk1 < xwrk) Then
               xwrkt (idcr) = xwrk
               xwrk = xwrk1
            Else
               xwrkt (idcr) = xwrk1
            End If
         End Do
         xwrkt (ideb) = xwrk
         Do icrs = ideb + 2, ideb + 6
            xwrk = xwrkt (icrs)
            If (xwrk < xwrkt(icrs-1)) Then
               xwrkt (icrs) = xwrkt (icrs-1)
               idcr = icrs - 1
               xwrk1 = xwrkt (idcr-1)
               Do
                  If (xwrk >= xwrk1) Exit
                  xwrkt (idcr) = xwrk1
                  idcr = idcr - 1
                  xwrk1 = xwrkt (idcr-1)
               End Do
               xwrkt (idcr) = xwrk
            End If
         End Do
      End Do
End Subroutine oldsub7
Subroutine newsub7 (xdont, xwrkt)
      Real, Dimension (:), Intent (In) :: xdont
      Real, Dimension (:), Intent (Out) :: xwrkt
      Real :: xwrk1, xwrk2, xwrk3, xwrk4, xwrk5, xwrk6
      Real :: xwrk, xwrki, xwrks
      Integer :: ndon, ideb, ideba
!
! This routine uses a sort of Shellsort in a first pass
! trying to bring the set to the following form:
! {minimum} {X1 . . } {X4 . .} with X1 <= X4
! then
! {minimum} {X1 X2 . } {X4 X5 .} with X2 <= X5
! then sort each of the subsets, and then
! {minimum} {second minimum X2 X3 } {X4 X5 X6=maximum} with X2 <= X3 and
!                                                           X4 <= X5
!  and lastly merge the two subsets.
!
!
      ndon = size (xdont)
      xwrkt = 0.0
!
      Do ideb = 1, ndon - 6, 7
         xwrk = xdont (ideb)
!
!  First pair
!
         ideba = ideb + 1
         If (xdont(ideba) < xdont(ideba+3)) Then
            xwrks = xdont (ideba+3)
            xwrki = xdont (ideba)
         Else
            xwrki = xdont (ideba+3)
            xwrks = xdont (ideba)
         End If
         If (xwrki < xwrk) Then
            If (xwrks < xwrk) Then
               xwrk1 = xwrks
               xwrk4 = xwrk
            Else
               xwrk1 = xwrk
               xwrk4 = xwrks
            End If
            xwrk = xwrki
         Else
            xwrk1 = xwrki
            xwrk4 = xwrks
         End If
!
!  Second pair
!
         ideba = ideba + 1
         If (xdont(ideba) < xdont(ideba+3)) Then
            xwrks = xdont (ideba+3)
            xwrki = xdont (ideba)
         Else
            xwrki = xdont (ideba+3)
            xwrks = xdont (ideba)
         End If
         If (xwrki < xwrk) Then
            xwrk2 = xwrk1
            If (xwrks < xwrk) Then
               xwrk1 = xwrks
               xwrks = xwrk
            Else
               xwrk1 = xwrk
            End If
            xwrk = xwrki
         Else
            If (xwrki >= xwrk1) Then
               xwrk2 = xwrki
            Else
               xwrk2 = xwrk1
               xwrk1 = xwrki
            End If
         End If
         If (xwrks >= xwrk4) Then
            xwrk5 = xwrks
         Else
            xwrk5 = xwrk4
            xwrk4 = xwrks
         End If
!
!  Third pair
!
         ideba = ideba + 1
         If (xdont(ideba) < xdont(ideba+3)) Then
            xwrks = xdont (ideba+3)
            xwrki = xdont (ideba)
         Else
            xwrki = xdont (ideba+3)
            xwrks = xdont (ideba)
         End If
         If (xwrki <= xwrk) Then
            xwrk3 = xwrk2
            xwrk2 = xwrk1
            If (xwrks < xwrk) Then
               xwrk1 = xwrks
               xwrks = xwrk
            Else
               xwrk1 = xwrk
            End If
            xwrk = xwrki
         Else
            If (xwrki >= xwrk2) Then
               xwrk3 = xwrki
            Else
               xwrk3 = xwrk2
               If (xwrki >= xwrk1) Then
                  xwrk2 = xwrki
               Else
                  xwrk2 = xwrk1
                  xwrk1 = xwrki
               End If
            End If
         End If
         If (xwrks >= xwrk5) Then
            xwrk6 = xwrks
         Else
            xwrk6 = xwrk5
            If (xwrks >= xwrk4) Then
               xwrk5 = xwrks
            Else
               xwrk5 = xwrk4
               xwrk4 = xwrks
            End If
         End If
!
! Merge the two subsets into their final location
!
         xwrkt (ideb) = xwrk
         xwrkt (ideb+1) = xwrk1
         If (xwrk4 >= xwrk3) Then
            xwrkt (ideb+2) = xwrk2
            xwrkt (ideb+3) = xwrk3
            xwrkt (ideb+4) = xwrk4
            xwrkt (ideb+5) = xwrk5
         Else
            If (xwrk4 >= xwrk2) Then
               xwrkt (ideb+2) = xwrk2
               xwrkt (ideb+3) = xwrk4
            Else
               xwrkt (ideb+2) = xwrk4
               xwrkt (ideb+3) = xwrk2
            End If
            If (xwrk3 <= xwrk5) Then
               xwrkt (ideb+4) = xwrk3
               xwrkt (ideb+5) = xwrk5
            Else
               xwrkt (ideb+4) = xwrk5
               xwrkt (ideb+5) = xwrk3
            End If
         End If
         xwrkt (ideb+6) = xwrk6
      End Do
End Subroutine newsub7

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
      subroutine dtrco(t,ldt,n,rcond,z,job)
      integer ldt,n,job
      double precision t(ldt,*),z(*)
      double precision rcond
c
c     dtrco estimates the condition of a double precision triangular
c     matrix.
c
c     on entry
c
c        t       double precision(ldt,n)
c                t contains the triangular matrix. the zero
c                elements of the matrix are not referenced, and
c                the corresponding elements of the array can be
c                used to store other information.
c
c        ldt     integer
c                ldt is the leading dimension of the array t.
c
c        n       integer
c                n is the order of the system.
c
c        job     integer
c                = 0         t  is lower triangular.
c                = nonzero   t  is upper triangular.
c
c     on return
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  t .
c                for the system  t*x = b , relative perturbations
c                in  t  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  t  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  t  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,dasum
c     fortran dabs,dmax1,dsign
c
c     internal variables
c
      double precision w,wk,wkm,ek
      double precision tnorm,ynorm,s,sm,dasum
      integer i1,j,j1,j2,k,kk,l
      logical lower
c
      lower = job .eq. 0
c
c     compute 1-norm of t
c
      tnorm = 0.0d0
      do 10 j = 1, n
         l = j
         if (lower) l = n + 1 - j
         i1 = 1
         if (lower) i1 = j
         tnorm = dmax1(tnorm,dasum(l,t(i1,j),1))
   10 continue
c
c     rcond = 1/(norm(t)*(estimate of norm(inverse(t)))) .
c     estimate = norm(z)/norm(y) where  t*z = y  and  trans(t)*y = e .
c     trans(t)  is the transpose of t .
c     the components of  e  are chosen to cause maximum local
c     growth in the elements of y .
c     the vectors are frequently rescaled to avoid overflow.
c
c     solve trans(t)*y = e
c
      ek = 1.0d0
      do 20 j = 1, n
         z(j) = 0.0d0
   20 continue
      do 100 kk = 1, n
         k = kk
         if (lower) k = n + 1 - kk
         if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
         if (dabs(ek-z(k)) .le. dabs(t(k,k))) go to 30
            s = dabs(t(k,k))/dabs(ek-z(k))
            call dscal(n,s,z,1)
            ek = s*ek
   30    continue
         wk = ek - z(k)
         wkm = -ek - z(k)
         s = dabs(wk)
         sm = dabs(wkm)
         if (t(k,k) .eq. 0.0d0) go to 40
            wk = wk/t(k,k)
            wkm = wkm/t(k,k)
         go to 50
   40    continue
            wk = 1.0d0
            wkm = 1.0d0
   50    continue
         if (kk .eq. n) go to 90
            j1 = k + 1
            if (lower) j1 = 1
            j2 = n
            if (lower) j2 = k - 1
            do 60 j = j1, j2
               sm = sm + dabs(z(j)+wkm*t(k,j))
               z(j) = z(j) + wk*t(k,j)
               s = s + dabs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               w = wkm - wk
               wk = wkm
               do 70 j = j1, j2
                  z(j) = z(j) + w*t(k,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve t*z = y
c
      do 130 kk = 1, n
         k = n + 1 - kk
         if (lower) k = kk
         if (dabs(z(k)) .le. dabs(t(k,k))) go to 110
            s = dabs(t(k,k))/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  110    continue
         if (t(k,k) .ne. 0.0d0) z(k) = z(k)/t(k,k)
         if (t(k,k) .eq. 0.0d0) z(k) = 1.0d0
         i1 = 1
         if (lower) i1 = k + 1
         if (kk .ge. n) go to 120
            w = -z(k)
            call daxpy(n-kk,w,t(i1,k),1,z(i1),1)
  120    continue
  130 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (tnorm .ne. 0.0d0) rcond = ynorm/tnorm
      if (tnorm .eq. 0.0d0) rcond = 0.0d0
      return
      end

max_stars_repo_name: lifebit-ai/exomedepth

max_issues_repo_name: lifebit-ai/exomedepth

max_forks_repo_name: lifebit-ai/exomedepth


text:
! -------------------------------------------------------------------------
! Bernese GPS Software Version 5.1
! -------------------------------------------------------------------------

MODULE m_bern

! -------------------------------------------------------------------------
! Purpose:    This module defines several global variables for all
!             bernese routines writen in Fortran 90
!
! Author:     L. Mervart
!
! Created:    22-Nov-1997
!
! Changes:    03-May-2000 HB: INCLUDE I:MAXPOT
!             18-May-2000 HU: INCLUDE I:MAXPOT MOVED TO ROUTINES
!             20-Jan-2001 RD: ADD PARAMETER staNameLength
!             05-Mar-2001 DS: ADD PARAMETER staNam2Length
!             23-Jan-2002 CU: Add PARAMETER timStrgLength,timStrgLength2
!             29-Jan-2002 RD: Add r4b for REAL*4 types
!             01-Oct-2002 HU: Add fileNameLength80
!             28-Jan-2003 RS: r4b deleted
!             06-Feb-2003 RD: Add ProgramName and ProgramDescr
!             18-Feb-2003 HU: Save Program_Name and Program_Dscr
!             18-Feb-2003 HU: Parameter pgmver added, define backslash
!             13-May-2003 CU: Nullify pointers
!             23-Mar-2004 HU: V5.0 --> V5.1
!             21-Jun-2005 MM: LFNUMs moved to m_bern
!             20-Sep-2006 RD: longLineLength added
!             20-Feb-2011 RD: staFla2Length added
!             11-Jul-2011 HB: lineLength1024 added
!             15-Oct-2012 RD/SL: V5.1 --> V5.2
!
! Copyright:  Astronomical Institute
!             University of Bern
!             Switzerland
! -------------------------------------------------------------------------

  IMPLICIT NONE

  INTEGER*4                 i4ex
  REAL*8                    r8ex
  INTEGER,PARAMETER      :: i4b = KIND(i4ex)
  INTEGER,PARAMETER      :: r8b = KIND(r8ex)

  INTEGER(i4b), PARAMETER :: keyNameLength   =  32
  INTEGER(i4b), PARAMETER :: keyValueLength  = 255

  INTEGER(i4b), PARAMETER :: filePathLength  =  32
  INTEGER(i4b), PARAMETER :: fileNameLength  =  32
  INTEGER(i4b), PARAMETER :: fileNameLength80=  80
  INTEGER(i4b), PARAMETER :: fileExtLength   =   3

  INTEGER(i4b), PARAMETER :: shortLineLength =  80
  INTEGER(i4b), PARAMETER :: lineLength      = 255
  INTEGER(i4b), PARAMETER :: longLineLength  = 512
  INTEGER(i4b), PARAMETER :: lineLength1024  =1024

  INTEGER(i4b), PARAMETER :: staNameLength   =  16
  INTEGER(i4b), PARAMETER :: staNam2Length   =  20
  INTEGER(i4b), PARAMETER :: staFlagLength   =   1
  INTEGER(i4b), PARAMETER :: staFla2Length   =   5

  INTEGER(i4b), PARAMETER :: timStrgLength   =  19
  INTEGER(i4b), PARAMETER :: timStrgLength2  =  40

  CHARACTER(LEN=3), PARAMETER :: pgmver='5.2'

  CHARACTER(LEN=8), SAVE  :: program_Name    = ' '
  CHARACTER(LEN=80),SAVE  :: program_Dscr    = ' '

  CHARACTER(LEN=1), PARAMETER :: backslash = char(92)

  TYPE t_key
    CHARACTER(LEN=keyNameLength)                         :: name
    CHARACTER(LEN=keyValueLength), DIMENSION(:), POINTER :: value
  END TYPE

! Logical file numbers
! --------------------
!                  Extended file numbers !   FORTRAN standard
  INTEGER(i4b)    ::  LFNKBD =   5       !      LFNKBD =  5
  INTEGER(i4b)    ::  LFNPRT =   6       !      LFNPRT =  6
  INTEGER(i4b)    ::  LFNERR =   6       !      LFNERR =  6
  INTEGER(i4b)    ::  LFN001 =  11       !      LFN001 = 11
  INTEGER(i4b)    ::  LFN002 = 501       !      LFN002 = 51
  INTEGER(i4b)    ::  LFNEPH = 990       !      LFNEPH = 90
  INTEGER(i4b)    ::  LFNOR1 = 991       !      LFNOR1 = 91
  INTEGER(i4b)    ::  LFNRP1 = 992       !      LFNRP1 = 92
  INTEGER(i4b)    ::  LFNORB = 993       !      LFNORB = 93
  INTEGER(i4b)    ::  LFNRPR = 994       !      LFNRPR = 94
  INTEGER(i4b)    ::  LFNPLT = 995       !      LFNPLT = 95
  INTEGER(i4b)    ::  LFNRES = 996       !      LFNRES = 96
  INTEGER(i4b)    ::  LFNERF = 997       !      LFNERF = 97
  INTEGER(i4b)    ::  LFNPRF = 998       !      LFNPRF = 98
  INTEGER(i4b)    ::  LFNLOC = 999       !      LFNLOC = 99

! Initialize structure
! --------------------
CONTAINS

  SUBROUTINE init_key(key)
    TYPE(t_key)  :: key
    NULLIFY(key%value)
  END SUBROUTINE init_key

END MODULE m_bern

max_stars_repo_name: longzhmm/tropos-model

max_issues_repo_name: longzhmm/tropos-model

max_forks_repo_name: longzhmm/tropos-model


text:
        INTEGER FUNCTION NAME2FID( FNAME )

C***********************************************************************
C Version "$Id: name2fid.f 107 2018-07-26 14:05:39Z coats $"
C EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
C (C) 2003-2010 by Baron Advanced Meteorological Systems.
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C  function  NAME2FID   starts at line  66
C
C  FUNCTION:
C       Find STATE3 index FID for  I/O API file with logical name FNAME.
C       SIDE EFFECT:  calls INIT3() in a thread-safe manner.
C
C  RETURN VALUE:
C       TSTATE3 index FID if the file with logical name FNAME has been opened.
C        -1 if I/O API not yet initialized, or if FNAME too long;
C         0 if FNAME not yet opened.
C
C  PRECONDITIONS REQUIRED:
C       none
C
C  SUBROUTINES AND FUNCTIONS CALLED:
C       INDEX1, TRIMLEN
C
C  REVISION  HISTORY:
C       Prototype 10/2003 by CJC for I/O API version 3
C       Bug-fix   11/2003 by CJC:  don't return from within critical section
C       Modified  3/2005 by CJC:  bad name length returns  (-1)
C       Modified 03/2010 by CJC: F9x changes for I/O API v3.1
C***********************************************************************

        IMPLICIT NONE

C...........   INCLUDES:

        INCLUDE 'PARMS3.EXT'
        INCLUDE 'IODECL3.EXT'
        INCLUDE 'STATE3.EXT'

C...........   ARGUMENTS and their descriptions:

        CHARACTER*(*), INTENT(IN   ) :: FNAME   !  logical name of file to be opened

C...........   EXTERNAL FUNCTIONS and their descriptions:

        INTEGER, EXTERNAL ::INDEX1

C...........   SCRATCH LOCAL VARIABLES and their descriptions:

        CHARACTER*16    FIL16           !  scratch file-name buffer
        CHARACTER*256   MESG
        INTEGER         L
        LOGICAL         EFLAG

C***********************************************************************
C   begin body of function  NAME2FID

        EFLAG = .FALSE.
!$OMP   CRITICAL( S_INIT )
        IF ( .NOT. FINIT3 ) THEN
            L = INIT3()
            EFLAG    = .TRUE.
        END IF
!$OMP   END CRITICAL( S_INIT )

        IF ( EFLAG ) THEN
            CALL M3MSG2( 'I/O API not yet initialized' )
            NAME2FID = 0
            EFLAG    = .TRUE.
            RETURN
        END IF

        L = LEN_TRIM( FNAME )
        IF ( L .GT. NAMLEN3 ) THEN
            WRITE( MESG, '( 3 A, I9, A, I9 )' )
     &          'Bad file name length for "', FNAME( 1:L ),
     &          '":  max length ', NAMLEN3, ' actual ', L
            CALL M3MSG2( MESG )
            NAME2FID = -1
            RETURN
        END IF

C.......   Find STATE3 index for the file:

        FIL16    = FNAME   !  fixed-length-16 scratch copy of name
        NAME2FID = INDEX1( FIL16, COUNT3, FLIST3 )

        RETURN

        END FUNCTION NAME2FID

max_stars_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_issues_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork

max_forks_repo_name: mdhillmancmcl/TheWorldAvatar-CMCL-Fork


text: The Senior Citizens Commission is one of the City Commissions.  It advises City Council on all matters relating to policies and programs which will serve senior citizens in the community. The Commission identifies needs of the aging, creates citizen awareness programs, and explores improved standards of services.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search