module uvfit_options
  integer, parameter :: o_cont=1      ! /CONT
  integer, parameter :: o_index=2     ! /INDEX
  integer, parameter :: o_unit=3      ! /OUTPUT   
  integer, parameter :: o_quiet=4     ! /QUIET
  integer, parameter :: o_range=5     ! /RANGE
  integer, parameter :: o_result=6    ! /RESULT
  integer, parameter :: o_save=7      ! /SAVE
  integer, parameter :: o_uvrange=8   ! /UVRANGE
  integer, parameter :: o_widget=9    ! /WIDGET
end module uvfit_options
!
subroutine uvfit_comm(line,error)
  use uvfit_options
  use iso_fortran_env
  use gkernel_interfaces
  use gbl_message
  use clean_default
  use clean_arrays
  use imager_interfaces, only : map_message
  !---------------------------------------------------------------------
  !*
  ! IMAGER -- Support for command UV_FIT   
  !   UV_FIT [Func1 ... FuncN] [/QUIET] 
  !     [/WIDGET Nfunc] [/SAVE File] [/RESULT]
  !     [/UVRANGE Min [Max]]
  !     [/CONTINUUM [Field] [/INDEX Sp] [/RANGE Min Max TYPE]]
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: line !! Command line
  logical, intent(inout) :: error         !! Error flag
  !
  ! Constants
  character(len=*), parameter :: rname='UV_FIT'
  integer, parameter :: mf=4 ! Could be up to 10
  !
  character(len=32) :: chain,comm
  type(gildas) :: htmp
  integer :: nf, nline, in, nc
  logical :: verbose, do_insert, was_cont, err, re_use
  character(len=filename_length) :: fich
  character(len=2) :: code
  character(len=8) :: chnew
  integer :: io
  !
  integer :: my_unit, ier
  character(len=filename_length), save :: ofich, ofile
  data ofile/'uv_fit.res'/  
  !
  ! /RESULT option
  if (sic_present(o_result,0)) then
    do io=1,9
      if (io.ne.o_result) then
        if (sic_present(io,0)) then
          call map_message(seve%e,rname,'/RESULT Option conflicts with any other one')
          error = .true.
          return
        endif
      endif
    enddo
    call sub_uvfit_results(line,error)
    return
  endif
  do_insert = (sic_lire().eq.0)
  if (sic_present(o_save,0)) then
    do io=1,9
      if (io.ne.o_save) then
        if (sic_present(io,0)) then
          call map_message(seve%e,rname,'/SAVE Option conflicts with any other one')
          error = .true.
          return
        endif
      endif
    enddo
    call sic_ch(line,o_save,1,fich,nc,.true.,error)
    if (error) return
    call exec_program('@ s_uvfit '//fich(1:nc))
    if (do_insert) call sic_insert_log(line)
    return
  endif
  !
  verbose = .not.sic_present(o_quiet,0)
  my_unit = output_unit
  !
  was_cont = sic_present(o_cont,0)
  if (was_cont) then
    if (sic_present(o_widget,0)) then
      call map_message(seve%e,rname,'Option /WIDGET is not compatible with /CONTINUUM')
      error = .true.
      return
    endif
    if (huv%gil%nchan.le.1) then
      ! Only one channel, use as is
      was_cont = .false.
      call map_message(seve%w,rname,'Only one channel already')
    else
      call gildas_null(htmp,type='UVT')
      call uv_buffer_finduv(code)
      !
      ! Use (and Create if needed) the "Continuum" UV data set
      call map_message(seve%w,rname,'/CONTINUUM option still under test ')
      re_use = .true.
      if (sic_present(o_range,0).or.sic_present(o_index,0).or.(sic_narg(o_cont).ne.0)) re_use=.false.
      call switch_uvfit_cont(line,rname,re_use,code,htmp,error)
      if (error) return
    endif
  else
    if (sic_present(o_index,0).or.sic_present(o_range,0)) then
      call map_message(seve%e,rname,'Options /RANGE and /INDEX only valid with /CONTINUUM')
      error = .true.
      return
    endif
  endif
  !
  ! /OUTPUT [File]
  my_unit = output_unit  ! Default Fortran output
  if (sic_present(o_unit,0)) then
    my_unit = 1 !!TEST
    if (sic_present(o_unit,1)) then
      call sic_ch(line,o_unit,1,ofich,in,.true.,error)
      call sic_parse_file (ofich,' ','.res',ofile) 
      chnew = '  ' 
      call sic_ke(line,o_unit,2,chnew,in,.false.,error)
      if (chnew.eq.'NEW') then
        ier = sic_open(my_unit,ofile,chnew,.false.)
      else
        open(unit=my_unit,file=ofile,status='NEW',iostat=ier)
      endif
    else
      open(unit=my_unit,file=ofile,status='OLD',access='APPEND',iostat=ier)
    endif
    if (ier.ne.0) then
      call map_iostat(seve%e,rname,ier)
      error = .true.
      return
    endif
  endif
  !
  error =.false.
  do_insert = (sic_lire().eq.0)
  if (sic_present(o_widget,0)) then
    ! Create the Widget if option is mentionned
    in = index(line,'UV_FIT')+7
    chain = "@ x_uvfit "//line(in:)
    call sic_i4(line,o_widget,1,nf,.true.,error)
    if (error) return
    if (nf.lt.1 .or. nf.gt.mf) then
      write(chain,'(I0)') mf
      call map_message(seve%e,rname,'1 to '//trim(chain)//' functions possible')
      error = .true.
      return
    endif
    call exec_program(chain)
  else 
    if (sic_narg(0).ne.0) then
      nf = sic_narg(0)/8
      write(chain,'(A,I0)') "@ x_uvfit ",nf
      call exec_program(chain)
      comm = 'UV_FIT'
      nline = len_trim(line)
      call sic_analyse(comm,line,nline,error)
    endif
    huv%r2d => duv
    call uvfit_sub(line,huv,verbose,my_unit,error)
  endif
  !
  if (my_unit.ne.output_unit) close(my_unit)
  !
  if (was_cont) then
    ! Reset HUV buffer
    call uv_buffer_resetuv(code)
    call gdf_copy_header(htmp,huv,err)
  endif
  !
  if (error) return
  last_resid = 'UV_FIT'
  if (do_insert) call sic_insert_log(line)
end subroutine uvfit_comm
!
subroutine switch_uvfit_cont(line,comm,reuse,code,htmp,error)
  use uvfit_options
  use gildas_def
  use clean_default
  use clean_arrays
  use gbl_message
  use gkernel_interfaces
  use imager_interfaces, except_this => switch_uvfit_cont
  !---------------------------------------------------------------------
  ! @ private
  !*
  ! IMAGER -- Support for command UV_FIT /CONTINUUM
  !
  ! Temporarily point towards the "continuum" UV data
  !!
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: line   !! Command line
  character(len=*), intent(in)    :: comm   !! Command name
  character(len=2), intent(inout) :: code   !! UV buffer code
  type(gildas), intent(out) :: htmp         !! Re-usable Header
  logical, intent(in) :: reuse              !! Re-Use existing data
  logical, intent(inout) :: error
  !
  ! Local ---
  integer :: channels(3)
  integer :: ier
  real :: ofield(2), cfield
  !
  ! Code ----
  if (huv%loca%size.eq.0) then
    call map_message(seve%e,comm,'No UV_DATA available')
    error = .true.
    return
  endif
  call gildas_null(htmp,type='UVT')
  call uv_buffer_finduv(code)           ! Get next UV buffer code
  call gdf_copy_header(huv,htmp,error)
  !
  ! Select the data set. Can be UV_DATA, UV_MODEL, or UV_RESIDUAL
  ! We may have an issue about data sorting here,
  ! as well as Weight re-computation
  call uvdata_select(comm,error)
  if (error) return
  !
  if (reuse.and.huvc%loca%size.ne.0) then
    call map_message(seve%w,comm,'Re-using available Continuum UV data',3)
  else
    if (huvc%loca%size.eq.0) then
      call map_message(seve%w,comm,'Computing Continuum UV data',3)
    else if (.not.reuse) then
      call map_message(seve%w,comm,'Re-Computing modified Continuum UV data',3)
    endif
    !
    ! Use default_map to specify the Field of view
    ofield = default_map%field
    if (sic_present(o_cont,1)) then  ! Overide default value by /CONT Field
      call sic_r4(line,o_cont,1,cfield,.false.,error)
      if (error) return
      default_map%field = cfield
    endif
    ! No /STEP option...
    call sub_uvcont_header(line,error,huvc,channels,-1,o_index,o_range)
    default_map%field = ofield ! Restore previous value
    if (error) return
    !
    if (allocated(duvc)) deallocate(duvc)
    allocate(duvc(huvc%gil%dim(1),huvc%gil%dim(2)),stat=ier)
    huvc%loca%size = huvc%gil%dim(1)*huvc%gil%dim(2)
    huvc%r2d => duvc
    huv%r2d => duv
    call sub_uvcont_data(line,huvc,huv,channels,dchanflag,o_index,error)
    if (error) return
    !
    ! Weights must be recomputed
    do_weig = .true.
    call sic_delvariable ('UVCONT',.false.,error)
    call sic_mapgildas('UVCONT',huvc,error,duvc)
  endif
  !
  ! Point to this UV data set
  call gdf_copy_header(huvc,huv,error)
  duv => duvc
  !
end subroutine switch_uvfit_cont
!
subroutine uvfit_sub(line,huvl,verbose,my_unit,error)
  use uvfit_options
  use iso_fortran_env
  use gkernel_interfaces
  use gkernel_types
  use image_def
  use gbl_format
  use gbl_message
  use uvfit_data
  use clean_def
  use clean_arrays
  use imager_interfaces, only : map_message, primary_atten, load_data, outfit
  !---------------------------------------------------------------------
  ! @ private
  !*
  ! IMAGER -- Support for command UV_FIT 
  !
  !   The functions have been defined previously by uvfit_comm
  !!
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: line  !!
  type(gildas), intent(inout)  :: huvl  !! Specified UV header
  logical, intent(in) :: verbose        !! Printout more
  integer, intent(in) :: my_unit        !! Output unit number
  logical, intent(inout) :: error       !! Error flag
  !
  ! Globals and Constants
  external :: fitfcn    ! Unfortunately, this is a compulsory name.
  character(len=*), parameter :: Version='Version 2.7  30-Oct-2023 S.Guilloteau'
  character(len=*), parameter :: rname='UV_FIT'
  real(8), parameter :: pi = 3.14159265358979323846d0
  real(8), parameter :: clight = 299792458.d-6   ! in meter.mhz
  integer, parameter :: mfunc=11+3
  integer, parameter :: mstart=1000
  character(len=12) :: cfunc(mfunc) 
  data cfunc/'POINT','E_GAUSS','C_GAUSS','C_DISK','RING','EXPO',   &
     &    'POWER-2','POWER-3','E_DISK','U_RING','E_RING', &
     &    'SPERGEL','E_SPERGEL', 'E_EXPO'/
  character(len=8) :: ccpar(mpin,mfunc)
  data ccpar/'R.A.','DEC.','FLUX','    ','    ','    ',' ',   &
     &    'R.A.','Dec.','Flux','Major','Minor','Pos.Ang.',' ',   &
     &    'R.A.','Dec.','Flux','F.W.H.P.','    ','    ',' ',   &
     &    'R.A.','Dec.','Flux','Diam.','    ','    ',' ',   &
     &    'R.A.','Dec.','Flux','I.Diam.','O.Diam.','    ',' ',   &
     &    'R.A.','Dec.','Flux','F.W.H.P.','    ','    ',' ',   &
     &    'R.A.','Dec.','Flux','F.W.H.P.','    ','    ',' ',   &
     &    'R.A.','Dec.','Flux','F.W.H.P.','    ','    ',' ',   &
     &    'R.A.','Dec.','Flux','Major','Minor','Pos.Ang.',' ',   &
     &    'R.A.','Dec.','Flux','Radius','    ','    ',' ',   &
     &    'R.A.','Dec.','Flux','Outer','Inner','Pos.Ang.','Ratio', &
     &    'R.A.','Dec.','Flux','F.W.H.P.','nu','  ','   ',  &
     &    'R.A.','Dec.','Flux','Major','Minor','Pos.Ang.','nu', &
     &    'R.A.','Dec.','Flux','Major','Minor','Pos.Ang.','  '/
  integer :: mpfunc(mfunc), rafunc(mfunc)
  data mpfunc /3,6,4,4,5,4,4,4,6,4,7,5,7,6/
  data rafunc /0,-4,0,0,0,0,0,0,-4,0,7,0,-4,-4/
  !
  ! Local ---
  real(8), allocatable :: fvec(:), r(:,:), fjac(:,:)
  real(8), allocatable :: wa1(:), wa2(:), wa3(:), wa4(:)
  real(8) :: ftol,xtol,gtol,epsfcn,facto
  integer :: mode, nfev, njev, ldfjac, maxfev
  integer, allocatable :: ipvt(:)
  real(8), allocatable :: qtf(:), diag(:)
  !
  integer :: sever
  logical :: warning, report
  !
  real(8) :: freq
  real(4) :: v, incli, cincli, dincli
  real(8) :: xx, yy, xa, xd
  integer :: j, js, jsmin, ldr
  integer :: np2, nc
  integer :: n1, l, js1, if1, nvpar, npstart, kstart, ndata,  kc
  integer :: iii, k, i, ki, ic(2), nch, ncol
  integer :: iopt, nprint, info
  real :: uv_min, uv_max, rtmp, fact, vit
  !
  real :: par0(mpar), range(mpar)
  integer :: irat(mpar)
  real(8) :: parin(mpar,mstart), par2(mpar,mstart), parstep(mpar)
  real(8) :: parout(mpar,mstart), fsumsq, cj(mpar), preerr(mpar)
  real(8) :: fsumin, epar(mpar), rms, tol, denorm, factor, fluxfactor
  integer :: nstartf(mf,mfunc)
  real :: parf(mf,mfunc), rangef(mf,mfunc)
  character(len=8) :: fluxunit
  character(len=12) :: cf, ccf
  character(len=20) :: ch, errmess
  character(len=20) :: cpar(mpar)
  character(len=80) :: resu, chpar, chain, chincli
  character(len=15) :: chpos1
  character(len=15) :: chpos2
  integer :: ier, nvs
  type(projection_t) :: phase_proj, point_proj
  ! Primary beam correction
  integer :: nr,ir
  real(8), allocatable :: profile(:,:)
  real(8) :: rmax, rdist, xp, yp
  real :: bsize, atten
  !
  ! Code ----
  ncall = 0
  call xsetf(0)
  call sic_get_inte('UVF%NF',nf,error)
  do j=1,nf
    write(ch,'(a,i0,a)') 'UVF%PAR',j,'%RESULTS'
    call sic_delvariable(ch,.false.,error)
    write(ch,'(a,i0,a)') 'UVF%PAR',j,'%ERRORS'
    call sic_delvariable(ch,.false.,error)
  enddo
  error = .false.
  warning = .false.
  !     Code:
  !
  jsmin = 1 
  js1 = 0
  !
  ! Decode the Initial parameter values from command line
  nf = sic_narg(0)
  if (nf.eq.0) then
    call sic_get_inte('UVF%NF',nf,error)
  else if (nf.ne.1) then
    ! NAME + 7 parameters for each source model
    do i=1,nf/8
      ! Function name
      write(ch,'(a,i0,a)') 'UVF%PAR',i,'%NAME'
      call sic_ke(line,0,8*i-7,cf,nch,.false.,error)
      if (.not.error) call sic_let_char(ch,cf,error)
      do j=1,mpin
        write(ch,'(a,i0,a,i0,a)') 'UVF%PAR',i,'%PAR[',j,']'
        k = j-7+8*i
        call sic_r4(line,0,k,parf(j,i),.false.,error)
        if (error) then
          Print *,'Argument ',k,' is incorrect'
          return
        endif
        call sic_let_real(ch,parf(j,i),error)
      enddo
    enddo
    nf = nf/8
  else
    ch = 'UVF%PAR1%NAME'
    call sic_ke(line,0,1,cf,nch,.false.,error)
    if (error) return
    if (.not.sic_varexist('UVF%PAR1%NAME')) then
      call map_message(seve%e,rname,'Function '//trim(ch)//' requires 7 more parameters')
      error = .true.
      return
    endif
    call sic_let_char(ch,cf,error)
  endif
  !
  ! The limit 4 could be increased if needed up to 10
  if (nf.lt.1 .or. nf.gt.mf) then
    write(ch,'(I0)') mf
    call map_message(seve%e,rname,'1 to '//trim(ch)//' functions possible')
    error = .true.
    return
  endif
  !
  !     2 Additional parameters to use specific uv range.
  uv_min = 0
  uv_max = 0
  if (sic_present(o_uvrange,0)) then
    call sic_r4(line,o_uvrange,1,uv_min,.true.,error)
    if (error) return
    call sic_r4(line,o_uvrange,2,uv_max,.false.,error)
  endif
  call map_message(seve%i,rname,version)
  if (uv_min.ne.0 .or. uv_max.ne.0) then
    if (uv_max.eq.0) then
      write(chain,*) 'UV data from ',uv_min,   &
       &      ' to Infty m.'    
    else
      write(chain,*) 'UV data from ',uv_min,   &
       &      ' to ',uv_max,' m.'
    endif
    call map_message(seve%i,rname,chain,1)
  endif
  !
  k = 0
  !
  ! Scan all function parameters
  do i=1, nf
    write(ch,'(a,i0,a)') 'UVF%PAR',i,'%NAME'
    call sic_get_char(ch,cf,nch,error)
    if (error) then
      chain = 'No such variable '//trim(ch)  
      call map_message(seve%e,rname,chain)
      return
    endif
    !
    call sic_upper(cf)
    call sic_ambigs('FIT',cf,ccf,ifunc(i),cfunc,mfunc,error)
    if (error) then
      call map_message(seve%e,rname,'Invalid function '//cf)
      return      
    endif
    !
    ! Parameters
    do j=1,mpin
      write(ch,'(a,i0,a,i0,a)') 'UVF%PAR',i,'%PAR[',j,']'
      call sic_get_real(ch,parf(j,i),error)
      if (error) then
        chain = 'Error reading variable '//trim(ch)  
        call map_message(seve%e,rname,chain)
        return
      endif
    enddo
    !
    ! Ranges
    do j=1,mpin
      write(ch,'(a,i0,a,i0,a)') 'UVF%PAR',i,'%RANGE[',j,']'
      call sic_get_real(ch,rangef(j,i),error)
      if (error) then
        chain = 'Error reading variable '//trim(ch)  
        call map_message(seve%e,rname,chain)
        return
      endif
    enddo
    !
    ! Number of starts
    !     start=-1 means fixed parameter.
    do j=1,mpin
      write(ch,'(a,i0,a,i0,a)') 'UVF%PAR',i,'%START[',j,']'
      call sic_get_inte(ch,nstartf(j,i),error)
      if (error) then
        chain = 'Error reading variable '//trim(ch)  
        call map_message(seve%e,rname,chain)
        return
      endif
    enddo
    !
    ! Put them in place
    npfunc(i) = mpfunc(ifunc(i))
    if (ifunc(i).eq.11) then 
      ! E_Ring
      if (parf(4,i).lt.parf(5,i)) then
        call map_message(seve%i,rname,'Swapping Inner and Outer')
        rtmp = parf(4,i)
        parf(4,i) = parf(5,i)
        parf(5,i) = rtmp
      endif
    endif
    do j=1, npfunc(i)
      k = k + 1
      par0(k) = parf(j,i)
      range(k) = rangef(j,i)
      nstart(k) = nstartf(j,i)
      cpar(k) = ccf//' '//ccpar(j,ifunc(i))
      irat(k) = rafunc(ifunc(i))  ! Inclination code
    enddo
    !
    !     Additional option used to subtract model functions.
    ! Should not be needed in this model, since UV_RESIDUAL
    ! can do the job afterwards
    write(ch,'(a,i0,a)') 'UVF%PAR',i,'%SUBTRACT'
    call sic_get_logi(ch,savef(i),error)
    if (error) then
      savef(i) = .false.
      error = .false.
    endif
    !
  enddo
  !
  npar = k
  resu = ' '
  !
  !     Create array of starting values
  npstart = 1
  do i=1, npar
    if (nstart(i).gt.1) then
      n1 = nstart(i)-1
      parstep(i) = range(i)/n1
      parin(i,1) = par0(i)-0.5*parstep(i)*n1
    else
      parin(i,1) = par0(i)
    endif
  enddo
  do i=1, npar
    if (nstart(i).gt.1) then
      kstart = npstart
      do j=1, nstart(i)-1
        if (k.gt.mstart) then
          write(chain,'(A,I0,A,I0)') 'Too many starting values. Max is ',mstart
          call map_message(seve%e,rname,chain)
          error = .true.
          return
        endif
        do k=kstart+1,kstart+npstart
          do l=1, npar
            parin(l,k)= parin(l,k-npstart)
          enddo
          parin(i,k) = parin(i,k-npstart)+parstep(i)
        enddo
        kstart = kstart+npstart
      enddo
      npstart = kstart
    endif
  enddo
  !
  !     Load input UV Table (HUV -- DUV)
  !
  if (huvl%loca%size.eq.0) then
    call map_message(seve%e,rname,'No UV data')
    error = .true.
    return
  endif
  !
  error = .true.
  !
  if (huvl%gil%nvisi.ge.1.1*2**30) then
    call map_message(seve%e,rname, & 
    & 'Does not support more than 2^30 visibilities')
    return
  endif
  ndata = huvl%gil%nvisi
  !
  ic = 0      ! Must be initialized
  ier = gdf_range(ic, huvl%gil%nchan)
  nc = huvl%gil%nchan
  !
  np2 = 2*ndata                ! max. data points
  ldfjac = max(np2,npar)       ! Jacobian 1st size 
  iopt = 2                     ! Supply full Jacobian
  !     iopt = 1  !! or only Function (test mode)
  tol = 1d-8
  nprint = 0
  maxfev = 100*(npar+1)
  ftol = tol
  xtol = tol
  gtol = 0.d0
  epsfcn = 0.D0
  mode = 1
  facto = 100.d0
  !
  ! For DNLS1 only
  ier = 0
  allocate (fjac(ldfjac,npar),ipvt(npar),diag(npar),qtf(npar),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'FVEC allocation error')
    error = .true.
    return
  endif
  !
  ! For DCOV and DNLS1 
  allocate (fvec(np2),r(np2,npar), &
    & wa1(npar),wa2(npar),wa3(npar),wa4(np2),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'DCOV allocation error')
    error = .true.
    return
  endif
  !
  !     Create table of fitted results huvfit - duvfit
  call gildas_null (huvfit, type = 'TABLE')
  call gdf_copy_header(huvl,huvfit,error)
  huvfit%gil%bval = 0 ! Trial
  huvfit%gil%eval = 0 ! Trial
  !
  huvfit%char%code(2) = 'uv-fit'
  huvfit%char%code(1) = 'freq'
  huvfit%gil%dim(1) = nc
  huvfit%gil%dim(2) = 4 + nf*(3+2*mpin)
  huvfit%gil%val(2) = 0.
  !
  if (allocated(duvfit)) then
    deallocate(duvfit)
    call sic_delvariable('UV_FIT',.false.,error)
    error = .false.
  endif
  !
  allocate (duvfit(huvfit%gil%dim(1),huvfit%gil%dim(2)),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Cannot allocate Fit table')
    error = .true.
    return
  endif
  duvfit = 0.0
  !
  !     Loop on channels
  nvs = huvl%gil%dim(1)
  !
  if (allocated(uvriw)) then
    if (ndata.ne.ubound(uvriw,2)) then
      deallocate(uvriw,stat=ier)
      allocate (uvriw(5,ndata),stat=ier)
    else
      ier = 0
    endif
  else
    allocate (uvriw(5,ndata),stat=ier)
  endif
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Cannot allocate UVRIW array')
    error = .true.
    return
  endif
  !
  report = .not.verbose
  report = report .and. ((ic(2)-ic(1)).gt.15)
  do kc = ic(1),ic(2)
    if (sic_ctrlc()) then
      call map_message(seve%w,rname,'Aborted by ^C')
      error = .true.
      return
    endif
    if (report) then
      if (kc.eq.ic(1)+(ic(2)-ic(1))/4) then
        call map_message(seve%i,rname,'25 % done ')
      else if (kc.eq.ic(1)+(ic(2)-ic(1))/2) then
        call map_message(seve%i,rname,'50 % done ')
      else if (kc.eq.ic(1)+(ic(2)-ic(1))*3/4) then
        call map_message(seve%i,rname,'75 % done ')
      endif
    endif
    !
    ! Load (U,V) in arcsec**-1, compute observing frequency for channel KC
    fact = gdf_uv_frequency(huvl,dble(kc)) / clight * pi/180.d0/3600d0
    call load_data(ndata,nvs,kc,fact,huv%r2d,npuvfit,uvriw,uv_min,uv_max)
    if (verbose) then
      if (npuvfit.eq.0) then
        write(chain,'(A,I0)') 'No data for channel ', kc
        call map_message(seve%w,rname,chain)
      else
        write(chain,'(I0,A,I0)') npuvfit,' data points for channel ', kc
        call map_message(seve%i,rname,chain)
      endif
    endif
    if (npuvfit.eq.0) cycle ! Ignore all flagged data
    !
    np2 = 2*npuvfit
    vit = huvl%gil%voff+(kc-huvl%gil%ref(1))*huvl%gil%vres
    !
    fsumin = 1d20
    fsumsq = 1d30
    !
    do js=1, npstart
      !     Get only variable parameters:
      nvpar = 0
      do i=1, npar
        if (nstart(i).ge.0) then
          nvpar = nvpar+1
          par2(nvpar,js)=parin(i,js)
        endif
        pars(i) = parin(i,js)
      enddo
      if (verbose) then
        if (nvpar.eq.0) then
          call map_message(seve%i,rname,'No free parameter, using input values')
          jsmin = 1
          exit
        endif
        write(*,'(a,5(1pg12.5))') 'I-UV_FIT, Starting from ',   &
       &        (par2(iii,js),iii=1, nvpar)
      endif
      !
! Only valid if LWA < 2^32
!      call dnls1e (fitfcn, iopt, np2, nvpar, par2(1,js),   &
!     &        fvec, tol, nprint, info,   &
!     &        ipvt, wa, lwa)
!
! Use the "not so easy to use" calling sequence, where the sizes are
! given separately.
      CALL DNLS1 (fitFCN, IOPT, np2, nvpar, par2(1,js), &
        & FVEC, FJAC, LDFJAC, FTOL, XTOL, GTOL, MAXFEV, EPSFCN, & 
        & DIAG, MODE, FACTO, NPRINT, INFO, &
        & NFEV, NJEV, IPVT, QTF, WA1, WA2, WA3, WA4)
      !
      !
      if (verbose) then
        sever = 0
        if (info.eq.0) then
          write(chain,'(A,I0)') 'Improper input parameters, info= ',   &
       &          info
          sever = seve%e
        elseif (info.eq.6 .or. info.eq.7) then
          write(chain,'(A,I0)') 'TOL too small, info= ',info
          sever = seve%e
        elseif (info.eq.5) then
          write(chain,'(A,I0)') 'Not converging, info= ',info
          sever = seve%e
        elseif (info.eq.4) then
          write(chain,'(A,I0)') 'FVEC orthog. to Jacob. col., info= ',   &
       &          info
          sever = seve%w
        endif
        if (sever.ne.0) then
          call map_message(sever,'DNLS1E',chain)
          warning = .true.
        endif
      else
        if (info.eq.0 .or. (info.ge.4.and.info.le.7)) warning = .true.
      endif
      fsumsq  = denorm(np2, fvec)
      !
      if (fsumsq.lt.fsumin) then
        fsumin = fsumsq
        jsmin = js
      endif
      js1 = js
    enddo
    !
    ! Fit if needed
    if (nvpar.gt.0) then
      if (jsmin.ne.js1) then
        nprint = 0
        !!Print *,'NP2 ',np2, 2_8**32
        CALL DNLS1 (fitFCN, IOPT, np2, nvpar, par2(1,js), &
          & FVEC, FJAC, LDFJAC, FTOL, XTOL, GTOL, MAXFEV, EPSFCN, & 
          & DIAG, MODE, FACTO, NPRINT, INFO, &
          & NFEV, NJEV, IPVT, QTF, WA1, WA2, WA3, WA4)
!        call dnls1e (fitfcn, iopt, np2, nvpar, par2(1,jsmin),   &
!       &        fvec, tol, nprint, info,   &
!       &        iw, wa, lwa)
        if (verbose) then
          sever = 0
          if (info.eq.0) then
            write(chain,'(A,I0)') 'Improper input parameters, info= ',   &
         &          info
            sever = seve%e
          elseif (info.eq.6 .or. info.eq.7) then
            write(chain,'(A,I0)') 'TOL too small, info= ',info
            sever = seve%e
          elseif (info.eq.5) then
            write(chain,'(A,I0)') 'Not converging, info= ',info
            sever = seve%e
          elseif (info.eq.4) then
            write(chain,'(A,I0)') 'FVEC orthog. to Jacob. col., info= ',   &
         &          info
            sever = seve%w
          endif
          if (sever.ne.0) then
            call map_message(sever,'DNLS1E',chain)
            warning = .true.
          endif
        else
          if (info.eq.0 .or. (info.ge.4.and.info.le.7)) warning = .true.
        endif
        fsumsq  = denorm(np2, fvec)
      endif
      ldr = np2
      call dcov (fitfcn, iopt, np2, nvpar, par2(1,jsmin),   &
       &      fvec, r, ldr, info,   &
       &      wa1, wa2, wa3, wa4)
      if (verbose) then
        if (info.eq.0) then
          write(chain,'(A,I0)') 'improper input parameters, info= ',info
          call map_message(seve%e,'DCOV',chain)
        elseif (info.eq.2) then
          write(chain,'(A,I0)') 'Jacobian singular, info= ',info
          call map_message(seve%w,'DCOV',chain)
          warning = .true.
        endif
      else
        if (info.eq.2) warning = .true.
      endif
      !
      !     extract the diagonal of r
      call diagonal(np2,nvpar,r,cj)
      rms = fsumsq*dsqrt(np2*1d0)
      if (verbose) then
        write(chain,'(a,f10.4,a)') ' r.m.s.= ',rms,' Jy.'
        call map_message(seve%i,rname,chain)
      endif
      if1 = info
    endif
    !
    ! Load results and Errors
    k = 0
    preerr(:) = sqrt(abs(cj(:)))
    do i=1, npar
      if (nstart(i).ge.0) then
        k = k+1
        parout(i,jsmin) = par2(k,jsmin)
        epar(i) = preerr(k)
      else
        parout(i,jsmin) = pars(i)
        epar(i) = 0.
      endif
    enddo
    !
    k = 1
    do j=1, nf
      call outpar(ifunc(j),npfunc(j),parout(k,jsmin),epar(k))
      k = k + npfunc(j)
    enddo
    k = 0
    ki = 0
    call gwcs_projec(huvl%gil%a0,huvl%gil%d0,huvl%gil%pang,huvl%gil%ptyp,phase_proj,error)
    call gwcs_projec(huvl%gil%ra,huvl%gil%dec,huvl%gil%pang,huvl%gil%ptyp,point_proj,error)
    !
    do j=1,nf      
      if (rafunc(ifunc(j)).gt.0)  then
        ! Bring the aspect ratio < 1 to have the proper size...
        if (parout(ki,jsmin).gt.1) then
          factor = parout(ki,jsmin) 
          call map_message(seve%i,rname,'Aspect ratio brought to < 1')
          parout(ki-3,jsmin) = parout(ki-3,jsmin)*factor
          parout(ki-2,jsmin) = parout(ki-2,jsmin)*factor
          epar(ki-3) = epar(ki-3)*factor
          epar(ki-2) = epar(ki-2)*factor 
          parout(ki-1,jsmin) = 90.+parout(ki-1,jsmin) ! PA of Major Axis         
          parout(ki,jsmin) = 1./factor
          epar(ki) = epar(ki)/factor**2
        endif
      endif
      !
    enddo
    !
    k = 0
    ki = 0
    if (verbose.or.my_unit.ne.output_unit) then
      !
      freq = gdf_uv_frequency(huvl,dble(kc))
      if (ic(2).gt.ic(1)) then
        v = (kc-huvl%gil%ref(1))*huvl%gil%vres + huvl%gil%voff
        write(chpar,'(a,F11.3,a,f8.2,a)') 'Frequency ',freq,& 
        & ' MHz, Velocity ',v,' km/s'
      else
        write(chpar,'(a,i8,a)') 'Frequency ',nint(freq),' MHz'
      endif
      write(my_unit,*) trim(chpar)
      !
      bsize = 0
      rmax = 0
      do j=1,nf
        do i=1, npfunc(j)
          ki = ki+1          
          xx = parout(ki+1,jsmin)
          yy = parout(ki+2,jsmin)
          rmax = max(xx**2+yy**2,rmax)
        enddo
      enddo
      rmax = sqrt(rmax)*pi/180D0/3600D0
      call primary_atten(bsize,huvl,freq,rmax,nr,profile,error)
      !
      ki = 0
      do j=1, nf
        cincli = 0.
        dincli = -1.0
        !
        ! Ra/Dec absolute coordinates (1st and 2nd parameters)
        xx = parout(ki+1,jsmin)*pi/180d0/3600d0
        yy = parout(ki+2,jsmin)*pi/180d0/3600d0
        call rel_to_abs(phase_proj,xx,yy,xa,xd,1)
        call rad2sexa(xa,24,chpos1)
        call rad2sexa(xd,360,chpos2)
        !
        ! Correct if Phase Center is not  Pointing center
        if (bsize.ne.0) then
          call abs_to_rel(point_proj,xa,xd,xp,yp,1)
          rdist = sqrt(xp**2+yp**2)
          if (nr.ne.0) then
            ! Interpolate from discrete beam profile if possible
            atten = 0
            do ir=2,nr
              if ((profile(ir,1).gt.rdist).or.(ir.eq.nr)) then
                atten  = (rdist-profile(ir-1,1))*profile(ir,2) + &
                  & (profile(ir,1)-rdist)*profile(ir-1,2)
                atten = atten/(profile(ir,1)-profile(ir-1,1))
                exit
              endif
            end do
          else
            ! Use simple Gaussian if not
            atten = exp(-(rdist/(bsize/2.0/sqrt(log(2.0))))**2)
          endif
        else
          atten = 1
        endif
        ! Flux in best units (3rd parameter)
        if (abs(parout(ki+3,jsmin)).ge.1.d0) then
          fluxfactor = 1.d0
          fluxunit = 'Jy'
        elseif (abs(parout(ki+3,jsmin)).ge.1.d-3) then
          fluxfactor = 1.d3
          fluxunit = 'milliJy'  ! or 'mJy' ?
        else
          fluxfactor = 1.d6
          fluxunit = 'microJy'  ! or 'uJy' ?
        endif
        do i=1, npfunc(j)
          ki = ki+1
          if (i.eq.3) then
            factor = fluxfactor
          else
            factor = 1.d0
          endif
          if (nstart(ki).ge.0) then
            k = k+1
!            epar(ki) = sqrt(abs(cj(k)))
            write(errmess,'(f0.5)',iostat=ier)  epar(ki)*factor ! Error can be larger than "999.99999"
            write(chpar,'(2a,f11.5,a,a,a)')  &
              cpar(ki), ' = ',parout(ki,jsmin)*factor,' (',adjustr(errmess(1:9)),')'
          else
!            epar(ki) = 0.
            write(chpar,'(2a,f11.5,a)')  &
              cpar(ki), ' = ', parout(ki,jsmin)*factor,' (  fixed  )'
          endif
          nch = len_trim(chpar)
          if (i.eq.1) then
            write(my_unit,*) chpar(1:nch)//'  '//chpos1
          elseif (i.eq.2) then
            write(my_unit,*) chpar(1:nch)//' '//chpos2
          elseif (i.eq.3) then
            write(my_unit,*) chpar(1:nch)//'  '//fluxunit
          else
            write(my_unit,*) chpar(1:nch)
          endif
          !
          ! Inclination if any
          if (abs(irat(ki)).eq.i)  then
            if (irat(ki).eq.-i) then
              cincli = parout(ki+1,jsmin)/parout(ki,jsmin)
              dincli = abs(epar(ki+1)/parout(ki+1,jsmin)) + &
                & abs(epar(ki)/parout(ki,jsmin))
            else if (irat(ki).eq.i) then
              cincli = parout(ki,jsmin)
              dincli = abs(epar(ki)/parout(ki,jsmin))
            endif
            incli = acos(cincli)*180/pi
            dincli = incli / sqrt(1.-cincli**2) * dincli
            write(chincli,'(A,F7.1,A,f5.1,A)') cpar(ki)(1:12)//' Incli   = ' & 
            & ,incli,'     (',dincli,') °'
          endif
          !
          ! Print out Primary beam corrected flux
          if ((i.eq.3).and.(atten.ne.1)) then
            write(errmess,'(f0.5)',iostat=ier)  epar(ki)*factor/atten ! Error can be larger than "999.99999"
            write(chpar,'(2a,f11.5,a,a,a)')  &
              cpar(ki), ' = ',parout(ki,jsmin)*factor/atten,' (',adjustr(errmess(1:9)),')'
            write(my_unit,*) chpar(1:nch)//'  '//fluxunit//' ! Primary beam corrected '
          endif
        enddo
        ! Print out Inclination if Elliptical model
        if (cincli.ne.0) write(my_unit,*) chincli
      enddo
    endif
    !
    ncol = huvfit%gil%dim(2)
    call outfit(nc,kc,ncol,duvfit,rms,vit,npar,parout(1,jsmin),epar)
    !
  enddo
  !
  ! Return results in UVF%PARi%RESULT and UVF%PARi%ERRORS if
  ! only one Channel
  if (nc.eq.1) then
    k = 0
    ki = 0
    do j=1,nf
      !
      do i=1, npfunc(j)
        ki = ki+1
        uvf_errors(i,j) = epar(ki)
        uvf_results(i,j) = parout(ki,jsmin)
      enddo
      !
      write(ch,'(a,i0,a)') 'UVF%PAR',j,'%RESULTS'
      if (sic_varexist(ch)) call sic_delvariable(ch,.false.,error)      
      call sic_def_real(ch,uvf_results(1,j),1,mpin,.true.,error)
      write(ch,'(a,i0,a)') 'UVF%PAR',j,'%ERRORS'
      if (sic_varexist(ch)) call sic_delvariable(ch,.false.,error)
      call sic_def_real(ch,uvf_errors(1,j),1,mpin,.true.,error)
    enddo
  endif
  !
  if (len_trim(resu).gt.0) then
    call sic_parsef(resu,huvfit%file,' ','.uvfit')
    call map_message(seve%i,rname,'Creating fit table '//   &
       &    trim(huvfit%file) )
    call gdf_write_image(huvfit,duvfit,error)
  endif
  if (warning) then
    call map_message(seve%w,rname,'Completed with possible errors',1)
  endif
  !
  call sic_mapgildas('UV_FIT',huvfit,error,duvfit)
end subroutine uvfit_sub
!
subroutine uvfit_residual_model(line,rname,iarg,error)
  use uvfit_options
  use clean_def
  use clean_default
  use clean_arrays
  use uvfit_data
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message, model_data
  !---------------------------------------------------------------------
  ! @ private
  !*
  ! IMAGER -- Support for command UV_RESIDUAL and MODEL   
  !   after a UV_FIT command operation
  !!
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: line    !! Command line
  character(len=*), intent(in) :: rname   !! Caller command
  integer, intent(in) :: iarg             !! Argument pointer
  logical, intent(inout) :: error         !! Error flag
  !!
  !
  ! Local ---
  type(gildas) :: huvl
  character(len=80) :: chain
  character(len=32) :: coper
  integer :: nvt, nvs, i, if, nc, ndata, ier, ic(2), narg, iv, jc
  logical :: subtract
  real, pointer :: duvres(:,:)
  !
  ! Code ----
  call gildas_null(huvl,type='UVT')
  call gdf_copy_header(huv,huvl,error)
  !
  subtract = rname.eq.'UV_RESIDUAL'
  if (subtract) then
    call map_message(seve%i,rname,'Subtracting UV_FIT model results')
  endif
  !
  error = .false.
  narg = sic_narg(0)
  if (narg.lt.iarg) then
    savef(1:nf) = .true.
  else
    savef(1:nf) = .false.
    do i=iarg,narg
      call sic_i4(line,0,i,if,.true.,error)
      if (error) return
      if (if.gt.0 .and. if.le.nf) then
        savef(if) = .true.
      else
        write(chain,'(A,I0,A,I0,A,I0)') 'Argument #',i,' (',if,') out of boud [0,',nf,']'
        call map_message(seve%e,rname,chain,1)
        error = .true.
      endif
    enddo
    if (.not.any(savef)) then
      call map_message(seve%w,rname,'Nothing to subtract',3)
      return
    endif
  endif
  !
  ! Use DUVF or DUVM as result array, depending on the
  ! triggering command (MODEL or UV_FIT)
  ic = [0,0]
  ier = gdf_range(ic, huvl%gil%nchan)    ! Channel range
  nc = huvfit%gil%dim(1)                 ! Number of fitted channels
  nvt = huvfit%gil%dim(2)                ! Number of fitted parameters
  ndata = huvl%gil%nvisi                 ! Number of visibilities
  nvs = huvl%gil%dim(1)                  ! Size of visibilities
  !
  ! For convenience, the header and data area are available
  ! in the clean_arrays module
  !
  if (subtract) then
    coper = 'Removing model with '
    call sic_delvariable('UV_RESIDUAL',.false.,error)
    ! Use DUVF  (Fit residuals)
    if (allocated(duvf)) deallocate(duvf)
    call gdf_copy_header(huvl,huvf,error)
    !
    allocate (duvf(huvf%gil%dim(1),huvf%gil%dim(2)),stat=ier)
    if (ier.ne.0) then
      call map_message(seve%e,rname,'UV Model allocation error')
      error = .true.
      return
    endif
    duvres => duvf
    duvf(:,:) = duv  ! Copy data 
    uv_resid_updated = .true. 
    call sic_mapgildas('UV_RESIDUAL',huvf,error,duvf)
  else
    coper = 'Adding model for'
    call sic_delvariable('UV_MODEL',.false.,error)
    ! Use DUVM  (Model values)
    if (allocated(duvm)) deallocate(duvm)
    call gdf_copy_header(huvl,huvm,error)
    !
    allocate (duvm(huvm%gil%dim(1),huvm%gil%dim(2)),stat=ier)
    if (ier.ne.0) then
      call map_message(seve%e,rname,'UV Model allocation error')
      error = .true.
      return
    endif
    duvres => duvm
    duvm(:,:) = duv  ! Copy data 
    ! Set visibilities to Zero for MODEL
    do iv=1,ndata
      do jc=ic(1),ic(2)
        duvres(5+3*jc:6+3*jc,iv) = 0.
      enddo
    enddo
    uv_model_updated = .true. 
    call sic_mapgildas('UV_MODEL',huvm,error,duvm)
  endif
  !
  ! Loop on functions for subtracting / creating model.
  ! This is memory inefficient, but multi-function fits are rare
  ! Will be optimized later if needed...
  do if = 1, nf
    if (savef(if)) then
      write (chain,'(a,a,i2.2,1X,I0,1X,I0)') trim(coper),' UVF%PAR',if,ndata,nc
      call map_message(seve%i,rname,chain)
      call model_data(huvl,ndata,nvs,nc,ic(1),ic(2),nvt,duvres,duvfit,if, &
      & subtract)
    endif
  enddo
  !
end subroutine uvfit_residual_model
!
subroutine  uvfit_model(ifunc,kfunc,uu,vv,x,y,dy)
  !---------------------------------------------------------------------
  !*
  ! IMAGER --  Support routine for UV_FIT
  !
  ! Compute a model function.
  !!
  !---------------------------------------------------------------------
  integer, intent(in) :: ifunc       !! Fuction type
  integer, intent(in) :: kfunc       !! Number of parameters
  real(8), intent(in) :: uu          !! U coordinate in arcsec^-1
  real(8), intent(in) :: vv          !! V coordinate in arcsec^-1
  real(8), intent(in) :: x(kfunc)    !! Parameters
  real(8), intent(inout) :: y(2)        !! Function (real, imag.)
  real(8), intent(inout) :: dy(2,kfunc) !! Partial derivatives.
  !
  ! Global
  real(8), external :: z_exp
  real(8), parameter :: pi = 3.14159265358979323846d0
  real(8), parameter :: dpi=2d0*pi
  real(8), parameter :: cst=3.5597073312469d0  ! pi**2/4d0/log(2d0)
  real(8), parameter :: deg=pi/180d0
  ! Spergel approximation
  real(kind=8),parameter :: acnu = 2.4009610601053772
  real(kind=8),parameter :: bcnu = -0.22810144250066436
  real(kind=8),parameter :: ccnu = -0.40371257831497309
  real(kind=8),parameter :: cte = 3*pi**2/log(2d0)**2
  !
  ! Local ---
  integer :: i
  real(8) :: st, ct, q1, q2, arg, carg, sarg, darg1, darg2
  real(8) :: a, da(7), b, ksi, q, j0, j1, aa, dfac4, dfac5
  real(8) :: dadksi
  real(8) :: dbesj0, dbesj1, dbesk0, dbesk1
  real(8) :: a1, a2, fac, k0, k1, d, daa
  real(8) :: ii, oo, fi, fo, ff, dgo_do, dgi_do, dgi_di, dgo_di, dout2
  real(8) :: flux,dg_dmaj,dg_dmin,dg_dpa
  real(8) :: dg_douter,dg_dinner,dg_dratio,dg_drota
  real(8) ::  major, minor
  real(kind=8) :: cnu, dg_dnu, dg_dr0, repeat, nu, uvdist2, drepeat
  real(kind=8) :: dg_dr1, dg_dr2, uvdist1, dg_dtheta, sintheta, costheta, dfac
  !
  ! Code ----
  !-----------------------------------------------------------------------
  !
  ! The fitted function is of the form:
  !     F = flux * f(x-x0,y-y0)
  ! corresponding to a visibility model:
  !     G = flux * exp(-2i*pi(u*x0+v*y0)) * g(u,v)
  ! where g is the Fourier transform of f.
  !
  ! The first three parameters 1, 2, 3, are x0, y0, and flux.
  !
  ! First compute A = g(u,v), and DA(k) = dA/dx_k for k=4, ...
  ! depending on model.
  !
  select case (ifunc)
  !
  case (1)  ! Point source
    ! 1- Point source
    ! model = flux * delta(x-x0,y-y0)
    ! g(u,v) = 1
    ! 3 pars (x0, y0, flux)
    a = 1d0
    !
  case (2) ! Gaussian
    ! 2- Gaussian (2-dim)
    !     model = flux*4*ln2/(pi*b1*b2) * exp (-4*ln2*((r1/b1)**2+(r2/b2)**2)
    !     g(u,v) = exp(-pi**2/4/ln2*(b1*u1+b2*u2)**2)
    !       where u1 = u*sin(theta)+v*cos(theta)
    !             u2 = u*cos(theta)-v*sin(theta)
    !     6 pars (x0, y0, flux, theta, b1, b2)
    !
    st = sin(deg*x(6))
    ct = cos(deg*x(6))
    q1 = uu*st+vv*ct
    q2 = uu*ct-vv*st
    a1 = -cst*q1**2
    a2 = -cst*q2**2
    a = z_exp(a1*x(4)**2+a2*x(5)**2)
    da(4) = 2*x(4)*a1*a
    da(5) = 2*x(5)*a2*a
    da(6) = -2d0*cst*q1*q2*(x(4)**2-x(5)**2)*deg*a
    !
  case(3)
    !
    ! 3- Gaussian (1-dim)
    !     model = flux*4*ln2/(pi*b**2) * exp (-4*ln2*(r/b)**2)
    !     g(u,v) = exp(- pi**2/4/ln(2)*(b*q)**2)
    !     where q**2 = u**2+v**2
    !     4 pars (x0, y0, flux, b)
    !
    q2 = uu**2+vv**2
    a1 = -cst*q2
    a = z_exp(a1*x(4)**2)
    da(4) = a1*x(4)*2d0*a
    !
  case (4) ! Disk
    ! 4- Disk
    !     model = flux*4/(pi*b**2)
    !     g(u,v) = J1(pi*b*q)/q
    !     where q**2 = u**2+v**2
    !     4 pars (x0, y0, flux, b)
    !
    q = sqrt(uu**2+vv**2)
    ksi = pi*x(4)*q
    if (ksi.eq.0d0) then
      a = 1
      da(4) = 0
    else
      j1 = dbesj1(ksi)
      j0 = dbesj0(ksi)
      a = j1*2d0/ksi
      da(4) = 2d0*(j0-a)/x(4)
    endif
    !
  case (5) ! Ring
    !
    ! 5- Ring
    q = sqrt(uu**2+vv**2)
    a = 0
    da(4) = 0
    da(5) = 0
    if (x(4).ne.x(5)) then
      d = x(4)**2-x(5)**2
      fac = x(4)**2/d
      dfac4 =-2*x(5)**2*x(4)/d**2
      dfac5 =2*x(4)**2*x(5)/d**2
      ksi = pi*x(4)*q
      if (ksi.eq.0) then
        a = a + fac
        da(4) = da(4) + dfac4
        da(5) = da(5) + dfac5
      else
        j1 = dbesj1(ksi)
        j0 = dbesj0(ksi)
        aa = j1*2d0/ksi
        daa = 2d0*(j0-aa)/x(4)
        a = a + aa*fac
        da(4) = da(4) + daa*fac+aa*dfac4
        da(5) = da(5) + aa*dfac5
      endif
      ksi = pi*x(5)*q
      if (ksi.eq.0) then
        a = a+1d0-fac
        da(4) = da(4)-dfac4
        da(5) = da(5)-dfac5
      else
        j1 = dbesj1(ksi)
        j0 = dbesj0(ksi)
        aa = j1*2d0/ksi
        daa = 2d0*(j0-aa)/x(5)
        a = a + aa*(1d0-fac)
        da(4) = da(4) - aa*dfac4
        da(5) = da(5) + daa*(1d0-fac)-aa*dfac5
      endif
    endif
    !
  case(6) ! Exponential
    ! 6- exponential
    !     model = exp(- 2*ln2*r/b)
    !     g(u,v) = 1 / ( 1 + (q*b*pi/ln2)**2 )**(3/2)
    !
    q2 = uu**2+vv**2
    ksi = q2 * (x(4)*pi/log(2d0))**2
    b = 1d0+ksi
    a = 1d0/b**1.5
    da(4) = -3*a*ksi/b/x(4)
    !
  case(7) ! Power -2
    ! 7- Power -2
    !     model =
    !     g(u,v) =
    !
    q = sqrt(uu**2+vv**2)
    ksi = pi*x(4)*q
    k0 = dbesk0(ksi)
    k1 = dbesk1(ksi)
    a = k0
    da(4) = -ksi/x(4)*k1
    !
  case(8) ! Power -3
    !
    ! 8- Power -3
    !     model =
    !     g(u,v) = exp( -pi*q*b/sqrt(2**(1/3)-1) )
    !
    q = sqrt(uu**2+vv**2)
    ksi = pi*q*x(4)/sqrt(2.**(1./3)-1)
    a = z_exp(-ksi)
    da(4) = -a*ksi/x(4)
    !
  case(9) ! Elliptical disk
    ! 9- Elliptical Disk
    !     model = flux*4/(pi*(b1**2+b2**2)) (inside ellipse, 0 outside)
    !     g(u,v) = 2 J1 (ksi)  / ksi
    !     where u1 = u*sin(theta)+v*cos(theta)
    !           u2 = u*cos(theta)-v*sin(theta)
    !     ksi = pi*sqrt((b1*u1)**2+(b2*u2)**2)
    !     6 pars (x0, y0, flux, b1, b2, theta)
    !
    st = sin(deg*x(6))
    ct = cos(deg*x(6))
    q1 = uu*st+vv*ct
    q2 = uu*ct-vv*st
    ksi = pi*sqrt((x(4)*q1)**2+(x(5)*q2)**2)
    if (ksi.eq.0d0) then
      a = 1
      da(4) = 0
      da(5) = 0
      da(6) = 0
    else
      j1 = dbesj1(ksi)
      a = j1*2d0/ksi
      j0 = dbesj0(ksi)
      dadksi = 2d0*(j0-a)/ksi
      da(4) = dadksi*pi**2*q1**2*x(4)/ksi
      da(5) = dadksi*pi**2*q2**2*x(5)/ksi
      da(6) = dadksi/ksi*pi**2*q1*q2*(x(4)**2-x(5)**2)*deg
    endif
    !
  case (10)  ! Unresolved ring
    !
    ! 10- Unresolved Ring
    !     model = flux/(2*pi*b)*delta(r-b)
    !     g(u,v) = J0(pi*b*q)
    !     where q**2 = u**2+v**2
    !     4 pars (x0, y0, flux, b)
    !
    q = sqrt(uu**2+vv**2)
    ksi = pi*x(4)*q
    if (ksi.eq.0d0) then
      a = 1
      da(4) = 0
    else
      j1 = dbesj1(ksi)
      j0 = dbesj0(ksi)
      a = j0
      da(4) = -j1 * pi*q
    endif
    !
  case(11) ! Elliptical Ring
    ! 11- Elliptical Ring
    !
    !     To be developped more...
    !
    !     7 pars (x0, y0, flux, outer, inner, pa, ratio)
    !
    !     Define a1 = outer
    !     Define a2 = outer*ratio
    !     Define b1 = inner
    !     Define b2 = inner*ratio
    !
    ! Sum of two elliptical disks.
    !     a) a = fa *4/(pi*outer^2*ratio) > 0
    !        ga(u,v) = fa * J1(pi*sqrt((a1*u1)**2+(a2*u2)**2)
    !     b) b = fb *4/(pi*inner^2*ratio) < 0
    !        gb(u,v) = fb * J1(pi*sqrt((b1*u1)**2+(b2*u2)**2)
    !     and
    !        fa + fb = flux
    !        fa / fb = -(outer/inner)^2
    !     where u1 = u*sin(theta)+v*cos(theta)
    !           u2 = u*cos(theta)-v*sin(theta)
    !*     so
    !        fa = flux * outer^2 / (outer^2-inner^2)
    !        fb = - flux * inner^2 / (outer^2-inner^2)
    !
    ! Derivative vs outer
    !
    !     d(fa)/d(out) * J1 + fa * d(J1)/d(out)
    !
    !
    st = sin(deg*x(6))
    ct = cos(deg*x(6))
    q1 = uu*st+vv*ct
    q2 = uu*ct-vv*st
    ii = x(5) ! Inner radius
    oo = x(4) ! Outer radius
    ff = x(7) ! cos (inclination)
    dout2 = (oo**2-ii**2)
    !
    ! First source
    a1 = x(4)
    a2 = x(4)*ff
    !
    ksi = pi*sqrt((a1*q1)**2+(a2*q2)**2)
    if (ksi.eq.0d0) then
      a = 1
      dg_dmaj = 0
      dg_dmin = 0
      dg_dpa = 0
    else
      j1 = dbesj1(ksi)
      j0 = dbesj0(ksi)
      a = j1*2d0/ksi
      dadksi = 2d0*(j0-a)/ksi
      dg_dmaj = dadksi*pi**2*q1**2*a1/ksi    ! d(g)/d(major)
      dg_dmin = dadksi*pi**2*q2**2*a2/ksi    ! d(g)/d(minor)
      dg_dpa = dadksi/ksi*pi**2*q1*q2*(a1**2-a2**2)*deg
    endif
    !
    ! Now it gets a little more complex
    fo = oo**2 / dout2
    !
    dgo_do = 2 * oo * ii**2 / dout2 *  a    ! Strictly speaking
    dgo_do = dgo_do + fo * (dg_dmaj + ff * dg_dmin)
    dgo_di = 2 * oo**2 * ii / dout2 *  a
    !
    flux = a * fo
    dg_dratio = fo * a1 * dg_dmin
    dg_drota = fo * dg_dpa
    !
    ! Second source
    a1 = x(5)
    a2 = x(5)*ff
    !
    ksi = pi*sqrt((a1*q1)**2+(a2*q2)**2)
    if (ksi.eq.0d0) then
      a = 1
      dg_dmaj = 0
      dg_dmin = 0
      dg_dpa = 0
    else
      j1 = dbesj1(ksi)
      j0 = dbesj0(ksi)
      a = j1*2d0/ksi
      dadksi = 2d0*(j0-a)/ksi
      dg_dmaj = dadksi*pi**2*q1**2*a1/ksi    ! d(g)/d(major)
      dg_dmin = dadksi*pi**2*q2**2*a2/ksi    ! d(g)/d(minor)
      dg_dpa = dadksi/ksi*pi**2*q1*q2*(a1**2-a2**2)*deg
    endif
    !
    fi = ii**2 / dout2
    !
    dgi_di = 2 * ii * oo**2 / dout2 *  a    ! Strictly speaking
    dgi_di = dgo_di + fi * (dg_dmaj + ff * dg_dmin)
    dgi_do = 2 * ii**2 * oo / dout2 *  a
    !
    ! Add (or rather subtract...) to previous derivatives
    dg_dinner = dgo_di - dgi_di
    dg_douter  = dgo_do - dgi_do
    dg_dratio = dg_dratio - fi * a1 * dg_dmin
    dg_drota = dg_drota - fi * dg_dpa
    !
    ! and to flux (actually, relative visibility)
    flux = flux - a * fi
    !
    a = flux                     ! Normalized scaling factor now
    da(4) = dg_douter
    da(5) = dg_dinner
    da(6) = dg_drota
    da(7) = dg_dratio
    !
  case(12)
    ! SPERGEL
    !  'R.A.','Dec.','Flux','F.W.H.P.','nu'
    !
    ! Spergel 2010 profile (Elliptical galaxies)
    ! model = flux*(r/2)^2*(Knu(r)/(Gamma(nu+1))
    ! g(u,v) = 1/(2*pi*(1+(u^2+v^2)*(r0/cnu)^2))^(1+nu))
    !          1   2    3    4   5
    ! 5 pars (x0, y0, flux, r0, nu)
    ! 
    ! Approximation to cnu based on fit to tabulated cnu provided by Spergel 2010.
    ! 10% accuracy for nu < -0.6, for nu > -0.6 accuracy < 1%
    !
    nu = x(5)
    major = x(4)*2d0*cst
    cnu = acnu*log(nu+2d0)+bcnu*nu+ccnu
    uvdist2 = (uu**2+vv**2)
    repeat = (major)**2*2*uvdist2/cnu**2+1d0
    !
    a = 1d0/((repeat)**(1d0+nu))
    !
    dg_dnu = repeat**(-nu-1)/2/pi*(-(2*major**2*uvdist2*(-nu-1)*&
        (acnu/nu+ccnu))/(cnu**3*repeat)-log(repeat))
    !
    dg_dr0 = 2d0*cst*((-nu-1)*uvdist2*major*((uvdist2*major**2)/(cnu**2)+1)**(-nu-2))/(pi*cnu**2)
    !
    da(4) = dg_dr0
    da(5) = dg_dnu
    !
  case(13)
    ! E_SPERGEL
    !   'R.A.','Dec.','Flux','Major','Minor','Pos.Ang.','nu'
    !
    ! Elliptical adaptation to Spergel 2010 profile (for galaxies)
    ! model = flux*(r/2)^2*(Knu(r)/(Gamma(nu+1))
    ! g(u,v) = 1/(2*pi*(1+(uvd1^2*r1^2+uvd2^2*r2^2)/cnu^2))^(1+nu))
    !          1   2    3    4   5   6      7
    ! 7 pars (x0, y0, flux, r1, r2, theta, nu)
    ! 
    ! Approximation to cnu based on fit to tabulated cnu provided by Spergel 2010.
    ! 10% accuracy for nu < -0.6, for nu > -0.6 accuracy < 1%
    !
    ! ZZZ is the aforementioned approximation to Cnu still valid for the elliptic case?
    !
    nu = x(7)
    !
    major = x(4)*2*cst
    minor = x(5)*2*cst
    cnu = acnu*log(nu+2)+bcnu*nu+ccnu
    sintheta = sin(deg*x(6))
    costheta = cos(deg*x(6))
    uvdist1 = uu*sintheta+vv*costheta
    uvdist2 = uu*costheta-vv*sintheta
    dfac = (major**2*uvdist1**2+minor**2*uvdist2**2)
    repeat = dfac/cnu**2+1
    drepeat = 2d0*cst*dfac/cnu**2+1
    !
    a = 1/((repeat)**(1+nu))
    !
    dg_dnu = a*(-(2*(-nu-1)*(acnu/(nu+2)+bcnu)*dfac)/(cnu**3*repeat)-log(repeat))
    !
    dg_dr1 = 2d0*cst*((-nu-1)*major*uvdist1**2*repeat**(-nu-2))/(pi*cnu**2)
    !
    dg_dr2 = 2d0*cst*((-nu-1)*minor*uvdist2**2*repeat**(-nu-2))/(pi*cnu**2)
    !
    dg_dtheta = ((-nu-1)*(2*major**2*uvdist1*uvdist2-minor**2*uvdist1*uvdist2) &
       &   *repeat**(-nu-2))/(pi*cnu**2)
    !
    da(4) = dg_dr1
    da(5) = dg_dr2
    da(6) = dg_dtheta
    da(7) = dg_dnu
    !
  case(14)
    ! E_EXPO
    ! 'R.A.','Dec.','Flux','Major','Minor','Pos.Ang.'
    !
    ! Elliptical Exponential
    ! model = exp(- 2*ln2*(r1/b1+r2/b2))
    ! g(u,v) = 1 / ( 1 + (uvd1^2*r1^2+uvd2^2*r2^2)*(pi/ln2)**2 )**(3/2)
    ! 6 pars (x0,y0,flux,size1,size2,theta)
    !
    sintheta = sin(deg*x(6))
    costheta = cos(deg*x(6))
    uvdist1 = uu*sintheta+vv*costheta
    uvdist2 = uu*costheta-vv*sintheta
    dfac = x(4)**2*uvdist1**2+x(5)**2*uvdist2**2
    !
    ksi = dfac*(pi/log(2d0))**2
    !
    a = 1d0/(1d0+ksi)**1.5
    !
    da(4) = -cte*x(4)*uvdist1**2/(1d0+ksi)**2.5
    da(5) = -cte*x(5)*uvdist2**2/(1d0+ksi)**2.5
    da(6) = -cte*(x(4)**2-x(5)**2)*uvdist1*uvdist2/(1d0+ksi)**2.5
    !
  case default
    a = 1.
    da = 0.
  end select
  !
  ! Compute the phase term exp(-2i*pi(u*x0+v*y0)) and its derivatives
  ! with respect to x_0 and y_0
  !
  ! Sign is correct for X positive towards East.
  darg1 = dpi*uu
  darg2 = dpi*vv
  arg = darg1*x(1)+darg2*x(2)
  carg = cos(arg)
  sarg = sin(arg)
  !
  ! Now compute the real and imaginary part of function.
  y(1) = x(3)*a*carg
  y(2) = x(3)*a*sarg
  !
  ! And its derivatives with respect to x0, y0, flux
  dy(1,1) = -y(2)*darg1
  dy(2,1) =  y(1)*darg1
  dy(1,2) = -y(2)*darg2
  dy(2,2) =  y(1)*darg2
  dy(1,3) = a*carg
  dy(2,3) = a*sarg
  ! And its derivatives with respect to parameters 4, 5, 6, 7
  if (kfunc.ge.4) then
    do i=4, kfunc
      dy(1,i) = x(3)*carg*da(i)
      dy(2,i) = x(3)*sarg*da(i)
    enddo
  endif
end subroutine uvfit_model
!
function z_exp(x)
  !---------------------------------------------------------------------
  ! protect again underflows in exp(x)
  !---------------------------------------------------------------------
  real(8) :: z_exp                   !! Underflowed Exponential
  real(8) :: x                       !! Argument    
  !
  ! Constants ---
  real(8) :: xmin, ymin
  logical :: first
  data first/.true./
  save xmin, ymin, first
  !
  if (first) then
    ymin = 2.d0*tiny(1.D0) !! d1mach(1)
    xmin = log(ymin)
    first = .false.
  endif
  if (x.lt.xmin) then
    z_exp = ymin
    return
  endif
  z_exp = exp(x)
end function z_exp
!
subroutine sub_uvfit_results(line,error)
  use uvfit_options
  use gkernel_interfaces
  use uvfit_data
  use gbl_message
  use imager_interfaces, only : map_message
  !---------------------------------------------------------------------
  !* 
  ! IMAGER --  Support for command 
  !     UV_FIT [Func1 ... FuncN] /RESULT
  !
  ! Only works for  
  !  - all functions  
  !  - 1 channel only  
  ! Test functionality only. May disappear at any time...
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: line  !! Command line
  logical, intent(inout) :: error       !! Error flag
  !
  character(len=*), parameter :: rname='UV_FIT'
  !
  ! Local ---
  integer :: i,n,ier
  integer(kind=index_length) :: dim(2)
  real :: qmin, qmax, qstep
  real, allocatable, save :: uvri(:,:) 
  !
  ! Code ----
  if (nf.eq.0) then
    call map_message(seve%e,rname,'No UV_FIT available')
    error = .true.
    return
  endif
  call sic_delvariable ('UVF%PLOT',.false.,error)
  !
  ! Get Umin Umax Ustep to define the Sampling
  call sic_i4(line,o_result,1,n,.true.,error)
  call sic_r4(line,o_result,2,qmin,.true.,error)
  call sic_r4(line,o_result,3,qmax,.true.,error)
  qstep = (qmax-qmin)/(n-1)
  !
  if (allocated(uvri)) deallocate(uvri,stat=ier)
  allocate (uvri(n,4),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  !
  do i=1,n
    uvri(i,1) = (i-1)*qstep+qmin
  enddo
  call get_uvfit_model(n,uvri(:,1),uvri(:,2),uvri(:,3),uvri(:,4),error)
  !
  dim = [n,4]
  call sic_def_real('UVF%PLOT',uvri,2,dim,.true.,error)
end subroutine sub_uvfit_results
!
subroutine get_uvfit_model(nvisi,uu,vv,rr,ii,error)
  use gkernel_interfaces
  use uvfit_data
  !$ use omp_lib
  !---------------------------------------------------------------------
  !* 
  ! IMAGER -- Support for command   
  !     UV_FIT [Func1 ... FuncN] /RESULT
  !!
  !---------------------------------------------------------------------
  integer, intent(in) :: nvisi    !! Number of visibilities
  real, intent(in) :: uu(nvisi)   !! U coordinates
  real, intent(in) :: vv(nvisi)   !! V coordinates
  real, intent(out) :: rr(nvisi)  !! Real part
  real, intent(out) :: ii(nvisi)  !! Imaginary part
  logical, intent(inout) :: error !! Error flag
  !
  ! Local ---
  real :: fa,fb
  real(8) :: y(2),dy(2)
  integer :: iif, iv, if
  integer :: ithread,kpar
  !
  ! Code ----
  !$OMP PARALLEL DEFAULT(none)  &
  !$OMP & SHARED(uu,vv)   &  ! Input Visibility array
  !$OMP & SHARED(rr,ii)   &  ! Ouput arrays
  !$OMP & SHARED(nvisi,nf,npfunc,pars,kpar,ifunc) &
  !$OMP & PRIVATE(iv,if,iif)  &
  !$OMP & PRIVATE(ithread, y, dy, fa, fb)
  !
  ithread = 1
  !$ ithread = omp_get_thread_num()+1
  !$OMP DO
  do iv=1, nvisi
    !
    fa = 0.0
    fb = 0.0
    kpar = 1
    do if = 1, nf
      iif = ifunc(if)
      call uvfit_model(iif,npfunc(if),dble(uu(iv)),dble(vv(iv)),pars(kpar),y,dy)
      fa = fa + y(1)
      fb = fb + y(2)
      kpar = kpar + npfunc(if)
    enddo
    rr(iv) = fa
    ii(iv) = fb
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
end subroutine get_uvfit_model
!
!subroutine primary_radial(line,bsize,head,nr,nt,profile,error)
subroutine primary_atten(bsize,head,freq,rmax,nr,profile,error)
  use gkernel_interfaces
  use image_def
  use imager_interfaces, except_this=>primary_atten
  use gbl_message
  !---------------------------------------------------------------------
  ! @ private-mandatory
  !*
  ! IMAGER --  Support for command  PRIMARY [BeamSize] 
  !
  ! Compute primary beam radial profile
  !!
  !---------------------------------------------------------------------
  real(4), intent(inout) :: bsize      !! Force Beam Size if non zero
  type(gildas), intent(in) :: head     !! Header of UV data
  real(8), intent(in)  :: freq         !! Observing Frequency
  real(8), intent(in)  :: rmax         !! Maximum Angular Distance
  integer, intent(out) :: nr           !! Number of radial points
  real(8), allocatable, intent(out) :: profile(:,:) !! Radial profile
  logical, intent(out) :: error        !! Error flag
  ! 
  ! Constants
  character(len=*), parameter :: rname='UV_FIT'
  real(8), parameter :: pi=3.14159265358979323846d0
  real(8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
  !
  ! Local ---
  integer :: ir, ier
  real(8) :: dr, uvmax
  real :: bsizes(10)
  character(len=80) :: mess  
  !
  ! Code ----
  ! Compute radial profile of primary beam beyond Map limits
  uvmax = head%gil%basemax * freq * f_to_k
  dr = 1./(2.*uvmax)
  !
  nr = max(ceiling(1.2*(rmax/dr)),2)
  allocate (profile(nr,2),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'Memory allocation error')
    error = .true.
    return
  endif
  !
  do ir=1,nr
    profile(ir,1) = (ir-1)*dr    
  enddo
  profile(:,2) = 1.0
  !
  if (bsize.eq.0) then
    if (head%gil%nteles.ge.1) then
      if (head%gil%teles(1)%ctele.eq.'ALMA') then
        call map_message(seve%i,rname,'Using ALMA beam shape')
        call primary_alma(head,nr,profile) 
        bsize = -1.0    ! Non zero value
        return
      endif
    endif
  endif
  ! Get or Check beam size
  call get_bsize(head,' ',' ',bsizes,error)
  bsize = bsizes(1)
  !
  if (bsize.gt.0) then
    write(mess,'(a,f10.2,a)') 'Using a beam size of ',&
      & bsize/pi*180*3600,'"'
    call map_message(seve%i,rname,mess)
    call primary_gauss(bsize,nr,profile)
  endif
  !
end subroutine primary_atten
!
