module uap_fortran

type c_dummy_struct
  integer dummy
end type

type uap_attribute_struct
  character(100) :: name = ""
  character(100) :: value = ""
end type

type uap_node_pointer_struct
  type (uap_node_struct), pointer :: node => null()
end type

integer :: element_node$ = 0, text_node$ = 1

! Note: all allocatable components of uap_node_struct will be allocated.

type uap_node_struct
  character(100) :: name = ""
  integer :: type = 0
  type (uap_attribute_struct), allocatable :: attributes(:)
  type (uap_node_struct), pointer :: parent => null()
  type (uap_node_struct), pointer :: children(:) => null()
  type (uap_node_struct), pointer :: twin => null()
  type (uap_node_struct), pointer :: connect => null()
  type (uap_node_pointer_struct), allocatable :: slaves(:)
  type (uap_node_pointer_struct), allocatable :: masters(:)
  type (uap_node_pointer_struct), allocatable :: controllers(:)
  integer ix_child        ! Index of this node in parents %children(:) array
  integer ix              ! For general use
end type

contains

!-----------------------------------------------------------------------------
!+
! Subroutine get_child_by_name (parent_node, child_name, child_node)
!-

subroutine get_child_by_name (parent_node, child_name, child_node)

implicit none

type (uap_node_struct), target :: parent_node
type (uap_node_struct), pointer :: child_node

character(*) child_name

integer i

!

do i = lbound(parent_node%children, 1), ubound(parent_node%children, 1)
  child_node => parent_node%children(i)
  if (child_node%name == child_name) return
enddo

nullify (child_node)

end subroutine

!-----------------------------------------------------------------------------
!+
! Subroutine get_attribute_by_name (node, attribute_name, attribute)
!-

subroutine get_attribute_by_name (node, attribute_name, attribute)

implicit none

type (uap_node_struct), target :: node
type (uap_attribute_struct), pointer :: attribute

character(*) attribute_name

integer i

!

do i = lbound(node%attributes, 1), ubound(node%attributes, 1)
  attribute => node%attributes(i)
  if (attribute%name == attribute_name) return
enddo

nullify (attribute)

end subroutine

!-----------------------------------------------------------------------------
!+
! function get_attribute_value (node, attribute_name, attribute_value) result (found)
!-

function get_attribute_value (node, attribute_name, attribute_value) result (found)

implicit none

type (uap_node_struct), target :: node

character(*) attribute_name, attribute_value
logical found

integer i

!

do i = lbound(node%attributes, 1), ubound(node%attributes, 1)
  if (node%attributes(i)%name /= attribute_name) cycle
  attribute_value = node%attributes(i)%value
  found = .true.
  return
enddo

attribute_value = ''
found = .false.

end function

!-----------------------------------------------------------------------------
!+
! Subroutine uap_print_tree (node, ix_unit, n_indent, n_depth)
!
! Subroutine to print a node tree.
!
! Input:
!   node     -- Uap_node_struct: Node tree root.
!   ix_unit  -- Integer, optional: Fortran file unit number. 
!                 Default or a value of 0 will print to the screen.
!                 If ix_unit /= 0 then this routine assumes the appropriate 
!                 open statement has been executed.
!   n_indent -- Integer, optional: Line indentation. Default is 0.
!   n_depth  -- Integer, optional: Nesting depth. Default is 0.
!                 This argument should not be used.
!-

recursive subroutine uap_print_tree (node, ix_unit, n_indent, n_depth)

implicit none

type (uap_node_struct) node
integer, optional :: n_indent, n_depth, ix_unit
integer i, n_in, n_dep
character(200) line

!

n_in  = 0
n_dep = 0
if (present(n_indent)) n_in  = n_indent
if (present(n_depth))  n_dep = n_depth

if (n_dep == 0) then
  call uap_print_node (node, ix_unit, n_in)
else
  call uap_print_node (node, ix_unit, n_in + 3*n_dep, '|- ')
endif

do i = lbound(node%children, 1), ubound(node%children, 1)
  call uap_print_tree (node%children(i), ix_unit, n_in, n_dep+1)
enddo

end subroutine

!-----------------------------------------------------------------------------
!+
! Subroutine uap_print_node (node, ix_unit, n_indent, prefix)
!-

subroutine uap_print_node (node, ix_unit, n_indent, prefix) 

implicit none

type (uap_node_struct), target :: node
type (uap_node_struct), pointer :: node2

integer, optional :: n_indent, ix_unit
integer nl, i, n_ind

character(200) line
character(*), optional :: prefix

! print node name attribute info

n_ind = 0
if (present(n_indent)) n_ind = n_indent

