!
! Split ADJ_VALUE into ADJ_PROG (internal) and ADJ_USER (external)
! Suppress adj_prog accordingly (it will be ADJ_PROG)
!
! Make conversion when appropriate
!   - begin  USER --> PROG
!   - run  PROG --> USER
!   - finish  PROG --> USER
!
! Also correct error bars accordingly
!
subroutine all_from_internal
  use sic_interfaces, except_this=>all_from_internal
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer :: ivar
  do ivar=1,adj_n
     call from_internal(ivar,adj_prog(ivar),adj_user(ivar))
  enddo
end subroutine all_from_internal
!
subroutine from_internal(ivar,xint,xext)
  use sic_interfaces, except_this=>from_internal
  use sic_adjust
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer, intent(in) :: ivar       ! Variable number
  real(8), intent(in) :: xint       ! Internal value
  real(8), intent(out) :: xext      ! Outside value
  !
  if (adj_bound(ivar).eq.0) then
    ! Unbounded parameter
    xext = xint
  else if (adj_bound(ivar).eq.3) then
    ! Bounded parameter
    xext = adj_lower(ivar) + 0.5d0*(dsin(xint)+1d0)*(adj_upper(ivar)-adj_lower(ivar))
  else
    call sic_message(seve%e,'ADJUST','One bound unsupported')
  endif
end subroutine from_internal
!
subroutine all_to_adjust
  use sic_interfaces, except_this=>all_to_adjust
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer :: ivar
  !
  do ivar=1,adj_n
    call to_adjust(ivar,adj_prog(ivar),adj_user(ivar))
  enddo
end subroutine all_to_adjust
!
subroutine to_adjust(ivar,xint,xext)
  use sic_interfaces, except_this=>to_adjust
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer, intent(in) :: ivar       ! Variable number
  real(8), intent(out) :: xint      ! Internal value
  real(8), intent(inout) :: xext    ! Outside value
  ! Local
  real(kind=8) :: big=1.570796326794897d0
  real(kind=8) :: small=-1.570796326794897d0
  real(8) :: lower,upper,yy
  !
  if (adj_bound(ivar).eq.0) then
    xint = xext
  else if (adj_bound(ivar).eq.3) then
    !
    ! Others mean some limits
    lower = adj_lower(ivar)
    upper = adj_upper(ivar)
    if (xext.lt.lower) then
      xint = small
      xext = lower
    elseif  (xext.eq.lower) then
      xint = small
      return
    elseif  (xext.gt.upper) then
      xint = big
      xext = upper
    elseif  (xext.eq.upper) then
      xint = big
      return
    else
      yy=2.0d0*(xext-lower)/(upper-lower) - 1.0d0
      xint = datan(yy/dsqrt(1.d0- yy**2) )
      return
    endif
    ! Optional message
  endif
end subroutine to_adjust
!
subroutine run_adjust(line,comm,error)
  use sic_interfaces, except_this=>run_adjust
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  ! Support the ADJUST Language
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line   !
  character(len=*), intent(in)    :: comm   !
  logical,          intent(inout) :: error  !
  ! Local
  character(len=*), parameter :: rname='ADJUST'
  !
  call sic_message(seve%c,rname,line)
  !
  if (comm.eq.'ADJUST') then
    call fit_expression('ADJUST',line,error)
#if defined(GAG_USE_PYTHON)
  else if (comm.eq.'EMCEE') then
    call adjust_mcmc (comm,line,error)
  else if (comm.eq.'ESHOW') then
    call adjust_display (comm,line,error)
#endif
  else
    call sic_message(seve%e,rname,'Unsupported command')
    error = .true.
  endif
end subroutine run_adjust
!
!
subroutine init_adjust
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>init_adjust
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ public
  ! Initialize the ADJUST Language
  !---------------------------------------------------------------------
  ! Local
  integer(kind=address_length), save :: addr_exec
  integer, parameter :: mfit=11+3+9
  character(len=12) :: vfit(mfit)
  logical, save :: load_adjust=.true.
  !
  data vfit /' ADJUST','/START','/STEP','/WEIGHTS','/EPSILON','/METHOD',  &
    '/ITERATIONS','/QUIET','/BOUNDS','/ROOT_NAME','/PARAMETERS', &
    ' ESHOW', '/BURN', '/SPLIT', &
    ' EMCEE', '/BEGIN', '/BOUNDS', '/LENGTH', '/PARAMETERS', '/ROOT_NAME', &
    '/START', '/STEP',  '/WALKERS'/
  !
  if (load_adjust) then
    call sic_begin('ADJUST','GAG_HELP_ADJUST',mfit,vfit,  &
    '2.1    30-Sep-2016',run_adjust,err_vector)
    load_adjust = .false.
  endif
  !
  addr_exec = locwrd(exec_adjust)
  adj_exec = bytpnt(addr_exec,membyt)
end subroutine init_adjust
!
subroutine init_mfit
  use sic_dependencies_interfaces
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ private
  ! Initialize the MFIT driver routine address
  !---------------------------------------------------------------------
  external :: sic_libr
  ! Local
  integer(kind=address_length) :: addr_exec
  !
  addr_exec = locwrd(sic_libr)
  fun_exec = bytpnt(addr_exec,membyt)
