module gpack_private
  use gpack_def
  !---------------------------------------------------------------------
  ! @private
  ! Definitions for internal package management
  !---------------------------------------------------------------------
  !
  integer(kind=4) :: gpack_registered_count = 0  ! Current number of registered packages
  type(gpack_prop_t), save :: gpack_packages(gpack_max_count)
  !
end module gpack_private
!
function gpack_get_count()
  use gpack_private
  !---------------------------------------------------------------------
  ! @ public
  ! Return number of registered packages
  !---------------------------------------------------------------------
  integer(kind=4) :: gpack_get_count
  !
  gpack_get_count = gpack_registered_count
  !
end function gpack_get_count
!
function gpack_get_info(ipack)
  use gpack_def
  use gpack_private
  !---------------------------------------------------------------------
  ! @ public
  ! Return package information structure
  !---------------------------------------------------------------------
  type(gpack_info_t) :: gpack_get_info
  integer(kind=4), intent(in) :: ipack
  !
  gpack_get_info = gpack_packages(ipack)%info
  !
end function gpack_get_info
!
subroutine gpack_get_name(id,packname,error)
  use gpack_def
  use gpack_private
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! Get package name from the given package id
  !---------------------------------------------------------------------
  integer(kind=4),  intent(in)    :: id
  character(len=*), intent(out)   :: packname
  logical,          intent(inout) :: error
  ! Local
  character(len=message_length) :: mess
  !
  if (id.eq.0) then
     packname = gpack_global_name
  else if (1.le.id .and. id.le.gpack_registered_count) then
     packname = gpack_packages(id)%info%name
  else
     write(mess,*) "Unknown package id #",id
     call gsys_message(seve%e,"PACK",mess)
     packname = 'UNKNOWN'
     error = .true.
     return
  endif
  !