line = ''
if (present(prefix)) then
  line(n_ind+1:) =  prefix // trim(uap_print_node_basic(node))
else
  line(n_ind+1:) = trim(uap_print_node_basic(node))
endif
call uap_print_line (line, ix_unit)

! Print other info

if (associated(node%twin)) then
  line = ''
  line(n_ind+8:) = 'Twin: ' // trim(uap_print_node_basic(node%twin))
  call uap_print_line (line, ix_unit)
endif

if (associated(node%connect)) then
  line = ''
  line(n_ind+8:) = 'Connect: ' // trim(uap_print_node_basic(node%connect))
  call uap_print_line (line, ix_unit)
endif

do i = lbound(node%masters, 1), ubound(node%masters, 1)
  line = ''
  node2 => node%masters(i)%node
  if (associated(node2)) then
    line(n_ind+8:) = 'Master: ' // trim(uap_print_node_basic(node2))
  else
    line(n_ind+8:) = 'Master: NULL!' 
  endif
  call uap_print_line (line, ix_unit)
enddo

do i = lbound(node%slaves, 1), ubound(node%slaves, 1)
  line = ''
  node2 => node%slaves(i)%node
  if (associated(node2)) then
    line(n_ind+8:) = 'Slave: ' // trim(uap_print_node_basic(node2))
  else
    line(n_ind+8:) = 'Slave: NULL!' 
  endif
  call uap_print_line (line, ix_unit)
enddo

do i = lbound(node%controllers, 1), ubound(node%controllers, 1)
  line = ''
  node2 => node%controllers(i)%node
  if (associated(node2)) then
    if (node2%name == 'slave') then
      line(n_ind+8:) = 'Controller: ' // trim(uap_print_node_basic(node2%parent))
      call uap_print_line (line, ix_unit)
      line = ''
      line(n_ind+8:) = '            ' // trim(uap_print_node_basic(node2))
    else
      line(n_ind+8:) = 'Controller: ' // trim(uap_print_node_basic(node2))
    endif
  else
    line(n_ind+8:) = 'Controller: NULL!' 
  endif
  call uap_print_line (line, ix_unit)
enddo

end subroutine

!-----------------------------------------------------------------------------
!+
! Subroutine uap_print_line (line, ix_unit)
!-

subroutine uap_print_line (line, ix_unit)

implicit none

character(*) line
integer, optional :: ix_unit
integer ix_u

!

ix_u = 0
if (present(ix_unit)) ix_u = ix_unit

if (ix_u == 0) then
  print '(a)', trim(line)
else
  write (ix_u, '(a)') trim(line)
endif

end subroutine

!-----------------------------------------------------------------------------
!+
! Function uap_print_node_basic (node) result (line)
!-

function uap_print_node_basic (node) result (line)

implicit none

type (uap_node_struct) node

integer nl, i

character(200) line

!

line = '<' // node%name

do i = lbound(node%attributes, 1), ubound(node%attributes, 1)
  nl = len_trim(line)
  line(nl+1:) = ' ' // trim(node%attributes(i)%name) // &
                ' = "' // trim(node%attributes(i)%value) // '"'
enddo

nl = len_trim(line)
line(nl+1:) = '>'

end function

!-----------------------------------------------------------------------------
!+
! Subroutine err_print (routine_name, err_message)
!-

subroutine err_print (routine_name, err_message)

implicit none

character(*) routine_name, err_message

!

print '(a)'
print '(a)', 'Error in: ', trim(routine_name)
print '(a)', trim(err_message)

end subroutine

!-----------------------------------------------------------------------------
!+
! Subroutine uap_deallocate_node (uap_node)
!-

recursive subroutine uap_deallocate_node (uap_node)

implicit none

type (uap_node_struct) uap_node
integer i

!

if (associated(uap_node%children)) then
  do i = lbound(uap_node%children, 1), ubound(uap_node%children, 1)
    call uap_deallocate_node (uap_node%children(i))
  enddo
  deallocate (uap_node%children)
endif

if (allocated(uap_node%attributes)) deallocate(uap_node%attributes)

end subroutine

!-----------------------------------------------------------------------------
!+
! Subroutine uap_allocate_node (uap_node, n_attrib, n_children, name)
!-

subroutine uap_allocate_node (uap_node, n_attrib, n_children, name)

implicit none

type (uap_node_struct) uap_node

integer n_attrib, n_children
integer i

character(*), optional :: name

! Allocate attributes

if (allocated(uap_node%attributes)) then
  if (size(uap_node%attributes) /= n_attrib) deallocate(uap_node%attributes) 
endif

if (.not. allocated(uap_node%attributes)) allocate(uap_node%attributes(0:n_attrib-1))