end subroutine init_mfit
!
subroutine fit_expression (comm,line,error)
  use gildas_def
  use gbl_format
  use sic_adjust
  use gbl_message
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>fit_expression
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  !
  !     Support for commands
  !
  !     ADJUST Data Command [/START A1 B1 C1 ...] [/STEP A2 B2 C2 ...]
  !     [/EPSILON e] [/WEIGHTS w] [/METHOD Powell|Robust|Simplex|Slatec|Anneal]
  !     [/ITER Niter] [/QUIET]  /Bounds Par Low Up [...] /Parameters Va Vb Vc ...
  !     [/ROOT]
  !
  ! and
  !     MFIT Y=f(X) [/START A1,B1,C1,...] [/STEP A2,B2,C2,...]
  !     [/EPSILON e] [/WEIGHTS w] [/METHOD Powell|Robust|Simplex|Slatec|Anneal]
  !     [/ITER Niter] [/QUIET] /Bounds &Par Low Up
  !
  ! Allows fitting arbitrary data with arbitrary number of parameters
  !
  ! POWELL and SIMPLEX methods use the library routines from Press et al.,
  ! Numerical Recipes modified to allow easy error recovery.
  !
  ! SLATEC method uses the Slatec library, modified Levenberg-Marquardt
  ! routine DNLS1E, and also computes the error bars on the parameters.
  ! Much faster, but sensitive to starting values...
  !
  ! ROBUST uses a combination of SIMPLEX to get started and SLATEC to finish with
  !
  ! ANNEAL uses a simulated annealing. Very robust, but slow... It finishes
  ! with a SLATEC method to compute the errors.
  !---------------------------------------------------------------------
  character(len=*)                :: comm   !
  character(len=*)                :: line   !
  logical,          intent(inout) :: error  !
  ! Local
  character(len=*), parameter :: rname='ADJUST'
  !
  integer, parameter :: O_START = 1
  integer, parameter :: O_STEP = 2
  integer, parameter :: O_WEIGHT = 3
  integer, parameter :: O_EPS = 4
  integer, parameter :: O_METHOD = 5
  integer, parameter :: O_ITER = 6
  integer, parameter :: O_QUIET = 7
  integer, parameter :: O_BOUND = 8
  integer, parameter :: O_ROOT = 9
  integer, parameter :: O_PAR = 10
  !
  character(len=256) :: cstart,cstep,cweight
  character(len=formula_length) :: chain,formula
  character(len=commandline_length) :: fitexpr
  character(len=varname_length) :: avar,cvar
  character(len=64) :: work
  logical :: found
  integer :: lstart,lstep,lweight
  integer :: i,narg,ivar
  real(4) :: xstart(adj_m),xstep(adj_m),xdef(adj_m)
  real(8) :: epsilon
  type(sic_descriptor_t) :: ddesc,wdesc,default
  integer :: iter,nc,pdim
  !
  integer, parameter :: mtools=5
  character(len=12) :: argum,method,tools(mtools)
  integer :: la,nm,lk
  data tools /'ANNEALING','POWELL','SIMPLEX','SLATEC','ROBUST'/
  logical :: do_anneal
  logical :: do_simplex
  logical :: do_powell
  logical :: do_slatec
  logical :: do_errorbars
  logical :: is_general
  logical :: quiet
  !
  integer :: m1,m2,m3,lc,ier,ilun,j,k
  character(len=filename_length) :: fname
  character(len=message_length) :: mess
  !
  is_general = comm.ne.'MFIT'
  !
  ! Delete the (previous) generic structure name to be as clean as possible
  call sic_delvariable(adj_root(1:adj_lroot),.false.,error)
  error = .false.
  !
  ! Option /ROOT : Root name
  if (sic_present(O_ROOT,1)) then
    call sic_ch(line,O_ROOT,1,adj_root,adj_lroot,.true.,error)
    if (error) return
  else if (comm.eq.'MFIT') then
    adj_root = 'MFIT'
  endif
  !
  ! Delete the (new) generic structure name, in case it exists
  call sic_delvariable(adj_root(1:adj_lroot),.false.,error)
  error = .false.
  !
  if (is_general) then
    cur_exec = adj_exec
    pdim = sic_narg(O_PAR)
    if (pdim.le.0) then
      call sic_message(seve%e,rname,'No variable specified')
      error = .true.
      return
    endif
  else
    cur_exec = fun_exec
    if (sic_narg(0).eq.0) then
      call sic_message(seve%e,rname,'No Formula...')
      error = .true.
      return
    endif
  endif
  !
  ! Option /METHOD 
  if (sic_present(O_METHOD,0)) then
    call sic_ke (line,O_METHOD,1,argum,la, .true.,error)
    if (error) return
    call sic_ambigs('style',argum,method,nm,tools,mtools,error)
    if (error) return
  else
    method = 'ROBUST'
  endif
  do_anneal = .false.
  do_simplex = .false.
  do_powell = .false.
  do_slatec = .false.
  do_errorbars = .false.
  select case (method)
  case ('POWELL')
    iter = 200
    epsilon = 2d-6
    do_powell = .true.
    do_errorbars = .true.
  case ('SIMPLEX') 
    iter = 500
    epsilon = 2d-6
    do_simplex = .true.
  case  ('ANNEALING') 
    epsilon = 0.0
    iter = 2000
    do_anneal = .true.
    do_slatec = .true.
  case ('SLATEC') 
    do_slatec = .true.
    epsilon = 0.0
    do_errorbars = .true.
  case ('ROBUST') 
    do_simplex = .true.
    do_slatec = .true.
    do_errorbars = .true.
    epsilon = 0.
    iter = 200                 ! for robust, just to initialize
  case default  
    call sic_message(seve%e,rname,'No such method '//method)
    error = .true.
    return
  end select
  !
  ! Option /EPSILON  : Epsilon value. Note it must be after /METHOD
  ! to inherit the proper default
  call sic_r8 (line,O_EPS,1,epsilon,.false.,error)
  if (error) return
  !
  ! Option /ITERATIONS : Iterations
  call sic_i4 (line,O_ITER,1,iter,.false.,error)
  if (error) return
  !
  ! Option /QUIET 
  quiet = sic_present(O_QUIET,0)
  !
  call sic_defstructure(adj_root(1:adj_lroot),.true.,error)
  if (error) return
  !
  ! Main arguments; must be the last ones, because
  ! of use of M_VARCOP in one case
  if (is_general) then
    !
    default%type = fmt_r8
    default%readonly = .false.
    default%addr = 0
    default%ndim = 0
    default%dims(:) = 0
    default%size = 0
    default%status = 0
    call sic_desc (line,0,1,ddesc,default,.true.,error)
    if (error) return
    !
    call sic_ch(line,0,2,diff_expression,nc,.true.,error)
    if (error) return
  else
    !
    ! Non standard, but to remain compatible with MFIT
    m1=sic_narg(0)
    m2=sic_start(0,1)
    m3=sic_end(0,m1)
    chain = line(m2:m3)
    ! Here the formula is without blanks.
    lc = m3-m2+1
    call sic_black(chain,lc)
    !
    ! Look if it might be a filename:
    found = index (chain(1:lc),'=').ne.0
    !
    ! No "=" sign in formula: this might be a file. Default extension is .grf
    ! (like GRemlin Fit, GReg Fit, GRaphic Fit) instead of simply .fit to avoid
    ! possible collisions with MIDAS *.FIT files.
    !
    if (.not. found) then
      error = .true.
      call sic_parse_file (chain,' ','.grf',fname)
      ier = sic_getlun(ilun)
      open(ilun,file=fname,form='FORMATTED',status='OLD',iostat=ier)
      if (ier.ne.0) then
        call sic_frelun(ilun)
        call putios('E-ADJUST,  ',ier)
        error = .true.
        return
      endif
      !
      k = 1
      formula = ' '
      !
      ! Formula file reading loop:
      do
        read(ilun,'(A)',iostat=ier) chain
        if (ier.ne.0)  exit
        !
        ! Overread comment lines
        if (chain(1:1).eq.'!')  cycle
        !
        do j = 1, len_trim(chain)
          if (chain(j:j) .ne. ' ') then
            formula(k:k) = chain(j:j)
            k = k+1
            if (k .gt. len(formula)) then
              call sic_message(seve%e,rname,'Formula too long')
              close(unit=ilun)
              call sic_frelun(ilun)
              return
            endif
          endif
        enddo
      enddo
      !
      close (unit=ilun)
      call sic_frelun(ilun)
    else
      ! Commandline formula:
      formula = chain
    endif
    call sic_upper (formula)
    error = .false.
    call get_formula(formula,fitexpr,ddesc,pdim,quiet,error)
    if (error) return
  endif
  !
  ! Option /PARAMETER : parameter names, must be parsed before /BOUND
  ! /START and /STEP options
  !
  if (is_general) then
    pdim = sic_narg(O_PAR)
    do i=1,pdim
      call sic_ke(line,O_PAR,i,work,nc,.true.,error)
      if (error) return
      if (.not.sic_varexist(work(1:nc))) then
        call sic_message(seve%e,rname,'Parameter'//work(1:nc)//' does not exist')
        error = .true.
        return
      endif
      adj_names(i) = work
    enddo
  else
    do i=1,pdim
      write(adj_names(i),'(A,A,I2.2,A)') adj_root(1:adj_lroot),'%PAR[',i,']'
    enddo
  endif
  !
  ! Option /BOUNDS : Allowed range for parameter values
  adj_bound = 0 ! Reset to Unbound
  narg = max(sic_narg(O_BOUND),0)  ! -1 if not present
  if (mod(narg,3).ne.0) then
    call sic_message(seve%e,rname,'/BOUND requires N times 3 arguments')
    error = .true.
    return
  endif
  do i=1,narg,3
    call sic_ke (line,O_BOUND,i,avar,lk,.false.,error)
    if (is_general) then
      ! Parameter names have been defined
      call sic_ambigs('/BOUNDS',avar,cvar,ivar,adj_names,pdim,error)
      if (error) return
    else
      ! Parameters are &A .. &N
      ivar = ichar(avar(2:2)) - ichar('A') +1
    endif
    call sic_ke (line,O_BOUND,i+1,argum,lk,.false.,error)
    if (argum.eq.'*') then
      call sic_message(seve%e,rname,'Free Lower bound not yet supported')
      error = .true.
      return
    else
      call sic_r8 (line,O_BOUND,i+1,adj_lower(ivar),.false.,error)
    endif
    call sic_ke (line,O_BOUND,i+2,argum,lk,.false.,error)
    if (argum.eq.'*') then
      call sic_message(seve%e,rname,'Free Upper bound not yet supported')
      error = .true.
      return
    else
      call sic_r8 (line,O_BOUND,i+2,adj_upper(ivar),.false.,error)
    endif
    adj_bound(ivar) = 3
    write (mess,*) 'Bound ',ivar,adj_lower(ivar),adj_upper(ivar)
    call sic_message(seve%i,rname,mess)
  enddo
  !
  ! Option /START: Starting values (again after everything, to have PDIM defined)
  narg = min(sic_narg(O_START),pdim)
  cstart = ' '
  call sic_ch (line,O_START,1,cstart,lstart,.false.,error)
  if (error) return
  xstart = 0.0
  !
  if (index(cstart,',').ne.0) then
    !
    ! This stupid code below is to support the old MFIT syntax
    call sic_upper(cstart)
    xdef = 1.0 ! 0.5*(adj_lower+adj_upper)
    call txt_array(cstart,pdim,xstart,xdef)
    ! The 'mess' string below may be too small if pdim (number of
    ! variables to be fitted) is large
    write (mess,*) 'XSTART ',trim(cstart),xstart(1:pdim)
    call sic_message(seve%d,rname,mess)
    !
    ! Set the variable to their starting values
    do i=1,pdim
      adj_user(i) = xstart(i)
      call sic_let_auto(adj_names(i),adj_user(i),error)
    enddo
  else
    !
    ! More generic and standard syntax - one argument per value.
    !
    ! Get the default
    if (is_general) then
      do i=1,pdim
        call sic_get_real(adj_names(i),xstart(i),error)
        error = .false.
      enddo
    else
      xstart = 1.0
    endif
    !
    ! Override by user specified values
    do i=1,narg
      call sic_r4 (line,O_START,i,xstart(i),.false.,error)
      if (error) return
      !
      ! Set the variable to its starting value ...
      adj_user(i) = xstart(i)
      if (is_general) then
        call sic_let_auto(adj_names(i),adj_user(i),error)
      endif
    enddo
  endif
  !
  ! Option O_STEP: Steps
  cstep = ' '
  narg = min(sic_narg(O_STEP),pdim) 
  call sic_ch (line,O_STEP,1,cstep,lstep,.false.,error)
  if (error) return
  xstep = 0.0
  if (index(cstep,',').ne.0) then
    call sic_upper(cstep)
    xdef = 0.1*xstart
    call txt_array(cstep(1:lstep),pdim,xstep,xdef)
    write (mess,*) "XSTEP",xstep(1:pdim)
    call sic_message(seve%d,rname,mess)
  else
    xstep = 0.25 * xstart
    where (xstep.eq.0) xstep = 0.25
    do i=1,narg
      call sic_r4 (line,O_STEP,i,xstep(i),.false.,error)
      if (error) return
    enddo
  endif
  !
  ! Option /WEIGHT: Weight. Put it last because of variable incarnation
  cweight = ' '
  call sic_ke (line,O_WEIGHT,1,cweight,lweight,.false.,error)
  if (error) return
  if (lweight.gt.0) then
    default%type = fmt_r8
    default%readonly = .false.
    default%addr = 0
    default%ndim = 0
    default%dims(:) = 0
    default%size = 0
    default%status = 0
    call sic_inca (line,O_WEIGHT,1,wdesc,default,.true.,error)
    if (error) return
  else
    wdesc%type = 0
    wdesc%readonly = .false.
    wdesc%addr = 0
    wdesc%ndim = 0
    wdesc%dims(:) = 0
    wdesc%size = 0
    wdesc%status = 0
  endif
  !
  ! Make the minimization
  error = .false.
  call minimize_all (pdim,ddesc,xstart,xstep,wdesc,epsilon,do_anneal,  &
  do_simplex,do_powell,do_slatec,do_errorbars,error,iter,quiet)
  !
  if (.not.error) then
    !
    ! Set the output variables or the residual
    if (is_general) then
      do i=1,adj_n
        call from_internal(i,adj_prog(i),adj_user(i))
        call sic_let_auto(adj_names(i),adj_user(i),error)
      enddo
    else
      call sic_libr(diff_expression,error)
      call sic_libr(fitexpr,error)
    endif
  endif
  !
  ! Cleanup incarnations
  call sic_volatile(wdesc)
end subroutine fit_expression
!
subroutine minimize_all (np,darray,xstart,xstep,weight,epsilon,do_anneal,  &
  do_simplex,do_powell,do_slatec,do_errorbars,error,iter,quiet)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_adjust
  use sic_types
  use sic_interfaces, except_this=>minimize_all
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! Adjust parameters in the least-square sense for a general problem.
  !
  ! Uses a set of minimization routines
  ! - Simplex
  ! - Gradient (Powell method)
  ! - Simulated annealing
  ! - Levenberg Marquardt (from SLATEC)
  ! and error bars through the Jacobian
  !---------------------------------------------------------------------
  integer(kind=4),        intent(in)    :: np            ! Number of parameters to be adjusted
  type(sic_descriptor_t), intent(in)    :: darray        ! Descriptor of Data array
! character(len=*)                      :: cstart        ! Starting values
! character(len=*)                      :: cstep         ! Increments to compute derivatives
  real(kind=4),           intent(in)    :: xstart(np)    ! Starting values
  real(kind=4),           intent(in)    :: xstep(np)     ! Increments to compute derivatives
  type(sic_descriptor_t), intent(in)    :: weight        ! Descriptor of Weight array
  real(kind=8),           intent(inout) :: epsilon       ! Precision to decided convergence
  logical,                intent(in)    :: do_anneal     !
  logical,                intent(in)    :: do_simplex    !
  logical,                intent(in)    :: do_powell     !
  logical,                intent(in)    :: do_slatec     !
  logical,                intent(inout) :: do_errorbars  !
  logical,                intent(inout) :: error         ! Error return flag
  integer(kind=4),        intent(in)    :: iter          !
  logical,                intent(in)    :: quiet         !
  ! Local
  integer :: i,j,ni,signum
  !
  real(8), allocatable :: fvec(:)
  integer(kind=address_length) :: ip
  integer :: memory(1)
  real(8), allocatable :: wa(:)
  integer, allocatable :: iw(:)
  real(8), allocatable :: wa1(:),wa2(:),wa3(:),wa4(:),r(:,:)
  integer :: ier
  integer :: nprint,info,lwa,iopt
  real(8) :: chi2,tmp,guess_i
  !
  ! Simulated Annealing
  real(8) :: lbounds(adj_m),ubounds(adj_m),step(adj_m),guess(adj_m),saved(adj_m)
  real(8), allocatable :: fstar(:),xp(:)
  real(8) :: temp_factor,eps,temperature,fopt
  integer :: ncycles,niter,neps,iseed1,iseed2,iprint,nacc,nfcnev,nobds,maxevl
  integer, allocatable :: nacp(:)
  !
  ! Powell and Simplex
  !  real pstart(np), e_v(np,np), y(np), point(np)
  real, allocatable :: pstart(:),e_v(:,:),y(:),point(:)
  real fret,p(adj_m+1,adj_m),epsi
  !
  ! Errors with bounds
  real(8) :: dx,al,bl,du1,du2
  !
  character(len=filename_length) :: mess
  character(len=6) :: rname = 'ADJUST'
  !
  write (mess,*) "START ",xstart
  call sic_message(seve%d,rname,mess)
  write (mess,*) "STEP ",xstep
  call sic_message(seve%d,rname,mess)
  !
  call xsetf(0)
  !
  adj_ncall = 0
  press_pdim = np
  !
  ! Error detection:
  call sic_def_logi (adj_root(1:adj_lroot)//'%STATUS',press_error,.false.,error)
  press_error = .false.
  !
  ! Make a "local" copy to hold the "difference" array.
  ! Note that SIC does not care about non-conformant array provided they have
  ! the same size, so do it simply...
  ndata = desc_nelem(darray)
  if (allocated(dvec)) deallocate(dvec)
  allocate(dvec(ndata),stat=ier)
  ip = gag_pointer(darray%addr,memory)
  call r8tor8(memory(ip),dvec,ndata)
  !
  ! Do the same for the weights
  if (weight%type.ne.0) then
    if (weight%size.ne.2*ndata) then
      call sic_message(seve%e,rname,'Weight array size mismatch')
      error = .true.
      return
    endif
    allocate(wvec(ndata),stat=ier)
    ip = gag_pointer(weight%addr,memory)
    call r8tor8(memory(ip),wvec,ndata)
    wvec = sqrt(wvec)
  else
    allocate(wvec(ndata),stat=ier)
    wvec = 1.d0
  endif
  !
  ! Create the Parameter variables
  call sic_def_inte(adj_root(1:adj_lroot)//'%N',adj_n,0,0,.false.,error)
  call sic_def_dble(adj_root(1:adj_lroot)//'%PAR',adj_user,1,np,.false.,error)
  call sic_def_charn(adj_root(1:adj_lroot)//'%NAME',adj_names,1,np,.false.,error)
  !
  adj_guess(1:np) = xstart
  adj_user = adj_guess
  adj_step(1:np) = xstep
  do i=1,np
    if (adj_bound(i).eq.0) then
      if (xstep(i).eq.0) then
        adj_step(i) = 0.1
      else
        adj_step(i) = xstep(i)
      endif
    else if (adj_bound(i).eq.3) then
      if (xstep(i).eq.0) then
        adj_step(i) = 0.5d0*(adj_upper(i) - adj_lower(i))
      else
        guess_i = adj_guess(i)
        call to_adjust(i,dx,guess_i)
        guess_i = adj_guess(i)+xstep(i)
        call to_adjust(i,al,guess_i)
        guess_i = adj_guess(i)-xstep(i)
        call to_adjust(i,bl,guess_i)
        adj_step(i) = 0.5d0 * (dabs(al-dx)+dabs(bl-dx))
      endif
    endif
  enddo
  write(mess,*) 'Adjust Steps ',adj_step(1:np)
  call sic_message(seve%d,rname,mess)
  adj_n = np
  !
  ! Make the minimization...
  allocate (fvec(ndata),stat=ier)
  if (ier.ne.0) then
    call sic_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  call sic_def_dble(adj_root(1:adj_lroot)//'%RES',dvec,1,ndata,.false.,error)
  call exec_subprogram (membyt(cur_exec),diff_expression,error)
  !
  ! Now minimize
  !
  if (do_simplex) then
    allocate(pstart(np),y(np+1),point(np),stat=ier)
    call all_to_adjust !! adj_prog(1:adj_n) = adj_user(1:adj_n)
    press_itmax = iter
    epsi = epsilon
    if (do_slatec.or.epsi.eq.0) epsi = 2e-6
    !
    ! Calculate the Simplex points:
    !
    do j = 1, np+1
      do i = 1, np
        signum = 1
        if (i .ge. j) signum = -1
        ! This does not work for Bounded values !!BOUND
        point(i) = adj_prog(i) + signum * adj_step(i)
      enddo
      y(j) = press_func (point)
      do i = 1, np
        p(j,i) = point(i)
      enddo
    enddo
    !
    ! Simplex Amoeba minimum detection (Numerical Recipes, Press et al.)
    !
    if (.not.quiet) then
      call sic_message(seve%i,rname,'Using method SIMPLEX')
    endif
    call press_amoeba(p,y,adj_m+1,adj_m,np,epsi,press_func,ni)
    do i = 1, np
      pstart(i) = p(np+1,i)
    enddo
    fret = y(np+1)
    adj_prog(1:np) = pstart(1:np)
    call all_from_internal
    deallocate(pstart,y,point,stat=ier)
  endif
  !
  if (do_powell) then
    call all_to_adjust !! adj_prog(1:adj_n) = adj_user(1:adj_n)
    allocate(pstart(np),e_v(np,np),stat=ier)
    press_itmax = 100
    epsi = epsilon
    if (do_slatec.or.epsi.eq.0) epsi = 2e-6
    !
    e_v = 0.0
    do i=1,np
      e_v(i,i) = adj_step(i)
      pstart(i) = adj_prog(i)
    enddo
    !
    ! Powell minimum detection (Numerical Recipes, Press et al.)
    !
    if (.not.quiet) then
      call sic_message(seve%i,rname,'Using method POWELL')
    endif
    call press_powell(pstart,e_v,np,np,epsi,ni,fret,press_func,press_f1dim)
    !
    adj_prog(1:np) = pstart(1:np)
    call all_from_internal
    deallocate(pstart,e_v,stat=ier)
  endif
  !
  if (do_anneal) then
    call all_to_adjust !! adj_prog(1:adj_n) = adj_user(1:adj_n)
    ! Need also to convert the Guesses
    do i=1,adj_n
      call to_adjust(i,guess(i),adj_guess(i))
    enddo
    neps = 4
    allocate (fstar(neps),xp(adj_n),nacp(adj_n))
    temp_factor = 0.85d0
    call sic_get_dble('ANNEAL%RT',temp_factor,error)
    eps = epsilon
    if (eps.eq.0d0) then
      eps  = 4.d0              ! A few sigma make sense
    endif
    ncycles = 20
    call sic_get_inte('ANNEAL%CYCLE',ncycles,error)
    niter = max(20,5*adj_n)
    call sic_get_inte('ANNEAL%NT',niter,error)
    step(1:adj_n) = 2.0
    iseed1 = 10000
    iseed2 = 20000
    lbounds = -1d30
    ubounds = 1d30
    temperature = 5.0
    call sic_get_dble('ANNEAL%T',temperature,error)
    iprint = 0                 ! 1,2,3
    if (quiet.or.do_slatec) iprint = -1
    maxevl = iter
    if (iter.eq.0) then
      maxevl = 5000
    endif
    call sic_get_inte('ANNEAL%MAX',maxevl,error)
    !!Print *,'Annealing ',eps,niter,temperature,' eps,niter,temperature'
    call simann (  &
       adj_n,       &  ! N - Number of variables in the function to be optimized. (INT)
       guess,       &  ! X - The starting values for the variables of the function to be optimized. (DP(N))
       .false.,     &  !    MAX - the function should be maximized or minimized.
       temp_factor, &  !    RT - The temperature reduction factor. 0.85 in practice
       eps,         &  !    EPS - Error tolerance for termination.
       ncycles,     &  !    NS - Number of cycles.
       niter,       &  !    NT - Number of iterations before temperature reduction
       neps,        &  !    NEPS - Number of final function values used to decide upon termination.
       maxevl,      &  !    MAXEVL - The maximum number of function call. If exceeded, IER = 1. (INT)
       lbounds,     &  !    LB - The lower bound for the allowable solution variables. (DP(N))
       ubounds,     &  !    UB - The upper bound for the allowable solution variables. (DP(N))
       step,        &  !    C - Vector that controls the step length adjustment. (DP(N))
       iprint,      &  !    IPRINT - controls printing inside SA. (INT) (0 nothing  - 3 too many)
       iseed1,      &  !    ISEED1 - The first seed   0 .LE. ISEED1 .LE. 31328. (INT)
       iseed2,      &  !    ISEED2 - The second seed  0 .LE. ISEED2 .LE. 30081. (INT)
       temperature, &  !   Annealing Temperature (initial and final)  (DP)
       adj_step,    &  !    VM - The step length vector.  (DP(N))
       adj_prog,    &  !    XOPT - The variables that optimize the function. (DP(N))
       fopt,        &  !    FOPT - The optimal value of the function. (DP)
       nacc,        &  !    NACC - The number of accepted function evaluations. (INT)
       nfcnev,      &  !    NFCNEV - The total number of function evaluations.
       nobds,       &  !    NOBDS - The total number of evaluations that would have been out of bounds.
       ier,         &  !    IER - The error return number. (INT) (0 - 3)
       fstar,       &  !    Work arrays (DP(NEPS)
       xp,          &  !    Work array DP(N)
       nacp,        &  !    Work array I(N)
       mini_siman)     !    FCN - Function to be optimized.
    deallocate (fstar,xp,nacp)
    call all_from_internal         !      adj_user = adj_prog
  endif
  !
  if (epsilon.eq.0d0) then
    epsilon  = max(0.7d0/ndata,1d-12)
  endif
  !
  if (do_slatec) then
    if (.not.quiet) then
      call sic_message(seve%i,rname,'Using method SLATEC')
    endif
    call all_to_adjust !! adj_prog(1:adj_n) = adj_user(1:adj_n)
    !
    lwa = adj_n*(ndata+5)+ndata
    allocate (wa(lwa),stat=ier)
    allocate (iw(ndata),stat=ier)
    !
    nprint = 2               ! 00               ! Just for debug
    if (quiet) nprint = 100000
    info = 0
    iopt = 2
    call dnls1e( &
       mini_dnls, &  ! Function to be minimized
       iopt,      &  ! 1=No, 2=Full Jacobian provided, 3=Single Derivative
       ndata,     &  ! Number of data points
       adj_n,     &  ! Number of variable fitted parameters
       adj_prog,  &  ! Values of variable fitted parameters
       fvec,      &  !
       epsilon,   &  ! Tolerance
       nprint,    &  ! Print control every NPRINT iterations (IFLAG = 0 in FCN)
       info,      &  ! Information on result quality
       iw,        &  ! integer work array of length NPAR
       wa,        &  !
       lwa )
     !
    if (info.eq.0) then
      write(mess,*) 'Improper input parameters, info= ',info
      call sic_message(seve%e,'DNLS1E',mess)
      error = .true.
    elseif (info.eq.6 .or. info.eq.7) then
      write(mess,*) 'TOL too small, info= ',info
      call sic_message(seve%e,'DNLS1E',mess)
      error = .true.
    elseif (info.eq.5) then
      write(mess,*) 'Not converging, info= ',info
      call sic_message(seve%e,'DNLS1E',mess)
      error = .true.
    elseif (info.eq.4) then
      write(mess,*) 'Singular Jacobian, info= ',info
      call sic_message(seve%e,'DNLS1E',mess)
      error = .true.
    elseif (info.eq.1 .or. info.eq.2 .or.info.eq.3) then
      if (.not.quiet) then
        write(mess,*) 'Algorithm reaches convergence, info= ',info
        call sic_message(seve%i,'DNLS1E',mess)
        if (info.eq.1 .or. info.eq.3) then
          write(mess,*) 'Relative error on CHI2 less than ',epsilon
          call sic_message(seve%i,'DNLS1E',mess)
        endif
        if (info.eq.2 .or. info.eq.3) then
          write(mess,*) 'Relative error on solution less than ',epsilon
          call sic_message(seve%i,'DNLS1E',mess)
        endif
      endif
      error = .false.
    elseif (info.eq.-1) then
      write(mess,*) 'Aborted by user, info= ',info
      call sic_message(seve%e,'DNLS1E',mess)
      error = .true.
    else
      write(mess,*) 'Unknown info code, info= ',info
      call sic_message(seve%e,'DNLS1E',mess)
      error = .true.
    endif
    if (error) then
      write (mess,*) 'Epsilon ',epsilon
      call sic_message(seve%i,'DNLS1E',mess)
      write (mess,*) 'Adj_n ',adj_n
      call sic_message(seve%i,'DNLS1E',mess)
      write (mess,*) 'Ndata ',ndata
      call sic_message(seve%i,'DNLS1E',mess)
      write (mess,*) 'Iopt ',iopt
      call sic_message(seve%i,'DNLS1E',mess)
    endif
    !
    deallocate (iw,wa)
    if (error) do_errorbars = .false.
    call all_from_internal         !      adj_user = adj_prog
  endif
  !
  ! Find errors: do we use the Bounds ?
  if (do_errorbars) then
    call all_to_adjust !! adj_prog(1:adj_n) = adj_user(1:adj_n)
    allocate(wa(ndata),r(ndata,adj_n),stat=ier)
    saved = adj_prog
    wa(:) = dvec
    !
    r = 0
    allocate(wa1(adj_n),wa2(adj_n),wa3(adj_n),wa4(ndata),stat=ier)
    !
    info = 0
    call dcov(     &
       mini_dnls,   &
       iopt,        &
       ndata,       &
       adj_n,       &
       adj_prog,    &
       fvec,        &
       r,           &
       ndata,       &
       info,        &     ! Result condition
       wa1,wa2,wa3, &
       wa4)
    !
    adj_prog = saved  ! DCOV disturbs the values...
    dvec(:) = wa      ! and the residuals
    call all_from_internal         !      adj_user = adj_prog
    error = .true.
    if (info.eq.0) then
      write(mess,*) 'Improper input parameters, info= ',info
      call sic_message(seve%e,'DCOV',mess)
    elseif (info.eq.2) then
      write(mess,*) 'Singular Jacobian, info= ',info
      call sic_message(seve%e,'DCOV',mess)
      error = .false.
    else
      error = .false.
      ! To be corrected if bounded
      do i=1,adj_n
        dx = sqrt(abs(r(i,i)))  !!BOUND
        if (adj_bound(i).eq.3) then
          al = adj_lower(i)
          bl = adj_upper(i) - al
          du1 = al + 0.5d0 *(sin(adj_prog(i)+dx) +1.0d0) * bl - adj_user(i)
          du2 = al + 0.5d0 *(sin(adj_prog(i)-dx) +1.0d0) * bl - adj_user(i)
          if (dx .gt. 1.0d0)  du1 = bl
          dx = 0.5d0 * (abs(du1) + abs(du2))
        endif
        adj_errors(i) = dx
      enddo
    endif
    deallocate (wa,r,wa1,wa2,wa3,wa4)
  endif
  !
  if (error) then
    deallocate(fvec,wvec)
    return
  endif
  if (do_errorbars) then
    call sic_def_dble(adj_root(1:adj_lroot)//'%ERRORS',adj_errors,1,np,.false.,error)
  endif
  if (error.or.quiet) then
    deallocate(fvec,wvec)
    return
  endif
  !
  ! Compute Chi^2
  chi2 = 0
  do i=1,ndata
    tmp = dvec(i) * wvec(i)
    chi2 = chi2 + tmp*tmp
  enddo
  deallocate(fvec,wvec)
  !
  ! Print out Results
  write(mess,'(I6,A,1PG20.10,1X,1PG20.10)') adj_ncall,  &
  ' Function calls, Chi2: ',chi2,sqrt(chi2/ndata)
  call sic_message(seve%i,rname,mess)
  if (do_errorbars) then
    call sic_message(seve%i,rname,'Parameters and Errors:')
    do i=1,adj_n
      write(mess,*) trim(adj_names(i)),adj_user(i),adj_errors(i)
      call sic_message(seve%i,rname,mess)
    enddo
  else
    call sic_message(seve%i,rname,'Parameters')
    do i=1,adj_n
      write(mess,*) trim(adj_names(i)),adj_user(i)
      call sic_message(seve%i,rname,mess)
    enddo
  endif
  call sic_message(seve%i,rname,'Residuals in '//adj_root(1:adj_lroot)//'%RES')
  !
end subroutine minimize_all
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine mini_dnls(iflag,mdat,npar,x,fvec,fjac,ldfjac)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>mini_dnls
  use sic_adjust
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  ! Driver routine for the Levenberq-Marquardt
  !---------------------------------------------------------------------
  integer, intent(inout)  :: iflag        ! Operation Flag
  integer, intent(in)  :: mdat            ! Number of data points
  integer, intent(in)  :: npar            ! Number of variable fitted parameters
  real(8), intent(in)  :: x(npar)         ! Variable fitted parameters
  real(8), intent(inout) :: fvec(mdat)    ! Difference between value and data
  integer, intent(in)  :: ldfjac          ! First dimension of fjac
  real(8), intent(out) :: fjac(ldfjac,*)  ! Jacobian
  ! Local
  real(8) :: chi2, y,newx
  real(8), allocatable :: svec(:)
  integer :: i,k,ier
  logical :: error
  character(len=message_length) :: mess
  !
  error = .false.
  if (iflag.eq.0) return  ! We want to be quiet here...
  !
  ! From x to association module
  do i=1,adj_n
    call from_internal(i,x(i),y)
    call sic_let_auto(adj_names(i),y,error)
  enddo
  !
  if (iflag.eq.0) then         ! Print current values
    chi2 = 0.
    do i=1,mdat
      y = fvec(i)
      chi2 = chi2 + y*y
    enddo
    write (mess,*) 'Val  ',(x(i),i=1,adj_n)
    call sic_message(seve%i,'MINI_DNLS',mess)
    write (mess,'(1x,A,F12.2)') 'Chi2 ',chi2
    call sic_message(seve%i,'MINI_DNLS',mess)
  elseif  (iflag.eq.1) then    ! Compute the difference vector (fvec)
    adj_ncall = adj_ncall+1
    call exec_subprogram (membyt(cur_exec),diff_expression,error)
    if (error) then
      iflag = -1
      return
    endif
    fvec = dvec*wvec
  elseif  (iflag.eq.2) then
    !
    ! fvec must *NOT* be altered here (See dnsl1e documentation).
    !
    call exec_subprogram (membyt(cur_exec),diff_expression,error)
    if (error) then
      iflag = -1
      return
    endif
    !
    allocate(svec(ndata),stat=ier)
    svec(:) = dvec
    !
    adj_ncall = adj_ncall+adj_n
    do i=1,adj_n
      newx = x(i) + adj_step(i)
      call from_internal(i,newx,y)
      call sic_let_auto(adj_names(i),y,error)
      call exec_subprogram (membyt(cur_exec),diff_expression,error)
      do k=1,ndata
         fjac(k,i) = (dvec(k)-svec(k))/adj_step(i) * wvec(k)
      enddo
      call from_internal(i,x(i),y)
      call sic_let_auto(adj_names(i),y,error)
    enddo
    deallocate (svec)
  else
    write(mess,*) 'Do not know IFLAG ',iflag
    call sic_message(seve%u,'MINI_DNLS',mess)
  endif
  if (sic_ctrlc()) iflag=-1
end subroutine mini_dnls
!
subroutine mini_siman(npar,x,value,ier)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>mini_siman
  use sic_adjust
  !---------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  ! Driver routine for the Simulated Annealing
  !---------------------------------------------------------------------
  integer, intent(in) :: npar          ! Number of parameters
  real(kind=8), intent(in) :: x(npar)  ! Parameter values
  real(kind=8), intent(out) :: value   ! Resulting Chi2
  integer, intent(inout) :: ier        ! Error code
  ! Local
  real(8) :: y
  integer :: i
  logical :: error
  !
  ! From x to association module
  error = .false.
  do i=1,adj_n
    call from_internal(i,x(i),y)   !!BOUND : not obvious, the method is different here
    call sic_let_auto(adj_names(i),y,error)
  enddo
  !
  adj_ncall = adj_ncall+1
  call exec_subprogram (membyt(cur_exec),diff_expression,error)
  value = 0.d0
  do i = 1,ndata
    y = dvec(i)*wvec(i)
    value = value + y*y
  enddo
  if (sic_ctrlc()) ier = -1
end subroutine mini_siman
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine exec_subprogram (passed_function,command,error)
  !---------------------------------------------------------------------
  ! @ no-interface (because of argument type mismatch)
  !---------------------------------------------------------------------
  external                        :: passed_function  !
  character(len=*)                :: command          !
  logical,          intent(inout) :: error            !
  !
  !! print *,command(1:len_trim(command))
  call passed_function(command,error)
  !! print *,'Error ',error
end subroutine exec_subprogram
!
subroutine get_formula(formula,fitexpr,darray,pdim,quiet,error)
  use gildas_def
  use sic_interfaces, except_this=>get_formula
  use sic_adjust
  use sic_types
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! Fit a given formula to a set of data points using the
  ! DNLS1E method form SLATEC (Modified Levenberg-Marquardt routine)
  !---------------------------------------------------------------------
  character(len=*) :: formula                ! Formula used for minimisation
  character(len=*) :: fitexpr                ! Formula used for minimisation
  type(sic_descriptor_t) :: darray           !
  integer :: pdim                            !
  logical :: quiet                           !
  logical :: error                           !
  ! Local
  character(len=*), parameter :: rname='ADJUST'
  integer, parameter :: mp=27,np=26
  character(len=formula_length) :: text,work
  character(len=32) :: cnum
  character(len=26), parameter :: alphab='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  integer :: i,k,l,lw,nr
  !
  character(len=formula_length) :: funtext
  !
  ! Edit the formula string: from y=f(x) to y-(f(x)) ,
  ! and replace the placeholder &A ...&Z by the mfit array:
  !
  l = len_trim(formula)
  !
  funtext = formula
  pdim = 0
  !
  do i = 1, np
    write (cnum,'(A,A,I2.2,A1)') adj_root(1:adj_lroot),'%PAR[', pdim+1, ']'
    call replace_string(funtext(1:l),'&'//alphab(i:i),cnum,work,l,2,adj_lroot+8,k)
    funtext = work
    l = len_trim(funtext)
    if (k .ne. 0) pdim = pdim+1
  enddo
  if (pdim.eq.0) then
    call sic_message(seve%e,rname,'No fit parameter (&A ... &Z) found in formula.')
    error = .true.
    return
  endif
  !
  k = index(funtext,'=')
  if (k.ne.0) then
    k = k+1
    if (.not.quiet) then
      call sic_message(seve%i,rname,'Formula is :')
      call sic_message(seve%i,rname,funtext(k:l))
    endif
  else
    call sic_message(seve%e,rname,'No = sign found in formula.')
    error = .true.
    return
  endif
  !
  math_expression = funtext(k:l)
  lw = l-k+1
  call sic_def_char(adj_root(1:adj_lroot)//'%MATH',math_expression(1:lw),.true.,error)
  !
  ! Error detection:
  press_error = .false.
  !
  ! Create a variable to hold the fit solution, and the text to execute
  ! the command to calculate it. Return the 'Y' variable descriptor, too
  !
  call create_fitvar (funtext(1:k-2),adj_root(1:adj_lroot)//'%FIT',darray,error)
  fitexpr = 'LET '//adj_root(1:adj_lroot)//'%FIT = ' // funtext(k:l)
  !
  ! Edit the formula into the Difference form.
  !
  call replace_string(funtext, '=', '-(', text, l,1,2,nr)
  if (nr .ne. 1) then
    call  sic_message(seve%e,rname,'Error in syntax.')
    error = .true.
    return
  endif
  diff_expression = 'LET '//adj_root(1:adj_lroot)//'%RES = '//text(1:l+1) // ')'
end subroutine get_formula
!
subroutine txt_array(chain,ndim,values,default)
  use sic_interfaces, except_this=>txt_array
  !---------------------------------------------------------------------
  ! @ private
  ! Read a real array from a comma separated text string.
  ! Return the default in case of error.
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: chain  ! Input chain (modified)
  integer, intent(in) :: ndim               ! Number of values
  real(4), intent(out) :: values(ndim)      ! Output values
  real(4), intent(in) :: default(ndim)      ! Default values
  ! Local
  integer :: lc
  integer :: i,k,n,j,l
  !
  lc = len_trim(chain)
  values = default
  !
  if (lc .gt. 0) then
    k = 0
    j = 1
    n = 1
    do i = 1, lc
      if (chain(i:i).eq.'"') chain(i:i) = ' '
      if (chain(i:i).eq.',') then
        l = i-j
        if (l.gt.0) values(n) = txt_real(chain(j:i-1), default(n))
        n = n + 1
        if (n.gt.ndim) return
        j = i + 1
      endif
    enddo
    l = lc-j
    if (l.ge.0) values(n) = txt_real(chain(j:lc), default(n))
  endif
end subroutine txt_array
!
function txt_real (text, default)
  !---------------------------------------------------------------------
  ! @ private
  ! Read a real variable from a text string. Return the default
  ! in case of error.
  !---------------------------------------------------------------------
  real :: txt_real                      !  Output value
  character(len=*), intent(in) :: text  !  Input string
  real(4), intent(in) :: default        !  Default value
  ! Local
  real(8) :: value
  integer :: ier, nt
  !
  nt=len_trim(text)
  !
  read (text(1:nt),*,iostat=ier) value
  if (ier.eq.0) then
    txt_real = value
  else
    txt_real = default
  endif
end function txt_real
!
subroutine create_fitvar (in,out,y_array,err)
  use sic_dependencies_interfaces
  use gildas_def
  use sic_interfaces, except_this=>create_fitvar
  use sic_types
  use gbl_format
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private
  ! Copy a SIC variable into R(8) array
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: in                 ! Input SIC variable name
  character(len=*), intent(in) :: out                ! Output DOUBLE variable
  type(sic_descriptor_t), intent(out) :: y_array     ! Output variable descriptor
  logical, intent(out) :: err                        ! Error flag
  ! Local
  character(len=*), parameter :: rname='MFIT'
  integer :: i,ier,ndata,memory(1)
  logical :: found
  type(sic_descriptor_t) :: d_array
  integer(kind=address_length) :: ip
  real(8), allocatable, save :: hvec(:)
  !
  err = .false.
  !
  ! Delete output variable, if it exists
  call sic_descriptor (out,d_array,found)
  if (found) then
    call sic_delvariable(out,.false.,err)    ! This is a Program request
    if (err) then
      call sic_message(seve%e,rname,'Protected target variable exists.')
      err = .true.
      return
    endif
  endif
  !
  found = .true.
  call sic_materialize(in,y_array,found)   ! Checked, allow transposition
  if (.not. found) then
    call sic_message(seve%e,rname,'Input Variable does not exist.')
    err = .true.
    return
  endif
  d_array = y_array
  d_array%readonly = .false.
  !
  ! Make a double-precision copy to hold the array. Do not forget to
  ! free the sic_materialization before leaving (see below).
  ! Note that SIC does not care about non-conformant array provided they have
  ! the same size, so do it simply...
  ndata = desc_nelem(d_array)
  if (allocated(hvec)) deallocate(hvec)
  allocate(hvec(ndata),stat=ier)
  !
  ! Get data type:
  ip = gag_pointer(d_array%addr,memory)
  if (d_array%type.eq.fmt_r4) then
    call r4tor8(memory(ip),hvec,ndata)
  else if (d_array%type.eq.fmt_r8) then
    call r8tor8(memory(ip),hvec,ndata)
  else
    call sic_message(seve%e,rname,'Variable type invalid in this context')
    err = .true.
  endif
  if (err) return
  !
  call sic_volatile(y_array)  ! Free the materialization (if relevant) now that
                              ! we have a copy
  !
  ! Now define variable
  call sic_def_dble(out,hvec,1,ndata,.false.,err)
  ! Now reset Y_ARRAY
  call sic_descriptor (out,y_array,found)
end subroutine create_fitvar
!
subroutine m_varcop (in,out,out_array,global,err)
  use gildas_def
  use gbl_format
  use gbl_message
  use sic_interfaces, except_this=>m_varcop
  use sic_types
  !---------------------------------------------------------------------
  ! @ private
  ! Create a copy of a SIC variable
  !---------------------------------------------------------------------
  character(len=*) :: in                        ! Input variable name
  character(len=*) :: out                       ! Output variable name
  type(sic_descriptor_t) :: out_array           ! Output variable descriptor
  logical :: global                             ! Global status
  logical :: err                                ! Error flag
  ! Local
  character(len=*), parameter :: rname='MFIT'
  character(len=80) :: text
  character(len=6) :: wort
  integer :: ibyte,k
  logical :: found
  type(sic_descriptor_t) :: d_array
  !
  err = .false.
  !
  found = .true.
  call sic_materialize(in,d_array,found)   ! Checked, allow transposition
  if (.not. found) then
    call sic_message(seve%e,rname,'Variable to be copied does not exist.')
    err = .true.
    return
  endif
  d_array%readonly = .false.
  call sic_volatile(d_array)  ! Free descriptor
  !
  found = .true.
  call sic_descriptor (out,out_array,found)
  if (found) then
    call sic_delvariable(out,.false.,err)    ! This is a Program request
    if (err) then
      call sic_message(seve%e,rname,'Protected target variable exists.')
      return
    endif
  endif
  !
  ! Get data type:
  !
  if (d_array%type.gt.0) then
    write (wort,'(I6.6)') d_array%type
    text = 'DEFINE CHARACTER '//trim(out)//'*'//wort
    ibyte = 1
  else
    ibyte = 4
    if (d_array%type.eq.fmt_l )  text = 'DEFINE LOGICAL ' // out
    if (d_array%type.eq.fmt_i4)  text = 'DEFINE INTEGER ' // out
    if (d_array%type.eq.fmt_r4)  text = 'DEFINE REAL ' // out
    if (d_array%type.eq.fmt_r8) then
      text = 'DEFINE DOUBLE ' // out
      ibyte = 8
    endif
  endif
  !
  ! Get dimensions, and create the variables:
  !
  k = len_trim(text)+1
  if (global) then
    text(k:) = ' /GLOBAL /LIKE '//in
  else
    text(k:) = ' /LIKE '//in
  endif
  call sic_libr (text,err)
  if (err) return
  !
  ! Initialize it
  text = 'LET '//trim(out)//' = '//in
  call sic_libr (text,err)
  found = .true.
  call sic_descriptor (out,out_array,found)    ! Checked
end subroutine m_varcop
!
subroutine sic_libr(buffer,error)
  use sic_dependencies_interfaces
  use sic_interfaces, except_this=>sic_libr
  use gbl_message
  !---------------------------------------------------------------------
  ! @ public
  !   Execute a restricted set of SIC commands in "library" mode
  !   No commands with level change allowed here
  !---------------------------------------------------------------------
  character(len=*)                :: buffer  ! Command line
  logical,          intent(inout) :: error   ! Error flag
  ! Local
  character(len=commandline_length) :: line
  character(len=16) :: comm
  character(len=1), parameter :: backslash=char(92)
  integer :: nline
  !
  line = 'SIC'//backslash//buffer
  nline = len(line)
  call sic_blanc(line,nline)
  call sic_find(comm,line,nline,error)
  if (error)  return
  !
  if (comm.eq.'DEFINE') then
    call sic_define (line,nline,error)
  elseif (comm.eq.'LET') then
    call let_variable (line,nline,error)
  elseif (comm.eq.'EXAMINE') then
    call examine_variable(line,error)
  elseif (comm.eq.'COMPUTE') then
    call sic_compute (line,nline,error)
  else
    call sic_message(seve%e,'SIC',  &
       'Command '''//trim(comm)//''' not supported in this context')
    error = .true.
  endif
end subroutine sic_libr
!
subroutine replace_string (in,old,new,out,l1,l2,l3,nr)
  use sic_interfaces, except_this=>replace_string
  !---------------------------------------------------------------------
  ! @ private
  ! Replace occurrence of string OLD in IN by NEW and store the new string in
  ! OUT. String lengths for the input strings have to be provided.
  ! Number of replacements is returned in integer NR.
  !---------------------------------------------------------------------
  character(len=*) :: in            !
  character(len=*) :: old           !
  character(len=*) :: new           !
  character(len=*) :: out           !
  integer :: l1                     !
  integer :: l2                     !
  integer :: l3                     !
  integer :: nr                     !
  ! Local
  integer :: i,k
  !
  out = ' '
  nr  = 0
  if (l2 .gt. l1) then
    out(1:l1) = in(1:l1)
    return
  else
    k = 1
    i = 1
10  continue
    if (in(i:i+l2-1).eq.old(1:l2)) then
      out(k:k+l3-1) = new(1:l3)
      i  = i + l2
      k  = k + l3
      nr = nr + 1
    else
      out(k:k) = in(i:i)
      i = i + 1
      k = k + 1
    endif
    if (i .le. l1-l2+1) goto 10
    out(k:k+l2-2)=in(i:l1)
  endif
  !
end subroutine replace_string