end subroutine gpack_get_name
!
function gpack_get_id(gpack_name,present,error)
  use gsys_interfaces, except_this=>gpack_get_id
  use gpack_private
  use gbl_message
  !---------------------------------------------------------------------
  ! @ public
  ! Private function to get the package id from the package name
  !---------------------------------------------------------------------
  integer(kind=4)  :: gpack_get_id ! Returned package id
  character(len=*), intent(in)    :: gpack_name   ! Package name
  logical,          intent(in)    :: present      ! Must the package be already registered?
  logical,          intent(inout) :: error        ! Error flag
  !
  if (gpack_name.eq.gpack_global_name) then
     gpack_get_id = gpack_global_id
     return
  else
     do gpack_get_id=1,gpack_registered_count
        if (gpack_packages(gpack_get_id)%info%name.eq.gpack_name) return
     end do
  endif
  !
  ! Unknown package name may be licit at init time, not after:
  gpack_get_id = gpack_null_id
  if (present) then
     call gsys_message(seve%e,"PACK",'Unknown package name '''//gpack_name//'''')
     error = .true.
  endif
  !
end function gpack_get_id
!
function gpack_register(pack,error)
  use gsys_interfaces, except_this=>gpack_register
  use gpack_def
  use gpack_private
  use gbl_message
  !----------------------------------------------------------------------
  ! @ private
  ! Private function to register a package and return a new package id
  !----------------------------------------------------------------------
  integer(kind=4) :: gpack_register
  type(gpack_prop_t), intent(in)    :: pack
  logical,            intent(inout) :: error
  !
  gpack_register = 0
  !
  ! Check package registration status
  if (gpack_get_id(pack%info%name,.false.,error).ne.gpack_null_id) then
     ! Already registred
     call gag_message(seve%e,'GAG_REGISTER','Package '//pack%info%name//' already registered')
     error = .true.
     return
  else if (gpack_registered_count.eq.gpack_max_count) then
     call gag_message(seve%e,'GAG_REGISTER','Too many registered packages: Increase gpack_max_count')
     error = .true.
     return
  endif
  !
  gpack_registered_count = gpack_registered_count+1
  gpack_packages(gpack_registered_count) = pack
  gpack_packages(gpack_registered_count)%id = gpack_registered_count
  !
  if (pack%info%toscreen.ne.'') then
     call gmessage_parse_and_set(gpack_registered_count,pack%info%toscreen,error)
     if (error) return
  endif
  if (pack%info%tofile.ne.'') then
     call gmessage_parse_and_set(gpack_registered_count,pack%info%tofile,error)
     if (error) return
  endif
  !
  gpack_register = gpack_registered_count
  !
end function gpack_register
!
subroutine gpack_resolve(packname,found,error)
  use gsys_interfaces, except_this=>gpack_resolve
  use gbl_message
  use gpack_def
  use gpack_private
  !---------------------------------------------------------------------
  ! @ public
  ! Resolve packname string ambiguities
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: packname  ! Package name
  logical,          intent(out)   :: found     ! Found package?
  logical,          intent(inout) :: error     ! Error flag
  ! Local
  character(len=*), parameter :: rname='gpack_resolve'
  integer(kind=4) :: id,ipack
  character(len=gpack_name_length) :: outname                      ! Resolved package name
  character(len=gpack_name_length) :: allnames(gpack_max_count+1)  ! All packages name
  !
  found = .false.
  call sic_lower(packname)
  allnames(1:1+gpack_registered_count) =  &
    (/ gpack_global_name,(gpack_packages(ipack)%info%name,ipack=1,gpack_registered_count) /)
  !
  call sic_ambigs_sub(rname,packname,outname,id,allnames,gpack_registered_count+1,error)
  if (error) return  ! There was an ambiguity
  !
  if (id.gt.0) then  ! Found 1 and only 1 correspondance
    found = .true.
    packname = outname
  endif
  !
end subroutine gpack_resolve
!
function gpack_is_registered(gpack_name)
  use gsys_interfaces, except_this=>gpack_is_registered
  use gpack_private
  use gbl_message
  !---------------------------------------------------------------------
  ! @ public
  ! Check registration status of a package
  !---------------------------------------------------------------------
  logical                      :: gpack_is_registered  ! Package registration status
  character(len=*), intent(in) :: gpack_name           ! Package name
  ! Local
  logical :: error
  !
  ! Check package status
  error = .false.
  if (gpack_get_id(gpack_name,.false.,error).ne.gpack_null_id) then
     gpack_is_registered = .true.
  else
     gpack_is_registered = .false.
  endif
  !
end function gpack_is_registered
!
subroutine gexec0(routine)
  !---------------------------------------------------------------------
  ! @ no-interface
  ! Call a routine from its address with no argument
  !---------------------------------------------------------------------
  external :: routine
  !
  call routine
end subroutine gexec0
!
subroutine gexec1(routine,a1)
  !---------------------------------------------------------------------
  ! @ no-interface
  ! Call a routine from its address with 1 argument
  !---------------------------------------------------------------------
  external        :: routine
  integer(kind=4) :: a1
  !
  call routine(a1)
end subroutine gexec1
!
subroutine gexec2(routine,a1,a2)
  !---------------------------------------------------------------------
  ! @ no-interface
  ! Call a routine from its address with 2 arguments
  !---------------------------------------------------------------------
  external        :: routine
  integer(kind=4) :: a1
  integer(kind=4) :: a2
  !
  call routine(a1,a2)
end subroutine gexec2
!
recursive subroutine gexec3(routine,a1,a2,a3)
  !---------------------------------------------------------------------
  ! @ no-interface
  ! Call a routine from its address with 3 arguments. Subroutine is
  ! recursive because of recursive calls in gpack_recurse_depend
  !---------------------------------------------------------------------
  external        :: routine
  integer(kind=4) :: a1
  integer(kind=4) :: a2
  integer(kind=4) :: a3
  !
  call routine(a1,a2,a3)
end subroutine gexec3
!
recursive subroutine gpack_recurse(pack_fct,pack_id,error)
  use gsys_interfaces, except_this=>gpack_recurse
  use gpack_private
  !---------------------------------------------------------------------
  ! @ private
  ! Call pack_fct on all package from the dependency hierarchy, starting
  ! from low level packages and ending with the root package given by
  ! pack_id
  !---------------------------------------------------------------------
  external                       :: pack_fct
  integer(kind=4), intent(in)    :: pack_id
  logical,         intent(inout) :: error
  ! Local
  logical :: pack_reach_flags(gpack_max_count)
  integer(kind=4) :: ipack
  !
  pack_reach_flags = (/ (.false., ipack=1,gpack_max_count) /)
  !
  call gpack_recurse_depend(pack_fct,gpack_packages(pack_id),  &
    gpack_packages(pack_id),.true.,0,pack_reach_flags,error)
  !
end subroutine gpack_recurse
!
subroutine gpack_recurse_high_first(pack_fct,pack_id,error)
  use gsys_interfaces, except_this=>gpack_recurse_high_first
  use gpack_private
  !---------------------------------------------------------------------
  ! @ private
  ! Call pack_fct on all package from the dependency hierarchy, starting
  ! from the root package given by pack_id and ending with low level
  ! packages
  !---------------------------------------------------------------------
  external                       :: pack_fct
  integer(kind=4), intent(in)    :: pack_id
  logical,         intent(inout) :: error
  ! Local
  logical :: pack_reach_flags(gpack_max_count)
  integer(kind=4) :: ipack
  !
  pack_reach_flags = (/ (.false., ipack=1,gpack_max_count) /)
  !
  call gpack_recurse_depend(pack_fct,gpack_packages(pack_id),  &
    gpack_packages(pack_id),.false.,0,pack_reach_flags,error)
  !
end subroutine gpack_recurse_high_first
!
recursive subroutine gpack_recurse_depend(pack_fct,pack,parent_pack,low_first,  &
  recurse_level,pack_reach_flags,error)
  use gsys_interfaces, except_this=>gpack_recurse_depend
  use gpack_def
  use gpack_private
  !---------------------------------------------------------------------
  ! @ private
  ! Generic routine to recurse through all dependent packages of package
  ! pack
  !---------------------------------------------------------------------
  external                          :: pack_fct       ! Function to call on each package
  type(gpack_prop_t), intent(in)    :: pack           ! Package to start from
  type(gpack_prop_t), intent(in)    :: parent_pack    ! Initial recursion package
  logical,            intent(in)    :: low_first      ! Call pack_fct from low level package to high level
  integer(kind=4),    intent(in)    :: recurse_level  !
  logical,            intent(inout) :: pack_reach_flags(gpack_max_count)
  logical,            intent(inout) :: error          ! Error flag
  ! Global
  include 'gbl_memory.inc'
  ! Local
  integer(kind=4) :: ipack, pack_depend_id
  !
  ! call pack_fct
  if (.not.low_first) then
     call gexec3(pack_fct,pack,parent_pack,error)
     if (error) return
  endif
  !
  ! Loop over the registered packages
  do ipack=1,gpack_registered_count,1
     pack_depend_id = pack%depend_id(ipack)
     if (pack_depend_id.eq.0) exit
     !
     ! Flag reached package
     if (pack_reach_flags(pack_depend_id)) cycle
     pack_reach_flags(pack_depend_id) = .true.
     !
     ! Do recursion
     call gpack_recurse_depend(pack_fct,gpack_packages(pack_depend_id),parent_pack,  &
       low_first,recurse_level+1,pack_reach_flags,error)
     if (error) return
  end do
  !
  ! Recurse again or call pack_fct
  if (low_first) then
     call gexec3(pack_fct,pack,parent_pack,error)
     if (error) return
  endif
  !
end subroutine gpack_recurse_depend
!
recursive subroutine gpack_set_dependencies(pack,error)
  use gsys_interfaces, except_this=>gpack_set_dependencies
  use gpack_def
  use gpack_private
  !---------------------------------------------------------------------
  ! @ private
  ! Intermediate routine to call gpack_set recursively and build package
  ! depend_id member
  !---------------------------------------------------------------------
  type(gpack_prop_t), intent(inout) :: pack
  logical,            intent(inout) :: error
  ! Global
  integer(kind=4) :: gpack_set
  include 'gbl_memory.inc'
  ! Local
  integer(kind=4) :: ipack
  logical :: already_registered
  !
  do ipack = 1,gpack_max_count
     if (pack%info%depend(ipack).eq.0) exit
     pack%depend_id(ipack) = gpack_set(membyt(bytpnt(pack%info%depend(ipack),membyt)),already_registered,error)
     if (error) return
  end do
  !
end subroutine gpack_set_dependencies
!
recursive function gpack_set(pack_set,already_registered,error)
  use gsys_interfaces
  use gpack_private
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  ! Private routine to define and register a package and all its
  !  dependencies.
  !---------------------------------------------------------------------
  integer(kind=4) :: gpack_set
  external               :: pack_set   ! package definition method
  logical, intent(out)   :: already_registered
  logical, intent(inout) :: error
  ! Local
  type(gpack_prop_t) :: pack
  !
  gpack_set = 0
  !
  call pack_set(pack%info)
  !
  ! Check package registration status
  if (gpack_is_registered(pack%info%name)) then
     gpack_set = gpack_get_id(pack%info%name,.true.,error)
     already_registered = .true.
     return
  endif
  already_registered = .false.
  !
  ! Take care of dependencies:
  ! This must be done before registration of current package
  call gpack_set_dependencies(pack,error)
  if (error) return
  !
  ! Store registration information
  gpack_set = gpack_register(pack,error)
  if (error) return
  !
end function gpack_set
!
subroutine gpack_init(pack,parent_pack,error)
  use gsys_interfaces, except_this=>gpack_init
  use gpack_def
  use gpack_private
  !---------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  ! Call package init method from gpack_recurse
  !---------------------------------------------------------------------
  type(gpack_prop_t), intent(inout) :: pack
  type(gpack_prop_t), intent(in)    :: parent_pack
  logical,            intent(inout) :: error
  ! Global
  include 'gbl_memory.inc'
  !
  if (pack%init_done) return
  !
  if (pack%info%init.ne.0) then
     call gexec2(membyt(bytpnt(pack%info%init,membyt)),pack%id,error)
  endif
  !
  call gpack_recurse(gpack_exec_on_child,pack%id,error)
  if (error) return
  !
  pack%init_done = .true.
  !
end subroutine gpack_init
!
subroutine gpack_exec_on_child(pack,parent_pack,error)
  use gsys_interfaces, except_this=>gpack_exec_on_child
  use gpack_def
  use gpack_private
  !---------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  ! Call package exec_on_child method from gpack_recurse_again
  !---------------------------------------------------------------------
  type(gpack_prop_t), intent(in)    :: pack
  type(gpack_prop_t), intent(in)    :: parent_pack
  logical,            intent(inout) :: error
  ! Global
  include 'gbl_memory.inc'
  !
  if (pack%info%exec_on_child.ne.0.and..not.parent_pack%init_done) then
     call gexec2(membyt(bytpnt(pack%info%exec_on_child,membyt)),parent_pack%info,error)
  endif
end subroutine gpack_exec_on_child
!
subroutine gpack_clean(pack,parent_pack,error)
  use gsys_interfaces, except_this=>gpack_clean
  use gpack_def
  use gpack_private
  !---------------------------------------------------------------------
  ! @ private
  ! Call package start method from gpack_recurse_high_first
  !---------------------------------------------------------------------
  type(gpack_prop_t), intent(in)    :: pack
  type(gpack_prop_t), intent(in)    :: parent_pack
  logical,            intent(inout) :: error
  ! Global
  include 'gbl_memory.inc'
  !
  if (pack%info%clean.ne.0) then
     call gexec1(membyt(bytpnt(pack%info%clean,membyt)),error)
  endif
end subroutine gpack_clean
!
function gpack_build(pack_set,already_registered,error)
  use gsys_interfaces, except_this=>gpack_build
  !---------------------------------------------------------------------
  ! @ public
  ! Builds a package and its dependencies, returns package registration
  ! id
  !---------------------------------------------------------------------
  integer(kind=4) :: gpack_build
  external               :: pack_set
  logical, intent(out)   :: already_registered
  logical, intent(inout) :: error
  ! Global
  integer(kind=4) :: gpack_set
  ! Local
  integer(kind=4) :: pack_id
  !
  gpack_build = 0
  !
  pack_id = gpack_set(pack_set,already_registered,error)
  if (error) return
  !
  if (already_registered) then
     gpack_build = pack_id
     return
  endif
  !
  call gpack_recurse(gpack_init,pack_id,error)
  if (error) return
  !
  gpack_build = pack_id
  !
end function gpack_build
