subroutine solve_tp(line,error)
  use gildas_def
  use gkernel_interfaces
  use classic_api  
  !---------------------------------------------------------------------
  ! Antenna based.
  ! SOLVE arg /TOTAL /FIX /PLOT /COMPRESS
  ! option numbers
  !      1  /PLOT
  !                      (plot data and fit)
  !      6  /COMPRESS
  !                      (used to improve SNR and combine beam switch states)
  !     11  /FIX parameter1 value1 parameter2 value2 ...
  !                      ( to fix parameters)
  !     12  /TOTAL       (is there)
  !         /OUT
  !---------------------------------------------------------------------
  character(len=*) :: line          !
  logical :: error                  !
  ! Global
  external :: fitfcn
  include 'clic_parameter.inc'
  include 'clic_clic.inc'
  include 'clic_display.inc'
  include 'gbl_pi.inc'
  include 'clic_par.inc'
  include 'clic_xy_code.inc'
  include 'gbl_memory.inc'
  include 'clic_tpfit.inc'
  ! Local
  logical :: plot, weight, compress, check, out
  logical :: output, tpoint,print
  integer :: i, j, lwork, jb, nkey, old_pen, nch, iopt, itype
  integer :: type_pointing, type_focus, p_lun, q_lun, iout
  integer(kind=address_length) :: ipwork, ipfvec, ipr, ipwa, ipwa1
  integer(kind=address_length) :: ipwa2, ipwa3, ipwa4, ipiw, ipcheck, addr, mtype, my
  parameter (mtype=4, my=2)
  integer :: nvpar, lwa, ia, ib, ka, ix, nprint, info
  integer :: ldr, k, lc, kant, narg, ncoord(mtype)
  integer(kind=index_length) :: dim(4)
  real :: t0, l0(mdim), b0, t1, diam, rms, time_max, rarg, coll(2)
  real :: plate
  character(len=6) :: cpar(mpar,mtype),arg
  character(len=80) :: chain
  character(len=12) :: kw,argum
  character(len=12) :: ctype(mtype),yvocab(my)
  integer :: xy_par
  real*8 :: vpar(mpar), fsumsq, cj(mpar), denorm, epars(mpar)
  real*8 :: p0(mpar), y0, dy0(mpar), dy1, y, dy(mpar), tol, xx(mdim)
  real*8 :: d1mach, parant(mnant,mpar), eparant(mnant,mpar), freq
  save parant, eparant
  !
  parameter (check = .false.)
  !cc      parameter (check = .true.) !! for derivative calculation testing only
  data cpar /'AZ','EL','PEAK','WIDTH','ZERO','ASTIGM',   &
    'ZFOCUS','PEAK','WIDTH','ZERO',' ',' ',   &
    'XFOCUS','PEAK','WIDTH','ZERO',' ',' ',   &
    'YFOCUS','PEAK','WIDTH','ZERO',' ',' '/
  data ctype /'POINTING','FOCUS','XFOCUS','YFOCUS'/
  data ncoord /2,1,1,1/
  data yvocab/'TOTAL', 'T02'/
  !------------------------------------------------------------------------
  ! Code:
  call xsetf(0)
  lwork = 0
  tol = sqrt(d1mach(4))
  old_pen = -1
  !
  ! reset some defaults for plotting
  call check_index(error)
  if (error) return
  call get_first(.false.,error)
  if (error) return
  !
  ! First argument: type of fit
  call clic_kw(line,0,1,arg,nkey,ctype,mtype,.true.,error,.true.)
  if (error) return
  itype = nkey
  call message(6,1,'SOLVE_TP','Solve type is '//ctype(itype))
  print = sic_present(10,0)
  !
  ! /OUTPUT FLUX|OLD|NEW, /PRINT
  call file_point(line,output,p_lun,flux,q_lun,tpoint,error)
  !
  ! Fixed parameters (option 11)
  do i=1, mpar
    variable(i) = .true.
  enddo
  if (sic_present(11,0)) then
    i = 1
    nkey = 0
    do while (i.le.sic_narg(11))
      call sic_ch(line,11,i,arg,narg,.true.,error)
      if (error) return
      if (ichar(arg(1:1)).gt.ichar('9')) then
        call clic_kw(line,11,i,arg,nkey,   &
          cpar(1,itype),mpar,.true.,error,.true.)
        if (error) return
        variable(nkey) = .false.
        i = i+1
      elseif (nkey.gt.0) then
        call sic_r4(line,11,i,rarg,.true.,error)
        pars(nkey) = rarg
        i = i+1
        chain = cpar(nkey,itype)//' fixed to'
        lc = lenc(chain)
        write (chain(lc+1:),'(1x,1pg13.6)') pars(nkey)
        lc = lc + 14
        call message(6,1,'SOLVE_TP',chain(1:lc))
      endif
    enddo
  endif
  chain = 'Fitting'
  lc = 7
  do i=1, mpar
    if (variable(i)) then
      chain(lc+1:) = ' ' // cpar(i,itype)
      lc = lc + 1 +lenc(cpar(i,itype))
    endif
  enddo
  call message(6,1,'SOLVE_TP',chain(1:lc))
  !
  ! /COMPRESS option
  !c      compress = sic_present(6,0)
  !
  ! Get  a first one
  call get_first(.true.,error)
  if (error) goto 999
  compress = r_nswitch.gt.0
  !      print *, r_scaty
  !      print *, ctype(itype),r_scaty
  if ((itype.eq.3).or.(itype.eq.4)) then
    if (r_scaty.eq.11) then
      itype = 3
    elseif (r_scaty.eq.12) then
      itype = 4
    endif
  endif
  !
  ! Plot and data description
  if (ctype(itype).eq.'POINTING') then
    fbeam = 1.5
    !
    ! Lambda, Beta in X
    ndim = 2
    if (n_x.ne.ndim) then
      n_x = ndim
      change_display = .true.
    endif
    if (i_x(1) .ne. xy_lambd) then
      i_x(1) = xy_lambd
      sm_x1(1) = '*'
      sm_x2(1) = '*'
      do_bin = .false.
      change_display = .true.
    endif
    if (i_x(2) .ne. xy_beta) then
      i_x(2) = xy_beta
      sm_x1(2) = '*'
      sm_x2(2) = '*'
      do_bin = .false.
      change_display = .true.
    endif
  else
    !
    ! Focus in X
    fbeam = 10.
    ndim = 1
    if (n_x.ne.ndim) then
      n_x = ndim
      change_display = .true.
    endif
    if (ctype(itype).eq.'FOCUS') then
      if (i_x(1) .ne. xy_focus) then
        i_x(1) = xy_focus
        sm_x1(1) = '*'
        sm_x2(1) = '*'
        do_bin = .false.
        change_display = .true.
      endif
    ! XFOCUS or YFOCUS: use lambda or beta
    elseif (ctype(itype).eq.'XFOCUS') then
      if (i_x(1) .ne. xy_lambd) then
        i_x(1) = xy_lambd
        sm_x1(1) = '*'
        sm_x2(1) = '*'
        do_bin = .false.
        change_display = .true.
      endif
    elseif (ctype(itype).eq.'YFOCUS') then
      if (i_x(1) .ne. xy_beta) then
        i_x(1) = xy_beta
        sm_x1(1) = '*'
        sm_x2(1) = '*'
        do_bin = .false.
        change_display = .true.
      endif
    endif
  endif
  !!      npar = ndim+3
  npar = ndim+4
  !
  ! Total Power in Y by default can be overridden in /TOTAL T02
  arg='TOTAL'
  call clic_kw(line,12,1,arg,nkey,yvocab,my,.false.,error,.true.)
  if (error) return
  call message(6,1,'SOLVE_TP','Y variable is '//yvocab(nkey))
  if (yvocab(nkey).eq.'TOTAL') then
    xy_par = xy_total
  elseif (yvocab(nkey).eq.'T02') then
    xy_par = xy_t02
  endif
  if (n_y.ne.1) then
    n_y = 1
    change_display = .true.
  endif
  if (i_y(1) .ne. xy_par) then
    i_y(1) = xy_par
    sm_y1(1) = '*'
    sm_y2(1) = '*'
    do_bin = .false.
    change_display = .true.
  endif
  call switch_antenna
  !
  call set_display(error)
  if (error) return
  !
  ! plot all scans in index, UNsorted, plot buffer re-initialized.
  if (compress) then
    call read_data('COMPRESS',.false.,.true., error)
  else
    call read_data('ALL',.false.,.true., error)
  endif
  plotted = .false.
  if (error) return
  change_display = .false.
  plot = sic_present(1,0)
  weight = sic_present(2,0)
  if (plot) then
    clear = .true.
    if (.not. plotted) call sub_plot('A',.false.,.false.,0,error)
    if (error) return
    plotted = .true.
    old_pen = gr_spen (1)
    call gr_segm('FIT',error)
  endif
  !cc      return
  !cc 1999 continue
  !
  ! Get storage:
  !
  do i=1, npar
    epars(i) = 0
  enddo
  np = n_data(1)
  nb = m_boxes
  if (np.eq.0) goto 999
  lwa = npar*(np+5) + np
  lwork = 6*np + 2*lwa + 2*npar*np + 7*npar
  if (sic_getvm(lwork,addr) .ne. 1) goto 999
  ipwork = gag_pointer(addr, memory)
  !
  ipfvec = ipwork
  ipwa = ipfvec + 2*np
  ipr = ipwa + 2*lwa
  ipwa1 = ipr + 2*npar*np
  ipwa2 = ipwa1 + 2*npar
  ipwa3 = ipwa2 + 2*npar
  ipwa4 = ipwa3 + 2*npar
  ipiw = ipwa4 + npar
  ipcheck = ipiw + 4*np
  if (ipcheck-ipwork .ne. lwork) goto 999
  !
  ipx = gag_pointer(data_x,memory)
  ipy = gag_pointer(data_y,memory)
  ipw = gag_pointer(data_w,memory)
  ipfvec = ipwork
  !
  ! Get beam size
  if (r_presec(alma_sec)) then
    diam = r_dishdiameter(1)
  else
    call get_diameter(r_teles, diam)
  endif
  print *, 'diameter ',diam
  ! this is the half power  beam size - or width of focus curve
  freq = r_flo1 + r_isb*r_fif1
  if (ctype(itype) .eq. 'POINTING') then
    beam = 41*(115000./freq)*(15./diam)
    print *, 'Estimated beam size ',beam, ' arc sec.'
  elseif (ctype(itype) .eq. 'FOCUS') then
    beam = 4.2*sqrt(95000./freq)   ! IS THIS TRUE ?
    print *, 'Estimated width of focus curve ',beam, ' mm.'
  elseif (ctype(itype) .eq. 'XFOCUS' .or.   &
    ctype(itype) .eq. 'YFOCUS') then
    beam = 21.5*sqrt(95000./freq)  ! IS THIS TRUE ?
    print *, 'Estimated width of focus curve ',beam, ' mm.'
    plate = 33.5
    if (ctype(itype) .eq. 'YFOCUS') plate=-plate
    beam = beam*abs(plate)
    print *, '(converted into ',beam, ' arc sec.)'
  endif
  !
  ! /PRINT option
  if (q_lun.ne.0) then
    if (r_scaty.eq.1) then
      call check_scan(q_lun,r_scan,'Focus')
    else
      call check_scan(q_lun,r_scan,'Pointing')
    endif
  endif
  !
  ! Indentify box numbers
  antenna: do jb = 1, n_base
    ia = - i_base(jb)
    if (.not.r_mobil(ia)) then
      exit antenna
    endif
    do i=1, ndim
      ibx(i) = 0
    enddo
    do ib=1, n_boxes
      if (jb.eq.k_base(ib)) then
        ix = i_x(k_x(ib))
        if (ix.eq.xy_lambd   &
          .or. ix.eq.xy_focus   &
          .or.   &
          (ix.eq.xy_beta.and.ctype(itype).eq.'YFOCUS'))   &
          then
          ibx(1) = ib
        elseif (ix.eq.xy_beta) then
          ibx(2) = ib
        endif
      endif
    enddo
    !         print *, '(ibx(i),i=1, ndim)'
    !         print *, (ibx(i),i=1, ndim)
    if (ibx(1).eq.0) goto 999
    !
    ! Guess parameters
    call guess_tp(l0, t0, t1, error)
    if (error) return
    do k=1, ndim
      if (variable(k)) pars(k) = l0(k)
    enddo
    k = ndim+1
    if (variable(k)) pars(k) = t1
    k = k+1
    if (variable(k)) pars(k) = beam
    k = k+1
    if (variable(k)) pars(k) = t0
    k = k+1
    if (variable(k)) pars(k) = 1.d0
    nvpar = 0
    !         print *, '(pars(k), k=1, ndim)'
    !         print *, (pars(k), k=1, ndim)
    !
    ! Check derivatives
    if (check) then
      xx(1) = 0.
      xx(2) = 0.
      call gmodel(xx, pars, y, dy)
      do i=1, npar
        p0(i) = pars(i)
        dy0(i) = dy(i)
        y0 = y
      enddo
      do i=1, npar
        pars(i) = p0(i)*1.001d0
        call gmodel(xx, pars, y, dy)
        dy1 = (y-y0)/(pars(i)-p0(i))
        !               print *, 'TEST', i, dy0(i), dy1
        pars(i) = p0(i)
      enddo
    endif
    !
    do i=1, npar
      if (variable(i)) then
        nvpar = nvpar+1
        vpar(nvpar) = pars(i)
      endif
    enddo
    nprint = -1
    !         print *, '(pars(k), k=1, ndim)'
    !         print *, (pars(k), k=1, ndim)
    !         print *, (vpar(k), k=1, nvpar)
    !
    iopt=2                     ! full jacobian
    !cc         iopt = 1               ! no jacobian
    !         print *, 'call dnls1e'
    call dnls1e(fitfcn,   &    ! function
      iopt,   &                ! jacobian code
      np,   &                  ! number of points
      nvpar,   &               ! number of fitted parameters
      vpar,   &                ! fitted parameters
      memory(ipfvec),   &      !
      tol,   &
      nprint,   &
      info,   &                ! error code
      memory(ipiw),   &
      memory(ipwa),   &
      lwa)
    !
    if (info.eq.0) then
      print *,'F-DNLS1E, improper input parameters, info= ',   &
        info
    elseif (info.eq.6 .or. info.eq.7) then
      print *,'F-DNLS1E, TOL too small, info= ',info
    elseif (info.eq.5) then
      print *,'F-DNLS1E, not converging, info= ',info
    elseif (info.eq.4) then
      print *,'W-DNLS1E, FVEC orthog. to Jacob. col., info= ',   &
        info
    endif
    fsumsq  = denorm(np, memory(ipfvec))
    !
    ldr = np
    !         print *, 'call dcov'
    call dcov (fitfcn,   &
      iopt,   &
      np,   &
      nvpar,   &
      vpar,   &
      memory(ipfvec),   &
      memory(ipr),   &
      ldr,   &
      info,   &
      memory(ipwa1),   &
      memory(ipwa2),   &
      memory(ipwa3),   &
      memory(ipwa3))
    if (info.eq.0) then
      print *,'F-DCOV, improper input parameters, info= ',info
    elseif (info.eq.2) then
      print *,'W-DCOV, Jacobian singular, info= ',info
    endif
    !
    ! extract the diagonal of r
    call diagonal(np, nvpar, memory(ipr), cj)
    rms = fsumsq*dsqrt(np*1d0)
    kant = r_kant(ia)
    write(chain,'(a,1x,i0,a,f10.4,a)') 'Ant',kant,' r.m.s.= ',rms,   &
      ' units of '//clab(i_y(1))
    lc = lenc(chain)
    call message(6,1,'SOLVE_TP',chain(1:lc))
    k = 0
    do i=1, npar
      write(chain,'(a4,i0,1x,a5)') 'Ant ',kant, cpar(i,itype)
      lc = 12
      if (variable(i)) then
        k = k+1
        pars(i) = vpar(k)
        epars(i) = sqrt(abs(cj(k)))
        if (cpar(i,itype).eq.'XFOCUS'   &
          .or. cpar(i,itype) .eq. 'YFOCUS'   &
          .or. (cpar(i,itype) .eq. 'WIDTH'   &
          .and. (ctype(itype) .eq. 'XFOCUS'   &
          .or. ctype(itype) .eq. 'YFOCUS')))   &
          then
          write(chain(lc+1:),1000) pars(i)/plate,   &
            '(',epars(i)/abs(plate),')'
          parant(ia,i) = pars(i)/plate
          eparant(ia,i) = epars(i)/abs(plate)
        else
          write(chain(lc+1:),1000) pars(i), '(',epars(i),')'
          parant(ia,i) = pars(i)
          eparant(ia,i) = epars(i)
        endif
1000    format(1x,f8.3,1a,f5.3,1a)
      else
        epars(i) = 0
        eparant(ia,i) = 0
        if (cpar(i,itype).eq.'XFOCUS'   &
          .or. cpar(i,itype) .eq. 'YFOCUS'   &
          .or. (cpar(i,itype) .eq. 'WIDTH'   &
          .and. (ctype(itype) .eq. 'XFOCUS'   &
          .or. ctype(itype) .eq. 'YFOCUS')))   &
          then
          write(chain(lc+1:),1001) pars(i)/plate, '(fixed)'
          parant(ia,i) = pars(i)/plate
        else
          write(chain(lc+1:),1001) pars(i), '(fixed)'
          parant(ia,i) = pars(i)
        endif
1001    format(1x,f8.3,7a)
      endif
      lc = lenc(chain)
      call message(6,1,'SOLVE_TP',chain(1:lc))
    enddo
    ! use message ...
    if (plot) then
      call plot_fittp(error)
    endif
    !
    ! Optionally write result file for POINT / TPOINT
    !
    if (output .and. r_mobil(ia)) then
      coll(1) = r_collaz(ia)
      coll(2) = r_collel(ia)
      ! (tpoint use only valid for one antenna...)
      if (tpoint) then
        write(p_lun,2003)   &
          r_num, r_scan, r_ut*12d0/pi,   &
          pars(1), epars(1), pars(2), epars(2),   &
          pars(3), epars(3),   &
          pars(4), epars(4), r_sourc
2003    format('!',2i5, f6.2, 8f8.2, 1x, a12)
        write(p_lun,2002)   &
          r_az*180d0/pi, r_el*180d0/pi,   &
          r_az*180d0/pi+(pars(1)+coll(1))/cos(r_el)/3600.d0,   &
          r_el*180d0/pi+(pars(2)+coll(2))/3600.d0
2002    format(3(1x,f10.5,','),1x,f10.5)
      else
        do i=1, 2
          write(p_lun,2001)   &
            r_num, r_scan, 2-i,   &
            r_az*180d0/pi, r_el*180d0/pi, r_ut*12d0/pi,   &
            r_kant(ia), r_istat(ia),   &
            pars(i)+coll(i), epars(i),   &
            pars(4), epars(4),   &
            pars(3), r_sourc, pars(i)
        enddo
2001    format(1x,i8,i6,i4,3(2x,f8.3),1x,2i4,   &
          2(f9.2,' ',f8.2,'  '),g10.3,2x,'''',a,''' ',f9.2)
      endif
    endif
    if (print) then
      if (ctype(itype) .eq. 'POINTING') then
        write(q_lun,3002) pars(1),pars(2),kant
3002    format('CORRECTION ',f6.1,1x,f6.1,' /ANTENNA ',i0)
      elseif (ctype(itype) .eq. 'FOCUS') then
        write(q_lun,3001) pars(1),kant
3001    format('CORRECTION * * ',f6.2,' /ANTENNA ',i0)
      endif
    endif
  enddo antenna
  ! Variables
  do i=1, npar
    call sic_delvariable('F_'//cpar(i,itype),.false.,error)
    call sic_delvariable('E_'//cpar(i,itype),.false.,error)
    dim(1)=mnant
    dim(2)= 1
    dim(3) = 1
    dim(4) = 1
    call sic_def_dble('F_'//cpar(i,itype),parant(1,i),1,dim,   &
      .false., error)
    call sic_def_dble('E_'//cpar(i,itype),eparant(1,i),1,dim,   &
      .false.,error)
  enddo
  !
998 if (output) then
    !         print *, 'close ',p_lun
    close(unit=p_lun)
    call sic_frelun(p_lun)
  endif
  if (print) then
    close(unit=q_lun)
    call sic_frelun(q_lun)
  endif
  if (lwork.gt.0) call free_vm(lwork,addr)
  if (old_pen.ne.-1)  then
    call gr_segm_close(error)
    i = gr_spen(old_pen)
  endif
  return
  !
999 error = .true.
  goto 998
end subroutine solve_tp
!
subroutine fitfcn(iflag,m,nvpar,x,f,fjac,ljc)
  use gildas_def
  !---------------------------------------------------------------------
  ! FCN is called by DNLS1E
  !
  !     IFLAG   Integer    Code for print out                Input
  !     M       Integer    Number of data points             Input
  !     NVPAR   Integer    Number of variable parameters     Input
  !     X       Real*8     Variable Parameters               Input
  !     F       Real*8     Function value at each point      Output
  !     FJAC    Real*8     Partial derivatives of F          Output
  !     LJC     Integer    First dimension of FJAC           Input
  !
  ! replacing     SUBROUTINE LSFUN2(M, NVPAR, X, F, FJAC, LJC)
  !---------------------------------------------------------------------
  integer :: iflag                  !
  integer :: m                      !
  integer :: nvpar                  !
  real*8 :: x(nvpar)                !
  real*8 :: f(m)                    !
  integer :: ljc                    !
  real*8 :: fjac(ljc,nvpar)         !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_display.inc'
  include 'gbl_memory.inc'
  include 'clic_tpfit.inc'
  ! Local
  integer :: k, i, l, j, kpar, iif, kvpar
  real*8 :: xx(mdim), tt, ww, ll(mdim), act, y, dy(mpar), denorm, sw
  real*8 :: rr
  !------------------------------------------------------------------------
  k = 1
  sw = 0
  !
  ! Put the variable parameters in PARS (already including the fixed ones)
  kvpar = 1
  do j=1, npar
    if (variable(j)) then
      pars(j) = x(kvpar)
      kvpar = kvpar+1
    endif
  enddo
  do i=1, np
    !
    ! Get total power
    call gettotal(m_data, m_boxes,   &
      memory(ipx), memory(ipy), memory(ipw),   &
      i, ll, tt, ww)
    rr = 0
    do l=1, ndim
      rr = rr+ll(l)**2
    enddo
    rr = sqrt(rr)
    !
    ! fit out to 1.5 beam radius only
    !         if (rr.gt.beam*fbeam) then
    !            ww = 0
    !         endif
    !
    if (iflag.le.1) then
      f(k) = -tt
    elseif (iflag.eq.2) then
      do l=1, nvpar
        fjac(k,l) = 0
      enddo
    endif
    !
    ! Compute F and FJAC from model
    call gmodel(ll, pars, y, dy)
    kvpar = 1
    if (iflag.le.1) then
      f(k) = f(k) + y
    elseif (iflag.eq.2) then
      do l = 1, mpar
        if (variable(l)) then
          fjac(k,kvpar) = fjac(k,kvpar) + dy(l)
          kvpar = kvpar+1
        endif
      enddo
    endif
    !
    ! Weight appropriately:
    !
    if (iflag.le.1) then
      f(k) = f(k)*ww
    elseif (iflag.eq.2) then
      do l=1, nvpar
        fjac(k,l) = fjac(k,l)*ww
      enddo
    endif
    k = k + 1
    sw = sw + ww
  enddo
  !
  ! In the end: normalize by the sum of weights.
  k = 1
  do i=1, np
    if (iflag.le.1) then
      f(k) = f(k)/sw
    elseif (iflag.eq.2) then
      do l=1, nvpar
        fjac(k,l) = fjac(k,l)/sw
      enddo
    endif
    k = k + 1
  enddo
  if (iflag.eq.0) then
    print 1000, (x(i), i=1, nvpar), denorm(k-1,f)
1000 format (10(1pg19.12))
  endif
  return
end subroutine fitfcn
!
subroutine gettotal(mp, mb, xd, yd, wd,   &
    i, ll, tt, ww)
  use gildas_def
  !---------------------------------------------------------------------
  !     Obtain U, V, and the visibility from the array UVRIW.
  !
  !     Np     Integer     Number data points        Input
  !     Nb     Integer     Number of boxes            Input
  !     xd     real        X data plot array
  !     yd     real        Y data plot array
  !     ibl    integer     box number of lambda       Input
  !     ibb    integer     box number of beta         Input
  !     i      integer     point nmber                Input
  !
  !     ll     Real*8      Lambda coord.              Output
  !     bb     Real*8      Beta   coord.              Output
  !     tt     Real*8      Total Power                Output
  !     ww     Real*8      Weight                     Output
  !---------------------------------------------------------------------
  include 'clic_tpfit.inc'
  integer :: mp                     !
  integer :: mb                     !
  real :: xd(mp, mb)                !
  real :: yd(mp, mb)                !
  real :: wd(mp, mb)                !
  integer :: i                      !
  real*8 ::  ll(mdim)               !
  real*8 ::  tt                     !
  real*8 ::  ww                     !
  ! Local
  integer :: k
  !-----------------------------------------------------------------------
  do k=1, ndim
    ll(k) = xd(i, ibx(k))
  enddo
  tt = yd(i, ibx(1))
  ww = wd(i, ibx(1))
  return
end subroutine gettotal
!
subroutine diagonal(m,n,r,c)
  integer :: m                      !
  integer :: n                      !
  real*8 :: r(m,n)                  !
  real*8 :: c(n)                    !
  ! Local
  integer :: i
  do i=1, n
    c(i) = r(i,i)
  enddo
end subroutine diagonal
!
subroutine guess_tp(x0, t0, t1, error)
  use gildas_def
  include 'clic_tpfit.inc'
  real :: x0(mdim)                  !
  real :: t0                        !
  real :: t1                        !
  logical :: error                  !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_display.inc'
  include 'gbl_memory.inc'
  ! Local
  real :: xx0(mdim)
  integer :: i, k
  real*8 :: s_w, s_wt, s_wt2, s_wf, s_wf2, s_wx(mdim), s_wxt(mdim)
  real*8 :: xx(mdim), tt, ww, ff, rr2, b2, cx(mdim)
  ! Code
  s_w = 0
  s_wt = 0
  s_wf = 0
  s_wt2 = 0
  s_wf2 = 0
  do k= 1, ndim
    s_wx(k) = 0
    s_wxt(k) = 0
  enddo
  !
  ! estimate  total power offset  and flux, and position(s)
  ! beam is assumed known at this point
  ! get center in all dimensions
  do i=1, np
    call gettotal(m_data, m_boxes,   &
      memory(ipx), memory(ipy), memory(ipw),   &
      i, xx, tt, ww)
    do k=1, ndim
      s_wx(k) = s_wx(k) + ww*xx(k)
    enddo
    s_w = s_w + ww
  enddo
  if (s_w .le. 0) then
    error = .true.
    call message (8,3,'GUESS_TP','Sum of weights <= zero')
    return
  endif
  do k=1, ndim
    cx(k) = s_wx(k)/s_w
    !         print *, k, cx(k)
    s_wx(k) = 0
  enddo
  !
  ! circular range of estimation
  b2 = (beam*fbeam)**2
  do i=1, np
    call gettotal(m_data, m_boxes,   &
      memory(ipx), memory(ipy), memory(ipw),   &
      i, xx, tt, ww)
    !
    rr2 = 0
    do k=1, ndim
      xx(k) = xx(k) - cx(k)
      rr2 = rr2 + xx(k)**2
    enddo
    if (rr2.le.b2) then
      ff = exp(-4*log(2.)*rr2/beam**2)
      s_wf = s_wf + ww*ff
      s_wf2 = s_wf2 + ww*ff*ff
      s_wt = s_wt + ww*tt
      s_wt2 = s_wt2 + ww*tt*tt
      s_w = s_w + ww
      do k=1, ndim
        s_wx(k) = s_wx(k) + ww*xx(k)
        s_wxt(k) = s_wxt(k) + ww*xx(k)*tt
      enddo
    endif
  enddo
  if (s_w .le. 0) then
    error = .true.
    call message (8,3,'GUESS_TP','Sum of weights <= zero')
    return
  endif
  t1 = (s_wt2*s_w - s_wt**2) / (s_wf2*s_w - s_wf**2)
  t1 = sqrt(abs(t1))
  t0 = (s_wt - t1*s_wf) / s_w
  !      print *, 't0, t1 ', t0, t1
  do k=1, ndim
    x0(k) = (s_wxt(k) - t0 * s_wx(k)) / (s_wt - t0*s_w) + cx(k)
  !         print *, 'k, x0(k) ', k, x0(k)
  enddo
  return
end subroutine guess_tp
!*
subroutine gmodel(xx, par, y, dy)
  use gildas_def
  !---------------------------------------------------------------------
  ! Function is
  !     t0 + t1 * exp (-4.*log(2.)*((xx-x0)**2+(yy-y0)**2)*ast**2)/beam**2
  ! pars are:
  !
  !     1 x0       x position
  !     2 y0       y position [optional]
  !     3 t1       amplitude (peak-offset)
  !     4 beam     half-power beam
  !     5 t0       amplitude offset
  !     6 ast      beam ratio y/x
  !---------------------------------------------------------------------
  include 'clic_tpfit.inc'
  real*8 :: xx(mdim)                !
  real*8 :: par(6)                  !
  real*8 :: y                       !
  real*8 :: dy(6)                   !
  ! Global
  real*8 :: z_exp
  ! Local
  !      integer ndim
  real*8 :: c, d, e, f, a
  integer :: kx(mdim), kt1, kw, kt0, k, i, kast
  !--------------------------------------------------------------------------
  !
  k = 1
  do i=1, ndim
    kx(i) = k
    k = k+1
  enddo
  kt1 = k                      ! amplitude
  k = k+1
  kw = k                       ! width
  k = k+1
  kt0 = k                      ! zero
  k = k+1
  kast = k                     ! zero
  c = 4.*log(2.)
  d = 0
  a = 1.d0
  do i=1, ndim
    if (i.eq.2) a = par(kast)
    d = d + ((xx(i)-par(kx(i)))*a)**2
  enddo
  e = par(kw)**2
  if (e.eq.0) return
  f = z_exp(-c*d/e)
  y = par(kt1) * f
  a = 1.d0
  do i = 1, ndim
    if (i.eq.2) a = par(kast)
    dy(kx(i)) = 2 * c / e * (xx(i)-par(kx(i))) * a**2 * y
  enddo
  dy(kt1) = f
  dy(kw) = par(kw) * 2*c*d/e**2 * y
  if (ndim.gt.1) then
    dy(kast) = - 2*c/e * par(kast) * (xx(2)-par(kx(2)))**2 * y
  endif
  y = y + par(kt0)
  dy(kt0) = 1.
  return
end subroutine gmodel
!
subroutine get_diameter(telescope,diam)
  character(len=12) :: telescope    !
  real *4 :: diam                   !
  ! Global
  include 'clic_panels.inc'
  !
  if (telescope.eq.'VTX-ALMATI') then
    write(6,*) 'I-GET_DIAMETER, ALMA Vertex 12m Antenna '
    call set_panels(type_vx12m)
  elseif (telescope.eq.'AEC-ALMATI') then
    write(6,*) 'I-GET_DIAMETER, ALMA AEC 12m Antenna '
    call set_panels(type_vx12m)
  else
    write(6,*) 'I-GET_DIAMETER, IRAM/NOEMA 15-m Antenna '
    call set_panels(type_bure)
  endif
  diam = diameter
  return
end subroutine get_diameter
!
function z_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)
  return
end function z_exp
!
subroutine plot_fittp(error)
  use gkernel_interfaces
  use gildas_def
  !---------------------------------------------------------------------
  ! Plot total power fit.
  !---------------------------------------------------------------------
  logical :: error                  !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_display.inc'
  include 'gbl_memory.inc'
  include 'clic_tpfit.inc'
  ! Local
  integer :: nn, ib(2), i, j, k
  parameter (nn=100)
  real*4 :: xx(nn), yy(nn), xmin, xmax, dx
  real*8 :: ll(mdim), bb, tt, dy(mpar)
  character(len=4) :: chain
  !---------------------------------------------------------------------------
  ! Code
  !
  ! ndim boxes:
  do i = 1, ndim
    write(chain,'(i4.4)') ibx(i)
    call gr_execl('CHANGE DIRECTORY BOX'//chain)
    error = gr_error()
    if (error) goto 999
    call sic_get_real ('USER_XMIN',xmin,error)
    call sic_get_real ('USER_XMAX',xmax,error)
    if (error) goto 999
    dx = (xmax-xmin)/(nn-1)
    do k = 1, nn
      xx(k) = xmin + (k-1)*dx
      do j=1, ndim
        if (j.eq.i) then
          ll(j) = xx(k)
        else
          ll(j) = 0.
        endif
      enddo
      call gmodel(ll, pars, tt, dy)
      yy(k) = tt
    enddo
    call gr4_connect (nn, xx, yy, 0.0d0, -1.0d0)
    call gr_execl('CHANGE DIRECTORY')
  enddo
  !
999 return
end subroutine plot_fittp
!
