!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
module cubego_oldload
  use cubetools_structure
  use cubetools_keywordlist_types
  use cubetools_access_types
  use cubedag_parameters
  use cube_types
  use cubeadm_cubeid_types
  use cubego_messaging
  !  
  public :: cubego_oldload_getcube_number
  public :: cubego_oldload_getcube_pointer
  public :: cubego_oldload_register
  public :: lastloaded,proglist,mprog
  private
  !
  type :: oldload_comm_t
     type(option_t),      pointer :: oldload
     type(cubeid_arg_t),  pointer :: cube
     type(option_t),      pointer :: in
     type(keywordlist_comm_t), pointer :: in_arg
     type(option_t),      pointer :: syntax
     type(keywordlist_comm_t), pointer :: syntax_arg
     type(order_comm_t)           :: access
  end type oldload_comm_t
  type(oldload_comm_t) :: comm
  !
  type uservar_t
     character(len=varn_l) :: name = 'AAA1'
     character(len=varn_l) :: status = 'READ' ! READonly by default
  end type uservar_t
  type progvar_t
     character(len=varn_l) :: name = 'AAA1'
     logical :: readonly = .true.
  end type progvar_t
  !
  type oldload_user_t
     type(cubeid_user_t) :: incube
     type(uservar_t)     :: var
     character(len=4)    :: syntax = 'HEAD'
     type(order_user_t)  :: access
  end type oldload_user_t
  !
  type oldload_prog_t
     integer(kind=iden_l)  :: id
     character(len=base_l) :: name
     logical               :: used=.false.
     type(progvar_t)       :: var
     type(cube_t), pointer :: cube
     logical               :: dohead=.true.
     type(order_prog_t)    :: access
  end type oldload_prog_t
  !
  type(oldload_user_t) :: user
  integer(kind=4), parameter :: mprog=16  ! Maximum number of cubes LOADed at a time
  type(oldload_prog_t), target :: proglist(mprog)
  integer(kind=4) :: lastloaded = 0
  !