! Allocate children

if (associated(uap_node%children)) then
  do i = lbound(uap_node%children, 1), ubound(uap_node%children, 1)
    call uap_deallocate_node(uap_node%children(i))
  enddo
endif

allocate(uap_node%children(0:n_children-1))

!

if (present(name)) uap_node%name = name

end subroutine

!-----------------------------------------------------------------------------
!+
! Function c_logic (logic) result (c_log)
!
! Function to convert from a fortran logical to a C logical.
!
! Modules needed:
!   use uap_fortran
!
! Input:
!   logic -- Logical: Fortran logical.
!
! Output:
!   c_log -- Integer: C logical.
!-

function c_logic (logic) result (c_log)

implicit none

logical logic
integer c_log

!

if (logic) then
  c_log = 1
else
  c_log = 0
endif

end function

!-----------------------------------------------------------------------------
!+
! Function f_logic (logic) result (f_log)
!
! Function to convert from a fortran logical to a C logical.
!
! Modules needed:
!   use uap_fortran
!
! Input:
!   logic -- Integer: C logical.
!
! Output:
!   f_log -- Logical: Fortran logical.
!-

function f_logic (logic) result (f_log)

implicit none

integer logic
logical f_log

!

if (logic == 0) then
  f_log = .false.
else
  f_log = .true.
endif

end function

!-----------------------------------------------------------------------------
!+
! Function c_str (str) result (c_string)
!
! Function to append a null (0) character at the end of a string (trimmed
! of trailing blanks) so it will look like a C character array. 
!
! Modules needed:
!  use uap_fortran
!
! Input:
!   str   -- Character(*): Input character string
!
! Output:
!   c_str -- Character(*): String with a null put just after the last
!             non-blank character.
!-

function c_str (str) result (c_string)

character(*) str
character(len_trim(str)+1) c_string

c_string = trim(str) // char(0)

end function

!-----------------------------------------------------------------------------
!+
! Subroutine pointer_to_node (root_node, path, node_ptr)
!
! Subroutine to set a pointer to point to a node specified by path.
!
! Input:
!   root_node -- Uap_node_struct: Root node of tree.
!   path(:)   -- Integer: Array of ix_child.
!
! Output:
!   node_ptr -- Uap_node_struct, pointer: Pointer to node given by path.
!                   Nullified if the path in invalid.
!-

subroutine pointer_to_node (root_node, path, node_ptr)

implicit none

type (uap_node_struct), target :: root_node
type (uap_node_struct), pointer :: node_ptr
integer path(:)
integer i
character(20) :: r_name = 'pointer_to_node'

! path(1) always refers to the root node so start with path(2).

node_ptr => root_node

do i = 2, size(path)
  if (path(i) < lbound(node_ptr%children, 1) .or. ubound(node_ptr%children, 1) < path(i)) then
    call err_print (r_name, 'Invalid node path.')
    nullify(node_ptr)
    return
  endif
  node_ptr => node_ptr%children(path(i))
enddo

end subroutine

end module

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+
! Subroutine uap_node_tree_to_c (f_node, c_node)
!
! Subroutine to convert a uap_node_struct tree to a C++ UAPNode tree.
!
! Modules needed:
!  use uap_fortran
!
! Input:
!   f_node -- Uap_node_struct: Input uap_node_struct root node.
!
! Output:
!   c_node -- c_dummy_struct: Output C_node root node.
!-

recursive subroutine uap_node_tree_to_c (f_node, c_node)

use uap_fortran

implicit none

type (uap_node_struct) f_node
type (c_dummy_struct) c_node

integer i

!

call uap_node_to_c2 (c_node, c_str(f_node%name), f_node%type)

if (allocated(f_node%attributes)) then
  do i = lbound(f_node%attributes, 1), ubound(f_node%attributes, 1)
    call uap_attribute_in_node_to_c2 (c_node, &
            c_str(f_node%attributes(i)%name), c_str(f_node%attributes(i)%value))
  enddo
endif

if (associated(f_node%children)) then
  do i = lbound(f_node%children, 1), ubound(f_node%children, 1)
    call uap_node_in_node_to_c2 (c_node, f_node%children(i))
  enddo
endif

end subroutine

!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!+
! Subroutine uap_node_to_f2 (f_node, node_name, n_name, ix_node_type, 
!                            n_attrib, n_children, n_master, n_slave, n_controller)
!
! Subroutine used by uap_node_tree_to_f to convert a C++ C_node into
! a Bmad uap_node_struct. This routine is not for general use.
!-

subroutine uap_node_to_f2 (f_node, node_name, n_name, ix_node_type, &
                            n_attrib, n_children, n_master, n_slave, n_controller)

