subroutine uvfit_comm(line,error)
  use gkernel_interfaces
  use gbl_message
  use clean_default
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support for command UV_FIT [Func1 ... FuncN] [/WIDGET Nfunc] 
  !     [/SAVE File]
  !---------------------------------------------------------------------
  !
  character(len=*), intent(inout) :: line
  logical, intent(inout) :: error
  !
  integer :: nf, nline, in, nc
  logical :: verbose, do_insert
  integer, parameter :: o_quiet=1
  integer, parameter :: o_save=2
  integer, parameter :: o_widget=3
  character(len=32) :: chain,comm
  character(len=*), parameter :: rname='UV_FIT'
  character(len=filename_length) :: fich
  !
  ! Create the Widget if option is mentionned
  in = index(line,'UV_FIT')+7
  chain = "@ x_uvfit "//line(in:)
  verbose = .not.sic_present(o_quiet,0)
  !
  error =.false.
  if (sic_present(o_save,0)) then
    do_insert = .false. ! To be checked
    call sic_ch(line,o_save,1,fich,nc,.true.,error)
    if (error) return
    !
    call exec_program('@ s_uvfit '//fich(1:nc))
  else if (sic_present(o_widget,0)) then
    do_insert = (sic_lire().eq.0)
    call sic_i4(line,o_widget,1,nf,.true.,error)
    if (error) return
    if (nf.lt.1 .or. nf.gt.4) then
      call map_message(seve%e,rname,'1 to 4 functions possible')
      error = .true.
      return
    endif
    call exec_program(chain)
  else if (sic_narg(0).ne.0) then
    do_insert = (sic_lire().eq.0) 
    call exec_program(chain)
    call sic_get_inte('UVF%NF',nf,error)
    comm = 'UV_FIT'
    nline = len_trim(line)
    call sic_analyse(comm,line,nline,error)
    call uvfit_sub(line,verbose,error)
  else
    do_insert = (sic_lire().eq.0) 
    call uvfit_sub(line,verbose,error)
  endif
  !
  if (error) return
  last_resid = 'UV_FIT'
  if (do_insert) call sic_insert_log(line)
end subroutine uvfit_comm
!
subroutine uvfit_sub(line,verbose,error)
  use gkernel_interfaces
  use gkernel_types
  use image_def
  use gbl_format
  use gbl_message
  use uvfit_data
  !
  use clean_def
  use clean_arrays
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support for command UV_FIT 
  !
  !   The functions have been defined previously by subroutine uvfit_comm
  !---------------------------------------------------------------------
  !---------------------------------------------------------------------
  !     Re-written with Fortran-90 interfaces
  !     on June 30 S.Guilloteau
  !---------------------------------------------------------------------
  !
  character(len=*), intent(in) :: line
  logical, intent(in) :: verbose
  logical, intent(inout) :: error
  !
  ! Local
  integer, allocatable :: iw(:)
  real(8), allocatable :: fvec(:), wa(:), r(:,:)
  real(8), allocatable :: wa1(:), wa2(:), wa3(:), wa4(:)
  integer :: sever
  logical :: warning, report
  !
  !
  real(8) :: xx, yy, xa, xd
  real(8), parameter :: pi = 3.14159265358979323846d0
  real(8), parameter :: clight = 299792458.d-6   ! in meter.mhz
  integer :: j, js, jsmin, lwa, 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
  integer, parameter :: mstart=1000
  real :: par0(mpar), range(mpar), fact, vit
  real :: uv_range(2), uv_min, uv_max
  real(8) :: parin(mpar,mstart), par2(mpar,mstart), parstep(mpar)
  real(8) :: parout(mpar,mstart), fsumsq, cj(mpar)
  real(8) :: fsumin, epar(mpar), rms, tol, denorm, factor, fluxfactor
  character(len=8) :: fluxunit
  integer, parameter :: mfunc=11
  integer :: mpfunc(mfunc), nstartf(mf,mfunc)
  real :: parf(mf,mfunc), rangef(mf,mfunc)
  character(len=8) :: cf, ccf, cfunc(mfunc), ccpar(mpin,mfunc)
  character(len=20) :: ch
  character(len=20) :: cpar(mpar),errmess
  character(len=80) :: resu, chpar, chain
  character(len=15) :: chpos1
  character(len=15) :: chpos2
  external :: fitfcn
  integer :: ier, nvs
  type(projection_t) :: proj
  !
  data cfunc/'POINT','E_GAUSS','C_GAUSS','C_DISK','RING','EXPO',   &
     &    'POWER-2','POWER-3','E_DISK','U_RING','E_RING'/
  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'/
  data mpfunc /3,6,4,4,5,4,4,4,6,4,7/
  !
  character(len=*), parameter :: Version='Version 2.2 25-Mar-2019 S.Guilloteau'
  character(len=*), parameter :: rname='UV_FIT'
  !
  !-----------------------------------------------------------------------
  !
  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:
  !
  ic = 0
  !
  !     2 Additional parameters to use specific uv range.
  uv_range = 0
  uv_min = uv_range(1)
  uv_max = uv_range(2)
  call map_message(seve%i,rname,version)
  if (uv_min.ne.0 .or. uv_max.ne.0) then
    write(chain,*) 'UV data from ',uv_min,   &
     &      ' to ',uv_max,' m.'
    call map_message(seve%i,rname,chain)
  endif
  !
  ! 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_ch(line,0,i,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,']'
        call sic_r4(line,0,j+1,parf(j,1),.false.,error)
        if (error) return
        call sic_let_real(ch,parf(j,i),error)
      enddo
    enddo
    nf = nf/8
  endif
  !
  ! The limit 4 could be increased if needed up to 10
  if (nf.lt.1 .or. nf.gt.4) then
    call map_message(seve%e,rname,'1 to 4 functions possible')
    error = .true.
    return
  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_ch(line,0,i,cf,nch,.false.,error)
    if (.not.error) call sic_let_char(ch,cf,error)
    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))
    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))
    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
        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 (huv%loca%size.eq.0) then
    call map_message(seve%e,rname,'No UV data')
    error = .true.
    return
  endif
  !
  error = .true.
  !
  ndata = huv%gil%dim(2)
  ier = gdf_range(ic, huv%gil%nchan)
  nc = huv%gil%nchan
  !
  np2 = 2*ndata                ! max. data points
  lwa = npar*(np2+5)+np2
  !
  ! For DNLS1E and DCOV
  ier = 0
  allocate (fvec(np2),wa(lwa),r(np2,npar),iw(npar),stat=ier)
  if (ier.ne.0) then
    call map_message(seve%e,rname,'FVEC allocation error')
    error = .true.
    return
  endif
  !
  ! For DCOV only
  allocate(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(huv,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 = huv%gil%dim(1)
  !
  allocate (uvriw(5,ndata),stat=ier)
  !
  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(huv,dble(kc)) / clight * pi/180.d0/3600d0
    call load_data(ndata,nvs,kc,fact,duv,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)
        cycle
      else
        write(chain,'(I0,A,I0)') npuvfit,' data points for channel ', kc
        call map_message(seve%i,rname,chain)
      endif
    endif
    !
    np2 = 2*npuvfit
    vit = huv%gil%voff+(kc-huv%gil%ref(1))*huv%gil%vres
    !
    fsumin = 1d20
    !
    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(6,'(a,5(1pg12.5))') 'I-UV_FIT, Starting from ',   &
       &        (par2(iii,js),iii=1, nvpar)
      endif
      !
      iopt = 2        ! Supply full Jacobian
      !     iopt = 1  !! or only Function (test mode)
      tol = 1d-8
      nprint = 0
      call dnls1e (fitfcn, iopt, np2, nvpar, par2(1,js),   &
     &        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)
      !
      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
        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
    !
    k = 0
    do i=1, npar
      if (nstart(i).ge.0) then
        k = k+1
        parout(i,jsmin) = par2(k,jsmin)
      else
        parout(i,jsmin) = pars(i)
      endif
    enddo
    !
    k = 1
    do j=1, nf
      call outpar(ifunc(j),npfunc(j),parout(k,jsmin))
      k = k + npfunc(j)
    enddo
    k = 0
    ki = 0
    call gwcs_projec(huv%gil%a0,huv%gil%d0,huv%gil%pang,huv%gil%ptyp,proj,error)
    !
    if (verbose) then
      do j=1, nf
        ! 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(proj,xx,yy,xa,xd,1)
        call rad2sexa(xa,24,chpos1)
        call rad2sexa(xd,360,chpos2)
        ! 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(6,*) chpar(1:nch)//'  '//chpos1
          elseif (i.eq.2) then
            write(6,*) chpar(1:nch)//' '//chpos2
          elseif (i.eq.3) then
            write(6,*) chpar(1:nch)//'  '//fluxunit
          else
            write(6,*) chpar(1:nch)
          endif
        enddo
      enddo
    else
      !
      ! Only computes the errors
      do j=1, nf
        do i=1, npfunc(j)
          ki = ki+1
          if (nstart(ki).ge.0) then
            k = k+1
            epar(ki) = sqrt(abs(cj(k)))
          else
            epar(ki) = 0.
          endif
        enddo
      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'
      call sic_def_real(ch,uvf_results(1,j),1,mpin,.true.,error)
      write(ch,'(a,i0,a)') 'UVF%PAR',j,'%ERRORS'
      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 message_colour(1)
    call map_message(seve%w,rname,'Completed with possible errors')
    call message_colour(-1)
  else
    call message_colour(2)
    call map_message(seve%i,rname,'Successful completion')
    call message_colour(-1)
  endif
  !
  call sic_mapgildas('UV_FIT',huvfit,error,duvfit)
end subroutine uvfit_sub
!
subroutine uvfit_residual(line,error)
  use clean_def
  use clean_arrays
  use uvfit_data
  use gkernel_interfaces
  use gbl_message
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support for command UV_RESIDUAL after a UV_FIT function  !
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: line
  logical, intent(inout) :: error
  !
  character(len=*), parameter :: rname='UV_RESIDUAL'
  character(len=80) :: chain
  integer :: nvt, nvs, i, if, nc, ndata, ier, ic(2), narg
  !
  error = .false.
  narg = sic_narg(0)
  if (narg.eq.0) then
    savef(1:nf) = .true.
  else
    savef(1:nf) = .false.
    do i=1,narg
      call sic_i4(line,0,i,if,.true.,error)
      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 message_colour(1)
        call map_message(seve%e,rname,chain)
        error = .true.
      endif
    enddo
    if (error) then
      call message_colour(-1)
      return
    endif
    if (.not.any(savef)) then
      call message_colour(4)
      call map_message(seve%w,rname,'Nothing to subtract')
      call message_colour(-1)
      return
    endif
  endif
  !
  ! Subtract using DUV as work space... Not standard yet
  ic = [0,0]
  ier = gdf_range(ic, huv%gil%nchan)    ! Where is that range ?
  nvt = huvfit%gil%dim(2)               ! Number of fitted parameters
  ndata = huv%gil%nvisi                 ! Number of visibilities
  nc = huv%gil%nchan                    ! Number of input channels
  nvs = huv%gil%dim(1)                  ! Size of visibilities
  !
  ! Loop on functions for subtracting  model.
  ! This is memory inefficient, but multi-function fits are rare
  do if = 1, nf
    if (savef(if)) then
      write (chain,'(a,i2.2,2i8)') 'Removing UVF%PAR',if,ndata,nc
      call map_message(seve%i,rname,chain)
      call model_data(huv,ndata,nvs,nc,ic(1),ic(2),nvt,duv,duvfit,if)
    endif
  enddo
  call message_colour(2)
  call map_message(seve%i,rname,'Succesful completion')
  call message_colour(-1)
  !
end subroutine uvfit_residual
!
subroutine diagonal(m,n,r,c)
  integer :: m                      !
  integer :: n                      !
  real(kind=8) :: r(m,n)                  !
  real(kind=8) :: c(n)                    !
  ! Local
  integer :: i
  do i=1, n
    c(i) = r(i,i)
  enddo
end subroutine diagonal
!
subroutine outfit(nc,ic,ncol,y,rms,vit,nbpar,par,epar)
  use gildas_def
  use uvfit_data
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support routine for UV_FIT
  !
  ! Store the fitted parameters into the output table Y
  !
  ! Format of table is, for each channel:
  ! 1-4  RMS of fit, number of functions, number of parameters, velocity
  ! then for each function, 3+mpin*2 columns:
  !        Function number, type of function, number of parameters
  !        then 6 times (parameter, error)
  !---------------------------------------------------------------------
  integer, intent(in) :: nc         ! Number of channels
  integer, intent(in) :: ic         ! Current channel
  integer, intent(in) :: ncol       ! Size of Y
  real, intent(out) :: y(nc,ncol)   ! Output table
  real(8), intent(in) :: rms        ! RMS of fit
  real, intent(in) :: vit           ! Velocity
  integer, intent(in) :: nbpar      ! Number of parameters
  real(8), intent(in) :: par(nbpar) ! Parameters
  real(8), intent(in) :: epar(nbpar)! Errors
  ! Local
  integer :: if, ip, k, kcol
  !
  y(ic,1) = rms
  y(ic,2) = nf
  y(ic,3) = nbpar
  y(ic,4) = vit
  kcol = 5
  k = 1
  do if=1, nf
    kcol = 5+(if-1)*(3+2*mpin)
    y(ic,kcol) = if
    y(ic,kcol+1) = ifunc(if)
    y(ic,kcol+2) = npfunc(if)
    kcol = kcol+3
    do ip=1, npfunc(if)
      y(ic,kcol) = par(k)
      y(ic,kcol+1) = epar(k)
      k = k+1
      kcol = kcol+2
    enddo
  enddo
end subroutine outfit
!
subroutine load_data(ndata,nx,ic,fact,visi,np,uvriw,uv_min,uv_max)
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support routine for UV_FIT
  ! Load Data of channel IC from the input UV table into array UVRIW.
  !---------------------------------------------------------------------
  integer, intent(in) :: ndata        ! Number of visibilities
  integer, intent(in) :: nx           ! Size of a visibility
  integer, intent(in) :: ic           ! Channel number
  real, intent(in) :: fact            ! Conversion factor of baselines
  real, intent(in) :: visi(nx,ndata)  ! Visibilities
  integer, intent(out) :: np          ! Number of non zero visibilities
  real, intent(out) :: uvriw(5,ndata) ! Output array
  real, intent(in) :: uv_min          ! Min UV
  real, intent(in) :: uv_max          ! Max UV
  !
  ! Local:
  integer :: i, irc, iic, iwc
  real :: uv1, uv2, uv
  !
  !! pi = 3.14159265358979323
  irc = 5 + 3*ic
  iic = irc + 1
  iwc = iic + 1
  np = 0
  if (uv_min.eq.0.0 .and. uv_max.eq.0.0) then
    do i = 1, ndata
      if (visi(iwc,i).gt.0) then
        np = np + 1
        uvriw(1,np) = visi(1,i) * fact
        uvriw(2,np) = visi(2,i) * fact
        uvriw(3,np) = visi(irc,i)
        uvriw(4,np) = visi(iic,i)
        uvriw(5,np) = visi(iwc,i) * 1e6
      endif
    enddo
  else
    uv1 = uv_min**2
    uv2 = uv_max**2
    do i = 1, ndata
      if (visi(iwc,i).gt.0) then
        uv = visi(1,i)**2+visi(2,i)**2
        if (uv.ge.uv1 .and. uv.lt.uv2) then
          np = np + 1
          uvriw(1,np) = visi(1,i) * fact
          uvriw(2,np) = visi(2,i) * fact
          uvriw(3,np) = visi(irc,i)
          uvriw(4,np) = visi(iic,i)
          uvriw(5,np) = visi(iwc,i) * 1e6
        endif
      endif
    enddo
  endif
  return
end subroutine load_data
!
subroutine model_data(huv,nd,nx,nc,ic1,ic2,ncol,vin,vy,if)
  use image_def
  use uvfit_data
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support routine for UV_FIT
  ! Subtract the model uv data for component function number IF
  ! from the input visibility data.
  !---------------------------------------------------------------------
  type (gildas), intent(in) :: huv  ! Input UV Table header
  integer, intent(in) :: nd         ! Number of visibilities
  integer, intent(in) :: nx         ! Size of a visbility
  integer, intent(in) :: nc         ! Number of channels
  integer, intent(in) :: ic1        ! First channel
  integer, intent(in) :: ic2        ! Last channel
  integer, intent(in) :: ncol       ! Size of VY
  real, intent(inout) :: vin(nx,nd) ! Visibilities
  real, intent(in) :: vy(nc,ncol)   ! Model parameters
  integer, intent(in) :: if         ! Function number
  !
  ! Local
  real :: fact
  integer :: j, i, k, iif, npf, kcol, ic
  real(8) :: y(2), dy(2,7), paris(7), uu, vv
  real(8), parameter :: pi = 3.14159265358979323846d0
  real(8), parameter :: clight = 299792458.d-6   ! in meter.mhz
  !
  ! Code:
  do j=1, nd
    !
    ! Kcol is the first column number in result table VY for function IF
    kcol = 5+(if-1)*(3+2*mpin)
    do ic = ic1, ic2
      fact = huv%gil%val(1) * &
     &        (1.d0+huv%gil%fres/huv%gil%freq*(ic-huv%gil%ref(1)))/clight   &
     &        *pi/180.d0/3600.d0
      uu = vin(1,j)*fact
      vv = vin(2,j)*fact
      !
      ! IIF is the function type and NPF its number of parameters.
      iif = nint(vy(ic,kcol+1))
      npf = nint(vy(ic,kcol+2))
      do i=1, npf
        paris(i) = vy(ic,kcol+3+2*(i-1))
      enddo
      call model(iif,npf,uu,vv,paris,y,dy)
      k = 8 + 3*(ic-1)
      vin(k,j) = vin(k,j) - y(1)
      vin(k+1,j) = vin(k+1,j) - y(2)
    enddo
  enddo
end subroutine model_data
!
subroutine fitfcn(iflag,m,nvpar,x,f,fjac,ljc)
  use gildas_def
  use uvfit_data
  !$ use omp_lib
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support routine for UV_FIT
  ! FITFCN is called by DNLS1E
  !---------------------------------------------------------------------
  integer, intent(in) :: iflag          ! Code for print out
  integer, intent(in) :: m              ! Number of data points
  integer, intent(in) :: nvpar          ! Number of variables
  real(8), intent(in) :: x(nvpar)       ! Variable parameters
  real(8), intent(out) :: f(m)          ! Function value at each point
  integer, intent(in) :: ljc            ! First dimension of FJAC
  real(8), intent(out) :: fjac(ljc,nvpar) ! Partial derivatives
  !
  real(8), external :: denorm
  !
  ! Local
  integer :: k, i, l, j, kpar, iif, kvpar, kf, kl
  integer :: ithread, nthread, ier
  real(8) :: uu, vv, rr, ii, ww, fact, y(2), dy(2,mpar), fa, fb
  real(8), allocatable :: swi(:)
  real(8), allocatable :: fone(:), ftwo(:)
  !
  k = 1
  sw = 0
  !
  ! Put the variable parameters in PARS (already including the fixed ones)
  kvpar = 1
  do j=1, npar
    if (nstart(j).ge.0) then
      pars(j) = x(kvpar)
      kvpar = kvpar+1
    endif
  enddo
  !
  nthread = 1
  !$ nthread = omp_get_max_threads()
  allocate(swi(nthread),fone(nvpar),ftwo(nvpar),stat=ier)
  if (ier.ne.0) then
    write(*,*) 'Memory allocation error in FITCN'
    return
  endif
  swi = 0.0
  !
  !$OMP PARALLEL DEFAULT(none)  &
  !$OMP & SHARED(uvriw) &  ! Input Visibility array
  !$OMP & SHARED(f,fjac) & ! Ouput arrays
  !$OMP & SHARED(npuvfit,nf,nvpar,npfunc,iflag,pars,ifunc,nstart, swi) &
  !$OMP & PRIVATE(i,uu,vv,rr,ii,ww,kf,kl,fact,kpar,kvpar,j,l)  &
  !$OMP & PRIVATE(ithread, iif, y, dy, fone, ftwo, fa, fb)
  !
  ithread = 1
  !$ ithread = omp_get_thread_num()+1
  !$OMP DO
  do i=1, npuvfit
    kf = 2*i-1
    kl = 2*i
    !
    ! Get real and imaginary part of visibility
    call getvisi(npuvfit,uvriw,i,uu,vv,rr,ii,ww)
    !
    ! Initialize F and derivatives.
    ! the weights are 1/sigma**2 (within a factor 2)
    fact = ww
    !
    ! Compute F and FJAC from model
    kpar  = 1
    kvpar = 1
    if (iflag.eq.1) then
      fa = -rr
      fb = -ii
      do j = 1, nf
        iif = ifunc(j)
        call model(iif,npfunc(j),uu,vv,pars(kpar),y,dy)
        fa = fa + y(1)
        fb = fb + y(2)
        kpar = kpar + npfunc(j)
      enddo
      f(kf) = fa*fact
      f(kl) = fb*fact
      !
    else if (iflag.eq.2) then
      fone = 0.d0
      ftwo = 0.d0
      do j = 1, nf
        iif = ifunc(j)
        call model(iif,npfunc(j),uu,vv,pars(kpar),y,dy)
        do l = 1, npfunc(j)
          if (nstart(kpar).ge.0) then
            fone(kvpar) = fone(kvpar) + dy(1,l)
            ftwo(kvpar) = ftwo(kvpar) + dy(2,l)
            kvpar = kvpar+1
          endif
          kpar = kpar + 1
        enddo
      enddo
      do l=1, nvpar
        fjac(kf,l) = fone(l)*fact
        fjac(kl,l) = ftwo(l)*fact
      enddo
      !
    else if (iflag.eq.0) then
      continue
    endif
    !
    ! Weight appropriately:
    swi(ithread) = swi(ithread) + fact
  enddo
  !$OMP END DO
  !$OMP END PARALLEL
  !
  sw = 0.0
  do i=1,nthread
    sw = sw+swi(i)
  enddo
  !
  ! In the end: normalize by the sum of weights.
  k = 1
  if (iflag.eq.1) then
    do k = 1, 2*npuvfit
      f(k) = f(k)/sw
    enddo
  else if (iflag.eq.2) then
    do l=1, nvpar
      do k=1,2*npuvfit
        fjac(k,l) = fjac(k,l)/sw
      enddo
    enddo
  endif
  if (iflag.eq.0) then
    print 1000, (x(i), i=1, nvpar), denorm(2*npuvfit,f)
    1000     format (10(1pg19.12))
  endif
  !!  print *,'Done FITFCN'
end subroutine fitfcn
!
subroutine getvisi(n,uvriw,k,u,v,r,i,w)
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support routine for UV_FIT
  !     Obtain U, V, and the visibility from the array UVRIW.
  !
  !     N      Integer     Number of visibilities     Input
  !     UVRIW  real(8)      Input array                Input
  !     K      Integer     Visibility number          Input
  !     U      real(8)      U coord.                   Output
  !     V      real(8)      V coord.                   Output
  !     R      real(8)      Real part                  Output
  !     I      real(8)      Imaginary part.            Output
  !     W      real(8)      Weight                     Output
  !---------------------------------------------------------------------
  integer, intent(in) :: n         ! Number of visibilities
  real, intent(in) :: uvriw(5,n)   ! Visibilities
  integer, intent(in) :: k         ! Desired visibility number
  real(8), intent(out) ::  u       ! U coordinate
  real(8), intent(out) ::  v       ! V coordinate
  real(8), intent(out) ::  r       ! Real part
  real(8), intent(out) ::  i       ! Imaginary part
  real(8), intent(out) ::  w       ! Weight
  !
  u = uvriw(1,k)
  v = uvriw(2,k)
  r = uvriw(3,k)
  i = uvriw(4,k)
  w = uvriw(5,k)
end subroutine getvisi
!
subroutine outpar(k,kfunc,par)
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support routine for UV_FIT
  ! Process fitted parameters to be saved, according to fitted functions
  !---------------------------------------------------------------------
  integer, intent(in) :: k     ! Function code
  integer, intent(in) :: kfunc ! Number of parameters
  real(8), intent(inout) :: par(kfunc)  ! Parameters
  ! Local
  real(8) :: aa
  integer :: ipoint, icgauss, iegauss, icdisk, iedisk, iexpo
  parameter (ipoint=1,iegauss=2,icgauss=3,icdisk=4,iexpo=6,iedisk=9)
  !
  ! Gaussian:  Reorder the axes, and change the P. Angle accordingly
  ! Make sure the axes are positive.
  if (k.eq.iegauss .or. k.eq.iedisk) then
    par(5) = abs(par(5))
    par(4) = abs(par(4))
    if (par(4).lt.par(5)) then
      par(6) = par(6)+90d0
      aa = par(4)
      par(4) = par(5)
      par(5) = aa
    endif
    par(6) = -90d0+mod(par(6)+3690d0,180d0)
  elseif (k.eq.icgauss .or. k.eq.icdisk .or.k.eq.iexpo) then
    par(4) = abs(par(4))
  endif
end subroutine outpar
!
subroutine  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
  !
  ! 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), 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
  real(8) flux,dg_dmaj,dg_dmin,dg_dpa
  real(8) dg_douter,dg_dinner,dg_dratio,dg_drota
  !-----------------------------------------------------------------------
  !
  ! 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
    !
  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 model
!
function z_exp(x)
  !---------------------------------------------------------------------
  ! protect again underflows in exp(x)
  !---------------------------------------------------------------------
  real(8) :: z_exp                   !
  real(8) :: x                       !
  ! Local
  real(8) :: d1mach, xmin, ymin
  logical :: first
  data first/.true./
  save xmin, ymin, first
  !
  if (first) then
    ymin = 2*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
