module tao_cpp_test_mod use tao_cpp_convert_mod use tao_equality_mod use bmad_cpp_test_mod contains !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_qp_rect (ok) implicit none type(qp_rect_struct), target :: f_qp_rect, f2_qp_rect logical(c_bool) c_ok logical ok interface subroutine test_c_qp_rect (c_qp_rect, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_qp_rect logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_qp_rect_test_pattern (f2_qp_rect, 1) call test_c_qp_rect(c_loc(f2_qp_rect), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_qp_rect_test_pattern (f_qp_rect, 4) if (f_qp_rect == f2_qp_rect) then print *, 'qp_rect: C side convert C->F: Good' else print *, 'qp_rect: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_qp_rect !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_qp_rect (c_qp_rect, c_ok) bind(c) implicit none type(c_ptr), value :: c_qp_rect type(qp_rect_struct), target :: f_qp_rect, f2_qp_rect logical(c_bool) c_ok ! c_ok = c_logic(.true.) call qp_rect_to_f (c_qp_rect, c_loc(f_qp_rect)) call set_qp_rect_test_pattern (f2_qp_rect, 2) if (f_qp_rect == f2_qp_rect) then print *, 'qp_rect: F side convert C->F: Good' else print *, 'qp_rect: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_qp_rect_test_pattern (f2_qp_rect, 3) call qp_rect_to_c (c_loc(f2_qp_rect), c_qp_rect) end subroutine test2_f_qp_rect !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_qp_rect_test_pattern (F, ix_patt) implicit none type(qp_rect_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%x1 = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%x2 = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%y1 = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%y2 = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%units) F%units(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo end subroutine set_qp_rect_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_qp_line (ok) implicit none type(qp_line_struct), target :: f_qp_line, f2_qp_line logical(c_bool) c_ok logical ok interface subroutine test_c_qp_line (c_qp_line, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_qp_line logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_qp_line_test_pattern (f2_qp_line, 1) call test_c_qp_line(c_loc(f2_qp_line), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_qp_line_test_pattern (f_qp_line, 4) if (f_qp_line == f2_qp_line) then print *, 'qp_line: C side convert C->F: Good' else print *, 'qp_line: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_qp_line !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_qp_line (c_qp_line, c_ok) bind(c) implicit none type(c_ptr), value :: c_qp_line type(qp_line_struct), target :: f_qp_line, f2_qp_line logical(c_bool) c_ok ! c_ok = c_logic(.true.) call qp_line_to_f (c_qp_line, c_loc(f_qp_line)) call set_qp_line_test_pattern (f2_qp_line, 2) if (f_qp_line == f2_qp_line) then print *, 'qp_line: F side convert C->F: Good' else print *, 'qp_line: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_qp_line_test_pattern (f2_qp_line, 3) call qp_line_to_c (c_loc(f2_qp_line), c_qp_line) end subroutine test2_f_qp_line !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_qp_line_test_pattern (F, ix_patt) implicit none type(qp_line_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[integer, 0, NOT] rhs = 1 + offset; F%width = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 2 + offset; F%color = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 3 + offset; F%pattern = rhs end subroutine set_qp_line_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_qp_symbol (ok) implicit none type(qp_symbol_struct), target :: f_qp_symbol, f2_qp_symbol logical(c_bool) c_ok logical ok interface subroutine test_c_qp_symbol (c_qp_symbol, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_qp_symbol logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_qp_symbol_test_pattern (f2_qp_symbol, 1) call test_c_qp_symbol(c_loc(f2_qp_symbol), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_qp_symbol_test_pattern (f_qp_symbol, 4) if (f_qp_symbol == f2_qp_symbol) then print *, 'qp_symbol: C side convert C->F: Good' else print *, 'qp_symbol: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_qp_symbol !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_qp_symbol (c_qp_symbol, c_ok) bind(c) implicit none type(c_ptr), value :: c_qp_symbol type(qp_symbol_struct), target :: f_qp_symbol, f2_qp_symbol logical(c_bool) c_ok ! c_ok = c_logic(.true.) call qp_symbol_to_f (c_qp_symbol, c_loc(f_qp_symbol)) call set_qp_symbol_test_pattern (f2_qp_symbol, 2) if (f_qp_symbol == f2_qp_symbol) then print *, 'qp_symbol: F side convert C->F: Good' else print *, 'qp_symbol: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_qp_symbol_test_pattern (f2_qp_symbol, 3) call qp_symbol_to_c (c_loc(f2_qp_symbol), c_qp_symbol) end subroutine test2_f_qp_symbol !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_qp_symbol_test_pattern (F, ix_patt) implicit none type(qp_symbol_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[integer, 0, NOT] rhs = 1 + offset; F%type = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%height = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 3 + offset; F%color = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 4 + offset; F%fill_pattern = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 5 + offset; F%line_width = rhs end subroutine set_qp_symbol_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_qp_point (ok) implicit none type(qp_point_struct), target :: f_qp_point, f2_qp_point logical(c_bool) c_ok logical ok interface subroutine test_c_qp_point (c_qp_point, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_qp_point logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_qp_point_test_pattern (f2_qp_point, 1) call test_c_qp_point(c_loc(f2_qp_point), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_qp_point_test_pattern (f_qp_point, 4) if (f_qp_point == f2_qp_point) then print *, 'qp_point: C side convert C->F: Good' else print *, 'qp_point: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_qp_point !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_qp_point (c_qp_point, c_ok) bind(c) implicit none type(c_ptr), value :: c_qp_point type(qp_point_struct), target :: f_qp_point, f2_qp_point logical(c_bool) c_ok ! c_ok = c_logic(.true.) call qp_point_to_f (c_qp_point, c_loc(f_qp_point)) call set_qp_point_test_pattern (f2_qp_point, 2) if (f_qp_point == f2_qp_point) then print *, 'qp_point: F side convert C->F: Good' else print *, 'qp_point: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_qp_point_test_pattern (f2_qp_point, 3) call qp_point_to_c (c_loc(f2_qp_point), c_qp_point) end subroutine test2_f_qp_point !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_qp_point_test_pattern (F, ix_patt) implicit none type(qp_point_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%x = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%y = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%units) F%units(jd1:jd1) = char(ichar("a") + modulo(100+3+offset+jd1, 26)) enddo end subroutine set_qp_point_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_qp_axis (ok) implicit none type(qp_axis_struct), target :: f_qp_axis, f2_qp_axis logical(c_bool) c_ok logical ok interface subroutine test_c_qp_axis (c_qp_axis, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_qp_axis logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_qp_axis_test_pattern (f2_qp_axis, 1) call test_c_qp_axis(c_loc(f2_qp_axis), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_qp_axis_test_pattern (f_qp_axis, 4) if (f_qp_axis == f2_qp_axis) then print *, 'qp_axis: C side convert C->F: Good' else print *, 'qp_axis: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_qp_axis !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_qp_axis (c_qp_axis, c_ok) bind(c) implicit none type(c_ptr), value :: c_qp_axis type(qp_axis_struct), target :: f_qp_axis, f2_qp_axis logical(c_bool) c_ok ! c_ok = c_logic(.true.) call qp_axis_to_f (c_qp_axis, c_loc(f_qp_axis)) call set_qp_axis_test_pattern (f2_qp_axis, 2) if (f_qp_axis == f2_qp_axis) then print *, 'qp_axis: F side convert C->F: Good' else print *, 'qp_axis: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_qp_axis_test_pattern (f2_qp_axis, 3) call qp_axis_to_c (c_loc(f2_qp_axis), c_qp_axis) end subroutine test2_f_qp_axis !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_qp_axis_test_pattern (F, ix_patt) implicit none type(qp_axis_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%label) F%label(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%min = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%max = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%number_offset = rhs !! f_side.test_pat[real, 0, NOT] rhs = 5 + offset; F%label_offset = rhs !! f_side.test_pat[real, 0, NOT] rhs = 6 + offset; F%major_tick_len = rhs !! f_side.test_pat[real, 0, NOT] rhs = 7 + offset; F%minor_tick_len = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 8 + offset; F%label_color = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 9 + offset; F%major_div = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 10 + offset; F%major_div_nominal = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 11 + offset; F%minor_div = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 12 + offset; F%minor_div_max = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 13 + offset; F%places = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%type) F%type(jd1:jd1) = char(ichar("a") + modulo(100+14+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%bounds) F%bounds(jd1:jd1) = char(ichar("a") + modulo(100+15+offset+jd1, 26)) enddo !! f_side.test_pat[integer, 0, NOT] rhs = 16 + offset; F%tick_side = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 17 + offset; F%number_side = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 18 + offset; F%draw_label = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 19 + offset; F%draw_numbers = (modulo(rhs, 2) == 0) end subroutine set_qp_axis_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_cmd_history (ok) implicit none type(tao_cmd_history_struct), target :: f_tao_cmd_history, f2_tao_cmd_history logical(c_bool) c_ok logical ok interface subroutine test_c_tao_cmd_history (c_tao_cmd_history, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_cmd_history logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_cmd_history_test_pattern (f2_tao_cmd_history, 1) call test_c_tao_cmd_history(c_loc(f2_tao_cmd_history), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_cmd_history_test_pattern (f_tao_cmd_history, 4) if (f_tao_cmd_history == f2_tao_cmd_history) then print *, 'tao_cmd_history: C side convert C->F: Good' else print *, 'tao_cmd_history: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_cmd_history !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_cmd_history (c_tao_cmd_history, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_cmd_history type(tao_cmd_history_struct), target :: f_tao_cmd_history, f2_tao_cmd_history logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_cmd_history_to_f (c_tao_cmd_history, c_loc(f_tao_cmd_history)) call set_tao_cmd_history_test_pattern (f2_tao_cmd_history, 2) if (f_tao_cmd_history == f2_tao_cmd_history) then print *, 'tao_cmd_history: F side convert C->F: Good' else print *, 'tao_cmd_history: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_cmd_history_test_pattern (f2_tao_cmd_history, 3) call tao_cmd_history_to_c (c_loc(f2_tao_cmd_history), c_tao_cmd_history) end subroutine test2_f_tao_cmd_history !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_cmd_history_test_pattern (F, ix_patt) implicit none type(tao_cmd_history_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, ALLOC] if (ix_patt < 3) then if (allocated(F%cmd)) deallocate (F%cmd) else if (.not. allocated(F%cmd)) allocate (F%cmd) do jd1 = 1, len(F%cmd) F%cmd(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo endif !! f_side.test_pat[integer, 0, NOT] rhs = 3 + offset; F%ix = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 4 + offset; F%cmd_file = (modulo(rhs, 2) == 0) end subroutine set_tao_cmd_history_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_real_pointer (ok) implicit none type(tao_real_pointer_struct), target :: f_tao_real_pointer, f2_tao_real_pointer logical(c_bool) c_ok logical ok interface subroutine test_c_tao_real_pointer (c_tao_real_pointer, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_real_pointer logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_real_pointer_test_pattern (f2_tao_real_pointer, 1) call test_c_tao_real_pointer(c_loc(f2_tao_real_pointer), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_real_pointer_test_pattern (f_tao_real_pointer, 4) if (f_tao_real_pointer == f2_tao_real_pointer) then print *, 'tao_real_pointer: C side convert C->F: Good' else print *, 'tao_real_pointer: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_real_pointer !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_real_pointer (c_tao_real_pointer, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_real_pointer type(tao_real_pointer_struct), target :: f_tao_real_pointer, f2_tao_real_pointer logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_real_pointer_to_f (c_tao_real_pointer, c_loc(f_tao_real_pointer)) call set_tao_real_pointer_test_pattern (f2_tao_real_pointer, 2) if (f_tao_real_pointer == f2_tao_real_pointer) then print *, 'tao_real_pointer: F side convert C->F: Good' else print *, 'tao_real_pointer: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_real_pointer_test_pattern (f2_tao_real_pointer, 3) call tao_real_pointer_to_c (c_loc(f2_tao_real_pointer), c_tao_real_pointer) end subroutine test2_f_tao_real_pointer !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_real_pointer_test_pattern (F, ix_patt) implicit none type(tao_real_pointer_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[logical, 0, PTR] if (ix_patt < 3) then if (associated(F%good_value)) deallocate (F%good_value) else if (.not. associated(F%good_value)) allocate (F%good_value) rhs = 3 + offset F%good_value = (modulo(rhs, 2) == 0) endif !! f_side.test_pat[logical, 0, PTR] if (ix_patt < 3) then if (associated(F%good_user)) deallocate (F%good_user) else if (.not. associated(F%good_user)) allocate (F%good_user) rhs = 5 + offset F%good_user = (modulo(rhs, 2) == 0) endif end subroutine set_tao_real_pointer_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_logical_array (ok) implicit none type(tao_logical_array_struct), target :: f_tao_logical_array, f2_tao_logical_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_logical_array (c_tao_logical_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_logical_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_logical_array_test_pattern (f2_tao_logical_array, 1) call test_c_tao_logical_array(c_loc(f2_tao_logical_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_logical_array_test_pattern (f_tao_logical_array, 4) if (f_tao_logical_array == f2_tao_logical_array) then print *, 'tao_logical_array: C side convert C->F: Good' else print *, 'tao_logical_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_logical_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_logical_array (c_tao_logical_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_logical_array type(tao_logical_array_struct), target :: f_tao_logical_array, f2_tao_logical_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_logical_array_to_f (c_tao_logical_array, c_loc(f_tao_logical_array)) call set_tao_logical_array_test_pattern (f2_tao_logical_array, 2) if (f_tao_logical_array == f2_tao_logical_array) then print *, 'tao_logical_array: F side convert C->F: Good' else print *, 'tao_logical_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_logical_array_test_pattern (f2_tao_logical_array, 3) call tao_logical_array_to_c (c_loc(f2_tao_logical_array), c_tao_logical_array) end subroutine test2_f_tao_logical_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_logical_array_test_pattern (F, ix_patt) implicit none type(tao_logical_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_logical_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_integer_array (ok) implicit none type(tao_integer_array_struct), target :: f_tao_integer_array, f2_tao_integer_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_integer_array (c_tao_integer_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_integer_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_integer_array_test_pattern (f2_tao_integer_array, 1) call test_c_tao_integer_array(c_loc(f2_tao_integer_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_integer_array_test_pattern (f_tao_integer_array, 4) if (f_tao_integer_array == f2_tao_integer_array) then print *, 'tao_integer_array: C side convert C->F: Good' else print *, 'tao_integer_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_integer_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_integer_array (c_tao_integer_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_integer_array type(tao_integer_array_struct), target :: f_tao_integer_array, f2_tao_integer_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_integer_array_to_f (c_tao_integer_array, c_loc(f_tao_integer_array)) call set_tao_integer_array_test_pattern (f2_tao_integer_array, 2) if (f_tao_integer_array == f2_tao_integer_array) then print *, 'tao_integer_array: F side convert C->F: Good' else print *, 'tao_integer_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_integer_array_test_pattern (f2_tao_integer_array, 3) call tao_integer_array_to_c (c_loc(f2_tao_integer_array), c_tao_integer_array) end subroutine test2_f_tao_integer_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_integer_array_test_pattern (F, ix_patt) implicit none type(tao_integer_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_integer_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_expression_info (ok) implicit none type(tao_expression_info_struct), target :: f_tao_expression_info, f2_tao_expression_info logical(c_bool) c_ok logical ok interface subroutine test_c_tao_expression_info (c_tao_expression_info, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_expression_info logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_expression_info_test_pattern (f2_tao_expression_info, 1) call test_c_tao_expression_info(c_loc(f2_tao_expression_info), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_expression_info_test_pattern (f_tao_expression_info, 4) if (f_tao_expression_info == f2_tao_expression_info) then print *, 'tao_expression_info: C side convert C->F: Good' else print *, 'tao_expression_info: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_expression_info !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_expression_info (c_tao_expression_info, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_expression_info type(tao_expression_info_struct), target :: f_tao_expression_info, f2_tao_expression_info logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_expression_info_to_f (c_tao_expression_info, c_loc(f_tao_expression_info)) call set_tao_expression_info_test_pattern (f2_tao_expression_info, 2) if (f_tao_expression_info == f2_tao_expression_info) then print *, 'tao_expression_info: F side convert C->F: Good' else print *, 'tao_expression_info: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_expression_info_test_pattern (f2_tao_expression_info, 3) call tao_expression_info_to_c (c_loc(f2_tao_expression_info), c_tao_expression_info) end subroutine test2_f_tao_expression_info !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_expression_info_test_pattern (F, ix_patt) implicit none type(tao_expression_info_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[logical, 0, NOT] rhs = 1 + offset; F%good = (modulo(rhs, 2) == 0) !! f_side.test_pat[integer, 0, NOT] rhs = 2 + offset; F%ix_ele = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%s = rhs end subroutine set_tao_expression_info_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_eval_stack1 (ok) implicit none type(tao_eval_stack1_struct), target :: f_tao_eval_stack1, f2_tao_eval_stack1 logical(c_bool) c_ok logical ok interface subroutine test_c_tao_eval_stack1 (c_tao_eval_stack1, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_eval_stack1 logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_eval_stack1_test_pattern (f2_tao_eval_stack1, 1) call test_c_tao_eval_stack1(c_loc(f2_tao_eval_stack1), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_eval_stack1_test_pattern (f_tao_eval_stack1, 4) if (f_tao_eval_stack1 == f2_tao_eval_stack1) then print *, 'tao_eval_stack1: C side convert C->F: Good' else print *, 'tao_eval_stack1: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_eval_stack1 !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_eval_stack1 (c_tao_eval_stack1, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_eval_stack1 type(tao_eval_stack1_struct), target :: f_tao_eval_stack1, f2_tao_eval_stack1 logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_eval_stack1_to_f (c_tao_eval_stack1, c_loc(f_tao_eval_stack1)) call set_tao_eval_stack1_test_pattern (f2_tao_eval_stack1, 2) if (f_tao_eval_stack1 == f2_tao_eval_stack1) then print *, 'tao_eval_stack1: F side convert C->F: Good' else print *, 'tao_eval_stack1: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_eval_stack1_test_pattern (f2_tao_eval_stack1, 3) call tao_eval_stack1_to_c (c_loc(f2_tao_eval_stack1), c_tao_eval_stack1) end subroutine test2_f_tao_eval_stack1 !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_eval_stack1_test_pattern (F, ix_patt) implicit none type(tao_eval_stack1_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[integer, 0, NOT] rhs = 1 + offset; F%type = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%scale = rhs !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%value)) deallocate (F%value) else if (.not. allocated(F%value)) allocate (F%value(-1:1)) do jd1 = 1, size(F%value,1); lb1 = lbound(F%value,1) - 1 rhs = 100 + jd1 + 4 + offset F%value(jd1+lb1) = rhs enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%info)) deallocate (F%info) else if (.not. allocated(F%info)) allocate (F%info(-1:1)) do jd1 = 1, size(F%info,1); lb1 = lbound(F%info,1) - 1 call set_tao_expression_info_test_pattern (F%info(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%value_ptr)) deallocate (F%value_ptr) else if (.not. allocated(F%value_ptr)) allocate (F%value_ptr(-1:1)) do jd1 = 1, size(F%value_ptr,1); lb1 = lbound(F%value_ptr,1) - 1 call set_tao_real_pointer_test_pattern (F%value_ptr(jd1+lb1), ix_patt+jd1) enddo endif end subroutine set_tao_eval_stack1_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_ele_shape (ok) implicit none type(tao_ele_shape_struct), target :: f_tao_ele_shape, f2_tao_ele_shape logical(c_bool) c_ok logical ok interface subroutine test_c_tao_ele_shape (c_tao_ele_shape, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_ele_shape logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_ele_shape_test_pattern (f2_tao_ele_shape, 1) call test_c_tao_ele_shape(c_loc(f2_tao_ele_shape), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_ele_shape_test_pattern (f_tao_ele_shape, 4) if (f_tao_ele_shape == f2_tao_ele_shape) then print *, 'tao_ele_shape: C side convert C->F: Good' else print *, 'tao_ele_shape: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_ele_shape !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_ele_shape (c_tao_ele_shape, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_ele_shape type(tao_ele_shape_struct), target :: f_tao_ele_shape, f2_tao_ele_shape logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_ele_shape_to_f (c_tao_ele_shape, c_loc(f_tao_ele_shape)) call set_tao_ele_shape_test_pattern (f2_tao_ele_shape, 2) if (f_tao_ele_shape == f2_tao_ele_shape) then print *, 'tao_ele_shape: F side convert C->F: Good' else print *, 'tao_ele_shape: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_ele_shape_test_pattern (f2_tao_ele_shape, 3) call tao_ele_shape_to_c (c_loc(f2_tao_ele_shape), c_tao_ele_shape) end subroutine test2_f_tao_ele_shape !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_ele_shape_test_pattern (F, ix_patt) implicit none type(tao_ele_shape_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ele_id) F%ele_id(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%shape) F%shape(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%color) F%color(jd1:jd1) = char(ichar("a") + modulo(100+3+offset+jd1, 26)) enddo !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%size = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%label) F%label(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo !! f_side.test_pat[logical, 0, NOT] rhs = 6 + offset; F%draw = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 7 + offset; F%multi = (modulo(rhs, 2) == 0) !! f_side.test_pat[integer, 0, NOT] rhs = 8 + offset; F%ix_ele_key = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name_ele) F%name_ele(jd1:jd1) = char(ichar("a") + modulo(100+9+offset+jd1, 26)) enddo end subroutine set_tao_ele_shape_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_pattern_point (ok) implicit none type(tao_pattern_point_struct), target :: f_tao_pattern_point, f2_tao_pattern_point logical(c_bool) c_ok logical ok interface subroutine test_c_tao_pattern_point (c_tao_pattern_point, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_pattern_point logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_pattern_point_test_pattern (f2_tao_pattern_point, 1) call test_c_tao_pattern_point(c_loc(f2_tao_pattern_point), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_pattern_point_test_pattern (f_tao_pattern_point, 4) if (f_tao_pattern_point == f2_tao_pattern_point) then print *, 'tao_pattern_point: C side convert C->F: Good' else print *, 'tao_pattern_point: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_pattern_point !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_pattern_point (c_tao_pattern_point, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_pattern_point type(tao_pattern_point_struct), target :: f_tao_pattern_point, f2_tao_pattern_point logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_pattern_point_to_f (c_tao_pattern_point, c_loc(f_tao_pattern_point)) call set_tao_pattern_point_test_pattern (f2_tao_pattern_point, 2) if (f_tao_pattern_point == f2_tao_pattern_point) then print *, 'tao_pattern_point: F side convert C->F: Good' else print *, 'tao_pattern_point: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_pattern_point_test_pattern (f2_tao_pattern_point, 3) call tao_pattern_point_to_c (c_loc(f2_tao_pattern_point), c_tao_pattern_point) end subroutine test2_f_tao_pattern_point !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_pattern_point_test_pattern (F, ix_patt) implicit none type(tao_pattern_point_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%s = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%x = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%radius = rhs end subroutine set_tao_pattern_point_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_pattern_curve (ok) implicit none type(tao_pattern_curve_struct), target :: f_tao_pattern_curve, f2_tao_pattern_curve logical(c_bool) c_ok logical ok interface subroutine test_c_tao_pattern_curve (c_tao_pattern_curve, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_pattern_curve logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_pattern_curve_test_pattern (f2_tao_pattern_curve, 1) call test_c_tao_pattern_curve(c_loc(f2_tao_pattern_curve), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_pattern_curve_test_pattern (f_tao_pattern_curve, 4) if (f_tao_pattern_curve == f2_tao_pattern_curve) then print *, 'tao_pattern_curve: C side convert C->F: Good' else print *, 'tao_pattern_curve: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_pattern_curve !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_pattern_curve (c_tao_pattern_curve, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_pattern_curve type(tao_pattern_curve_struct), target :: f_tao_pattern_curve, f2_tao_pattern_curve logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_pattern_curve_to_f (c_tao_pattern_curve, c_loc(f_tao_pattern_curve)) call set_tao_pattern_curve_test_pattern (f2_tao_pattern_curve, 2) if (f_tao_pattern_curve == f2_tao_pattern_curve) then print *, 'tao_pattern_curve: F side convert C->F: Good' else print *, 'tao_pattern_curve: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_pattern_curve_test_pattern (f2_tao_pattern_curve, 3) call tao_pattern_curve_to_c (c_loc(f2_tao_pattern_curve), c_tao_pattern_curve) end subroutine test2_f_tao_pattern_curve !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_pattern_curve_test_pattern (F, ix_patt) implicit none type(tao_pattern_curve_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 0, NOT] call set_qp_line_test_pattern (F%line, ix_patt) !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%pt)) deallocate (F%pt) else if (.not. allocated(F%pt)) allocate (F%pt(-1:1)) do jd1 = 1, size(F%pt,1); lb1 = lbound(F%pt,1) - 1 call set_tao_pattern_point_test_pattern (F%pt(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%scale) F%scale(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo end subroutine set_tao_pattern_curve_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_shape_pattern (ok) implicit none type(tao_shape_pattern_struct), target :: f_tao_shape_pattern, f2_tao_shape_pattern logical(c_bool) c_ok logical ok interface subroutine test_c_tao_shape_pattern (c_tao_shape_pattern, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_shape_pattern logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_shape_pattern_test_pattern (f2_tao_shape_pattern, 1) call test_c_tao_shape_pattern(c_loc(f2_tao_shape_pattern), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_shape_pattern_test_pattern (f_tao_shape_pattern, 4) if (f_tao_shape_pattern == f2_tao_shape_pattern) then print *, 'tao_shape_pattern: C side convert C->F: Good' else print *, 'tao_shape_pattern: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_shape_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_shape_pattern (c_tao_shape_pattern, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_shape_pattern type(tao_shape_pattern_struct), target :: f_tao_shape_pattern, f2_tao_shape_pattern logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_shape_pattern_to_f (c_tao_shape_pattern, c_loc(f_tao_shape_pattern)) call set_tao_shape_pattern_test_pattern (f2_tao_shape_pattern, 2) if (f_tao_shape_pattern == f2_tao_shape_pattern) then print *, 'tao_shape_pattern: F side convert C->F: Good' else print *, 'tao_shape_pattern: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_shape_pattern_test_pattern (f2_tao_shape_pattern, 3) call tao_shape_pattern_to_c (c_loc(f2_tao_shape_pattern), c_tao_shape_pattern) end subroutine test2_f_tao_shape_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_shape_pattern_test_pattern (F, ix_patt) implicit none type(tao_shape_pattern_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%curve)) deallocate (F%curve) else if (.not. allocated(F%curve)) allocate (F%curve(-1:1)) do jd1 = 1, size(F%curve,1); lb1 = lbound(F%curve,1) - 1 call set_tao_pattern_curve_test_pattern (F%curve(jd1+lb1), ix_patt+jd1) enddo endif end subroutine set_tao_shape_pattern_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_drawing (ok) implicit none type(tao_drawing_struct), target :: f_tao_drawing, f2_tao_drawing logical(c_bool) c_ok logical ok interface subroutine test_c_tao_drawing (c_tao_drawing, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_drawing logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_drawing_test_pattern (f2_tao_drawing, 1) call test_c_tao_drawing(c_loc(f2_tao_drawing), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_drawing_test_pattern (f_tao_drawing, 4) if (f_tao_drawing == f2_tao_drawing) then print *, 'tao_drawing: C side convert C->F: Good' else print *, 'tao_drawing: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_drawing !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_drawing (c_tao_drawing, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_drawing type(tao_drawing_struct), target :: f_tao_drawing, f2_tao_drawing logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_drawing_to_f (c_tao_drawing, c_loc(f_tao_drawing)) call set_tao_drawing_test_pattern (f2_tao_drawing, 2) if (f_tao_drawing == f2_tao_drawing) then print *, 'tao_drawing: F side convert C->F: Good' else print *, 'tao_drawing: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_drawing_test_pattern (f2_tao_drawing, 3) call tao_drawing_to_c (c_loc(f2_tao_drawing), c_tao_drawing) end subroutine test2_f_tao_drawing !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_drawing_test_pattern (F, ix_patt) implicit none type(tao_drawing_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%ele_shape)) deallocate (F%ele_shape) else if (.not. allocated(F%ele_shape)) allocate (F%ele_shape(-1:1)) do jd1 = 1, size(F%ele_shape,1); lb1 = lbound(F%ele_shape,1) - 1 call set_tao_ele_shape_test_pattern (F%ele_shape(jd1+lb1), ix_patt+jd1) enddo endif end subroutine set_tao_drawing_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_wave_kick_pt (ok) implicit none type(tao_wave_kick_pt_struct), target :: f_tao_wave_kick_pt, f2_tao_wave_kick_pt logical(c_bool) c_ok logical ok interface subroutine test_c_tao_wave_kick_pt (c_tao_wave_kick_pt, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_wave_kick_pt logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_wave_kick_pt_test_pattern (f2_tao_wave_kick_pt, 1) call test_c_tao_wave_kick_pt(c_loc(f2_tao_wave_kick_pt), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_wave_kick_pt_test_pattern (f_tao_wave_kick_pt, 4) if (f_tao_wave_kick_pt == f2_tao_wave_kick_pt) then print *, 'tao_wave_kick_pt: C side convert C->F: Good' else print *, 'tao_wave_kick_pt: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_wave_kick_pt !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_wave_kick_pt (c_tao_wave_kick_pt, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_wave_kick_pt type(tao_wave_kick_pt_struct), target :: f_tao_wave_kick_pt, f2_tao_wave_kick_pt logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_wave_kick_pt_to_f (c_tao_wave_kick_pt, c_loc(f_tao_wave_kick_pt)) call set_tao_wave_kick_pt_test_pattern (f2_tao_wave_kick_pt, 2) if (f_tao_wave_kick_pt == f2_tao_wave_kick_pt) then print *, 'tao_wave_kick_pt: F side convert C->F: Good' else print *, 'tao_wave_kick_pt: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_wave_kick_pt_test_pattern (f2_tao_wave_kick_pt, 3) call tao_wave_kick_pt_to_c (c_loc(f2_tao_wave_kick_pt), c_tao_wave_kick_pt) end subroutine test2_f_tao_wave_kick_pt !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_wave_kick_pt_test_pattern (F, ix_patt) implicit none type(tao_wave_kick_pt_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%phi_s = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%phi_r = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%phi = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%amp = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 5 + offset; F%ix_dat = rhs end subroutine set_tao_wave_kick_pt_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_wave (ok) implicit none type(tao_wave_struct), target :: f_tao_wave, f2_tao_wave logical(c_bool) c_ok logical ok interface subroutine test_c_tao_wave (c_tao_wave, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_wave logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_wave_test_pattern (f2_tao_wave, 1) call test_c_tao_wave(c_loc(f2_tao_wave), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_wave_test_pattern (f_tao_wave, 4) if (f_tao_wave == f2_tao_wave) then print *, 'tao_wave: C side convert C->F: Good' else print *, 'tao_wave: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_wave !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_wave (c_tao_wave, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_wave type(tao_wave_struct), target :: f_tao_wave, f2_tao_wave logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_wave_to_f (c_tao_wave, c_loc(f_tao_wave)) call set_tao_wave_test_pattern (f2_tao_wave, 2) if (f_tao_wave == f2_tao_wave) then print *, 'tao_wave: F side convert C->F: Good' else print *, 'tao_wave: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_wave_test_pattern (f2_tao_wave, 3) call tao_wave_to_c (c_loc(f2_tao_wave), c_tao_wave) end subroutine test2_f_tao_wave !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_wave_test_pattern (F, ix_patt) implicit none type(tao_wave_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_type) F%data_type(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%rms_rel_a = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%rms_rel_b = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%rms_rel_as = rhs !! f_side.test_pat[real, 0, NOT] rhs = 5 + offset; F%rms_rel_bs = rhs !! f_side.test_pat[real, 0, NOT] rhs = 6 + offset; F%rms_rel_ar = rhs !! f_side.test_pat[real, 0, NOT] rhs = 7 + offset; F%rms_rel_br = rhs !! f_side.test_pat[real, 0, NOT] rhs = 8 + offset; F%rms_rel_k = rhs !! f_side.test_pat[real, 0, NOT] rhs = 9 + offset; F%rms_rel_ks = rhs !! f_side.test_pat[real, 0, NOT] rhs = 10 + offset; F%rms_rel_kr = rhs !! f_side.test_pat[real, 0, NOT] rhs = 11 + offset; F%rms_phi = rhs !! f_side.test_pat[real, 0, NOT] rhs = 12 + offset; F%rms_phi_s = rhs !! f_side.test_pat[real, 0, NOT] rhs = 13 + offset; F%rms_phi_r = rhs !! f_side.test_pat[real, 0, NOT] rhs = 14 + offset; F%amp_ba_s = rhs !! f_side.test_pat[real, 0, NOT] rhs = 15 + offset; F%amp_ba_r = rhs !! f_side.test_pat[real, 0, NOT] rhs = 16 + offset; F%chi_a = rhs !! f_side.test_pat[real, 0, NOT] rhs = 17 + offset; F%chi_c = rhs !! f_side.test_pat[real, 0, NOT] rhs = 18 + offset; F%chi_ba = rhs !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%amp_a,1); lb1 = lbound(F%amp_a,1) - 1 rhs = 100 + jd1 + 19 + offset F%amp_a(jd1+lb1) = rhs enddo !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%amp_b,1); lb1 = lbound(F%amp_b,1) - 1 rhs = 100 + jd1 + 20 + offset F%amp_b(jd1+lb1) = rhs enddo !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%amp_ba,1); lb1 = lbound(F%amp_ba,1) - 1 rhs = 100 + jd1 + 21 + offset F%amp_ba(jd1+lb1) = rhs enddo !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%coef_a,1); lb1 = lbound(F%coef_a,1) - 1 rhs = 100 + jd1 + 22 + offset F%coef_a(jd1+lb1) = rhs enddo !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%coef_b,1); lb1 = lbound(F%coef_b,1) - 1 rhs = 100 + jd1 + 23 + offset F%coef_b(jd1+lb1) = rhs enddo !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%coef_ba,1); lb1 = lbound(F%coef_ba,1) - 1 rhs = 100 + jd1 + 24 + offset F%coef_ba(jd1+lb1) = rhs enddo !! f_side.test_pat[integer, 0, NOT] rhs = 25 + offset; F%n_func = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 26 + offset; F%ix_a1 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 27 + offset; F%ix_a2 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 28 + offset; F%ix_b1 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 29 + offset; F%ix_b2 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 30 + offset; F%i_a1 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 31 + offset; F%i_a2 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 32 + offset; F%i_b1 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 33 + offset; F%i_b2 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 34 + offset; F%n_a = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 35 + offset; F%n_b = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 36 + offset; F%i_wrap_pt = rhs !! f_side.test_pat[integer, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%ix_data)) deallocate (F%ix_data) else if (.not. allocated(F%ix_data)) allocate (F%ix_data(-1:1)) do jd1 = 1, size(F%ix_data,1); lb1 = lbound(F%ix_data,1) - 1 rhs = 100 + jd1 + 37 + offset F%ix_data(jd1+lb1) = rhs enddo endif !! f_side.test_pat[integer, 0, NOT] rhs = 39 + offset; F%n_kick = rhs !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%kick)) deallocate (F%kick) else if (.not. allocated(F%kick)) allocate (F%kick(-1:1)) do jd1 = 1, size(F%kick,1); lb1 = lbound(F%kick,1) - 1 call set_tao_wave_kick_pt_test_pattern (F%kick(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 0, NOT] call set_tao_graph_test_pattern (F%graph, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_ele_test_pattern (F%ele, ix_patt) end subroutine set_tao_wave_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_title (ok) implicit none type(tao_title_struct), target :: f_tao_title, f2_tao_title logical(c_bool) c_ok logical ok interface subroutine test_c_tao_title (c_tao_title, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_title logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_title_test_pattern (f2_tao_title, 1) call test_c_tao_title(c_loc(f2_tao_title), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_title_test_pattern (f_tao_title, 4) if (f_tao_title == f2_tao_title) then print *, 'tao_title: C side convert C->F: Good' else print *, 'tao_title: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_title !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_title (c_tao_title, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_title type(tao_title_struct), target :: f_tao_title, f2_tao_title logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_title_to_f (c_tao_title, c_loc(f_tao_title)) call set_tao_title_test_pattern (f2_tao_title, 2) if (f_tao_title == f2_tao_title) then print *, 'tao_title: F side convert C->F: Good' else print *, 'tao_title: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_title_test_pattern (f2_tao_title, 3) call tao_title_to_c (c_loc(f2_tao_title), c_tao_title) end subroutine test2_f_tao_title !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_title_test_pattern (F, ix_patt) implicit none type(tao_title_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%string) F%string(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%x = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%y = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%units) F%units(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%justify) F%justify(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo !! f_side.test_pat[logical, 0, NOT] rhs = 6 + offset; F%draw_it = (modulo(rhs, 2) == 0) end subroutine set_tao_title_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_data_var_component (ok) implicit none type(tao_data_var_component_struct), target :: f_tao_data_var_component, f2_tao_data_var_component logical(c_bool) c_ok logical ok interface subroutine test_c_tao_data_var_component (c_tao_data_var_component, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_data_var_component logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_data_var_component_test_pattern (f2_tao_data_var_component, 1) call test_c_tao_data_var_component(c_loc(f2_tao_data_var_component), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_data_var_component_test_pattern (f_tao_data_var_component, 4) if (f_tao_data_var_component == f2_tao_data_var_component) then print *, 'tao_data_var_component: C side convert C->F: Good' else print *, 'tao_data_var_component: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_data_var_component !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_data_var_component (c_tao_data_var_component, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_data_var_component type(tao_data_var_component_struct), target :: f_tao_data_var_component, f2_tao_data_var_component logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_data_var_component_to_f (c_tao_data_var_component, c_loc(f_tao_data_var_component)) call set_tao_data_var_component_test_pattern (f2_tao_data_var_component, 2) if (f_tao_data_var_component == f2_tao_data_var_component) then print *, 'tao_data_var_component: F side convert C->F: Good' else print *, 'tao_data_var_component: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_data_var_component_test_pattern (f2_tao_data_var_component, 3) call tao_data_var_component_to_c (c_loc(f2_tao_data_var_component), c_tao_data_var_component) end subroutine test2_f_tao_data_var_component !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_data_var_component_test_pattern (F, ix_patt) implicit none type(tao_data_var_component_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%sign = rhs end subroutine set_tao_data_var_component_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_histogram (ok) implicit none type(tao_histogram_struct), target :: f_tao_histogram, f2_tao_histogram logical(c_bool) c_ok logical ok interface subroutine test_c_tao_histogram (c_tao_histogram, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_histogram logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_histogram_test_pattern (f2_tao_histogram, 1) call test_c_tao_histogram(c_loc(f2_tao_histogram), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_histogram_test_pattern (f_tao_histogram, 4) if (f_tao_histogram == f2_tao_histogram) then print *, 'tao_histogram: C side convert C->F: Good' else print *, 'tao_histogram: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_histogram !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_histogram (c_tao_histogram, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_histogram type(tao_histogram_struct), target :: f_tao_histogram, f2_tao_histogram logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_histogram_to_f (c_tao_histogram, c_loc(f_tao_histogram)) call set_tao_histogram_test_pattern (f2_tao_histogram, 2) if (f_tao_histogram == f2_tao_histogram) then print *, 'tao_histogram: F side convert C->F: Good' else print *, 'tao_histogram: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_histogram_test_pattern (f2_tao_histogram, 3) call tao_histogram_to_c (c_loc(f2_tao_histogram), c_tao_histogram) end subroutine test2_f_tao_histogram !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_histogram_test_pattern (F, ix_patt) implicit none type(tao_histogram_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[logical, 0, NOT] rhs = 1 + offset; F%density_normalized = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 2 + offset; F%weight_by_charge = (modulo(rhs, 2) == 0) !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%minimum = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%maximum = rhs !! f_side.test_pat[real, 0, NOT] rhs = 5 + offset; F%width = rhs !! f_side.test_pat[real, 0, NOT] rhs = 6 + offset; F%center = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 7 + offset; F%number = rhs end subroutine set_tao_histogram_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_curve (ok) implicit none type(tao_curve_struct), target :: f_tao_curve, f2_tao_curve logical(c_bool) c_ok logical ok interface subroutine test_c_tao_curve (c_tao_curve, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_curve logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_curve_test_pattern (f2_tao_curve, 1) call test_c_tao_curve(c_loc(f2_tao_curve), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_curve_test_pattern (f_tao_curve, 4) if (f_tao_curve == f2_tao_curve) then print *, 'tao_curve: C side convert C->F: Good' else print *, 'tao_curve: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_curve !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_curve (c_tao_curve, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_curve type(tao_curve_struct), target :: f_tao_curve, f2_tao_curve logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_curve_to_f (c_tao_curve, c_loc(f_tao_curve)) call set_tao_curve_test_pattern (f2_tao_curve, 2) if (f_tao_curve == f2_tao_curve) then print *, 'tao_curve: F side convert C->F: Good' else print *, 'tao_curve: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_curve_test_pattern (f2_tao_curve, 3) call tao_curve_to_c (c_loc(f2_tao_curve), c_tao_curve) end subroutine test2_f_tao_curve !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_curve_test_pattern (F, ix_patt) implicit none type(tao_curve_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_source) F%data_source(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_index) F%data_index(jd1:jd1) = char(ichar("a") + modulo(100+3+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_type_x) F%data_type_x(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_type_z) F%data_type_z(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_type) F%data_type(jd1:jd1) = char(ichar("a") + modulo(100+6+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ele_ref_name) F%ele_ref_name(jd1:jd1) = char(ichar("a") + modulo(100+7+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%legend_text) F%legend_text(jd1:jd1) = char(ichar("a") + modulo(100+8+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%message_text) F%message_text(jd1:jd1) = char(ichar("a") + modulo(100+9+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%units) F%units(jd1:jd1) = char(ichar("a") + modulo(100+10+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%component) F%component(jd1:jd1) = char(ichar("a") + modulo(100+11+offset+jd1, 26)) enddo !! f_side.test_pat[type, 0, NOT] call set_tao_histogram_test_pattern (F%hist, ix_patt) !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%x_line)) deallocate (F%x_line) else if (.not. allocated(F%x_line)) allocate (F%x_line(-1:1)) do jd1 = 1, size(F%x_line,1); lb1 = lbound(F%x_line,1) - 1 rhs = 100 + jd1 + 15 + offset F%x_line(jd1+lb1) = rhs enddo endif !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%y_line)) deallocate (F%y_line) else if (.not. allocated(F%y_line)) allocate (F%y_line(-1:1)) do jd1 = 1, size(F%y_line,1); lb1 = lbound(F%y_line,1) - 1 rhs = 100 + jd1 + 17 + offset F%y_line(jd1+lb1) = rhs enddo endif !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%y2_line)) deallocate (F%y2_line) else if (.not. allocated(F%y2_line)) allocate (F%y2_line(-1:1)) do jd1 = 1, size(F%y2_line,1); lb1 = lbound(F%y2_line,1) - 1 rhs = 100 + jd1 + 19 + offset F%y2_line(jd1+lb1) = rhs enddo endif !! f_side.test_pat[integer, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%ix_line)) deallocate (F%ix_line) else if (.not. allocated(F%ix_line)) allocate (F%ix_line(-1:1)) do jd1 = 1, size(F%ix_line,1); lb1 = lbound(F%ix_line,1) - 1 rhs = 100 + jd1 + 21 + offset F%ix_line(jd1+lb1) = rhs enddo endif !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%x_symb)) deallocate (F%x_symb) else if (.not. allocated(F%x_symb)) allocate (F%x_symb(-1:1)) do jd1 = 1, size(F%x_symb,1); lb1 = lbound(F%x_symb,1) - 1 rhs = 100 + jd1 + 23 + offset F%x_symb(jd1+lb1) = rhs enddo endif !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%y_symb)) deallocate (F%y_symb) else if (.not. allocated(F%y_symb)) allocate (F%y_symb(-1:1)) do jd1 = 1, size(F%y_symb,1); lb1 = lbound(F%y_symb,1) - 1 rhs = 100 + jd1 + 25 + offset F%y_symb(jd1+lb1) = rhs enddo endif !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%z_symb)) deallocate (F%z_symb) else if (.not. allocated(F%z_symb)) allocate (F%z_symb(-1:1)) do jd1 = 1, size(F%z_symb,1); lb1 = lbound(F%z_symb,1) - 1 rhs = 100 + jd1 + 27 + offset F%z_symb(jd1+lb1) = rhs enddo endif !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%symb_size)) deallocate (F%symb_size) else if (.not. allocated(F%symb_size)) allocate (F%symb_size(-1:1)) do jd1 = 1, size(F%symb_size,1); lb1 = lbound(F%symb_size,1) - 1 rhs = 100 + jd1 + 29 + offset F%symb_size(jd1+lb1) = rhs enddo endif !! f_side.test_pat[integer, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%ix_symb)) deallocate (F%ix_symb) else if (.not. allocated(F%ix_symb)) allocate (F%ix_symb(-1:1)) do jd1 = 1, size(F%ix_symb,1); lb1 = lbound(F%ix_symb,1) - 1 rhs = 100 + jd1 + 31 + offset F%ix_symb(jd1+lb1) = rhs enddo endif !! f_side.test_pat[real, 0, NOT] rhs = 33 + offset; F%y_axis_scale_factor = rhs !! f_side.test_pat[real, 0, NOT] rhs = 34 + offset; F%s = rhs !! f_side.test_pat[real, 0, NOT] rhs = 35 + offset; F%z_color0 = rhs !! f_side.test_pat[real, 0, NOT] rhs = 36 + offset; F%z_color1 = rhs !! f_side.test_pat[type, 0, NOT] call set_qp_line_test_pattern (F%line, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_qp_symbol_test_pattern (F%symbol, ix_patt) !! f_side.test_pat[integer, 0, NOT] rhs = 39 + offset; F%ix_universe = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 40 + offset; F%symbol_every = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 41 + offset; F%ix_branch = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 42 + offset; F%ix_ele_ref = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 43 + offset; F%ix_ele_ref_track = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 44 + offset; F%ix_bunch = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 45 + offset; F%use_y2 = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 46 + offset; F%draw_line = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 47 + offset; F%draw_symbols = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 48 + offset; F%draw_symbol_index = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 49 + offset; F%smooth_line_calc = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 50 + offset; F%use_z_color = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 51 + offset; F%autoscale_z_color = (modulo(rhs, 2) == 0) end subroutine set_tao_curve_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_graph (ok) implicit none type(tao_graph_struct), target :: f_tao_graph, f2_tao_graph logical(c_bool) c_ok logical ok interface subroutine test_c_tao_graph (c_tao_graph, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_graph logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_graph_test_pattern (f2_tao_graph, 1) call test_c_tao_graph(c_loc(f2_tao_graph), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_graph_test_pattern (f_tao_graph, 4) if (f_tao_graph == f2_tao_graph) then print *, 'tao_graph: C side convert C->F: Good' else print *, 'tao_graph: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_graph !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_graph (c_tao_graph, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_graph type(tao_graph_struct), target :: f_tao_graph, f2_tao_graph logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_graph_to_f (c_tao_graph, c_loc(f_tao_graph)) call set_tao_graph_test_pattern (f2_tao_graph, 2) if (f_tao_graph == f2_tao_graph) then print *, 'tao_graph: F side convert C->F: Good' else print *, 'tao_graph: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_graph_test_pattern (f2_tao_graph, 3) call tao_graph_to_c (c_loc(f2_tao_graph), c_tao_graph) end subroutine test2_f_tao_graph !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_graph_test_pattern (F, ix_patt) implicit none type(tao_graph_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%type) F%type(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%title) F%title(jd1:jd1) = char(ichar("a") + modulo(100+3+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%title_suffix) F%title_suffix(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo !! f_side.test_pat[character, 1, NOT] do jd1 = lbound(F%text_legend, 1), ubound(F%text_legend, 1) do jd = 1, len(F%text_legend(jd1)) F%text_legend(jd1)(jd:jd) = char(ichar("a") + modulo(100+5+offset+10*jd+jd1, 26)) enddo enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%component) F%component(jd1:jd1) = char(ichar("a") + modulo(100+6+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%why_invalid) F%why_invalid(jd1:jd1) = char(ichar("a") + modulo(100+7+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%floor_plan_view) F%floor_plan_view(jd1:jd1) = char(ichar("a") + modulo(100+8+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%floor_plan_orbit_color) F%floor_plan_orbit_color(jd1:jd1) = char(ichar("a") + modulo(100+9+offset+jd1, 26)) enddo !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%curve)) deallocate (F%curve) else if (.not. allocated(F%curve)) allocate (F%curve(-1:1)) do jd1 = 1, size(F%curve,1); lb1 = lbound(F%curve,1) - 1 call set_tao_curve_test_pattern (F%curve(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 0, NOT] call set_qp_point_test_pattern (F%text_legend_origin, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_qp_point_test_pattern (F%curve_legend_origin, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_qp_axis_test_pattern (F%x, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_qp_axis_test_pattern (F%y, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_qp_axis_test_pattern (F%y2, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_qp_rect_test_pattern (F%margin, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_qp_rect_test_pattern (F%scale_margin, ix_patt) !! f_side.test_pat[real, 0, NOT] rhs = 21 + offset; F%x_axis_scale_factor = rhs !! f_side.test_pat[real, 0, NOT] rhs = 22 + offset; F%symbol_size_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 23 + offset; F%floor_plan_rotation = rhs !! f_side.test_pat[real, 0, NOT] rhs = 24 + offset; F%floor_plan_orbit_scale = rhs !! f_side.test_pat[integer, 1, NOT] do jd1 = 1, size(F%box,1); lb1 = lbound(F%box,1) - 1 rhs = 100 + jd1 + 25 + offset F%box(jd1+lb1) = rhs enddo !! f_side.test_pat[integer, 0, NOT] rhs = 26 + offset; F%ix_branch = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 27 + offset; F%ix_universe = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 28 + offset; F%clip = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 29 + offset; F%valid = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 30 + offset; F%y2_mirrors_y = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 31 + offset; F%limited = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 32 + offset; F%draw_axes = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 33 + offset; F%correct_xy_distortion = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 34 + offset; F%floor_plan_size_is_absolute = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 35 + offset; F%floor_plan_draw_only_first_pass = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 36 + offset; F%draw_curve_legend = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 37 + offset; F%draw_grid = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 38 + offset; F%allow_wrap_around = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 39 + offset; F%draw_only_good_user_data_or_vars = (modulo(rhs, 2) == 0) end subroutine set_tao_graph_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_plot (ok) implicit none type(tao_plot_struct), target :: f_tao_plot, f2_tao_plot logical(c_bool) c_ok logical ok interface subroutine test_c_tao_plot (c_tao_plot, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_plot logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_plot_test_pattern (f2_tao_plot, 1) call test_c_tao_plot(c_loc(f2_tao_plot), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_plot_test_pattern (f_tao_plot, 4) if (f_tao_plot == f2_tao_plot) then print *, 'tao_plot: C side convert C->F: Good' else print *, 'tao_plot: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_plot !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_plot (c_tao_plot, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_plot type(tao_plot_struct), target :: f_tao_plot, f2_tao_plot logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_plot_to_f (c_tao_plot, c_loc(f_tao_plot)) call set_tao_plot_test_pattern (f2_tao_plot, 2) if (f_tao_plot == f2_tao_plot) then print *, 'tao_plot: F side convert C->F: Good' else print *, 'tao_plot: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_plot_test_pattern (f2_tao_plot, 3) call tao_plot_to_c (c_loc(f2_tao_plot), c_tao_plot) end subroutine test2_f_tao_plot !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_plot_test_pattern (F, ix_patt) implicit none type(tao_plot_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%description) F%description(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%graph)) deallocate (F%graph) else if (.not. allocated(F%graph)) allocate (F%graph(-1:1)) do jd1 = 1, size(F%graph,1); lb1 = lbound(F%graph,1) - 1 call set_tao_graph_test_pattern (F%graph(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 0, NOT] call set_qp_axis_test_pattern (F%x, ix_patt) !! f_side.test_pat[integer, 0, NOT] rhs = 8 + offset; F%n_curve_pts = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%type) F%type(jd1:jd1) = char(ichar("a") + modulo(100+9+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%x_axis_type) F%x_axis_type(jd1:jd1) = char(ichar("a") + modulo(100+10+offset+jd1, 26)) enddo !! f_side.test_pat[logical, 0, NOT] rhs = 11 + offset; F%autoscale_x = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 12 + offset; F%autoscale_y = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 13 + offset; F%autoscale_gang_x = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 14 + offset; F%autoscale_gang_y = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 15 + offset; F%list_with_show_plot_command = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 16 + offset; F%phantom = (modulo(rhs, 2) == 0) end subroutine set_tao_plot_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_plot_region (ok) implicit none type(tao_plot_region_struct), target :: f_tao_plot_region, f2_tao_plot_region logical(c_bool) c_ok logical ok interface subroutine test_c_tao_plot_region (c_tao_plot_region, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_plot_region logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_plot_region_test_pattern (f2_tao_plot_region, 1) call test_c_tao_plot_region(c_loc(f2_tao_plot_region), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_plot_region_test_pattern (f_tao_plot_region, 4) if (f_tao_plot_region == f2_tao_plot_region) then print *, 'tao_plot_region: C side convert C->F: Good' else print *, 'tao_plot_region: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_plot_region !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_plot_region (c_tao_plot_region, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_plot_region type(tao_plot_region_struct), target :: f_tao_plot_region, f2_tao_plot_region logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_plot_region_to_f (c_tao_plot_region, c_loc(f_tao_plot_region)) call set_tao_plot_region_test_pattern (f2_tao_plot_region, 2) if (f_tao_plot_region == f2_tao_plot_region) then print *, 'tao_plot_region: F side convert C->F: Good' else print *, 'tao_plot_region: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_plot_region_test_pattern (f2_tao_plot_region, 3) call tao_plot_region_to_c (c_loc(f2_tao_plot_region), c_tao_plot_region) end subroutine test2_f_tao_plot_region !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_plot_region_test_pattern (F, ix_patt) implicit none type(tao_plot_region_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[type, 0, NOT] call set_tao_plot_test_pattern (F%plot, ix_patt) !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%location,1); lb1 = lbound(F%location,1) - 1 rhs = 100 + jd1 + 3 + offset F%location(jd1+lb1) = rhs enddo !! f_side.test_pat[logical, 0, NOT] rhs = 4 + offset; F%visible = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 5 + offset; F%list_with_show_plot_command = (modulo(rhs, 2) == 0) end subroutine set_tao_plot_region_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_plot_page (ok) implicit none type(tao_plot_page_struct), target :: f_tao_plot_page, f2_tao_plot_page logical(c_bool) c_ok logical ok interface subroutine test_c_tao_plot_page (c_tao_plot_page, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_plot_page logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_plot_page_test_pattern (f2_tao_plot_page, 1) call test_c_tao_plot_page(c_loc(f2_tao_plot_page), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_plot_page_test_pattern (f_tao_plot_page, 4) if (f_tao_plot_page == f2_tao_plot_page) then print *, 'tao_plot_page: C side convert C->F: Good' else print *, 'tao_plot_page: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_plot_page !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_plot_page (c_tao_plot_page, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_plot_page type(tao_plot_page_struct), target :: f_tao_plot_page, f2_tao_plot_page logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_plot_page_to_f (c_tao_plot_page, c_loc(f_tao_plot_page)) call set_tao_plot_page_test_pattern (f2_tao_plot_page, 2) if (f_tao_plot_page == f2_tao_plot_page) then print *, 'tao_plot_page: F side convert C->F: Good' else print *, 'tao_plot_page: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_plot_page_test_pattern (f2_tao_plot_page, 3) call tao_plot_page_to_c (c_loc(f2_tao_plot_page), c_tao_plot_page) end subroutine test2_f_tao_plot_page !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_plot_page_test_pattern (F, ix_patt) implicit none type(tao_plot_page_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 1, NOT] do jd1 = 1, size(F%title,1); lb1 = lbound(F%title,1) - 1 rhs = 100 + jd1 + 1 + offset call set_tao_title_test_pattern (F%title(jd1+lb1), ix_patt+jd1) enddo !! f_side.test_pat[type, 0, NOT] call set_qp_rect_test_pattern (F%border, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_drawing_test_pattern (F%floor_plan, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_drawing_test_pattern (F%lat_layout, ix_patt) !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%pattern)) deallocate (F%pattern) else if (.not. allocated(F%pattern)) allocate (F%pattern(-1:1)) do jd1 = 1, size(F%pattern,1); lb1 = lbound(F%pattern,1) - 1 call set_tao_shape_pattern_test_pattern (F%pattern(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%template)) deallocate (F%template) else if (.not. allocated(F%template)) allocate (F%template(-1:1)) do jd1 = 1, size(F%template,1); lb1 = lbound(F%template,1) - 1 call set_tao_plot_test_pattern (F%template(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%region)) deallocate (F%region) else if (.not. allocated(F%region)) allocate (F%region(-1:1)) do jd1 = 1, size(F%region,1); lb1 = lbound(F%region,1) - 1 call set_tao_plot_region_test_pattern (F%region(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%plot_display_type) F%plot_display_type(jd1:jd1) = char(ichar("a") + modulo(100+11+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ps_scale) F%ps_scale(jd1:jd1) = char(ichar("a") + modulo(100+12+offset+jd1, 26)) enddo !! f_side.test_pat[real, 1, NOT] do jd1 = 1, size(F%size,1); lb1 = lbound(F%size,1) - 1 rhs = 100 + jd1 + 13 + offset F%size(jd1+lb1) = rhs enddo !! f_side.test_pat[real, 0, NOT] rhs = 14 + offset; F%text_height = rhs !! f_side.test_pat[real, 0, NOT] rhs = 15 + offset; F%main_title_text_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 16 + offset; F%graph_title_text_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 17 + offset; F%axis_number_text_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 18 + offset; F%axis_label_text_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 19 + offset; F%legend_text_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 20 + offset; F%key_table_text_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 21 + offset; F%curve_legend_line_len = rhs !! f_side.test_pat[real, 0, NOT] rhs = 22 + offset; F%curve_legend_text_offset = rhs !! f_side.test_pat[real, 0, NOT] rhs = 23 + offset; F%floor_plan_shape_scale = rhs !! f_side.test_pat[real, 0, NOT] rhs = 24 + offset; F%lat_layout_shape_scale = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 25 + offset; F%n_curve_pts = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 26 + offset; F%id_window = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 27 + offset; F%delete_overlapping_plots = (modulo(rhs, 2) == 0) end subroutine set_tao_plot_page_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_plot_array (ok) implicit none type(tao_plot_array_struct), target :: f_tao_plot_array, f2_tao_plot_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_plot_array (c_tao_plot_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_plot_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_plot_array_test_pattern (f2_tao_plot_array, 1) call test_c_tao_plot_array(c_loc(f2_tao_plot_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_plot_array_test_pattern (f_tao_plot_array, 4) if (f_tao_plot_array == f2_tao_plot_array) then print *, 'tao_plot_array: C side convert C->F: Good' else print *, 'tao_plot_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_plot_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_plot_array (c_tao_plot_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_plot_array type(tao_plot_array_struct), target :: f_tao_plot_array, f2_tao_plot_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_plot_array_to_f (c_tao_plot_array, c_loc(f_tao_plot_array)) call set_tao_plot_array_test_pattern (f2_tao_plot_array, 2) if (f_tao_plot_array == f2_tao_plot_array) then print *, 'tao_plot_array: F side convert C->F: Good' else print *, 'tao_plot_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_plot_array_test_pattern (f2_tao_plot_array, 3) call tao_plot_array_to_c (c_loc(f2_tao_plot_array), c_tao_plot_array) end subroutine test2_f_tao_plot_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_plot_array_test_pattern (F, ix_patt) implicit none type(tao_plot_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_plot_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_graph_array (ok) implicit none type(tao_graph_array_struct), target :: f_tao_graph_array, f2_tao_graph_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_graph_array (c_tao_graph_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_graph_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_graph_array_test_pattern (f2_tao_graph_array, 1) call test_c_tao_graph_array(c_loc(f2_tao_graph_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_graph_array_test_pattern (f_tao_graph_array, 4) if (f_tao_graph_array == f2_tao_graph_array) then print *, 'tao_graph_array: C side convert C->F: Good' else print *, 'tao_graph_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_graph_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_graph_array (c_tao_graph_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_graph_array type(tao_graph_array_struct), target :: f_tao_graph_array, f2_tao_graph_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_graph_array_to_f (c_tao_graph_array, c_loc(f_tao_graph_array)) call set_tao_graph_array_test_pattern (f2_tao_graph_array, 2) if (f_tao_graph_array == f2_tao_graph_array) then print *, 'tao_graph_array: F side convert C->F: Good' else print *, 'tao_graph_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_graph_array_test_pattern (f2_tao_graph_array, 3) call tao_graph_array_to_c (c_loc(f2_tao_graph_array), c_tao_graph_array) end subroutine test2_f_tao_graph_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_graph_array_test_pattern (F, ix_patt) implicit none type(tao_graph_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_graph_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_curve_array (ok) implicit none type(tao_curve_array_struct), target :: f_tao_curve_array, f2_tao_curve_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_curve_array (c_tao_curve_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_curve_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_curve_array_test_pattern (f2_tao_curve_array, 1) call test_c_tao_curve_array(c_loc(f2_tao_curve_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_curve_array_test_pattern (f_tao_curve_array, 4) if (f_tao_curve_array == f2_tao_curve_array) then print *, 'tao_curve_array: C side convert C->F: Good' else print *, 'tao_curve_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_curve_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_curve_array (c_tao_curve_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_curve_array type(tao_curve_array_struct), target :: f_tao_curve_array, f2_tao_curve_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_curve_array_to_f (c_tao_curve_array, c_loc(f_tao_curve_array)) call set_tao_curve_array_test_pattern (f2_tao_curve_array, 2) if (f_tao_curve_array == f2_tao_curve_array) then print *, 'tao_curve_array: F side convert C->F: Good' else print *, 'tao_curve_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_curve_array_test_pattern (f2_tao_curve_array, 3) call tao_curve_array_to_c (c_loc(f2_tao_curve_array), c_tao_curve_array) end subroutine test2_f_tao_curve_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_curve_array_test_pattern (F, ix_patt) implicit none type(tao_curve_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_curve_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_data (ok) implicit none type(tao_data_struct), target :: f_tao_data, f2_tao_data logical(c_bool) c_ok logical ok interface subroutine test_c_tao_data (c_tao_data, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_data logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_data_test_pattern (f2_tao_data, 1) call test_c_tao_data(c_loc(f2_tao_data), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_data_test_pattern (f_tao_data, 4) if (f_tao_data == f2_tao_data) then print *, 'tao_data: C side convert C->F: Good' else print *, 'tao_data: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_data !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_data (c_tao_data, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_data type(tao_data_struct), target :: f_tao_data, f2_tao_data logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_data_to_f (c_tao_data, c_loc(f_tao_data)) call set_tao_data_test_pattern (f2_tao_data, 2) if (f_tao_data == f2_tao_data) then print *, 'tao_data: F side convert C->F: Good' else print *, 'tao_data: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_data_test_pattern (f2_tao_data, 3) call tao_data_to_c (c_loc(f2_tao_data), c_tao_data) end subroutine test2_f_tao_data !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_data_test_pattern (F, ix_patt) implicit none type(tao_data_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ele_name) F%ele_name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ele_start_name) F%ele_start_name(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ele_ref_name) F%ele_ref_name(jd1:jd1) = char(ichar("a") + modulo(100+3+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_type) F%data_type(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%merit_type) F%merit_type(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_source) F%data_source(jd1:jd1) = char(ichar("a") + modulo(100+6+offset+jd1, 26)) enddo !! f_side.test_pat[integer, 0, NOT] rhs = 7 + offset; F%ix_bunch = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 8 + offset; F%ix_branch = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 9 + offset; F%ix_ele = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 10 + offset; F%ix_ele_start = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 11 + offset; F%ix_ele_ref = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 12 + offset; F%ix_ele_merit = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 13 + offset; F%ix_d1 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 14 + offset; F%ix_data = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 15 + offset; F%ix_dmodel = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 16 + offset; F%eval_point = rhs !! f_side.test_pat[real, 0, NOT] rhs = 17 + offset; F%meas_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 18 + offset; F%ref_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 19 + offset; F%model_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 20 + offset; F%design_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 21 + offset; F%old_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 22 + offset; F%base_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 23 + offset; F%delta_merit = rhs !! f_side.test_pat[real, 0, NOT] rhs = 24 + offset; F%weight = rhs !! f_side.test_pat[real, 0, NOT] rhs = 25 + offset; F%invalid_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 26 + offset; F%merit = rhs !! f_side.test_pat[real, 0, NOT] rhs = 27 + offset; F%s = rhs !! f_side.test_pat[real, 0, NOT] rhs = 28 + offset; F%s_offset = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 29 + offset; F%exists = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 30 + offset; F%good_model = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 31 + offset; F%good_base = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 32 + offset; F%good_design = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 33 + offset; F%good_meas = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 34 + offset; F%good_ref = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 35 + offset; F%good_user = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 36 + offset; F%good_opt = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 37 + offset; F%good_plot = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 38 + offset; F%useit_plot = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 39 + offset; F%useit_opt = (modulo(rhs, 2) == 0) !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%stack)) deallocate (F%stack) else if (.not. allocated(F%stack)) allocate (F%stack(-1:1)) do jd1 = 1, size(F%stack,1); lb1 = lbound(F%stack,1) - 1 call set_tao_eval_stack1_test_pattern (F%stack(jd1+lb1), ix_patt+jd1) enddo endif end subroutine set_tao_data_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_d1_data (ok) implicit none type(tao_d1_data_struct), target :: f_tao_d1_data, f2_tao_d1_data logical(c_bool) c_ok logical ok interface subroutine test_c_tao_d1_data (c_tao_d1_data, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_d1_data logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_d1_data_test_pattern (f2_tao_d1_data, 1) call test_c_tao_d1_data(c_loc(f2_tao_d1_data), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_d1_data_test_pattern (f_tao_d1_data, 4) if (f_tao_d1_data == f2_tao_d1_data) then print *, 'tao_d1_data: C side convert C->F: Good' else print *, 'tao_d1_data: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_d1_data !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_d1_data (c_tao_d1_data, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_d1_data type(tao_d1_data_struct), target :: f_tao_d1_data, f2_tao_d1_data logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_d1_data_to_f (c_tao_d1_data, c_loc(f_tao_d1_data)) call set_tao_d1_data_test_pattern (f2_tao_d1_data, 2) if (f_tao_d1_data == f2_tao_d1_data) then print *, 'tao_d1_data: F side convert C->F: Good' else print *, 'tao_d1_data: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_d1_data_test_pattern (f2_tao_d1_data, 3) call tao_d1_data_to_c (c_loc(f2_tao_d1_data), c_tao_d1_data) end subroutine test2_f_tao_d1_data !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_d1_data_test_pattern (F, ix_patt) implicit none type(tao_d1_data_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo end subroutine set_tao_d1_data_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_d2_data (ok) implicit none type(tao_d2_data_struct), target :: f_tao_d2_data, f2_tao_d2_data logical(c_bool) c_ok logical ok interface subroutine test_c_tao_d2_data (c_tao_d2_data, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_d2_data logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_d2_data_test_pattern (f2_tao_d2_data, 1) call test_c_tao_d2_data(c_loc(f2_tao_d2_data), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_d2_data_test_pattern (f_tao_d2_data, 4) if (f_tao_d2_data == f2_tao_d2_data) then print *, 'tao_d2_data: C side convert C->F: Good' else print *, 'tao_d2_data: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_d2_data !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_d2_data (c_tao_d2_data, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_d2_data type(tao_d2_data_struct), target :: f_tao_d2_data, f2_tao_d2_data logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_d2_data_to_f (c_tao_d2_data, c_loc(f_tao_d2_data)) call set_tao_d2_data_test_pattern (f2_tao_d2_data, 2) if (f_tao_d2_data == f2_tao_d2_data) then print *, 'tao_d2_data: F side convert C->F: Good' else print *, 'tao_d2_data: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_d2_data_test_pattern (f2_tao_d2_data, 3) call tao_d2_data_to_c (c_loc(f2_tao_d2_data), c_tao_d2_data) end subroutine test2_f_tao_d2_data !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_d2_data_test_pattern (F, ix_patt) implicit none type(tao_d2_data_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_file_name) F%data_file_name(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ref_file_name) F%ref_file_name(jd1:jd1) = char(ichar("a") + modulo(100+3+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_date) F%data_date(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ref_date) F%ref_date(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo !! f_side.test_pat[character, 1, NOT] do jd1 = lbound(F%descrip, 1), ubound(F%descrip, 1) do jd = 1, len(F%descrip(jd1)) F%descrip(jd1)(jd:jd) = char(ichar("a") + modulo(100+6+offset+10*jd+jd1, 26)) enddo enddo !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%d1)) deallocate (F%d1) else if (.not. allocated(F%d1)) allocate (F%d1(-1:1)) do jd1 = 1, size(F%d1,1); lb1 = lbound(F%d1,1) - 1 call set_tao_d1_data_test_pattern (F%d1(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[integer, 0, NOT] rhs = 9 + offset; F%ix_uni = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 10 + offset; F%ix_d2_data = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 11 + offset; F%ix_data = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 12 + offset; F%ix_ref = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 13 + offset; F%data_read_in = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 14 + offset; F%ref_read_in = (modulo(rhs, 2) == 0) end subroutine set_tao_d2_data_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_data_array (ok) implicit none type(tao_data_array_struct), target :: f_tao_data_array, f2_tao_data_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_data_array (c_tao_data_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_data_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_data_array_test_pattern (f2_tao_data_array, 1) call test_c_tao_data_array(c_loc(f2_tao_data_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_data_array_test_pattern (f_tao_data_array, 4) if (f_tao_data_array == f2_tao_data_array) then print *, 'tao_data_array: C side convert C->F: Good' else print *, 'tao_data_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_data_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_data_array (c_tao_data_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_data_array type(tao_data_array_struct), target :: f_tao_data_array, f2_tao_data_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_data_array_to_f (c_tao_data_array, c_loc(f_tao_data_array)) call set_tao_data_array_test_pattern (f2_tao_data_array, 2) if (f_tao_data_array == f2_tao_data_array) then print *, 'tao_data_array: F side convert C->F: Good' else print *, 'tao_data_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_data_array_test_pattern (f2_tao_data_array, 3) call tao_data_array_to_c (c_loc(f2_tao_data_array), c_tao_data_array) end subroutine test2_f_tao_data_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_data_array_test_pattern (F, ix_patt) implicit none type(tao_data_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_data_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_d1_data_array (ok) implicit none type(tao_d1_data_array_struct), target :: f_tao_d1_data_array, f2_tao_d1_data_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_d1_data_array (c_tao_d1_data_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_d1_data_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_d1_data_array_test_pattern (f2_tao_d1_data_array, 1) call test_c_tao_d1_data_array(c_loc(f2_tao_d1_data_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_d1_data_array_test_pattern (f_tao_d1_data_array, 4) if (f_tao_d1_data_array == f2_tao_d1_data_array) then print *, 'tao_d1_data_array: C side convert C->F: Good' else print *, 'tao_d1_data_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_d1_data_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_d1_data_array (c_tao_d1_data_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_d1_data_array type(tao_d1_data_array_struct), target :: f_tao_d1_data_array, f2_tao_d1_data_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_d1_data_array_to_f (c_tao_d1_data_array, c_loc(f_tao_d1_data_array)) call set_tao_d1_data_array_test_pattern (f2_tao_d1_data_array, 2) if (f_tao_d1_data_array == f2_tao_d1_data_array) then print *, 'tao_d1_data_array: F side convert C->F: Good' else print *, 'tao_d1_data_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_d1_data_array_test_pattern (f2_tao_d1_data_array, 3) call tao_d1_data_array_to_c (c_loc(f2_tao_d1_data_array), c_tao_d1_data_array) end subroutine test2_f_tao_d1_data_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_d1_data_array_test_pattern (F, ix_patt) implicit none type(tao_d1_data_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_d1_data_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_d2_data_array (ok) implicit none type(tao_d2_data_array_struct), target :: f_tao_d2_data_array, f2_tao_d2_data_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_d2_data_array (c_tao_d2_data_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_d2_data_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_d2_data_array_test_pattern (f2_tao_d2_data_array, 1) call test_c_tao_d2_data_array(c_loc(f2_tao_d2_data_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_d2_data_array_test_pattern (f_tao_d2_data_array, 4) if (f_tao_d2_data_array == f2_tao_d2_data_array) then print *, 'tao_d2_data_array: C side convert C->F: Good' else print *, 'tao_d2_data_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_d2_data_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_d2_data_array (c_tao_d2_data_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_d2_data_array type(tao_d2_data_array_struct), target :: f_tao_d2_data_array, f2_tao_d2_data_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_d2_data_array_to_f (c_tao_d2_data_array, c_loc(f_tao_d2_data_array)) call set_tao_d2_data_array_test_pattern (f2_tao_d2_data_array, 2) if (f_tao_d2_data_array == f2_tao_d2_data_array) then print *, 'tao_d2_data_array: F side convert C->F: Good' else print *, 'tao_d2_data_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_d2_data_array_test_pattern (f2_tao_d2_data_array, 3) call tao_d2_data_array_to_c (c_loc(f2_tao_d2_data_array), c_tao_d2_data_array) end subroutine test2_f_tao_d2_data_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_d2_data_array_test_pattern (F, ix_patt) implicit none type(tao_d2_data_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_d2_data_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_var_slave (ok) implicit none type(tao_var_slave_struct), target :: f_tao_var_slave, f2_tao_var_slave logical(c_bool) c_ok logical ok interface subroutine test_c_tao_var_slave (c_tao_var_slave, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_var_slave logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_var_slave_test_pattern (f2_tao_var_slave, 1) call test_c_tao_var_slave(c_loc(f2_tao_var_slave), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_var_slave_test_pattern (f_tao_var_slave, 4) if (f_tao_var_slave == f2_tao_var_slave) then print *, 'tao_var_slave: C side convert C->F: Good' else print *, 'tao_var_slave: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_var_slave !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_var_slave (c_tao_var_slave, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_var_slave type(tao_var_slave_struct), target :: f_tao_var_slave, f2_tao_var_slave logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_var_slave_to_f (c_tao_var_slave, c_loc(f_tao_var_slave)) call set_tao_var_slave_test_pattern (f2_tao_var_slave, 2) if (f_tao_var_slave == f2_tao_var_slave) then print *, 'tao_var_slave: F side convert C->F: Good' else print *, 'tao_var_slave: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_var_slave_test_pattern (f2_tao_var_slave, 3) call tao_var_slave_to_c (c_loc(f2_tao_var_slave), c_tao_var_slave) end subroutine test2_f_tao_var_slave !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_var_slave_test_pattern (F, ix_patt) implicit none type(tao_var_slave_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[integer, 0, NOT] rhs = 1 + offset; F%ix_uni = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 2 + offset; F%ix_branch = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 3 + offset; F%ix_ele = rhs !! f_side.test_pat[real, 0, PTR] if (ix_patt < 3) then if (associated(F%model_value)) deallocate (F%model_value) else if (.not. associated(F%model_value)) allocate (F%model_value) rhs = 4 + offset F%model_value = rhs endif !! f_side.test_pat[real, 0, PTR] if (ix_patt < 3) then if (associated(F%base_value)) deallocate (F%base_value) else if (.not. associated(F%base_value)) allocate (F%base_value) rhs = 6 + offset F%base_value = rhs endif end subroutine set_tao_var_slave_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_var (ok) implicit none type(tao_var_struct), target :: f_tao_var, f2_tao_var logical(c_bool) c_ok logical ok interface subroutine test_c_tao_var (c_tao_var, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_var logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_var_test_pattern (f2_tao_var, 1) call test_c_tao_var(c_loc(f2_tao_var), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_var_test_pattern (f_tao_var, 4) if (f_tao_var == f2_tao_var) then print *, 'tao_var: C side convert C->F: Good' else print *, 'tao_var: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_var !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_var (c_tao_var, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_var type(tao_var_struct), target :: f_tao_var, f2_tao_var logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_var_to_f (c_tao_var, c_loc(f_tao_var)) call set_tao_var_test_pattern (f2_tao_var, 2) if (f_tao_var == f2_tao_var) then print *, 'tao_var: F side convert C->F: Good' else print *, 'tao_var: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_var_test_pattern (f2_tao_var, 3) call tao_var_to_c (c_loc(f2_tao_var), c_tao_var) end subroutine test2_f_tao_var !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_var_test_pattern (F, ix_patt) implicit none type(tao_var_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%ele_name) F%ele_name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%attrib_name) F%attrib_name(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%slave)) deallocate (F%slave) else if (.not. allocated(F%slave)) allocate (F%slave(-1:1)) do jd1 = 1, size(F%slave,1); lb1 = lbound(F%slave,1) - 1 call set_tao_var_slave_test_pattern (F%slave(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 0, NOT] call set_tao_var_slave_test_pattern (F%common_slave, ix_patt) !! f_side.test_pat[integer, 0, NOT] rhs = 6 + offset; F%ix_v1 = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 7 + offset; F%ix_var = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 8 + offset; F%ix_dvar = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 9 + offset; F%ix_attrib = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 10 + offset; F%ix_key_table = rhs !! f_side.test_pat[real, 0, NOT] rhs = 15 + offset; F%design_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 16 + offset; F%scratch_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 17 + offset; F%old_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 18 + offset; F%meas_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 19 + offset; F%ref_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 20 + offset; F%correction_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 21 + offset; F%high_lim = rhs !! f_side.test_pat[real, 0, NOT] rhs = 22 + offset; F%low_lim = rhs !! f_side.test_pat[real, 0, NOT] rhs = 23 + offset; F%step = rhs !! f_side.test_pat[real, 0, NOT] rhs = 24 + offset; F%weight = rhs !! f_side.test_pat[real, 0, NOT] rhs = 25 + offset; F%delta_merit = rhs !! f_side.test_pat[real, 0, NOT] rhs = 26 + offset; F%merit = rhs !! f_side.test_pat[real, 0, NOT] rhs = 27 + offset; F%dmerit_dvar = rhs !! f_side.test_pat[real, 0, NOT] rhs = 28 + offset; F%key_val0 = rhs !! f_side.test_pat[real, 0, NOT] rhs = 29 + offset; F%key_delta = rhs !! f_side.test_pat[real, 0, NOT] rhs = 30 + offset; F%s = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%merit_type) F%merit_type(jd1:jd1) = char(ichar("a") + modulo(100+31+offset+jd1, 26)) enddo !! f_side.test_pat[logical, 0, NOT] rhs = 32 + offset; F%exists = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 33 + offset; F%good_var = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 34 + offset; F%good_user = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 35 + offset; F%good_opt = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 36 + offset; F%good_plot = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 37 + offset; F%useit_opt = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 38 + offset; F%useit_plot = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 39 + offset; F%key_bound = (modulo(rhs, 2) == 0) end subroutine set_tao_var_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_v1_var (ok) implicit none type(tao_v1_var_struct), target :: f_tao_v1_var, f2_tao_v1_var logical(c_bool) c_ok logical ok interface subroutine test_c_tao_v1_var (c_tao_v1_var, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_v1_var logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_v1_var_test_pattern (f2_tao_v1_var, 1) call test_c_tao_v1_var(c_loc(f2_tao_v1_var), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_v1_var_test_pattern (f_tao_v1_var, 4) if (f_tao_v1_var == f2_tao_v1_var) then print *, 'tao_v1_var: C side convert C->F: Good' else print *, 'tao_v1_var: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_v1_var !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_v1_var (c_tao_v1_var, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_v1_var type(tao_v1_var_struct), target :: f_tao_v1_var, f2_tao_v1_var logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_v1_var_to_f (c_tao_v1_var, c_loc(f_tao_v1_var)) call set_tao_v1_var_test_pattern (f2_tao_v1_var, 2) if (f_tao_v1_var == f2_tao_v1_var) then print *, 'tao_v1_var: F side convert C->F: Good' else print *, 'tao_v1_var: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_v1_var_test_pattern (f2_tao_v1_var, 3) call tao_v1_var_to_c (c_loc(f2_tao_v1_var), c_tao_v1_var) end subroutine test2_f_tao_v1_var !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_v1_var_test_pattern (F, ix_patt) implicit none type(tao_v1_var_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[integer, 0, NOT] rhs = 2 + offset; F%ix_v1_var = rhs end subroutine set_tao_v1_var_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_var_array (ok) implicit none type(tao_var_array_struct), target :: f_tao_var_array, f2_tao_var_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_var_array (c_tao_var_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_var_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_var_array_test_pattern (f2_tao_var_array, 1) call test_c_tao_var_array(c_loc(f2_tao_var_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_var_array_test_pattern (f_tao_var_array, 4) if (f_tao_var_array == f2_tao_var_array) then print *, 'tao_var_array: C side convert C->F: Good' else print *, 'tao_var_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_var_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_var_array (c_tao_var_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_var_array type(tao_var_array_struct), target :: f_tao_var_array, f2_tao_var_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_var_array_to_f (c_tao_var_array, c_loc(f_tao_var_array)) call set_tao_var_array_test_pattern (f2_tao_var_array, 2) if (f_tao_var_array == f2_tao_var_array) then print *, 'tao_var_array: F side convert C->F: Good' else print *, 'tao_var_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_var_array_test_pattern (f2_tao_var_array, 3) call tao_var_array_to_c (c_loc(f2_tao_var_array), c_tao_var_array) end subroutine test2_f_tao_var_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_var_array_test_pattern (F, ix_patt) implicit none type(tao_var_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_var_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_v1_var_array (ok) implicit none type(tao_v1_var_array_struct), target :: f_tao_v1_var_array, f2_tao_v1_var_array logical(c_bool) c_ok logical ok interface subroutine test_c_tao_v1_var_array (c_tao_v1_var_array, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_v1_var_array logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_v1_var_array_test_pattern (f2_tao_v1_var_array, 1) call test_c_tao_v1_var_array(c_loc(f2_tao_v1_var_array), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_v1_var_array_test_pattern (f_tao_v1_var_array, 4) if (f_tao_v1_var_array == f2_tao_v1_var_array) then print *, 'tao_v1_var_array: C side convert C->F: Good' else print *, 'tao_v1_var_array: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_v1_var_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_v1_var_array (c_tao_v1_var_array, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_v1_var_array type(tao_v1_var_array_struct), target :: f_tao_v1_var_array, f2_tao_v1_var_array logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_v1_var_array_to_f (c_tao_v1_var_array, c_loc(f_tao_v1_var_array)) call set_tao_v1_var_array_test_pattern (f2_tao_v1_var_array, 2) if (f_tao_v1_var_array == f2_tao_v1_var_array) then print *, 'tao_v1_var_array: F side convert C->F: Good' else print *, 'tao_v1_var_array: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_v1_var_array_test_pattern (f2_tao_v1_var_array, 3) call tao_v1_var_array_to_c (c_loc(f2_tao_v1_var_array), c_tao_v1_var_array) end subroutine test2_f_tao_v1_var_array !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_v1_var_array_test_pattern (F, ix_patt) implicit none type(tao_v1_var_array_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt end subroutine set_tao_v1_var_array_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_building_wall_point (ok) implicit none type(tao_building_wall_point_struct), target :: f_tao_building_wall_point, f2_tao_building_wall_point logical(c_bool) c_ok logical ok interface subroutine test_c_tao_building_wall_point (c_tao_building_wall_point, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_building_wall_point logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_building_wall_point_test_pattern (f2_tao_building_wall_point, 1) call test_c_tao_building_wall_point(c_loc(f2_tao_building_wall_point), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_building_wall_point_test_pattern (f_tao_building_wall_point, 4) if (f_tao_building_wall_point == f2_tao_building_wall_point) then print *, 'tao_building_wall_point: C side convert C->F: Good' else print *, 'tao_building_wall_point: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_building_wall_point !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_building_wall_point (c_tao_building_wall_point, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_building_wall_point type(tao_building_wall_point_struct), target :: f_tao_building_wall_point, f2_tao_building_wall_point logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_building_wall_point_to_f (c_tao_building_wall_point, c_loc(f_tao_building_wall_point)) call set_tao_building_wall_point_test_pattern (f2_tao_building_wall_point, 2) if (f_tao_building_wall_point == f2_tao_building_wall_point) then print *, 'tao_building_wall_point: F side convert C->F: Good' else print *, 'tao_building_wall_point: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_building_wall_point_test_pattern (f2_tao_building_wall_point, 3) call tao_building_wall_point_to_c (c_loc(f2_tao_building_wall_point), c_tao_building_wall_point) end subroutine test2_f_tao_building_wall_point !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_building_wall_point_test_pattern (F, ix_patt) implicit none type(tao_building_wall_point_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%z = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%x = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%radius = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%z_center = rhs !! f_side.test_pat[real, 0, NOT] rhs = 5 + offset; F%x_center = rhs end subroutine set_tao_building_wall_point_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_building_wall_section (ok) implicit none type(tao_building_wall_section_struct), target :: f_tao_building_wall_section, f2_tao_building_wall_section logical(c_bool) c_ok logical ok interface subroutine test_c_tao_building_wall_section (c_tao_building_wall_section, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_building_wall_section logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_building_wall_section_test_pattern (f2_tao_building_wall_section, 1) call test_c_tao_building_wall_section(c_loc(f2_tao_building_wall_section), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_building_wall_section_test_pattern (f_tao_building_wall_section, 4) if (f_tao_building_wall_section == f2_tao_building_wall_section) then print *, 'tao_building_wall_section: C side convert C->F: Good' else print *, 'tao_building_wall_section: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_building_wall_section !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_building_wall_section (c_tao_building_wall_section, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_building_wall_section type(tao_building_wall_section_struct), target :: f_tao_building_wall_section, f2_tao_building_wall_section logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_building_wall_section_to_f (c_tao_building_wall_section, c_loc(f_tao_building_wall_section)) call set_tao_building_wall_section_test_pattern (f2_tao_building_wall_section, 2) if (f_tao_building_wall_section == f2_tao_building_wall_section) then print *, 'tao_building_wall_section: F side convert C->F: Good' else print *, 'tao_building_wall_section: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_building_wall_section_test_pattern (f2_tao_building_wall_section, 3) call tao_building_wall_section_to_c (c_loc(f2_tao_building_wall_section), c_tao_building_wall_section) end subroutine test2_f_tao_building_wall_section !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_building_wall_section_test_pattern (F, ix_patt) implicit none type(tao_building_wall_section_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%constraint) F%constraint(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%point)) deallocate (F%point) else if (.not. allocated(F%point)) allocate (F%point(-1:1)) do jd1 = 1, size(F%point,1); lb1 = lbound(F%point,1) - 1 call set_tao_building_wall_point_test_pattern (F%point(jd1+lb1), ix_patt+jd1) enddo endif end subroutine set_tao_building_wall_section_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_building_wall (ok) implicit none type(tao_building_wall_struct), target :: f_tao_building_wall, f2_tao_building_wall logical(c_bool) c_ok logical ok interface subroutine test_c_tao_building_wall (c_tao_building_wall, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_building_wall logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_building_wall_test_pattern (f2_tao_building_wall, 1) call test_c_tao_building_wall(c_loc(f2_tao_building_wall), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_building_wall_test_pattern (f_tao_building_wall, 4) if (f_tao_building_wall == f2_tao_building_wall) then print *, 'tao_building_wall: C side convert C->F: Good' else print *, 'tao_building_wall: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_building_wall !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_building_wall (c_tao_building_wall, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_building_wall type(tao_building_wall_struct), target :: f_tao_building_wall, f2_tao_building_wall logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_building_wall_to_f (c_tao_building_wall, c_loc(f_tao_building_wall)) call set_tao_building_wall_test_pattern (f2_tao_building_wall, 2) if (f_tao_building_wall == f2_tao_building_wall) then print *, 'tao_building_wall: F side convert C->F: Good' else print *, 'tao_building_wall: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_building_wall_test_pattern (f2_tao_building_wall, 3) call tao_building_wall_to_c (c_loc(f2_tao_building_wall), c_tao_building_wall) end subroutine test2_f_tao_building_wall !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_building_wall_test_pattern (F, ix_patt) implicit none type(tao_building_wall_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%section)) deallocate (F%section) else if (.not. allocated(F%section)) allocate (F%section(-1:1)) do jd1 = 1, size(F%section,1); lb1 = lbound(F%section,1) - 1 call set_tao_building_wall_section_test_pattern (F%section(jd1+lb1), ix_patt+jd1) enddo endif end subroutine set_tao_building_wall_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_global (ok) implicit none type(tao_global_struct), target :: f_tao_global, f2_tao_global logical(c_bool) c_ok logical ok interface subroutine test_c_tao_global (c_tao_global, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_global logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_global_test_pattern (f2_tao_global, 1) call test_c_tao_global(c_loc(f2_tao_global), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_global_test_pattern (f_tao_global, 4) if (f_tao_global == f2_tao_global) then print *, 'tao_global: C side convert C->F: Good' else print *, 'tao_global: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_global !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_global (c_tao_global, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_global type(tao_global_struct), target :: f_tao_global, f2_tao_global logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_global_to_f (c_tao_global, c_loc(f_tao_global)) call set_tao_global_test_pattern (f2_tao_global, 2) if (f_tao_global == f2_tao_global) then print *, 'tao_global: F side convert C->F: Good' else print *, 'tao_global: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_global_test_pattern (f2_tao_global, 3) call tao_global_to_c (c_loc(f2_tao_global), c_tao_global) end subroutine test2_f_tao_global !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_global_test_pattern (F, ix_patt) implicit none type(tao_global_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%y_axis_plot_dmin = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%lm_opt_deriv_reinit = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%de_lm_step_ratio = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%de_var_to_population_factor = rhs !! f_side.test_pat[real, 0, NOT] rhs = 5 + offset; F%lmdif_eps = rhs !! f_side.test_pat[real, 0, NOT] rhs = 6 + offset; F%svd_cutoff = rhs !! f_side.test_pat[real, 0, NOT] rhs = 7 + offset; F%unstable_penalty = rhs !! f_side.test_pat[real, 0, NOT] rhs = 8 + offset; F%merit_stop_value = rhs !! f_side.test_pat[real, 0, NOT] rhs = 9 + offset; F%random_sigma_cutoff = rhs !! f_side.test_pat[real, 0, NOT] rhs = 10 + offset; F%delta_e_chrom = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 11 + offset; F%n_opti_cycles = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 12 + offset; F%n_opti_loops = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 13 + offset; F%phase_units = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 14 + offset; F%bunch_to_plot = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 15 + offset; F%random_seed = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 16 + offset; F%n_top10 = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%random_engine) F%random_engine(jd1:jd1) = char(ichar("a") + modulo(100+17+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%random_gauss_converter) F%random_gauss_converter(jd1:jd1) = char(ichar("a") + modulo(100+18+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%track_type) F%track_type(jd1:jd1) = char(ichar("a") + modulo(100+19+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%prompt_string) F%prompt_string(jd1:jd1) = char(ichar("a") + modulo(100+20+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%prompt_color) F%prompt_color(jd1:jd1) = char(ichar("a") + modulo(100+21+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%optimizer) F%optimizer(jd1:jd1) = char(ichar("a") + modulo(100+22+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%print_command) F%print_command(jd1:jd1) = char(ichar("a") + modulo(100+23+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%var_out_file) F%var_out_file(jd1:jd1) = char(ichar("a") + modulo(100+24+offset+jd1, 26)) enddo !! f_side.test_pat[logical, 0, NOT] rhs = 25 + offset; F%initialized = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 26 + offset; F%opt_with_ref = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 27 + offset; F%opt_with_base = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 28 + offset; F%label_lattice_elements = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 29 + offset; F%label_keys = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 30 + offset; F%derivative_recalc = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 31 + offset; F%derivative_uses_design = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 32 + offset; F%init_plot_needed = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 33 + offset; F%orm_analysis = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 34 + offset; F%plot_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 35 + offset; F%lattice_calc_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 36 + offset; F%svd_retreat_on_merit_increase = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 37 + offset; F%stop_on_error = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 38 + offset; F%command_file_print_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 39 + offset; F%box_plots = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 40 + offset; F%beam_timer_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 41 + offset; F%var_limits_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 42 + offset; F%only_limit_opt_vars = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 43 + offset; F%optimizer_var_limit_warn = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 44 + offset; F%rf_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 45 + offset; F%draw_curve_off_scale_warn = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 46 + offset; F%wait_for_cr_in_single_mode = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 47 + offset; F%disable_smooth_line_calc = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 48 + offset; F%debug_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 49 + offset; F%single_step = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 50 + offset; F%optimizer_allow_user_abort = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 51 + offset; F%quiet = (modulo(rhs, 2) == 0) end subroutine set_tao_global_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_alias (ok) implicit none type(tao_alias_struct), target :: f_tao_alias, f2_tao_alias logical(c_bool) c_ok logical ok interface subroutine test_c_tao_alias (c_tao_alias, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_alias logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_alias_test_pattern (f2_tao_alias, 1) call test_c_tao_alias(c_loc(f2_tao_alias), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_alias_test_pattern (f_tao_alias, 4) if (f_tao_alias == f2_tao_alias) then print *, 'tao_alias: C side convert C->F: Good' else print *, 'tao_alias: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_alias !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_alias (c_tao_alias, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_alias type(tao_alias_struct), target :: f_tao_alias, f2_tao_alias logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_alias_to_f (c_tao_alias, c_loc(f_tao_alias)) call set_tao_alias_test_pattern (f2_tao_alias, 2) if (f_tao_alias == f2_tao_alias) then print *, 'tao_alias: F side convert C->F: Good' else print *, 'tao_alias: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_alias_test_pattern (f2_tao_alias, 3) call tao_alias_to_c (c_loc(f2_tao_alias), c_tao_alias) end subroutine test2_f_tao_alias !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_alias_test_pattern (F, ix_patt) implicit none type(tao_alias_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%expanded_str) F%expanded_str(jd1:jd1) = char(ichar("a") + modulo(100+2+offset+jd1, 26)) enddo end subroutine set_tao_alias_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_command_file (ok) implicit none type(tao_command_file_struct), target :: f_tao_command_file, f2_tao_command_file logical(c_bool) c_ok logical ok interface subroutine test_c_tao_command_file (c_tao_command_file, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_command_file logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_command_file_test_pattern (f2_tao_command_file, 1) call test_c_tao_command_file(c_loc(f2_tao_command_file), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_command_file_test_pattern (f_tao_command_file, 4) if (f_tao_command_file == f2_tao_command_file) then print *, 'tao_command_file: C side convert C->F: Good' else print *, 'tao_command_file: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_command_file !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_command_file (c_tao_command_file, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_command_file type(tao_command_file_struct), target :: f_tao_command_file, f2_tao_command_file logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_command_file_to_f (c_tao_command_file, c_loc(f_tao_command_file)) call set_tao_command_file_test_pattern (f2_tao_command_file, 2) if (f_tao_command_file == f2_tao_command_file) then print *, 'tao_command_file: F side convert C->F: Good' else print *, 'tao_command_file: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_command_file_test_pattern (f2_tao_command_file, 3) call tao_command_file_to_c (c_loc(f2_tao_command_file), c_tao_command_file) end subroutine test2_f_tao_command_file !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_command_file_test_pattern (F, ix_patt) implicit none type(tao_command_file_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%name) F%name(jd1:jd1) = char(ichar("a") + modulo(100+1+offset+jd1, 26)) enddo !! f_side.test_pat[integer, 0, NOT] rhs = 2 + offset; F%ix_unit = rhs !! f_side.test_pat[character, 1, NOT] do jd1 = lbound(F%cmd_arg, 1), ubound(F%cmd_arg, 1) do jd = 1, len(F%cmd_arg(jd1)) F%cmd_arg(jd1)(jd:jd) = char(ichar("a") + modulo(100+3+offset+10*jd+jd1, 26)) enddo enddo !! f_side.test_pat[logical, 0, NOT] rhs = 4 + offset; F%paused = (modulo(rhs, 2) == 0) !! f_side.test_pat[integer, 0, NOT] rhs = 5 + offset; F%n_line = rhs end subroutine set_tao_command_file_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_common (ok) implicit none type(tao_common_struct), target :: f_tao_common, f2_tao_common logical(c_bool) c_ok logical ok interface subroutine test_c_tao_common (c_tao_common, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_common logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_common_test_pattern (f2_tao_common, 1) call test_c_tao_common(c_loc(f2_tao_common), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_common_test_pattern (f_tao_common, 4) if (f_tao_common == f2_tao_common) then print *, 'tao_common: C side convert C->F: Good' else print *, 'tao_common: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_common !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_common (c_tao_common, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_common type(tao_common_struct), target :: f_tao_common, f2_tao_common logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_common_to_f (c_tao_common, c_loc(f_tao_common)) call set_tao_common_test_pattern (f2_tao_common, 2) if (f_tao_common == f2_tao_common) then print *, 'tao_common: F side convert C->F: Good' else print *, 'tao_common: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_common_test_pattern (f2_tao_common, 3) call tao_common_to_c (c_loc(f2_tao_common), c_tao_common) end subroutine test2_f_tao_common !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_common_test_pattern (F, ix_patt) implicit none type(tao_common_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 1, NOT] do jd1 = 1, size(F%alias,1); lb1 = lbound(F%alias,1) - 1 rhs = 100 + jd1 + 1 + offset call set_tao_alias_test_pattern (F%alias(jd1+lb1), ix_patt+jd1) enddo !! f_side.test_pat[type, 1, NOT] do jd1 = 1, size(F%key,1); lb1 = lbound(F%key,1) - 1 rhs = 100 + jd1 + 2 + offset call set_tao_alias_test_pattern (F%key(jd1+lb1), ix_patt+jd1) enddo !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%cmd_file)) deallocate (F%cmd_file) else if (.not. allocated(F%cmd_file)) allocate (F%cmd_file(-1:1)) do jd1 = 1, size(F%cmd_file,1); lb1 = lbound(F%cmd_file,1) - 1 call set_tao_command_file_test_pattern (F%cmd_file(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[real, 2, ALLOC] if (ix_patt < 3) then if (allocated(F%covar)) deallocate (F%covar) else if (.not. allocated(F%covar)) allocate (F%covar(-1:1, 2)) do jd1 = 1, size(F%covar,1); lb1 = lbound(F%covar,1) - 1 do jd2 = 1, size(F%covar,2); lb2 = lbound(F%covar,2) - 1 rhs = 100 + jd1 + 10*jd2 + 7 + offset F%covar(jd1+lb1,jd2+lb2) = rhs enddo; enddo endif !! f_side.test_pat[real, 2, ALLOC] if (ix_patt < 3) then if (allocated(F%alpha)) deallocate (F%alpha) else if (.not. allocated(F%alpha)) allocate (F%alpha(-1:1, 2)) do jd1 = 1, size(F%alpha,1); lb1 = lbound(F%alpha,1) - 1 do jd2 = 1, size(F%alpha,2); lb2 = lbound(F%alpha,2) - 1 rhs = 100 + jd1 + 10*jd2 + 10 + offset F%alpha(jd1+lb1,jd2+lb2) = rhs enddo; enddo endif !! f_side.test_pat[real, 0, NOT] rhs = 13 + offset; F%dummy_target = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 14 + offset; F%ix_ref_taylor = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 15 + offset; F%ix_ele_taylor = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 16 + offset; F%n_alias = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 17 + offset; F%cmd_file_level = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 18 + offset; F%ix_key_bank = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 19 + offset; F%n_universes = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 20 + offset; F%default_universe = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 21 + offset; F%default_branch = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 22 + offset; F%ix_history = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 23 + offset; F%n_history = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 24 + offset; F%cmd_file_paused = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 25 + offset; F%use_cmd_here = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 26 + offset; F%multi_commands_here = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 27 + offset; F%cmd_from_cmd_file = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 28 + offset; F%use_saved_beam_in_tracking = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 29 + offset; F%single_mode = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 30 + offset; F%combine_consecutive_elements_of_like_name = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 31 + offset; F%common_lattice = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 32 + offset; F%init_beam = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 33 + offset; F%init_var = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 34 + offset; F%init_read_lat_info = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 35 + offset; F%init_data = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 36 + offset; F%parse_cmd_args = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 37 + offset; F%optimizer_running = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 38 + offset; F%have_datums_using_expressions = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 39 + offset; F%noplot_arg_set = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 40 + offset; F%init_tao_file_arg_set = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 41 + offset; F%log_startup = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 42 + offset; F%print_to_terminal = (modulo(rhs, 2) == 0) !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%cmd) F%cmd(jd1:jd1) = char(ichar("a") + modulo(100+43+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%init_name) F%init_name(jd1:jd1) = char(ichar("a") + modulo(100+44+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%lat_file) F%lat_file(jd1:jd1) = char(ichar("a") + modulo(100+45+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%init_tao_file) F%init_tao_file(jd1:jd1) = char(ichar("a") + modulo(100+46+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%init_tao_file_path) F%init_tao_file_path(jd1:jd1) = char(ichar("a") + modulo(100+47+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%beam_file) F%beam_file(jd1:jd1) = char(ichar("a") + modulo(100+48+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%beam_all_file) F%beam_all_file(jd1:jd1) = char(ichar("a") + modulo(100+49+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%beam0_file) F%beam0_file(jd1:jd1) = char(ichar("a") + modulo(100+50+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%data_file) F%data_file(jd1:jd1) = char(ichar("a") + modulo(100+51+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%plot_file) F%plot_file(jd1:jd1) = char(ichar("a") + modulo(100+52+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%startup_file) F%startup_file(jd1:jd1) = char(ichar("a") + modulo(100+53+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%var_file) F%var_file(jd1:jd1) = char(ichar("a") + modulo(100+54+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%building_wall_file) F%building_wall_file(jd1:jd1) = char(ichar("a") + modulo(100+55+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%hook_init_file) F%hook_init_file(jd1:jd1) = char(ichar("a") + modulo(100+56+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%plot_geometry) F%plot_geometry(jd1:jd1) = char(ichar("a") + modulo(100+57+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%single_mode_buffer) F%single_mode_buffer(jd1:jd1) = char(ichar("a") + modulo(100+58+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%unique_name_suffix) F%unique_name_suffix(jd1:jd1) = char(ichar("a") + modulo(100+59+offset+jd1, 26)) enddo !! f_side.test_pat[character, 1, NOT] do jd1 = lbound(F%valid_plot_who, 1), ubound(F%valid_plot_who, 1) do jd = 1, len(F%valid_plot_who(jd1)) F%valid_plot_who(jd1)(jd:jd) = char(ichar("a") + modulo(100+60+offset+10*jd+jd1, 26)) enddo enddo end subroutine set_tao_common_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_lat_mode (ok) implicit none type(tao_lat_mode_struct), target :: f_tao_lat_mode, f2_tao_lat_mode logical(c_bool) c_ok logical ok interface subroutine test_c_tao_lat_mode (c_tao_lat_mode, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_lat_mode logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_lat_mode_test_pattern (f2_tao_lat_mode, 1) call test_c_tao_lat_mode(c_loc(f2_tao_lat_mode), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_lat_mode_test_pattern (f_tao_lat_mode, 4) if (f_tao_lat_mode == f2_tao_lat_mode) then print *, 'tao_lat_mode: C side convert C->F: Good' else print *, 'tao_lat_mode: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_lat_mode !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_lat_mode (c_tao_lat_mode, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_lat_mode type(tao_lat_mode_struct), target :: f_tao_lat_mode, f2_tao_lat_mode logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_lat_mode_to_f (c_tao_lat_mode, c_loc(f_tao_lat_mode)) call set_tao_lat_mode_test_pattern (f2_tao_lat_mode, 2) if (f_tao_lat_mode == f2_tao_lat_mode) then print *, 'tao_lat_mode: F side convert C->F: Good' else print *, 'tao_lat_mode: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_lat_mode_test_pattern (f2_tao_lat_mode, 3) call tao_lat_mode_to_c (c_loc(f2_tao_lat_mode), c_tao_lat_mode) end subroutine test2_f_tao_lat_mode !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_lat_mode_test_pattern (F, ix_patt) implicit none type(tao_lat_mode_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%chrom = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%growth_rate = rhs end subroutine set_tao_lat_mode_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_sigma_mat (ok) implicit none type(tao_sigma_mat_struct), target :: f_tao_sigma_mat, f2_tao_sigma_mat logical(c_bool) c_ok logical ok interface subroutine test_c_tao_sigma_mat (c_tao_sigma_mat, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_sigma_mat logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_sigma_mat_test_pattern (f2_tao_sigma_mat, 1) call test_c_tao_sigma_mat(c_loc(f2_tao_sigma_mat), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_sigma_mat_test_pattern (f_tao_sigma_mat, 4) if (f_tao_sigma_mat == f2_tao_sigma_mat) then print *, 'tao_sigma_mat: C side convert C->F: Good' else print *, 'tao_sigma_mat: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_sigma_mat !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_sigma_mat (c_tao_sigma_mat, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_sigma_mat type(tao_sigma_mat_struct), target :: f_tao_sigma_mat, f2_tao_sigma_mat logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_sigma_mat_to_f (c_tao_sigma_mat, c_loc(f_tao_sigma_mat)) call set_tao_sigma_mat_test_pattern (f2_tao_sigma_mat, 2) if (f_tao_sigma_mat == f2_tao_sigma_mat) then print *, 'tao_sigma_mat: F side convert C->F: Good' else print *, 'tao_sigma_mat: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_sigma_mat_test_pattern (f2_tao_sigma_mat, 3) call tao_sigma_mat_to_c (c_loc(f2_tao_sigma_mat), c_tao_sigma_mat) end subroutine test2_f_tao_sigma_mat !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_sigma_mat_test_pattern (F, ix_patt) implicit none type(tao_sigma_mat_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 2, NOT] do jd1 = 1, size(F%sigma,1); lb1 = lbound(F%sigma,1) - 1 do jd2 = 1, size(F%sigma,2); lb2 = lbound(F%sigma,2) - 1 rhs = 100 + jd1 + 10*jd2 + 1 + offset F%sigma(jd1+lb1,jd2+lb2) = rhs enddo; enddo end subroutine set_tao_sigma_mat_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_lattice_branch (ok) implicit none type(tao_lattice_branch_struct), target :: f_tao_lattice_branch, f2_tao_lattice_branch logical(c_bool) c_ok logical ok interface subroutine test_c_tao_lattice_branch (c_tao_lattice_branch, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_lattice_branch logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_lattice_branch_test_pattern (f2_tao_lattice_branch, 1) call test_c_tao_lattice_branch(c_loc(f2_tao_lattice_branch), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_lattice_branch_test_pattern (f_tao_lattice_branch, 4) if (f_tao_lattice_branch == f2_tao_lattice_branch) then print *, 'tao_lattice_branch: C side convert C->F: Good' else print *, 'tao_lattice_branch: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_lattice_branch !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_lattice_branch (c_tao_lattice_branch, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_lattice_branch type(tao_lattice_branch_struct), target :: f_tao_lattice_branch, f2_tao_lattice_branch logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_lattice_branch_to_f (c_tao_lattice_branch, c_loc(f_tao_lattice_branch)) call set_tao_lattice_branch_test_pattern (f2_tao_lattice_branch, 2) if (f_tao_lattice_branch == f2_tao_lattice_branch) then print *, 'tao_lattice_branch: F side convert C->F: Good' else print *, 'tao_lattice_branch: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_lattice_branch_test_pattern (f2_tao_lattice_branch, 3) call tao_lattice_branch_to_c (c_loc(f2_tao_lattice_branch), c_tao_lattice_branch) end subroutine test2_f_tao_lattice_branch !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_lattice_branch_test_pattern (F, ix_patt) implicit none type(tao_lattice_branch_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%bunch_params)) deallocate (F%bunch_params) else if (.not. allocated(F%bunch_params)) allocate (F%bunch_params(-1:1)) do jd1 = 1, size(F%bunch_params,1); lb1 = lbound(F%bunch_params,1) - 1 call set_bunch_params_test_pattern (F%bunch_params(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%linear)) deallocate (F%linear) else if (.not. allocated(F%linear)) allocate (F%linear(-1:1)) do jd1 = 1, size(F%linear,1); lb1 = lbound(F%linear,1) - 1 call set_tao_sigma_mat_test_pattern (F%linear(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%orbit)) deallocate (F%orbit) else if (.not. allocated(F%orbit)) allocate (F%orbit(-1:1)) do jd1 = 1, size(F%orbit,1); lb1 = lbound(F%orbit,1) - 1 call set_coord_test_pattern (F%orbit(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 0, NOT] call set_coord_test_pattern (F%orb0, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_lat_test_pattern (F%high_e_lat, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_lat_test_pattern (F%low_e_lat, ix_patt) !! f_side.test_pat[integer, 0, NOT] rhs = 10 + offset; F%track_state = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 11 + offset; F%has_open_match_element = (modulo(rhs, 2) == 0) !! f_side.test_pat[type, 0, NOT] call set_normal_modes_test_pattern (F%modes, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_rad_int_all_ele_test_pattern (F%rad_int, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_lat_mode_test_pattern (F%a, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_lat_mode_test_pattern (F%b, ix_patt) !! f_side.test_pat[integer, 0, NOT] rhs = 16 + offset; F%ix_rad_int_cache = rhs !! f_side.test_pat[type, 0, NOT] call set_normal_modes_test_pattern (F%modes_rf_on, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_rad_int_all_ele_test_pattern (F%rad_int_rf_on, ix_patt) end subroutine set_tao_lattice_branch_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_lattice (ok) implicit none type(tao_lattice_struct), target :: f_tao_lattice, f2_tao_lattice logical(c_bool) c_ok logical ok interface subroutine test_c_tao_lattice (c_tao_lattice, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_lattice logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_lattice_test_pattern (f2_tao_lattice, 1) call test_c_tao_lattice(c_loc(f2_tao_lattice), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_lattice_test_pattern (f_tao_lattice, 4) if (f_tao_lattice == f2_tao_lattice) then print *, 'tao_lattice: C side convert C->F: Good' else print *, 'tao_lattice: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_lattice !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_lattice (c_tao_lattice, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_lattice type(tao_lattice_struct), target :: f_tao_lattice, f2_tao_lattice logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_lattice_to_f (c_tao_lattice, c_loc(f_tao_lattice)) call set_tao_lattice_test_pattern (f2_tao_lattice, 2) if (f_tao_lattice == f2_tao_lattice) then print *, 'tao_lattice: F side convert C->F: Good' else print *, 'tao_lattice: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_lattice_test_pattern (f2_tao_lattice, 3) call tao_lattice_to_c (c_loc(f2_tao_lattice), c_tao_lattice) end subroutine test2_f_tao_lattice !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_lattice_test_pattern (F, ix_patt) implicit none type(tao_lattice_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 0, NOT] call set_lat_test_pattern (F%lat, ix_patt) !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%tao_branch)) deallocate (F%tao_branch) else if (.not. allocated(F%tao_branch)) allocate (F%tao_branch(-1:1)) do jd1 = 1, size(F%tao_branch,1); lb1 = lbound(F%tao_branch,1) - 1 call set_tao_lattice_branch_test_pattern (F%tao_branch(jd1+lb1), ix_patt+jd1) enddo endif end subroutine set_tao_lattice_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_element (ok) implicit none type(tao_element_struct), target :: f_tao_element, f2_tao_element logical(c_bool) c_ok logical ok interface subroutine test_c_tao_element (c_tao_element, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_element logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_element_test_pattern (f2_tao_element, 1) call test_c_tao_element(c_loc(f2_tao_element), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_element_test_pattern (f_tao_element, 4) if (f_tao_element == f2_tao_element) then print *, 'tao_element: C side convert C->F: Good' else print *, 'tao_element: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_element !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_element (c_tao_element, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_element type(tao_element_struct), target :: f_tao_element, f2_tao_element logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_element_to_f (c_tao_element, c_loc(f_tao_element)) call set_tao_element_test_pattern (f2_tao_element, 2) if (f_tao_element == f2_tao_element) then print *, 'tao_element: F side convert C->F: Good' else print *, 'tao_element: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_element_test_pattern (f2_tao_element, 3) call tao_element_to_c (c_loc(f2_tao_element), c_tao_element) end subroutine test2_f_tao_element !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_element_test_pattern (F, ix_patt) implicit none type(tao_element_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 0, NOT] call set_beam_test_pattern (F%beam, ix_patt) !! f_side.test_pat[logical, 0, NOT] rhs = 2 + offset; F%save_beam = (modulo(rhs, 2) == 0) end subroutine set_tao_element_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_ping_scale (ok) implicit none type(tao_ping_scale_struct), target :: f_tao_ping_scale, f2_tao_ping_scale logical(c_bool) c_ok logical ok interface subroutine test_c_tao_ping_scale (c_tao_ping_scale, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_ping_scale logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_ping_scale_test_pattern (f2_tao_ping_scale, 1) call test_c_tao_ping_scale(c_loc(f2_tao_ping_scale), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_ping_scale_test_pattern (f_tao_ping_scale, 4) if (f_tao_ping_scale == f2_tao_ping_scale) then print *, 'tao_ping_scale: C side convert C->F: Good' else print *, 'tao_ping_scale: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_ping_scale !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_ping_scale (c_tao_ping_scale, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_ping_scale type(tao_ping_scale_struct), target :: f_tao_ping_scale, f2_tao_ping_scale logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_ping_scale_to_f (c_tao_ping_scale, c_loc(f_tao_ping_scale)) call set_tao_ping_scale_test_pattern (f2_tao_ping_scale, 2) if (f_tao_ping_scale == f2_tao_ping_scale) then print *, 'tao_ping_scale: F side convert C->F: Good' else print *, 'tao_ping_scale: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_ping_scale_test_pattern (f2_tao_ping_scale, 3) call tao_ping_scale_to_c (c_loc(f2_tao_ping_scale), c_tao_ping_scale) end subroutine test2_f_tao_ping_scale !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_ping_scale_test_pattern (F, ix_patt) implicit none type(tao_ping_scale_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[real, 0, NOT] rhs = 1 + offset; F%a_mode_meas = rhs !! f_side.test_pat[real, 0, NOT] rhs = 2 + offset; F%a_mode_ref = rhs !! f_side.test_pat[real, 0, NOT] rhs = 3 + offset; F%b_mode_meas = rhs !! f_side.test_pat[real, 0, NOT] rhs = 4 + offset; F%b_mode_ref = rhs end subroutine set_tao_ping_scale_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_universe_branch (ok) implicit none type(tao_universe_branch_struct), target :: f_tao_universe_branch, f2_tao_universe_branch logical(c_bool) c_ok logical ok interface subroutine test_c_tao_universe_branch (c_tao_universe_branch, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_universe_branch logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_universe_branch_test_pattern (f2_tao_universe_branch, 1) call test_c_tao_universe_branch(c_loc(f2_tao_universe_branch), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_universe_branch_test_pattern (f_tao_universe_branch, 4) if (f_tao_universe_branch == f2_tao_universe_branch) then print *, 'tao_universe_branch: C side convert C->F: Good' else print *, 'tao_universe_branch: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_universe_branch !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_universe_branch (c_tao_universe_branch, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_universe_branch type(tao_universe_branch_struct), target :: f_tao_universe_branch, f2_tao_universe_branch logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_universe_branch_to_f (c_tao_universe_branch, c_loc(f_tao_universe_branch)) call set_tao_universe_branch_test_pattern (f2_tao_universe_branch, 2) if (f_tao_universe_branch == f2_tao_universe_branch) then print *, 'tao_universe_branch: F side convert C->F: Good' else print *, 'tao_universe_branch: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_universe_branch_test_pattern (f2_tao_universe_branch, 3) call tao_universe_branch_to_c (c_loc(f2_tao_universe_branch), c_tao_universe_branch) end subroutine test2_f_tao_universe_branch !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_universe_branch_test_pattern (F, ix_patt) implicit none type(tao_universe_branch_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%ele)) deallocate (F%ele) else if (.not. allocated(F%ele)) allocate (F%ele(-1:1)) do jd1 = 1, size(F%ele,1); lb1 = lbound(F%ele,1) - 1 call set_tao_element_test_pattern (F%ele(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%track_start) F%track_start(jd1:jd1) = char(ichar("a") + modulo(100+3+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%track_end) F%track_end(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo !! f_side.test_pat[integer, 0, NOT] rhs = 5 + offset; F%ix_track_start = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 6 + offset; F%ix_track_end = rhs end subroutine set_tao_universe_branch_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_beam (ok) implicit none type(tao_beam_struct), target :: f_tao_beam, f2_tao_beam logical(c_bool) c_ok logical ok interface subroutine test_c_tao_beam (c_tao_beam, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_beam logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_beam_test_pattern (f2_tao_beam, 1) call test_c_tao_beam(c_loc(f2_tao_beam), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_beam_test_pattern (f_tao_beam, 4) if (f_tao_beam == f2_tao_beam) then print *, 'tao_beam: C side convert C->F: Good' else print *, 'tao_beam: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_beam !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_beam (c_tao_beam, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_beam type(tao_beam_struct), target :: f_tao_beam, f2_tao_beam logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_beam_to_f (c_tao_beam, c_loc(f_tao_beam)) call set_tao_beam_test_pattern (f2_tao_beam, 2) if (f_tao_beam == f2_tao_beam) then print *, 'tao_beam: F side convert C->F: Good' else print *, 'tao_beam: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_beam_test_pattern (f2_tao_beam, 3) call tao_beam_to_c (c_loc(f2_tao_beam), c_tao_beam) end subroutine test2_f_tao_beam !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_beam_test_pattern (F, ix_patt) implicit none type(tao_beam_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 0, NOT] call set_beam_init_test_pattern (F%beam_init, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_beam_test_pattern (F%start, ix_patt) !! f_side.test_pat[logical, 0, NOT] rhs = 3 + offset; F%init_beam0 = (modulo(rhs, 2) == 0) !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%beam_all_file) F%beam_all_file(jd1:jd1) = char(ichar("a") + modulo(100+4+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%beam0_file) F%beam0_file(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%saved_at) F%saved_at(jd1:jd1) = char(ichar("a") + modulo(100+6+offset+jd1, 26)) enddo end subroutine set_tao_beam_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_universe_calc (ok) implicit none type(tao_universe_calc_struct), target :: f_tao_universe_calc, f2_tao_universe_calc logical(c_bool) c_ok logical ok interface subroutine test_c_tao_universe_calc (c_tao_universe_calc, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_universe_calc logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_universe_calc_test_pattern (f2_tao_universe_calc, 1) call test_c_tao_universe_calc(c_loc(f2_tao_universe_calc), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_universe_calc_test_pattern (f_tao_universe_calc, 4) if (f_tao_universe_calc == f2_tao_universe_calc) then print *, 'tao_universe_calc: C side convert C->F: Good' else print *, 'tao_universe_calc: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_universe_calc !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_universe_calc (c_tao_universe_calc, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_universe_calc type(tao_universe_calc_struct), target :: f_tao_universe_calc, f2_tao_universe_calc logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_universe_calc_to_f (c_tao_universe_calc, c_loc(f_tao_universe_calc)) call set_tao_universe_calc_test_pattern (f2_tao_universe_calc, 2) if (f_tao_universe_calc == f2_tao_universe_calc) then print *, 'tao_universe_calc: F side convert C->F: Good' else print *, 'tao_universe_calc: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_universe_calc_test_pattern (f2_tao_universe_calc, 3) call tao_universe_calc_to_c (c_loc(f2_tao_universe_calc), c_tao_universe_calc) end subroutine test2_f_tao_universe_calc !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_universe_calc_test_pattern (F, ix_patt) implicit none type(tao_universe_calc_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[logical, 0, NOT] rhs = 1 + offset; F%rad_int_for_data = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 2 + offset; F%rad_int_for_plotting = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 3 + offset; F%chrom_for_data = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 4 + offset; F%chrom_for_plotting = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 5 + offset; F%beam_sigma_for_data = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 6 + offset; F%beam_sigma_for_plotting = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 7 + offset; F%dynamic_aperture = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 8 + offset; F%one_turn_map = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 9 + offset; F%lattice = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 10 + offset; F%mat6 = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 11 + offset; F%track = (modulo(rhs, 2) == 0) end subroutine set_tao_universe_calc_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_mpi (ok) implicit none type(tao_mpi_struct), target :: f_tao_mpi, f2_tao_mpi logical(c_bool) c_ok logical ok interface subroutine test_c_tao_mpi (c_tao_mpi, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_mpi logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_mpi_test_pattern (f2_tao_mpi, 1) call test_c_tao_mpi(c_loc(f2_tao_mpi), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_mpi_test_pattern (f_tao_mpi, 4) if (f_tao_mpi == f2_tao_mpi) then print *, 'tao_mpi: C side convert C->F: Good' else print *, 'tao_mpi: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_mpi !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_mpi (c_tao_mpi, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_mpi type(tao_mpi_struct), target :: f_tao_mpi, f2_tao_mpi logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_mpi_to_f (c_tao_mpi, c_loc(f_tao_mpi)) call set_tao_mpi_test_pattern (f2_tao_mpi, 2) if (f_tao_mpi == f2_tao_mpi) then print *, 'tao_mpi: F side convert C->F: Good' else print *, 'tao_mpi: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_mpi_test_pattern (f2_tao_mpi, 3) call tao_mpi_to_c (c_loc(f2_tao_mpi), c_tao_mpi) end subroutine test2_f_tao_mpi !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_mpi_test_pattern (F, ix_patt) implicit none type(tao_mpi_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[logical, 0, NOT] rhs = 1 + offset; F%on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 2 + offset; F%master = (modulo(rhs, 2) == 0) !! f_side.test_pat[integer, 0, NOT] rhs = 3 + offset; F%rank = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 4 + offset; F%max_rank = rhs !! f_side.test_pat[character, 0, NOT] do jd1 = 1, len(F%host_name) F%host_name(jd1:jd1) = char(ichar("a") + modulo(100+5+offset+jd1, 26)) enddo end subroutine set_tao_mpi_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_dynamic_aperture (ok) implicit none type(tao_dynamic_aperture_struct), target :: f_tao_dynamic_aperture, f2_tao_dynamic_aperture logical(c_bool) c_ok logical ok interface subroutine test_c_tao_dynamic_aperture (c_tao_dynamic_aperture, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_dynamic_aperture logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_dynamic_aperture_test_pattern (f2_tao_dynamic_aperture, 1) call test_c_tao_dynamic_aperture(c_loc(f2_tao_dynamic_aperture), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_dynamic_aperture_test_pattern (f_tao_dynamic_aperture, 4) if (f_tao_dynamic_aperture == f2_tao_dynamic_aperture) then print *, 'tao_dynamic_aperture: C side convert C->F: Good' else print *, 'tao_dynamic_aperture: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_dynamic_aperture !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_dynamic_aperture (c_tao_dynamic_aperture, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_dynamic_aperture type(tao_dynamic_aperture_struct), target :: f_tao_dynamic_aperture, f2_tao_dynamic_aperture logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_dynamic_aperture_to_f (c_tao_dynamic_aperture, c_loc(f_tao_dynamic_aperture)) call set_tao_dynamic_aperture_test_pattern (f2_tao_dynamic_aperture, 2) if (f_tao_dynamic_aperture == f2_tao_dynamic_aperture) then print *, 'tao_dynamic_aperture: F side convert C->F: Good' else print *, 'tao_dynamic_aperture: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_dynamic_aperture_test_pattern (f2_tao_dynamic_aperture, 3) call tao_dynamic_aperture_to_c (c_loc(f2_tao_dynamic_aperture), c_tao_dynamic_aperture) end subroutine test2_f_tao_dynamic_aperture !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_dynamic_aperture_test_pattern (F, ix_patt) implicit none type(tao_dynamic_aperture_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%scan)) deallocate (F%scan) else if (.not. allocated(F%scan)) allocate (F%scan(-1:1)) do jd1 = 1, size(F%scan,1); lb1 = lbound(F%scan,1) - 1 call set_aperture_scan_test_pattern (F%scan(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[real, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%pz)) deallocate (F%pz) else if (.not. allocated(F%pz)) allocate (F%pz(-1:1)) do jd1 = 1, size(F%pz,1); lb1 = lbound(F%pz,1) - 1 rhs = 100 + jd1 + 3 + offset F%pz(jd1+lb1) = rhs enddo endif end subroutine set_tao_dynamic_aperture_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_universe (ok) implicit none type(tao_universe_struct), target :: f_tao_universe, f2_tao_universe logical(c_bool) c_ok logical ok interface subroutine test_c_tao_universe (c_tao_universe, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_universe logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_universe_test_pattern (f2_tao_universe, 1) call test_c_tao_universe(c_loc(f2_tao_universe), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_universe_test_pattern (f_tao_universe, 4) if (f_tao_universe == f2_tao_universe) then print *, 'tao_universe: C side convert C->F: Good' else print *, 'tao_universe: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_universe !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_universe (c_tao_universe, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_universe type(tao_universe_struct), target :: f_tao_universe, f2_tao_universe logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_universe_to_f (c_tao_universe, c_loc(f_tao_universe)) call set_tao_universe_test_pattern (f2_tao_universe, 2) if (f_tao_universe == f2_tao_universe) then print *, 'tao_universe: F side convert C->F: Good' else print *, 'tao_universe: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_universe_test_pattern (f2_tao_universe, 3) call tao_universe_to_c (c_loc(f2_tao_universe), c_tao_universe) end subroutine test2_f_tao_universe !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_universe_test_pattern (F, ix_patt) implicit none type(tao_universe_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 0, NOT] call set_tao_beam_test_pattern (F%beam, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_dynamic_aperture_test_pattern (F%dynamic_aperture, ix_patt) !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%d2_data)) deallocate (F%d2_data) else if (.not. allocated(F%d2_data)) allocate (F%d2_data(-1:1)) do jd1 = 1, size(F%d2_data,1); lb1 = lbound(F%d2_data,1) - 1 call set_tao_d2_data_test_pattern (F%d2_data(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%data)) deallocate (F%data) else if (.not. allocated(F%data)) allocate (F%data(-1:1)) do jd1 = 1, size(F%data,1); lb1 = lbound(F%data,1) - 1 call set_tao_data_test_pattern (F%data(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 0, NOT] call set_tao_ping_scale_test_pattern (F%ping_scale, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_lat_test_pattern (F%scratch_lat, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_universe_calc_test_pattern (F%calc, ix_patt) !! f_side.test_pat[real, 2, ALLOC] if (ix_patt < 3) then if (allocated(F%dmodel_dvar)) deallocate (F%dmodel_dvar) else if (.not. allocated(F%dmodel_dvar)) allocate (F%dmodel_dvar(-1:1, 2)) do jd1 = 1, size(F%dmodel_dvar,1); lb1 = lbound(F%dmodel_dvar,1) - 1 do jd2 = 1, size(F%dmodel_dvar,2); lb2 = lbound(F%dmodel_dvar,2) - 1 rhs = 100 + jd1 + 10*jd2 + 20 + offset F%dmodel_dvar(jd1+lb1,jd2+lb2) = rhs enddo; enddo endif !! f_side.test_pat[integer, 0, NOT] rhs = 23 + offset; F%ix_uni = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 24 + offset; F%n_d2_data_used = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 25 + offset; F%n_data_used = rhs !! f_side.test_pat[logical, 0, NOT] rhs = 26 + offset; F%reverse_tracking = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 27 + offset; F%is_on = (modulo(rhs, 2) == 0) !! f_side.test_pat[logical, 0, NOT] rhs = 28 + offset; F%picked_uni = (modulo(rhs, 2) == 0) end subroutine set_tao_universe_test_pattern !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test1_f_tao_super_universe (ok) implicit none type(tao_super_universe_struct), target :: f_tao_super_universe, f2_tao_super_universe logical(c_bool) c_ok logical ok interface subroutine test_c_tao_super_universe (c_tao_super_universe, c_ok) bind(c) import c_ptr, c_bool type(c_ptr), value :: c_tao_super_universe logical(c_bool) c_ok end subroutine end interface ! ok = .true. call set_tao_super_universe_test_pattern (f2_tao_super_universe, 1) call test_c_tao_super_universe(c_loc(f2_tao_super_universe), c_ok) if (.not. f_logic(c_ok)) ok = .false. call set_tao_super_universe_test_pattern (f_tao_super_universe, 4) if (f_tao_super_universe == f2_tao_super_universe) then print *, 'tao_super_universe: C side convert C->F: Good' else print *, 'tao_super_universe: C SIDE CONVERT C->F: FAILED!' ok = .false. endif end subroutine test1_f_tao_super_universe !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine test2_f_tao_super_universe (c_tao_super_universe, c_ok) bind(c) implicit none type(c_ptr), value :: c_tao_super_universe type(tao_super_universe_struct), target :: f_tao_super_universe, f2_tao_super_universe logical(c_bool) c_ok ! c_ok = c_logic(.true.) call tao_super_universe_to_f (c_tao_super_universe, c_loc(f_tao_super_universe)) call set_tao_super_universe_test_pattern (f2_tao_super_universe, 2) if (f_tao_super_universe == f2_tao_super_universe) then print *, 'tao_super_universe: F side convert C->F: Good' else print *, 'tao_super_universe: F SIDE CONVERT C->F: FAILED!' c_ok = c_logic(.false.) endif call set_tao_super_universe_test_pattern (f2_tao_super_universe, 3) call tao_super_universe_to_c (c_loc(f2_tao_super_universe), c_tao_super_universe) end subroutine test2_f_tao_super_universe !--------------------------------------------------------------------------------- !--------------------------------------------------------------------------------- subroutine set_tao_super_universe_test_pattern (F, ix_patt) implicit none type(tao_super_universe_struct) F integer ix_patt, offset, jd, jd1, jd2, jd3, lb1, lb2, lb3, rhs ! offset = 100 * ix_patt !! f_side.test_pat[type, 0, NOT] call set_tao_global_test_pattern (F%global, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_common_test_pattern (F%com, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_plot_page_test_pattern (F%plot_page, ix_patt) !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%v1_var)) deallocate (F%v1_var) else if (.not. allocated(F%v1_var)) allocate (F%v1_var(-1:1)) do jd1 = 1, size(F%v1_var,1); lb1 = lbound(F%v1_var,1) - 1 call set_tao_v1_var_test_pattern (F%v1_var(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%var)) deallocate (F%var) else if (.not. allocated(F%var)) allocate (F%var(-1:1)) do jd1 = 1, size(F%var,1); lb1 = lbound(F%var,1) - 1 call set_tao_var_test_pattern (F%var(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%u)) deallocate (F%u) else if (.not. allocated(F%u)) allocate (F%u(-1:1)) do jd1 = 1, size(F%u,1); lb1 = lbound(F%u,1) - 1 call set_tao_universe_test_pattern (F%u(jd1+lb1), ix_patt+jd1) enddo endif !! f_side.test_pat[type, 0, NOT] call set_tao_mpi_test_pattern (F%mpi, ix_patt) !! f_side.test_pat[integer, 1, ALLOC] if (ix_patt < 3) then if (allocated(F%key)) deallocate (F%key) else if (.not. allocated(F%key)) allocate (F%key(-1:1)) do jd1 = 1, size(F%key,1); lb1 = lbound(F%key,1) - 1 rhs = 100 + jd1 + 11 + offset F%key(jd1+lb1) = rhs enddo endif !! f_side.test_pat[type, 0, NOT] call set_tao_building_wall_test_pattern (F%building_wall, ix_patt) !! f_side.test_pat[type, 0, NOT] call set_tao_wave_test_pattern (F%wave, ix_patt) !! f_side.test_pat[integer, 0, NOT] rhs = 15 + offset; F%n_var_used = rhs !! f_side.test_pat[integer, 0, NOT] rhs = 16 + offset; F%n_v1_var_used = rhs !! f_side.test_pat[type, 1, NOT] do jd1 = 1, size(F%history,1); lb1 = lbound(F%history,1) - 1 rhs = 100 + jd1 + 17 + offset call set_tao_cmd_history_test_pattern (F%history(jd1+lb1), ix_patt+jd1) enddo end subroutine set_tao_super_universe_test_pattern end module