use uap_fortran

implicit none

type (uap_node_struct), target :: f_node

integer n_name, n_attrib, n_children, n_master, n_slave, n_controller
integer i

character(n_name) node_name
integer ix_node_type

!

f_node%name = node_name
f_node%type = ix_node_type

if (allocated(f_node%attributes)) deallocate(f_node%attributes)
if (n_attrib > 0) allocate (f_node%attributes(0:n_attrib-1))

if (associated(f_node%children)) deallocate(f_node%children)
if (n_children > 0) allocate (f_node%children(0:n_children-1))

do i = lbound(f_node%children, 1), ubound(f_node%children, 1)
  f_node%children(i)%ix_child = i
  f_node%children(i)%parent => f_node
enddo

allocate(f_node%masters(0:n_master-1))
allocate(f_node%slaves(0:n_slave-1))
allocate(f_node%controllers(0:n_controller-1))

end subroutine

!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!+
! Subroutine uap_attribute_in_node_to_f2 (f_node, ix_attrib, &
!                                             name, n_name, value, n_value)
!
! Subroutine used by uap_node_tree_to_f to convert a C++ C_node into
! a Bmad uap_node_struct. This routine is not for general use.
!-

subroutine uap_attribute_in_node_to_f2 (f_node, ix_attrib, name, n_name, value, n_value)

use uap_fortran

implicit none

type (uap_node_struct) f_node
type (c_dummy_struct) c_child
integer ix_attrib, n_name, n_value

character(n_name) name
character(n_value) value

!

f_node%attributes(ix_attrib)%name = name
f_node%attributes(ix_attrib)%value = value

end subroutine

!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!+
! Subroutine uap_node_in_node_to_f2 (f_node, ix_child, c_child)
!
! Subroutine used by uap_node_tree_to_f to convert a C++ C_node into
! a Bmad uap_node_struct. This routine is not for general use.
!-

subroutine uap_node_in_node_to_f2 (f_node, ix_child, c_child)

use uap_fortran

implicit none

type (uap_node_struct) f_node
type (c_dummy_struct) c_child
integer ix_child

!

call uap_node_in_node_to_f(c_child, f_node%children(ix_child))

end subroutine

!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!+
! Subroutine uap_master_info_array_to_f2 (f_node, path, n_path, ix_list, 
!                                                path2, n2_path, who_name, n_who)
!
! Subroutine used by uap_node_tree_to_f to convert a C++ C_node into
! a Bmad uap_node_struct. This routine is not for general use.
!-

subroutine uap_master_info_array_to_f2 (f_node, path, n_path, ix_list, &
                                                 path2, n_path2, who_name, n_who)

use uap_fortran

implicit none

type (uap_node_struct), target :: f_node
type (uap_node_struct), pointer :: this, this2

integer n_path, n_path2, ix_list, n_who
integer path(n_path), path2(n_path2)

character(n_who) who_name
character(40) :: r_name = 'uap_master_info_array_to_f2'

! Find the node containing the pointer.
!

call pointer_to_node (f_node, path, this)
call pointer_to_node (f_node, path2, this2)

if (.not. associated(this)) return

select case (who_name)
case ("MASTER")
  this%masters(ix_list)%node => this2

case ("SLAVE")
  this%slaves(ix_list)%node => this2

case ("CONTROLLER")
  this%controllers(ix_list)%node => this2

case default
  call err_print (r_name, 'Internal Error!')
  stop
end select

end subroutine

!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!-----------------------------------------------------------------------------
!+
! Subroutine uap_master_info_single_to_f2 (f_node, path, n_path, 
!                                                path2, n2_path, who_name, n_who)
!
! Subroutine used by uap_node_tree_to_f to convert a C++ C_node into
! a Bmad uap_node_struct. This routine is not for general use.
!-

subroutine uap_master_info_single_to_f2 (f_node, path, n_path, &
                                                 path2, n_path2, who_name, n_who)

use uap_fortran

implicit none

type (uap_node_struct), target :: f_node
type (uap_node_struct), pointer :: this, this2

integer n_path, n_path2, n_who
integer path(n_path), path2(n_path2)

character(n_who) who_name
character(40) :: r_name = 'uap_master_info_single_to_f2'

! Find the node containing the pointer.

call pointer_to_node (f_node, path, this)
call pointer_to_node (f_node, path2, this2)

if (.not. associated(this)) return

select case (who_name)
case ("TWIN")
  this%twin => this2

case ("CONNECT")
  this%connect => this2

case default
  call err_print (r_name, 'Internal Error!')
  stop
end select

end subroutine