subroutine uv_residual_comm(line,error)
  use gkernel_interfaces
  use clean_default
  use gbl_message
  use imager_interfaces, except_this => uv_residual_comm
  !---------------------------------------------------------------------
  ! @ private
  ! IMAGER
  !   Support for command UV_RESIDUAL [CLEAN|CCT|[Func1 ... FuncN] [/QUIET] 
  !     [/WIDGET Nfunc] [/SAVE File] [/RESULT]
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: line
  logical, intent(inout) :: error
  !
  character(len=*), parameter :: comm='UV_RESIDUAL'
  character(len=12) :: key
  integer :: iarg, nk
  !
  if (last_resid.eq.' ') then
    call map_message(seve%e,comm,'No CLEAN or UV_FIT performed')
    error = .true. 
    return
  endif
  !
  key = last_resid
  call sic_ke(line,0,1,key,nk,.false.,error)
  !
  if (key.eq.'CCT'.or.key.eq.'CLEAN') then
    iarg = 2
    key = 'CCT'
  else if (key.eq.'FIT'.or.key.eq.'UV_FIT') then
    iarg = 2
    key = 'UV_FIT'
  else
    iarg = 1
    key = last_resid
  endif
  !  
  if (key.eq.'CCT') then
    call uv_residual_clean(line,comm,iarg,error)
  else
    call uvfit_residual_model(line,comm,iarg,error)
  endif
end subroutine uv_residual_comm
!
subroutine uvfit_comm(line,error)
  use gkernel_interfaces
  use gbl_message
  use clean_default
  use imager_interfaces, only : map_message
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support for command UV_FIT [Func1 ... FuncN] [/QUIET] 
  !     [/WIDGET Nfunc] [/SAVE File] [/RESULT]
  !     [/UVRANGE Min [Max]]
  !---------------------------------------------------------------------
  !
  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
  integer, parameter :: o_result=4
  character(len=32) :: chain,comm
  character(len=*), parameter :: rname='UV_FIT'
  character(len=filename_length) :: fich
  !
  ! /RESULT option
  if (sic_present(o_result,0)) then
    call sub_uvfit_results(line,error)
    return
  endif
  !
  ! 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
  use imager_interfaces, only : map_message, primary_atten
  !---------------------------------------------------------------------
  ! @ private
  ! IMAGER
  !   Support for command UV_FIT 
  !
  !   The functions have been defined previously by subroutine uvfit_comm
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: line
  logical, intent(in) :: verbose
  logical, intent(inout) :: error
  !
  integer, parameter :: o_uvrange=5
  !
  ! 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
  real(8), parameter :: pi = 3.14159265358979323846d0
  real(8), parameter :: clight = 299792458.d-6   ! in meter.mhz
  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
  integer, parameter :: mstart=1000
  real :: par0(mpar), range(mpar), fact, vit
  real :: uv_min, uv_max, rtmp
  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
  character(len=8) :: fluxunit
  integer, parameter :: mfunc=11+3
  integer :: mpfunc(mfunc), nstartf(mf,mfunc), rafunc(mfunc), irat(mf)
  real :: parf(mf,mfunc), rangef(mf,mfunc)
  character(len=12) :: cf, ccf, cfunc(mfunc) 
  character(len=8) :: ccpar(mpin,mfunc)
  character(len=20) :: ch
  character(len=20) :: cpar(mpar),errmess
  character(len=80) :: resu, chpar, chain, chincli
  character(len=15) :: chpos1
  character(len=15) :: chpos2
  external :: fitfcn
  integer :: ier, nvs
  type(projection_t) :: phase_proj, point_proj
  !
  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'/
  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.','  '/
  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/
  !
  character(len=*), parameter :: Version='Version 2.5  7-Feb-2022 S.Guilloteau'
  character(len=*), parameter :: rname='UV_FIT'
  !
  ! Primary beam correction
  integer :: nr,ir
  real(8), allocatable :: profile(:,:)
  real(8) :: rmax, rdist, xp, yp
  real :: bsize, atten
  !-----------------------------------------------------------------------
  !
  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:
  !
  ic = 0
  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)
      !!print *,i,8*i-7,cf(1:nch)
      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
        !!Print *,'Start ',i,j,parf(j,i)
        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
    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.4) then
    call map_message(seve%e,rname,'1 to 4 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)
  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
        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.
  !
  if (huv%gil%nvisi.ge.2**30) then
    call map_message(seve%e,rname, & 
    & 'Does not support more than 2^30 visibilities')
    return
  endif
  ndata = huv%gil%nvisi
  ier = gdf_range(ic, huv%gil%nchan)
  nc = huv%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(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)
  !
  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(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
    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(6,'(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(huv%gil%a0,huv%gil%d0,huv%gil%pang,huv%gil%ptyp,phase_proj,error)
    call gwcs_projec(huv%gil%ra,huv%gil%dec,huv%gil%pang,huv%gil%ptyp,point_proj,error)
    !
    do j=1,nf      
! They were loaded before
!      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
      if (rafunc(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) then
      !
      freq = gdf_uv_frequency(huv,dble(kc))
      if (ic(2).gt.ic(1)) then
        v = (kc-huv%gil%ref(1))*huv%gil%vres + huv%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(6,*) trim(chpar)
      !
      bsize = 0
      rmax = 0
      do j=1,nf
        do i=1, npfunc(j)
          ki = ki+1
          xx = parout(ki+1,jsmin)*pi/180d0/3600d0
          yy = parout(ki+2,jsmin)*pi/180d0/3600d0
          rmax = max(xx**2+yy*22,rmax)
        enddo
      enddo
      rmax = sqrt(rmax)
      call primary_atten(bsize,huv,freq,rmax,nr,profile,error)
      !
      ki = 0
      do j=1, nf
        cincli = 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
        call abs_to_rel(point_proj,xa,xd,xp,yp,1)
        rdist = sqrt(xp**2+yp**2)
        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
        ! 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
          !
          ! Inclination if any
!!          Print *,'J ',j,' irat(j) ',irat(j),' I ',i,ki
          if (irat(j).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(j).eq.i) then
            cincli = parout(ki,jsmin)
            dincli = abs(epar(ki)/parout(ki,jsmin))
          else
            cincli = 0
            dincli = -1.
          endif
          if (dincli.ne.-1) then
            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) 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(6,*) chpar(1:nch)//'  '//fluxunit//' ! Primary beam corrected '
          endif
        enddo
        ! Print out Inclination if Elliptical model
        if (cincli.ne.0) write(6,*) 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'
      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 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 clean_def
  use clean_default
  use clean_arrays
  use uvfit_data
  use gkernel_interfaces
  use gbl_message
  use imager_interfaces, only : map_message
  !---------------------------------------------------------------------
  ! @ private
  !
  ! IMAGER
  !   Support for command UV_RESIDUAL and MODEL 
  !   after a UV_FIT command operation
  !
  !---------------------------------------------------------------------
  character(len=*), intent(in) :: line
  character(len=*), intent(in) :: rname 
  integer, intent(in) :: iarg
  logical, intent(inout) :: error
  !
  integer, parameter :: o_output=2
  !
  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(:,:)
  !
  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, 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
  !
  ! 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(huv,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(huv,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(huv,ndata,nvs,nc,ic(1),ic(2),nvt,duvres,duvfit,if, &
      & subtract)
    endif
  enddo
  !
end subroutine uvfit_residual_model
!
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
  !---------------------------------------------------------------------
  ! @ private
  !
  ! 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)
  !---------------------------------------------------------------------
  ! @ private
  !
  ! 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
    if (uv_max.ne.0) then
      uv2 = uv_max**2
    else
      uv2 = huge(1.0)
    endif
    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,subtract)
  use image_def
  use uvfit_data
  !---------------------------------------------------------------------
  ! @ private
  !
  ! 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
  logical, intent(in) :: subtract   ! Subtract (Residual) or Add (Model)
  !
  ! 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 uvfit_model(iif,npf,uu,vv,paris,y,dy)
      k = 8 + 3*(ic-1)
      if (subtract) then
        vin(k,j) = vin(k,j) - y(1)
        vin(k+1,j) = vin(k+1,j) - y(2)
      else
        vin(k,j) = vin(k,j) + y(1)
        vin(k+1,j) = vin(k+1,j) + y(2)
      endif
    enddo
  enddo
end subroutine model_data
!
subroutine fitfcn(iflag,m,nvpar,x,f,fjac,ljc)
  use gildas_def
  use uvfit_data
  use gbl_message
  use imager_interfaces, only : map_message
  !$ 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
  !
  character(len=*), parameter :: rname='UV_FIT'
  !
  ! 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(:)
  real(8) :: elapsed_s, elapsed_e, elapsed
  real(8), save :: elapsem 
  character(len=80) :: chain
  !
  if (ncall.eq.0) elapsem = 0.
  if (iflag.ne.0) then
    elapsed_e = 0.
    elapsed_s = 0.
    elapsed = 0.
    !$ elapsed_s = omp_get_wtime()
    ncall = ncall+1
  endif
  !  
  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 uvfit_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 uvfit_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
    !$OMP PARALLEL DEFAULT(none)  &
    !$OMP & SHARED(fjac, npuvfit, nvpar, sw) &  
    !$OMP & PRIVATE(l,k)
    !$OMP DO COLLAPSE(2)
    do l=1, nvpar
      do k=1,2*npuvfit
        fjac(k,l) = fjac(k,l)/sw
      enddo
    enddo
    !$OMP END DO
    !$OMP END PARALLEL
  endif
  if (iflag.eq.0) then
    print 1000, (x(i), i=1, nvpar), denorm(2*npuvfit,f)
    1000     format (10(1pg19.12))
  else
    !$ elapsed_e = omp_get_wtime()
    !$ elapsed = elapsed_e - elapsed_s
    !$ elapsem = elapsem + elapsed
    if (elapsem.ne.0) then
      write(chain,'(A,F8.3,A,I0)') 'Elapsed ',elapsem/ncall,' sec #',iflag
      call map_message(seve%d,rname,chain)
    endif
  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(id,kfunc,pars,errs)
  !---------------------------------------------------------------------
  ! IMAGER
  !   Support routine for UV_FIT
  ! Process fitted parameters to be saved, according to fitted functions
  !---------------------------------------------------------------------
  integer, intent(in) :: id    ! Function code
  integer, intent(in) :: kfunc ! Number of parameters
  real(8), intent(inout) :: pars(kfunc)  ! Parameters
  real(8), intent(inout) :: errs(kfunc)  ! Uncertainties
  ! Local
  real(8) :: dummy, factor
!!  integer :: ipoint, icgauss, iegauss, icdisk, iedisk, iexpo
!!  parameter (ipoint=1,iegauss=2,icgauss=3,icdisk=4,iexpo=6,iedisk=9)
  !
  ! Elliptical structures:  Reorder the axes, and change the P. Angle accordingly
  ! Make sure the axes are positive.
  select case (id)
  case (2,9,13,14)
    ! E_GAUSS, E_DISK, E_SPERGEL, E_EXPO
    pars(5) = abs(pars(5))
    pars(4) = abs(pars(4))
    if (pars(4).lt.pars(5)) then
      pars(6) = pars(6)+90d0
      dummy = pars(4)
      pars(4) = pars(5)
      pars(5) = dummy
      dummy = errs(4)
      errs(4) = errs(5)
      errs(5) = dummy
    endif
    pars(6) = -90d0+mod(pars(6)+90d0,180d0) ! Main determination of PA
  case(11)
    ! E_RING 
    !    'R.A.','Dec.','Flux','Outer','Inner','Pos.Ang.','Ratio', &
    ! Swap Inner and Outer if needed
    if (pars(5).gt.pars(4)) then
      dummy = pars(4)
      pars(4) = pars(5)
      pars(5) = dummy
      dummy = errs(4)
      errs(4) = errs(5)
      errs(5) = dummy
    endif
    ! Ratio and Pos.Ang are more subtle
    ! Bring the aspect ratio < 1 to have the proper size...
    if (pars(7).gt.1.0) then
      factor = pars(7)
      pars(4) = pars(4)*factor
      pars(5) = pars(5)*factor
      errs(4) = errs(4)*factor
      errs(5) = errs(5)*factor
      pars(6) = 90.d0+pars(6) 
      pars(7) = 1./factor
      errs(7) = errs(7)/factor**2
    endif
    pars(6) = -90d0+mod(pars(6)+90d0,180d0) ! Main determination of PA
  case (3,4,6,7,8,10,12)
    ! C_GAUSS, C_DISK, EXPO, POWER-2, POWER-3, U_RING, SPERGEL
    pars(4) = abs(pars(4))     
  case (5)
    ! RING  
    pars(4) = abs(pars(4))
    pars(5) = abs(pars(5))
    if (pars(5).lt.pars(4)) then
      dummy = pars(4)
      pars(4) = pars(5)
      pars(5) = dummy
      dummy = errs(4)
      errs(4) = errs(5)
      errs(5) = dummy
    endif
  end select
end subroutine outpar
!
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
  !-----------------------------------------------------------------------
  !
  ! 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                   !
  real(8) :: x                       !
  ! Local
  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 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
  logical, intent(inout) :: error
  !
  character(len=*), parameter :: rname='UV_FIT'
  integer, parameter :: o_result=4
  !
  integer :: i,n,ier
  integer(kind=index_length) :: dim(2)
  real :: qmin, qmax, qstep
  real, allocatable, save :: uvri(:,:) 
  !
  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
  !
  real :: fa,fb
  real(8) :: y(2),dy(2)
  integer :: iif, iv, if
  integer :: ithread,kpar
  !
  !$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_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
  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
  !
  character(len=*), parameter :: rname='UV_FIT'
  real(8), parameter :: pi=3.14159265358979323846d0
  real(8), parameter :: f_to_k = 2.d0*pi/299792458.d-6
  !
  integer :: ir, ier
  real(8) :: dr, uvmax
  character(len=80) :: mess  
  !
  ! Compute radial profile of primary beam beyond Map limits
  uvmax = head%gil%basemax * freq * f_to_k
  dr = 1./(2.*uvmax)
  !
  nr = 1.2*(rmax/dr)
  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.gt.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) 
        return
      endif
    endif
  endif
  ! Get or Check beam size
  call get_bsize(head,rname,' ',bsize,error) 
  !
  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
!