contains
  !
  subroutine cubego_oldload_register(error)
    use cubedag_allflags
    !-------------------------------------------------------------------
    ! Register GO\OLDLOAD command and its options
    !-------------------------------------------------------------------
    logical, intent(inout) :: error
    !
    type(cubeid_arg_t) :: cubearg
    type(standard_arg_t) :: stdarg
    type(keywordlist_comm_t) :: keyarg
    !
    character(len=*), parameter :: readwrite(2) = ['READ ','WRITE']
    character(len=*), parameter :: syntaxes(2)  = ['HEAD','HGDF']
    character(len=*), parameter :: rname='OLDLOAD>REGISTER'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call cubetools_register_command(&
         'OLDLOAD','[cubeid]',&
         'Load a cube onto a sic variable',&
         'Load a cube into a SIC variable through the legacy OLDLOAD&
         & path. By default, it creates read-only variable AAA1 with&
         & image access and the new header mapping. Use /SYNTAX HGDF&
         & only for compatibility workflows.',&
         cubego_oldload_command,&
         comm%oldload,error)
    if (error) return
    call cubearg%register(&
         'CUBEID',&
         'Identity of the cube to be loaded',&
         'If omitted, use the last matching cube (any family/flags) in&
         & the default index (DAG by default; see SET\INDEX).',&
         code_arg_optional,&
         [flag_any],&
         code_read,&
         code_access_imaset_or_speset,&
         comm%cube,&
         error)
    if (error) return
    !
    call cubetools_register_option(&
         'IN','varname status',&
         'Define the name of the SIC variable',&
         'The option can also be used to modify the read-write status&
         & of the SIC variable',&
         comm%in,error)
    if (error) return
    call stdarg%register(&
         'varname',&
         'Name of the variable onto which to load data',&
         strg_emp,&
         code_arg_mandatory,&
         error)
    if (error) return
    call keyarg%register(&
         'status',&
         'Variable access status',&
         'Default is READ',&
         code_arg_optional,&
         readwrite,&
         .not.flexible,&
         comm%in_arg,&
         error)
    if (error) return
    !
    call cubetools_register_option(&
         'SYNTAX','type',&
         'Define the type of structure of the SIC variable',&
         'HEAD (default if options is not present) means the new CUBE&
         & header, HGDF means the classic GREG header',&
         comm%syntax,error)
    if (error) return
    call keyarg%register(&
         'type',&
         'SIC structure syntax type',&
         strg_emp,&
         code_arg_mandatory,&
         syntaxes,&
         .not.flexible,&
         comm%syntax_arg,&
         error)
    if (error) return
    !
    call comm%access%register(&
         'ACCESS',&
         'Define the access type of the loaded cube',&
         'If Access is IMAGE, command GO\GET will fetch images, if&
         & access is SPECTRUM, command GO\GET will fetch spectra',&
         error)
    if (error) return
  end subroutine cubego_oldload_register
  !
  subroutine cubego_oldload_command(line,error)
    !-------------------------------------------------------------------
    ! Support routine for command OLDLOAD
    !-------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    integer(kind=4) :: iprog
    character(len=*), parameter :: rname='OLDLOAD>COMMAND'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call cubego_oldload_sicdef(.false.,error)
    if (error) return
    call cubego_oldload_parse(line,user,error)
    if (error) return
    call cubego_oldload_getslot(user%var%name,proglist,iprog,error)
    if (error) return
    call cubego_oldload_user2prog(user,proglist(iprog),error)
    if (error) return
    call cubego_oldload_main(user,proglist(iprog),error)
    if (error) return
    call cubego_oldload_sicdef(.true.,error)
    if (error) return
    lastloaded = iprog
  end subroutine cubego_oldload_command
  !
  subroutine cubego_oldload_sicdef(loaded,error)
    use cubetools_progstruct_types
    use cubego_buffer
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    logical, intent(in)    :: loaded
    logical, intent(inout) :: error
    !
    type(progstruct_t) :: oldload
    character(len=*), parameter :: rname='OLDLOAD>SICDEF'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call cubego%recreate('oldload',oldload,error)
    if (error) return
    call sic_def_logi(trim(oldload%name)//'found',loaded,readonly,error)
    if (error) return
  end subroutine cubego_oldload_sicdef
  !
  subroutine cubego_oldload_parse(line,user,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    character(len=*),     intent(in)    :: line
    type(oldload_user_t), intent(out)   :: user
    logical,              intent(inout) :: error
    !
    type(uservar_t) :: default_var
    character(len=*), parameter :: rname='OLDLOAD>PARSE'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call cubeadm_cubeid_parse(line,comm%oldload,user%incube,error)
    if (error) return    
    call cubego_oldload_parse_variable(line,default_var,user%var,error)
    if (error) return
    call cubego_oldload_parse_syntax(line,'HEAD',user%syntax,error)
    if (error) return
    call cubego_oldload_parse_access(line,error)
    if (error) return
  end subroutine cubego_oldload_parse
  !
  subroutine cubego_oldload_parse_access(line,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    logical,          intent(inout) :: error
    !
    character(len=*), parameter :: rname='OLDLOAD>PARSE>ACCESS'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call comm%access%parse(line,user%access,error)
    if (error)  return
    if (user%access%do) then
       if (user%syntax.eq.'HGDF') then
          call cubego_message(seve%e,rname,'Access cannot be defined for HGDF syntax')
          error = .true.
          return
       endif
    endif
  end subroutine cubego_oldload_parse_access
  !
  subroutine cubego_oldload_parse_variable(line,def,out,error)
    use cubetools_disambiguate
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*),      intent(in)    :: line
    type(uservar_t),       intent(in)    :: def
    type(uservar_t),       intent(out)   :: out
    logical,               intent(inout) :: error
    !
    integer(kind=4) :: ikey
    character(len=12) :: status
    character(len=varn_l) :: name
    logical :: dovar
    integer(kind=4), parameter :: iname = 1
    integer(kind=4), parameter :: iaccess = 2
    character(len=*), parameter :: rname='OLDLOAD>PARSE>VARIABLE'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call comm%in%present(line,dovar,error)
    if (error) return
    if (dovar) then
       call cubetools_getarg(line,comm%in,iname,name,mandatory,error)
       if (error) return
       call cubetools_disambiguate_toupper(name,out%name,error)
       if (error) return
       status = def%status
       call cubetools_getarg(line,comm%in,iaccess,status,.not.mandatory,error)
       if (error) return
       call cubetools_keywordlist_user2prog(comm%in_arg,status,ikey,out%status,error)
       if (error) return
    else
       out = def
    endif
  end subroutine cubego_oldload_parse_variable
  !
  subroutine cubego_oldload_parse_syntax(line,def,out,error)
    !----------------------------------------------------------------------
    !
    !----------------------------------------------------------------------
    character(len=*), intent(in)    :: line
    character(len=*), intent(in)    :: def
    character(len=*), intent(out)   :: out
    logical,          intent(inout) :: error
    !
    integer(kind=4) :: ikey
    character(len=12) :: type
    logical :: dosyntax
    character(len=*), parameter :: rname='OLDLOAD>PARSE>SYNTAX'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call comm%syntax%present(line,dosyntax,error)
    if (error) return
    if (dosyntax) then
       call cubetools_getarg(line,comm%syntax,1,type,mandatory,error)
       if (error) return
       call cubetools_keywordlist_user2prog(comm%syntax_arg,type,ikey,out,error)
       if (error) return
    else
       out = def
    endif
  end subroutine cubego_oldload_parse_syntax
  !
  subroutine cubego_oldload_user2prog(user,prog,error)
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(oldload_user_t), intent(in)    :: user
    type(oldload_prog_t), intent(inout) :: prog
    logical,           intent(inout) :: error
    !
    type(cubeid_prog_t) :: cubeid
    character(len=*), parameter :: rname='OLDLOAD>USER2PROG'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    prog%var%name = user%var%name
    prog%var%readonly = user%var%status.eq.'READ'
    prog%dohead = user%syntax.eq.'HEAD'
    call user%access%toprog(comm%access,code_access_imaset,prog%access,error)
    if (error)  return
    !
    call cubeadm_cubeid_user2prog(comm%oldload,user%incube,cubeid,error)
    if (error) return
    prog%id = cubeid%id(comm%cube%inum)
  end subroutine cubego_oldload_user2prog
  !
  subroutine cubego_oldload_getslot(varname,proglist,iprog,error)
    use sic_types
    !-------------------------------------------------------------------
    ! Return a free 'slot' to be used for loading the cube
    !-------------------------------------------------------------------
    character(len=*),  intent(in)    :: varname
    type(oldload_prog_t), intent(inout) :: proglist(:)
    integer(kind=4),   intent(out)   :: iprog
    logical,           intent(inout) :: error
    !
    character(len=*), parameter :: rname='OLDLOAD>GETSLOT'
    logical :: found
    type(sic_descriptor_t) :: desc
    !
    ! First, search if one has to be overwritten
    iprog = cubego_oldload_get_varindex(varname,proglist)
    if (iprog.gt.0) then
      ! Found one in use with the correct name. Free it and return
      ! its number for reuse
      call cubego_oldload_clean(proglist(iprog),error)
      return
    endif
    !
    ! Remove SIC variable to be overwritten (if any), take care of
    ! read-only ones (e.g. PI)
    found = .false.  ! Quiet
    call sic_descriptor(varname,desc,found)
    if (found) then
      if (desc%readonly) then
        call cubego_message(seve%e,rname,'Can not delete read-only variable '//varname)
        error = .true.
        return
      endif
      call sic_delvariable(varname,.false.,error)
      if (error) return
    endif
    !
    ! Else, just find a free slot
    do iprog=1,size(proglist)
      if (.not.proglist(iprog)%used)  return
    enddo
    !
    ! No free slot found
    call cubego_message(seve%e,rname,'Maximum number of buffers exhausted')
    error = .true.
    return
  end subroutine cubego_oldload_getslot
  !
  function cubego_oldload_get_varindex(varname,proglist) result(varindex)
    !-------------------------------------------------------------------
    ! Return the cube index for which the cube is mapped to the named
    ! variable. Return 0 if not found.
    !-------------------------------------------------------------------
    integer(kind=4)               :: varindex
    character(len=*),  intent(in) :: varname
    type(oldload_prog_t), intent(in) :: proglist(:)
    !
    integer(kind=4) :: iprog
    !
    do iprog=1,size(proglist)
      if (.not.proglist(iprog)%used)            cycle
      if (proglist(iprog)%var%name.ne.varname)  cycle
      varindex = iprog
      return
    enddo
    varindex = 0
  end function cubego_oldload_get_varindex
  !
  subroutine cubego_oldload_clean(prog,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! Clean current contents of the LOAD prog structure
    !-------------------------------------------------------------------
    type(oldload_prog_t), intent(inout) :: prog
    logical,           intent(inout) :: error
    !
    character(len=*), parameter :: rname='OLDLOAD>MAIN'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    if (.not.sic_varexist(prog%var%name))  then
      ! The variable does not exist anymore. Since it is a program-defined
      ! variable, this was not done by the user. Assume this was done
      ! by cubedag_node_remove, when the target node was destroyed. This
      ! means prog%cube is now a dangling pointer, can not use it!
      prog%used = .false.
      return
    endif
    !
    call sic_delvariable(prog%var%name,.false.,error)
    if (error) error = .false.
    call prog%cube%unset_uservar(prog%var%name,error)
    if (error) error = .false.
    prog%used = .false.
  end subroutine cubego_oldload_clean
  !
  subroutine cubego_oldload_main(user,prog,error)
    use gkernel_interfaces
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(oldload_user_t), intent(in)    :: user
    type(oldload_prog_t), intent(inout) :: prog
    logical,           intent(inout) :: error
    !
    character(len=mess_l) :: mess
    character(len=*), parameter :: rname='OLDLOAD>MAIN'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    if (prog%dohead) then
       call cubego_oldload_main_head(user,prog,error)
    else
       call cubego_oldload_main_hgdf(prog,error)
    endif
    if (error) return
    call prog%cube%set_uservar(prog%var%name,error)
    if (error) return
    prog%used = .true.
    ! *** JP: Variable status and syntax kind still missing in this user feedback
    write(mess,'(a,i0,3a)')  &
      'Loaded ',prog%id,' into the ',trim(prog%var%name),' user variable'
    call cubego_message(seve%i,rname,mess)
  end subroutine cubego_oldload_main
  !
  subroutine cubego_oldload_write_name(prog,error)
    use cubetools_flag_types
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(oldload_prog_t), intent(inout) :: prog
    logical,           intent(inout) :: error
    !
    character(len=128) :: strflag
    integer(kind=4) :: lstrflag
    character(len=*), parameter :: rname='OLDLOAD>MAIN>HEAD'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call prog%cube%node%flag%repr(strflag=strflag,lstrflag=lstrflag,error=error)
    if (error) return
    write(prog%name,'(i0,2x,3a)') prog%id,trim(prog%cube%node%family),":",strflag(1:lstrflag)
  end subroutine cubego_oldload_write_name
  !
  subroutine cubego_oldload_main_head(user,prog,error)
    use cubetools_header_types
    use cubeadm_get
    !-------------------------------------------------------------------
    ! 
    !-------------------------------------------------------------------
    type(oldload_user_t), intent(in)    :: user
    type(oldload_prog_t), intent(inout) :: prog
    logical,           intent(inout) :: error
    !
    character(len=*), parameter :: rname='OLDLOAD>MAIN>HEAD'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    call cubeadm_get_header(comm%cube,user%incube,prog%cube,error,access=prog%access%code)
    if (error) return
    call cubego_oldload_write_name(prog,error)
    if (error) return
    call cubetools_header_sicdef(prog%var%name,prog%cube%head,prog%var%readonly,error)
    if (error) return
  end subroutine cubego_oldload_main_head
  !
  subroutine cubego_oldload_main_hgdf(prog,error)
    use gkernel_interfaces
    use cubeadm_get
    use cubeio_gdf
    !-------------------------------------------------------------------
    ! Backward compatible syntax, which oldloads and maps the historical
    ! GDF header and the data.
    !-------------------------------------------------------------------
    type(oldload_prog_t), intent(inout) :: prog
    logical,           intent(inout) :: error
    !
    character(len=*), parameter :: rname='OLDLOAD>MAIN>HGDF'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call cubeadm_get_cube(prog%id,code_access_imaset,code_read,prog%cube,error)
    if (error) return
    call cubego_oldload_write_name(prog,error)
    if (error) return
    ! NB: the header is forced-exported to HGDF to resync cube_header_t
    ! components to HGDF (e.g. extrema values). This uses with some private/internal
    ! libcubeio API. This is just a poor man solution for the backward compatibility.
    call cubeio_create_hgdf(prog%cube,prog%cube%tuple%current%desc,  &
      code_cube_imaset,prog%cube%tuple%current%file%hgdf,error)
    if (error) return
    ! NB: the data%r4 array below is not intended to be used out of the
    ! libcubeio. This is just a poor man solution for the backward
    ! compatibility.
    if (prog%cube%tuple%current%file%hgdf%gil%ndim.eq.1) then
      call sic_mapgildas(prog%var%name,prog%cube%tuple%current%file%hgdf,error,  &
        prog%cube%tuple%current%memo%r4(:,1,1))
    elseif (prog%cube%tuple%current%file%hgdf%gil%ndim.eq.2) then
      call sic_mapgildas(prog%var%name,prog%cube%tuple%current%file%hgdf,error,  &
        prog%cube%tuple%current%memo%r4(:,:,1))
    else
      call sic_mapgildas(prog%var%name,prog%cube%tuple%current%file%hgdf,error,  &
        prog%cube%tuple%current%memo%r4(:,:,:))
    endif
    if (error) return
    call sic_def_charn(trim(prog%var%name)//'%name',prog%name,0,0,.true.,error)
    if (error) return
  end subroutine cubego_oldload_main_hgdf
  !
  subroutine cubego_oldload_getcube_number(dovar,varname,number,error) 
    !-------------------------------------------------------------------
    ! Goes through the list of loaded cubes and returns the correct
    ! index for it in the list
    ! -------------------------------------------------------------------
    logical,          intent(in)    :: dovar
    character(len=*), intent(in)    :: varname
    integer(kind=4),  intent(out)   :: number
    logical,          intent(inout) :: error
    !
    integer(kind=4) :: icub
    character(len=*), parameter :: rname='OLDLOAD>GETCUBE>NUMBER'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    if (dovar) then
       number = -1
       do icub=1,mprog
          if (.not.proglist(icub)%used) cycle
          if (trim(proglist(icub)%var%name).eq.trim(varname)) then
             number = icub
             exit
          endif
       enddo
       if (number.eq.-1) then
          call cubego_message(seve%e,rname,'No cube is loaded in a variable called '//trim(varname))
          error = .true.
          return
       endif
    else
       if (lastloaded.eq.0) then
          call cubego_message(seve%e,rname,'No cube has been loaded')
          error = .true.
          return
       endif
       number = lastloaded
    endif
  end subroutine cubego_oldload_getcube_number
  !
  subroutine cubego_oldload_getcube_pointer(icub,cube,error)
    use cube_types
    use cubeadm_get
    !-------------------------------------------------------------------
    ! Returns a pointer to the cube under ID icub
    ! *** JP Not clear to me why this is needed?
    ! -------------------------------------------------------------------
    integer(kind=4),       intent(in)    :: icub
    type(cube_t), pointer, intent(out)   :: cube
    logical,               intent(inout) :: error
    !
    character(len=*), parameter :: rname='OLDLOAD>GETCUBE>POINTER'
    !
    call cubego_message(goseve%trace,rname,'Welcome')
    !
    call cubeadm_access_header(proglist(icub)%cube,proglist(icub)%access%code,  &
      code_read,error)
    if (error) return
    cube => proglist(icub)%cube
  end subroutine cubego_oldload_getcube_pointer
end module cubego_oldload
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
