subroutine solve_point(line,error)
  use gildas_def
  use gkernel_interfaces
  use classic_api
  !---------------------------------------------------------------------
  ! CLIC
  !	Support routine for command
  !	SOLVE POINT [BEAM] [/PLOT] [/OUTPUT File [OLD|NEW|PROC]]
  !              [/COMPRESS TIME_MAX]
  !	[/Store /Reset /Offset /Search] Not relevant here
  !---------------------------------------------------------------------
  character(len=*) :: line          !
  logical :: error                  !
  ! Global
  include 'gbl_memory.inc'
  include 'clic_parameter.inc'
  include 'clic_point.inc'
  ! Local
  logical :: plot, output, end, flu, tpoint
  real :: beam, lo1, bsize, time_max
  integer :: p_lun, q_lun
  integer :: icount, naddr, nant
  integer(kind=address_length) :: data_in, ip_data, iaddr
  integer(kind=data_length)    :: ldata_in
  !------------------------------------------------------------------------
  ! Code:
  iproc = 0
  naddr = 0
  iaddr = 0
  q_lun = 0
  output = .false.
  call check_input_file(error)
  if (error) goto 999
  call check_index(error)
  if (error) goto 999
  plot = sic_present(1,0)
  !
  ! /COMPRESS TIME_MAX option
  time_max = 4.0
  call sic_r4(line,6,1,time_max,.false.,error)
  if (error) goto 999
  !
  ! /OUTPUT FLUX|OLD|NEW, /PRINT
  call file_point(line,output,p_lun,flu,q_lun,tpoint,error)
  !
  ! Get beam size
  beam = -1.0                  ! fix to frequency dep. value
  call sic_r4(line,0,2,beam,.false.,error)
  if (error) goto 999
  !
  if (plot) call gr_exec1('TICKSPACE 0 0 0 0')
  !
  ! Get  a first one
  call get_first(.true.,error)
  if (error) goto 999
  end = .false.
  call check_point(error)
  do while (error .and. .not.end)
    call get_next(end,error)
    if (error) goto 999
    if (.not.end) call check_point(error)
  enddo
  if (error) goto 999
  icount = 0
  call get_data (ldata_in,data_in,error)
  if (error) goto 999
  ip_data = gag_pointer(data_in,memory)
  !
  call load_point (memory(ip_data),   &
    icount,iaddr,naddr,error,lo1,nant,time_max)
  if (error) goto 999
  call load_beam  (beam,bsize,lo1,nant)
  !
  ! Get next ones alike
  call get_next(end,error)
  if (error) goto 999
  do while (.not.end)
    call check_point(error)
    if (error) then
      if (icount.ne.0) then
        call sub_point (plot,output,p_lun,iaddr,naddr,q_lun,   &
          error,bsize,flu,end)
        icount = 0
        if (error) goto 998
        call free_vm  (naddr,iaddr)
        naddr = 0
        iaddr = 0
      endif
    elseif (icount.eq.0) then
      call get_data (ldata_in,data_in,error)
      if (error) goto 999
      ip_data = gag_pointer(data_in,memory)
      call load_point (memory(ip_data),   &
        icount,iaddr,naddr,error,lo1,nant,time_max)
      if (error) goto 998
      call load_beam  (beam,bsize,lo1,nant)
    else
      call get_data (ldata_in,data_in,error)
      if (error) goto 999
      ip_data = gag_pointer(data_in,memory)
      call load_point (memory(ip_data),   &
        icount,iaddr,naddr,error,lo1,nant,time_max)
      if (icount.eq.0) then
        call sub_point (plot,output,p_lun,iaddr,naddr,q_lun,   &
          error,bsize,flu,end)
        if (error) goto 998
        call free_vm(naddr,iaddr)
        naddr = 0
        iaddr = 0
        call load_point (memory(ip_data),   &
          icount,iaddr,naddr,error,lo1,nant,time_max)
        if (error) goto 998
      endif
      call load_beam  (beam,bsize,lo1,nant)
    endif
    call get_next(end,error)
    if (error) goto 999
    if (sic_ctrlc()) goto 999
  enddo
  !
  if (icount.ne.0) then
    call sub_point (plot,output,p_lun,iaddr,naddr,q_lun,   &
      error,bsize,flu,end)
    call free_vm(naddr,iaddr)
    naddr = 0
    iaddr = 0
  endif
  !
  goto 998
  !
999 error = .true.
998 if (output) then
    close(unit=p_lun)
    call sic_frelun(p_lun)
  endif
  if (naddr.ne.0 .and. iaddr.ne.0) then
    call free_vm(naddr,iaddr)
    iaddr = 0
    naddr = 0
  endif
  if (q_lun.ne.0) then
    close (unit=q_lun)
    call sic_frelun(q_lun)
  endif
2000 format(   &
    '!   Obs.#   Scan Code Azimuth   Elevation   Time  ',   &
    '     Position  ..        Width      ..     Intensity',   &
    '     Sigma    Source')
2010 format(   &
    '!   Obs.#  Scan Code Azimuth   Elevation  Time  ',   &
    '     Position  ..  A#     Width      ..     Intensity',   &
    '     ..  Gain   Fsignal  Fimage Source  Date')
2001 format(a)
2003 format(a,a,a)
end subroutine solve_point
!
subroutine check_point(error)
  use classic_api  
  !---------------------------------------------------------------------
  ! CLIC
  !	Check if data is a pointing scan
  !---------------------------------------------------------------------
  logical :: error                  !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  include 'clic_clic.inc'
  include 'clic_point.inc'
  ! Code:
  if (r_proc.ne.16) then
    call message(6,3,'POINT','Scan is not a pointing measurement')
    error = .true.
    return
  endif
  iauto = 0
end subroutine check_point
!
subroutine load_point (data,   &
    icount,jaddr,naddr,error,lo1,nant,time_max)
  use gildas_def
  use gkernel_interfaces
  use classic_api  
  !---------------------------------------------------------------------
  ! CLIC
  !	Support routine for SOLVE POINTING
  !	Measure antenna pointing position from a specialised
  !	routine in the real-time acquisition system
  ! Arguments:
  !     DATA      *      Data array
  !	ICOUNT	I	Subscan number 0 : not loaded
  !	JADDR	I	Array address
  !	NADDR	I	Array length
  !	LO1	R*4 	LO1 frequency
  !	NANT	I	Number of antennas
  !       TIME_MAX R*4    Max. integration time (compression)
  !---------------------------------------------------------------------
  real :: data(*)                        !
  integer :: icount                      !
  integer(kind=address_length) :: jaddr  !
  integer :: naddr                       !
  logical :: error                       !
  real :: lo1                            !
  integer :: nant                        !
  real :: time_max                       !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  include 'clic_clic.inc'
  include 'clic_point.inc'
  include 'gbl_memory.inc'
  ! Local
  integer(kind=address_length) :: iaddr, visi, posi, weig
  integer :: i, k1, kp1, kv1, kw1, mdump, msub
  real :: weight_factor, seuil
  save mdump
  real*8 :: fnu, ff, size(3)
  character(len=132) :: chain
  !
  ! Process up to msub subscan
  msub = 10  
  !
  ! Compute threshold and weight
  error = .false.
  seuil = 40.0                 ! Big displacement is bad
  weight_factor = 0.1          ! and really bad
  if (icount.ne.0 .and.   &
    (r_scan.ne.iscan  .or. r_scaty.ne.icode)) then
    icount = 0
    return
  endif
  !
  ! Compress (to time_max)
  if (icount.eq.0) mdump = r_ndump
  !      CALL COMPRESS(TIME_MAX, 7.5, DATA, NOUT,ERROR)
  !      IF (ERROR) GOTO 999
  !      R_NDUMP = MIN(NOUT,MDUMP)
  !      CALL LOOSE_DATA
  !
  if (icount.eq.0) then
    iscan = r_scan
    icode = r_scaty
    lo1   = r_flo1
    nfix = 0
    nmob = 0
    nant = r_nant
    do i=1,r_nant
      if (r_mobil(i)) then
        nmob = nmob+1
        imob(nmob) = i
      else
        nfix = nfix+1
        ifix(nfix) = i
      endif
      if (r_scaty.eq.2) then
        coll(i) = r_collaz(i)
      elseif (r_scaty.eq.3) then
        coll(i) = r_collel(i)
      elseif (r_scaty.eq.1) then
        coll(i) = r_corfoc(i)
      endif
      kant(i) = r_kant(i)
      istat(i) = r_istat(i)
    enddo
    source = r_sourc
    az = r_az
    el = r_el
    ut = r_ut
    mp = msub*mdump
    a_flux = r_flux
    fnu = r_restf * 1d-3
    call planet_flux (source,r_dobs,r_ut,   &
      fnu,ff,a_flux,size,error)
    !
    ! Get storage for up to 8 subscans like that one...
    !	IADDR (MP,3,NMOB)
    !
    naddr = mp*3*nmob + mdump*r_nant*3
    if (sic_getvm(naddr,jaddr).ne.1) goto 999
    np = 0
  endif
  !
  ! Check overflow
  if (icount.ge.msub) then
    write (chain,'(A,I0,A)') 'Can process only up to ',msub,' subscans'
    call message (6,3,'LOAD_POINT',chain(1:lenc(chain)))
    error = .true.
    return
  endif
  !
  ! Read visibilities and positions
  iaddr = gag_pointer(jaddr,memory)
  visi = iaddr + 3*mp*nmob
  posi = visi + mdump*r_nant
  weig = posi + mdump*r_nant
  call fill_visi_posi (mdump, r_nbas, r_nant,   &
    memory(visi),memory(posi),memory(weig),time_max,data,error)
  if (error) goto 999
  !
  ! Put in final array
  do i=1,nmob
    k1 = (imob(i)-1)*mdump
    kp1 = mdump*(3*msub*(i-1)+icount)
    kv1 = mdump*(3*msub*(i-1)+msub+icount)
    kw1 = mdump*(3*msub*(i-1)+2*msub+icount)
    call r4tor4 (memory(posi+k1),memory(iaddr+kp1),mdump)
    call r4tor4 (memory(visi+k1),memory(iaddr+kv1),mdump)
    call r4tor4 (memory(weig+k1),memory(iaddr+kw1),mdump)
  enddo
  icount = icount+1
  np = np+mdump
  return
  !
999 error = .true.
end subroutine load_point
!
subroutine sub_point (plot,out,iout,jaddr,naddr,qlun,   &
    error,beam,flu,end)
  use gildas_def
  use gkernel_interfaces
  use classic_api  
  !---------------------------------------------------------------------
  ! CLIC
  !	Support routine for SOLVE POINTING/PLOT
  !	Measure antenna pointing position from a specialised
  !	routine in the real-time acquisition system
  ! Arguments:
  !	PLOT	L	Plot data and fit
  !	OUT	L	Write fit on output file
  !	IOUT	I	Output logical unit
  !	JADDR	I	Work space address
  !	NADDR	I	Work space length
  !	ERROR	L	Logical error flag
  !	BEAM	R*4	Beam size (radian)
  !     flu      L       Special format for flux determination.
  !     end      L       Means this is the last scan in the index
  !---------------------------------------------------------------------
  logical :: plot                        !
  logical :: out                         !
  integer :: iout                        !
  integer(kind=address_length) :: jaddr  !
  integer :: naddr                       !
  integer :: qlun                        !
  logical :: error                       !
  real :: beam                           !
  logical :: flu                         !
  logical :: end                         !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_clic.inc'
  include 'gbl_pi.inc'
  include 'clic_point.inc'
  include 'clic_par.inc'
  include 'gbl_memory.inc'
  ! Local
  integer(kind=address_length) :: iaddr, posi, gain, weig
  integer :: i, n, j
  real :: dfo(mnant),efo(mnant),ofo(mnant),maxefo
  real :: focus,weigh,tan_el
  real :: par(3), err(3), daz(mnant), del(mnant), refraction(3)
  real :: qaz(mnant), qel(mnant), eaz(mnant), eel(mnant), ref_corr
  real :: effaz(mnant), effel(mnant), widaz(mnant), widel(mnant)
  integer :: lant(mnant), jant, nant, tant
  integer(kind=index_length) :: dim(2)
  character(len=12) :: answer
  character(len=132) :: chain
  character(len=6) :: sca(3)
  character(len=24) :: limit
  logical :: clear
  integer :: dummy
  real*8 :: fnu, size(3), ff, tt, eff
  ! Data
  data sca /'Focus','Azim.','Elev.'/
  !
  ! Compulsory SAVE statement
  save daz,del,lant,nant,qaz,qel,effaz,effel, widaz, widel
  !
  if (iauto.eq.0) then
    limit = 'LIMITS * * 0 *'
  else
    limit = 'LIMITS'
  endif
  !
  ! Find pointing parameters position
  clear = icode.le.2
  if (clear) nant = 0
  !
  iaddr = gag_pointer(jaddr,memory)
  do i=1,nmob
    posi = iaddr + 3*(i-1)*mp
    gain = posi + mp
    weig = gain + mp
    write (chain,1004) iscan, r_nrec, source, a_flux, az*180.d0/pi,   &
      el*180.d0/pi,' " 9 /BOX 7'
    if (plot) then
      call plot_point (nmob,i,kant(imob(i)),icode,clear,   &
        'DRAW TEXT 0 0.2 "'//chain(1:lenc(chain)),   &
        np,memory(gain),memory(posi),memory(weig),   &
        limit)
      clear = .false.
    endif
    call fit_point (np,   &
      memory(gain),memory(posi),memory(weig),   &
      par,err,beam,error)
    if (.not.error) then
      if (plot) then
        call pro_point(error)
      endif
      jant = kant(imob(i))     ! Physically connected antenna
      tant = 0
      do j=1,nant
        if (jant.eq.lant(j)) tant = j
      enddo
      if (tant.eq.0) then
        nant = nant+1
        lant(nant) = jant
        tant = nant
      endif
      !
      ! Write Results
      write (chain,1001) sca(icode), iscan, source, az*180.d0/pi,   &
        el*180.d0/pi
      call message(6,1,'SUB_POINT',chain(1:lenc(chain)))
      write (chain,1002) kant(imob(i)), (par(j),j=1,3)
      call message(6,1,'SUB_POINT',chain(1:lenc(chain)))
      write (chain,1003) kant(imob(i)), (err(j),j=1,3)
      call message(6,1,'SUB_POINT',chain(1:lenc(chain)))
      if (out) then
        if (.not.flu) then
          call refrac(refraction)
          ref_corr = 0.0
          if (el.ne.0) then
            tan_el = tan(el)
            ref_corr = refraction(1)/tan_el &
               + refraction(2)/tan_el**3 &
               + refraction(3)/tan_el**5 
            ref_corr = ref_corr * 180.0/pi * 3600.0
          endif
          write(iout,2001) inum, iscan, 3-icode,   &
            az*180d0/pi, el*180d0/pi, ut*12d0/pi,   &
            kant(imob(i)), istat(imob(i)),   & ! Antenna Station
            par(2)+coll(imob(i)), err(2),   &  ! position
            par(2), par(3), err(3),   &
            par(1)/par(3)/1.064467, r_topwind, &
            r_topwindir*180.0/pi, r_humid, r_tamb, r_pamb, &
            refraction(1), refraction(2), refraction(3), &
            ref_corr, source
        else
          !
          ! For flux: compute error on intensity...
          !C NGRX: Give the Gain for the first polar...
          !C TODO Average??
          call datec (r_dobs,chain,error)
          write(iout,2011) r_num, iscan, 3-icode,   &
            az*180d0/pi, el*180d0/pi, ut*12d0/pi,   &
            par(2), err(2),   &    ! Position & error
            kant(imob(i)),   & ! Station
            par(3), err(3),   &    ! Width & error
            par(1)/par(3)/1.064467, err(1)/par(3)/1.064467,   &
            r_gim(1,imob(i)),   &
            r_restf*1e-3,   &
            (r_restf-2*r_isb*r_fif1)*1e-3,   &
            source,chain(1:11)
        endif
        !
2011    format(1x,i8,i6,i3,3(1x,f8.3),1x,   &
          f9.2,1x,f8.2,1x,i2,1x,f9.2,1x,f8.2,1x,   &
          1pg10.3,1x,1pg10.3,1x,0pf6.2,2(1x,f8.3),1x,'''',a,'''',   &
          1x,'''',a,'''')
      !
      endif
      !
      ! compute efficiency?
      tt = par(1)/par(3)/1.064467
      eff = a_flux/tt
      !
      if (icode.eq.1) then
        !
        ! Write Results
        dfo(tant) = par(2)
        efo(tant) = err(2)
        ofo(tant) = r_corfoc(imob(i))
        if (plot) then
          write (chain,1025) 'DRAW TEXT 0.2 -0.2 "',   &
            dfo(tant),'" 3 /BOX 7'
          call gr_exec1(chain(1:lenc(chain)))
        endif
      !
      ! Bias the result towards the reference pointing constant by 1 sigma.
      ! However do nothing if the sigma is larger that 5 arc seconds (really bad).
      ! Note that R_COLL* are based on logical antennas
      elseif (icode.eq.2) then
        daz(jant) = par(2)
        eaz(jant) = err(2)
        effaz(jant) = eff
        widaz(jant) = par(3)
        if (eaz(jant).lt.5.) then
          qaz(jant) = daz(jant) + r_collaz(imob(i))
        else
          qaz(jant) = r_collaz(imob(i))
        endif
        if (plot) then
          write (chain,1015) 'DRAW TEXT 0.2 -0.2 "',   &
            daz(jant),'" 3 /BOX 7'
          call gr_exec1(chain(1:lenc(chain)))
          write (chain,1015) 'DRAW TEXT -0.2 -0.2 "',   &
            eff,' Jy/K" 1 /BOX 9'
          call gr_exec1(chain(1:lenc(chain)))
        endif
      else
        del(jant) = par(2)
        eel(jant) = err(2)
        effel(jant) = eff
        widel(jant) = par(3)
        if (eel(jant).lt.5.) then
          qel(jant) = del(jant) + r_collel(imob(i))
        else
          qel(jant) = r_collel(imob(i))
        endif
        if (plot) then
          write (chain,1015) 'DRAW TEXT 0.2 -0.2 "',   &
            del(jant),'" 3 /BOX 7'
          call gr_exec1(chain(1:lenc(chain)))
          write (chain,1015) 'DRAW TEXT -0.2 -0.2 "',   &
            eff,' Jy/K" 1 /BOX 9'
          call gr_exec1(chain(1:lenc(chain)))
        endif
      endif
    endif
  enddo
  if (icode.eq.3) then
    call sic_delvariable('DEL',.false.,error)
    call sic_delvariable('EFFEL',.false.,error)
    call sic_delvariable('WIDEL',.false.,error)
    dim = mnant
    call sic_def_real ('DEL',del,1,dim,.false.,error)
    call sic_def_real ('EFFEL',effel,1,dim,.false.,error)
    call sic_def_real ('WIDEL',widel,1,dim,.false.,error)
  elseif (icode.eq.2) then
    call sic_delvariable('DAZ',.false.,error)
    call sic_delvariable('EFFAZ',.false.,error)
    call sic_delvariable('WIDAZ',.false.,error)
    dim = mnant
    call sic_def_real ('DAZ',daz,1,dim,.false.,error)
    call sic_def_real ('EFFAZ',effaz,1,dim,.false.,error)
    call sic_def_real ('WIDAZ',widaz,1,dim,.false.,error)
  endif
  if (icode.eq.3) then
    do j =1,nant
      write(chain,1017) lant(j), daz(lant(j)), eaz(lant(j)),   &
        qaz(lant(j)), del(lant(j)), eel(lant(j)), qel(lant(j))
      call message(6,1,'SUB_POINT',chain(1:lenc(chain)))
    enddo
  endif
  !
  if (plot .and. icode.ne.2) then
    if (.not.end .and. sic_inter_state(dummy)) then
      answer = ' '
      write(6,*)   &
        '[Hardcopy - clear Alpha - Clear Plot - Quit]'
      call sic_wprn('I-PLOT,  Type H,A,Q,P or Return'   &
        ,answer,n)
      call sic_blanc(answer,n)
      if (index(answer,'H').ne.0)  call   &
        gr_exec('HARDCOPY /PRINT')
      if (index(answer,'A').ne.0)  call   &
        gtclear
      if (index(answer,'Q').ne.0)   &
        error = .true.
      if (index(answer,'P').ne.0)  call   &
        gtclal
    endif
  endif
  !
  ! /PRINT option
  if (qlun.ne.0 .and. icode.eq.3) then
    call check_scan(qlun,r_scan,'Pointing')
    do j =1,nant
      write(qlun,1007) qaz(lant(j)),qel(lant(j)),lant(j)
    enddo
  endif
  !
  ! Print the focus value
  if (qlun.ne.0 .and. icode.eq.1) then
    call check_scan(qlun,r_scan,'Focus')
    !
    ! First pass to compute the mean focus change
    focus = 0.0
    weigh = 0.0
    maxefo = 0.0
    do i=1,nant
      maxefo = max(maxefo,efo(i))
    enddo
    if (maxefo.eq.0.0) then
      do i=1,nant
        focus = focus + dfo(i)
        weigh = weigh + 1.0
      enddo
    else
      do i=1,nant
        if (efo(i).eq.0.0) efo(i) = maxefo
        focus = focus + dfo(i)/efo(i)**2
        weigh = weigh + 1.0/efo(i)**2
      enddo
    endif
    focus = focus/weigh
    !
    ! Use either the mean change, or the real change if significant
    write(chain,1025) 'Mean Focus: ',focus
    call message(6,1,'SUB_FOCUS',chain(1:lenc(chain)))
    do i=1,nant
      if (abs(focus-dfo(i)).gt.efo(i)) then
        write(chain,1035) 'Ant ',i,' correction ',dfo(i),' mm '
        ofo(i) = dfo(i)+ofo(i)
      else
        write(chain,1035) 'Ant ',i,' correction ',focus,   &
          ' mm (aver.)'
        ofo(i) = focus+ofo(i)
      endif
      write(qlun,'(A,F6.2,A,I2)') 'CORRECTION * * ',ofo(i),   &
        ' /ANTENNA ',lant(i)
      call message(6,1,'SUB_POINT',chain(1:lenc(chain)))
    enddo
    close (unit=qlun)
  endif
  return
  !
1001 format (a,' Scan ',i5,' Source ',a,' Az ',f8.2,' El ',f8.2)
1002 format ('A',i0,' Area ',1pg10.3,' Pos. ',1pg10.3,   &
    ' Wid. ',1pg10.3)
1003 format ('A',i0,' Err. ',1pg10.3,' Err. ',1pg10.3,   &
    ' Err. ',1pg10.3)
1004 format ('Scan: ',i4,' R',i1,1x,'Source: 'a,' S=',f8.2,& 
    ' Az=',f8.2,' El=',f8.2, a)
1015 format (a,f5.1,a)
1025 format (a,f6.2,a)
1035 format (a,i0,a,f6.2,a)
1007 format ('CORRECTIONS ',f6.1,1x,f6.1,' /ANTENNA ',i0)
1017 format('A',i0,' AZ:',f6.1,'(',f4.1,') Corr.',f6.1,   &
    ';   EL:',f6.1,'(',f4.1,') Corr.',f6.1)
2001 format(1x,i8,i6,i4,3(2x,f9.4),1x,2i4,   &
    2(f9.3,' ',f8.3,'  '),1pg9.3,1pg10.3,5(1x,1pg10.4), &
    4(1x,1pg10.3),2x,'''',a,''' ')
end subroutine sub_point
!
subroutine plot_point(nmob,imob,iant,icode,clea,chain,   &
    np,gain,posi,weig,limit)
  use gildas_def
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! CLIC
  !	Support routine for SOLVE POINTING/PLOT
  ! 	Plot gain data
  ! Arguments
  !	NMOB	I 	Number of mobile antennas
  !	IMOB	I 	Antenna
  !	ICODE	I	1,2,3 = Focus, Az, El
  !	CLEA	L	Reset plot
  !	CHAIN	C	Header
  !	NP	I 	Number of data points
  !	GAIN	R*4(NP)	Gain values
  !	POSI	R*4(NP) Position values
  !	WEIG 	R*4(NP) Weights
  !	CHAIN	C*(*)	X Axis Label
  !       LIMIT   C*(*)   Limits command
  !---------------------------------------------------------------------
  integer :: nmob                   !
  integer :: imob                   !
  integer :: iant                   !
  integer :: icode                  !
  logical :: clea                   !
  character(len=*) :: chain         !
  integer :: np                     !
  real :: gain(np)                  !
  real :: posi(np)                  !
  real :: weig(np)                  !
  character(len=*) :: limit         !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_display.inc'
  include 'clic_par.inc'
  ! Local
  character(len=10) :: label(3)
  character(len=132) :: ch, ch2,ch3
  real :: b1, b2, b3, b4, bx1, bx2, bx3, bx4
  parameter (b1=0.15,b2=0.9,b3=0.15,b4=0.90)
  integer :: i, lch
  ! Data
  data label/'Focus (mm)','Az pos.(`)','El pos(`)'/
  !------------------------------------------------------------------------
  ! Code:
  if (clea) then
    call gtclear
    write(ch,1000) b1, b2, b3, b4
    call gr_exec1('SET VIEW '//ch(1:lenc(ch)))
    call gr_exec1(chain)
    lch = 9
    ch2(1:9) = 'BB used: '
    do i = 1, l_baseband(1)
       ch2(lch:) = r_bbname(i_baseband(i,1))(1:4)//' '
       lch = lch+4
    enddo
    write(ch3,'(A,F4.2,A)') 'DRAW TEXT 0 ',0.8,' "'
    call gr_exec1 (ch3(1:18)//ch2(1:lch)//'" 9 /BOX 7')
  endif
  if (icode.eq.1) then
    bx1 = b1
    bx2 = b2
  else
    bx1 = b1+(b2-b1)/2*(icode-2)
    bx2 = b1+(b2-b1)/2*(icode-1)
  endif
  bx4 = b4-(b4-b3)/nmob*(imob-1)
  bx3 = b4-(b4-b3)/nmob*imob
  write(ch,1000) bx1, bx2, bx3, bx4
1000 format(4(1x,f4.2))
  call gr_exec1 ('SET VIEW '//ch(1:lenc(ch)))
  call gr4_give ('X',np,posi)
  call gr4_give ('Y',np,gain)
  call gr8_blanking(blank8,d_blank8)
  do i=1, np
    if (weig(i).gt.0) then
      weig(i) = 1e-3/sqrt(weig(i))
    endif
  enddo
  call gr4_give ('Z',np,weig)
  call gr_exec1(limit)
  if (icode.le.2) then
    call gr_exec1('AXIS YL')
    write(ch,'(i0)') iant
    call gr_exec1('LABEL "A'//ch(1:lenc(ch))//'" /Y')
    call gr_exec1('AXIS YR /LABEL NONE')
  else
    call gr_exec1('AXIS YL /LABEL NONE')
    call gr_exec1('AXIS YR /LABEL O')
  endif
  if (imob.eq.nmob) then
    call gr_exec1('LABEL "'//label(icode)//'" /X')
    call gr_exec1('AXIS XL /LABEL P')
  else
    call gr_exec1('AXIS XL /LABEL N')
  endif
  call gr_exec1('AXIS XU')
  call gr_exec1('POINTS')
  if (limit.ne.'LIMITS') call gr_exec1('ERROR Y')
  do i=1, np
    if (weig(i).gt.0) then
      weig(i) = 1e-6/weig(i)**2
    endif
  enddo
end subroutine plot_point
!
subroutine  pro_point(error)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  ! CLIC
  !	Support routine for SOLVE POINTING/PLOT
  !	Plots fit result
  ! Arguments
  !	ERROR 	L 	Logical error flag
  !---------------------------------------------------------------------
  logical :: error                  !
  ! Global
  real :: progauss
  include 'gbl_pi.inc'
  ! Local
  integer :: mx, i
  parameter (mx=100)
  real :: x(mx), y(mx), xmin, xmax
  !
  call gr_segm('FIT',error)
  call sic_get_real('USER_XMIN', xmin,error)
  call sic_get_real('USER_XMAX', xmax,error)
  if (error) return
  do i=1, mx
    x(i) = (xmax-xmin)/(mx-1.)*(i-1) + xmin
    y(i) = progauss (x(i),1)   !!*pi/180./3600.,1)
  enddo
  call gr4_connect (mx, x, y, 0.,-1.)
  call gr_segm_close(error)
end subroutine pro_point
!
subroutine load_beam (beam, bsize, lo1, nant)
  use gildas_def
  use classic_api  
  real :: beam                      !
  real :: bsize                     !
  real :: lo1                       !
  integer :: nant                   !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_clic.inc'
  include 'clic_par.inc'
  include 'clic_display.inc'
  ! Local
  integer :: i,j
  real*4 :: freq, fif1
  !
  if (beam.lt.0.0) then
    if (l_baseband(1).ne.0) then
      do i=1, l_baseband(1)
        j = i_baseband(i,1)
        fif1 = fif1+r_flo2(j)+r_band2(j)*(r_flo2bis(j) + &
                    r_band2bis(j)*r_lfcen(j))
      enddo
      fif1 = fif1/l_baseband(1)
    else
      fif1 = r_fif1
    endif
    if (n_band.eq.0 .or. i_band(1).eq.3) then
      freq = lo1               ! Sideband average
    elseif (i_band(1).eq.1) then
      freq = lo1+fif1      ! Upper sideband
    else
      freq = lo1-fif1      ! Lower sideband
    endif
    bsize = 41.0*115.0e3/freq  ! In arcseconds
    if (nant.lt.3) bsize = bsize*sqrt(2.0)
  elseif (beam.eq.0.0) then
    bsize = 0.0
  else
    bsize = beam
    if (nant.lt.3) bsize = bsize*sqrt(2.0)
  endif
end subroutine load_beam
!
subroutine check_scan(lun,iscan,measure)
  integer :: lun                    !
  integer :: iscan                  !
  character(len=*) :: measure       !
  ! Local
  character(len=8) :: pacifyf77
  !-----------------------------------------------------------------------
  pacifyf77=measure
  write(lun,100) 'IF SCAN-',iscan,'.GT.10 THEN'
  write(lun,100)   &
    '  SAY "_ '//pacifyf77//' is more than 10 scans old."'
  write(lun,100) '  DEFINE LOGICAL GO'
  write(lun,100) '  LET GO /PROMPT "Use anyway ?"'
  write(lun,100) '  IF .NOT.GO THEN'
  write(lun,100) '    RETURN'
  write(lun,100) '  ENDIF'
  write(lun,100) 'ENDIF'
100 format(a,i4.4,a)
  return
end subroutine check_scan
!
subroutine fit_point (npt,gain,posi,weig,pars,errs,beam,error)
  !---------------------------------------------------------------------
  ! CLIC
  !	Support routine for SOLVE POINTING
  ! 	Determine pointing parameters from a drift
  ! Arguments:
  !	NPT	I	Number of points in drift
  !	GAIN	R*4(Np)	Antenna gains
  !	POSI	R*4(Np)	Antenna positions
  !	WEIG	R*4(Np)	Minimization weights
  !	PARS	R*4(3)	Fitted parameters
  !	ERRS	R*4(3)	Fitted errors
  !	BEAM	R*4	Beam size (Radians)
  !---------------------------------------------------------------------
  integer :: npt                    !
  real :: gain(npt)                 !
  real :: posi(npt)                 !
  real :: weig(npt)                 !
  real :: pars(3)                   !
  real :: errs(3)                   !
  real :: beam                      !
  logical :: error                  !
  ! Global
  external :: mingauss
  include 'clic_parameter.inc'
  include 'clic_point.inc'
  include 'clic_gauss.inc'
  include 'clic_gaussdata.inc'
  include 'clic_fit.inc'
  include 'gbl_pi.inc'
  ! Local
  character(len=12) :: chain
  integer :: i,ier
  real :: sw,zzer,wzer,zinf,winf,zsup,wsup,offset,ao,aw,ak,ap
  !------------------------------------------------------------------------
  ! Code:
  nline = 1
  !
  ! Find starting parameters
  ndata = 0
  sw = 0
  if (iproc.le.1) then
    bavard = .true.
    do i = 1, npt
      if (weig(i).gt.0) then
        ndata = ndata + 1
        rdatax(ndata) = posi(i)
        rdatay(ndata) = gain(i)
        wfit(ndata) = sqrt(weig(i))
        sw = sw + wfit(ndata)
      endif
    enddo
    if (ndata.le.0) then
      call message(8,4,'FIT_POINT','No valid data point')
      error = .true.
      return
    endif
    do i=1, ndata
      wfit(i) = wfit(i)/sw*ndata
    enddo
    call inigauss
    if (beam.ne.0) then
      par(3) = beam
      kd1 = 1                  ! Fix the beam width
    else
      kd1 = 0                  !
    endif
    spar(1) = par(1)           ! Area
    spar(2) = par(2)           ! Position
    spar(3) = par(3)           ! Beam
    spar(1) = spar(1)/spar(3)/1.064467 ! Peak value
    call fitgauss (mingauss,.false.,ier)
    if (iproc.eq.0) then
      chain = 'SOLVE_POINT'
    else
      chain = 'SOLVE_FOCUS'
    endif
  else
    bavard = .false.
    zzer = 0
    wzer = 0
    zinf = 0
    winf = 0
    zsup = 0
    wsup = 0
    offset = 0
    do i=1,npt
      if (weig(i).gt.0) then
        ndata = ndata + 1
        rdatax(i) = posi(i)
        rdatay(i) = gain(i)
        offset = max(offset,abs(rdatax(i)))
        wfit(i) = weig(i)
        sw = sw + wfit(i)
        if (posi(i).lt.0) then
          zinf = zinf+wfit(i)*rdatay(i)
          winf = winf+wfit(i)
        elseif (posi(i).eq.0) then
          zzer = zzer+wfit(i)*rdatay(i)
          wzer = wzer+wfit(i)
        else
          zsup = zsup+wfit(i)*rdatay(i)
          wsup = wsup+wfit(i)
        endif
      endif
    enddo
    if (ndata.le.0) then
      call message(8,4,'FIT_POINT','No valid data point')
      error = .true.
      return
    endif
    do i=1, npt
      wfit(i) = wfit(i)/sw*ndata
    enddo
    zzer = zzer/wzer
    zsup = zsup/wsup
    zinf = zinf/winf
    ak = log(zsup/zinf)
    if (beam.ne.0) then
      par(3) = beam
      kd1 = 1                  ! Fix the beam width
      aw = par(3)/offset
      ap = log(zzer**2/(zinf*zsup))
      write(*,*) ' Width ',   &
        sqrt(2.0/ap)*offset*2.0*sqrt(log(2.0)),par(3)
      !??
      if (iproc.eq.1) then
        ao = 0.25*aw**2*ak
      else
        ao = 0.5*ak/ap
      endif
    else
      kd1 = 0                  !
      ap = log(zzer**2/(zinf*zsup))
      ao = 0.5*ak/ap
      aw = sqrt(2.0/ap)
      par(3) = aw*2.0*sqrt(log(2.0))*offset
    endif
    par(2) = ao*offset
    par(1) = par(3)*max(zsup,zinf,zzer)
    err(1) = 1e-3/sqrt(sw)*par(3)  ! Error on area
    err(2) = 1e-3*sqrt(sw)/par(1)  ! Error on position
    do i=1,4
      spar(1) = par(1)         ! Area
      spar(2) = par(2)         ! Position
      spar(3) = par(3)         ! Beam
      spar(1) = spar(1)/spar(3)/1.064467   ! Peak value
      call fitgauss (mingauss,.true.,ier)
    enddo
    chain = 'SOLVE_FIVE'
  endif
  if (ier.lt.0) then
    call message(6,3,chain,'Error on input parameters')
    error = .true.
  elseif (ier.eq.3) then
    call message(6,3,chain,'Solution not converged')
    error = .false.
  elseif (ier.ne.0) then
    call message(6,3,chain,'Bad Solution')
    error = .true.
  else
    error = .false.
  endif
  do i=1,3
    pars(i) = par(i)
    errs(i) = err(i)
  enddo
end subroutine fit_point
!
subroutine fill_visi_posi (qdump,qbas,qant,visi,posi,weig,   &
    time_max,data,error)
  use gildas_def
  use classic_api
  use clic_rdata
  !---------------------------------------------------------------------
  ! Read the data section and extract the visibilities for all baselines
  ! and the positions of all antennas
  ! Arguments:
  !	R 	Struc.	Header
  !	VISI	R*4(*)	Visibilities to be returned
  !	POSI	R*4(*)	"Position" of antenna. The "position"
  !			is actually a parameter defined by R.SCATY
  !	WEIG	R*4(*)	Weights to be returned
  !---------------------------------------------------------------------
  integer :: qdump                  !
  integer :: qbas                   !
  integer :: qant                   !
  real :: visi(qdump,qant)          !
  real :: posi(qdump,qant)          !
  real :: weig(qdump,qant)          !
  real :: time_max                  !
  real :: data(*)                   !
  logical :: error                  !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  include 'clic_clic.inc'
  include 'clic_display.inc'
  include 'gbl_memory.inc'
  ! Local variables:
  logical :: change
  integer :: iband, ibas, ir, iant, ix, iy, jw1, jw2, ivt, ipol, kb, kif
  integer :: iv, im, kr
  real :: vta(4,3,mnant), wta(4,3,mnant), vtb(4,3,mnbas)
  real :: wtb(4,3,mnbas), wbas(mnbas), want(mnant), dtmax
  integer(kind=address_length) :: k, kc, kl
  integer(kind=data_length) :: h_offset, c_offset, l_offset
  complex :: zbas(mnbas), zant(mnant)
  !------------------------------------------------------------------------
  ! Code:
  !
  ! Select band UPPER LOWER or AVERAGE
  ipol = 1 ! Not used, but for consistent call to brecord
  kb   = 1 ! Not used, but for consistent call to brecord
  kif  = 1 ! idem 
  if (n_band.ne.1) then
    call message(6,2,'FILL_VISI_POSI',   &
      'Using only first selected Band')
  endif
  iband = i_band(1)
  if (iband.eq.4) then
    call message(6,2,'FILL_VISI_POSI',   &
      'Sideband Ratio invalid in this context')
    error = .true.
    return
  endif
  !
  ! Select subbands and channels to be averaged
  jw1 = iw1(1)
  jw2 = iw2(1)
  call check_subb(1,.true.,error)
  if (error) goto 999
  iy = 1                       ! Amplitude
  if (r_scaty.eq.1) then
    ix = 78                    ! Focus
  elseif (r_scaty.eq.2) then
    ix = 76                    ! Lambda
  elseif (r_scaty.eq.3) then
    ix = 77                    ! Beta
  elseif (r_scaty.eq.6) then
    ix = 76                    ! Lambda first, Then Beta
  endif
  !
  if (do_pass) then
    call set_pass (r_nsb,r_nband,r_nbas+r_ntri,   &
      r_lntch, passc, passl, error)
    if (error) goto 999
  endif
  !
  do ibas = 1, r_nbas
    !     im = 1 (time weight) 2 (tsys weight) 3 (phase rms weighting)
    !     iv = 1 (X value) 2 (Y value) 3 (real part) 4 (imag part)
    do iv=1,4
      do im=1,3
        vtb(iv,im,ibas) = 0
        wtb(iv,im,ibas) = 0
      enddo
    enddo
  enddo
  do iant = 1, r_nant
    do iv=1,4
      do im=1,3
        vta(iv,im,iant) = 0
        wta(iv,im,iant) = 0
      enddo
    enddo
  enddo
  ivt = 0
  !
  ! Loop on records
  call spectral_dump(kr,0,0)
  do ir = 1, r_ndump
    k = h_offset(ir)+1
    call decode_header (data(k))
    if (ir.eq.1) then
      call set_scaling(error)
      if (error) return
    endif
    kc = 1 + c_offset(ir)
    dtmax = 0
    do iant = 1, r_nant
      call spectral_dump(kr,iant,0)
      kl = 1 + l_offset(kr)
      call arecord (   &
        r_nsb, r_nband, r_nbas, r_lntch,   &
        data(kc), data(kl), passc, passl,   &
        iant, iband, ipol, kb, kif, l_subb(1), i_subb(1,1),jw1,jw2,ix,iy,   &
        vta(1,1,iant),wta(1,1,iant),.false.,error)
      dtmax = max(dtmax,wta(1,1,iant))
      if (error) goto 999
    enddo
    do ibas = 1, r_nbas
      call spectral_dump(kr,0,ibas)
      kl = 1 + l_offset(kr)
      call brecord (   &
        r_nsb, r_nband, r_nbas, r_lntch,   &
        data(kc), data(kl), passc, passl,   &
        ibas, iband, ipol, kb, kif, l_subb(1), i_subb(1,1),jw1,jw2,ix,iy,   &
        vtb(1,1,ibas),wtb(1,1,ibas),error)
      if (error) goto 999
    enddo
    if (dtmax.ge.time_max   &
      .or. (dtmax.gt.0 .and. ir.eq.r_ndump)) then
      ivt = ivt+1
      do ibas = 1, r_nbas
        if (wtb(3,2,ibas).gt.0) then
          zbas(ibas) = cmplx(vtb(3,2,ibas),vtb(4,2,ibas))   &
            /wtb(3,2,ibas)
        endif
        wbas(ibas) = wtb(1,2,ibas)
      enddo
      call antgain(zbas,wbas,zant,want)
      do iant = 1, r_nant
        weig(ivt,iant) =  want(iant)
        visi(ivt,iant) = abs(zant(iant))
        if (wta(1,2,iant).gt.0) then
          posi(ivt,iant) = vta(1,2,iant)/wta(1,2,iant)
        endif
        if (wta(1,2,iant).eq.0 .or. wta(2,2,iant).eq.0   &
          .or. want(iant).eq.0 ) then
          visi(ivt,iant) = blank4
          posi(ivt,iant) = 0
          weig(ivt,iant) = 0
        endif
        do iv=1,4
          do im=1,3
            vta(iv,im,iant) = 0
            wta(iv,im,iant) = 0
          enddo
        enddo
      enddo
      do ibas = 1, r_nbas
        do iv=1,4
          do im=1,3
            vtb(iv,im,ibas) = 0
            wtb(iv,im,ibas) = 0
          enddo
        enddo
      enddo
    endif
    !
    ! Change scanning direction if on (0,0) for Five-Points
    if (r_scaty.eq.6) then
      change = .true.
      do iant=1,r_nant
        if (posi(ir,iant).ne.0.0) change = .false.
      enddo
      if (change) ix = 77
    endif
  enddo
  if (qdump.gt.ivt) then
    do iant = 1, r_nant
      do ir=ivt+1, qdump
        posi(ir,iant) = 0
        visi(ir,iant) = 0
        weig(ir,iant) = 0
      enddo
    enddo
  endif
  !
  return
  !
999 error = .true.
  return
end subroutine fill_visi_posi
!
      subroutine refrac(refraction)
      use classic_api  
!----------------------------------------------------------------------
!       cette subroutine calcule les coefficients de la refraction
!       atmospherique (copiee de obs.)
!
!       les parametres d'entree sont :
!
!               tambia  = temperature ambiante en k ( 223 < tambia <  323   )
!               humidi  = humidite relative (%)     (   0 < humidi <  100   )
!               pambia  = pression in mbar          ( 690 < pambia <  790   )
!
!       les parametres de sortie sont :
!               refrc1,refrc2,refrc3
!               la formule utilisee est
!               refr = refrc1/tan(el.)+refrc2/tan(el.)**3+refrc3/tan(el.)**5
!
!       pour la refraction radio on utilise la formule suivante
!       waters, j.w. 1976, in methods of experimental physics
!       vol 12, part b, pag. 186.
!
!       n = (77.6 pambia/tambia+ 3.73e05 e/tambia**2)*10e-06 radians
!
!       ou e est la pression partielle de la vapeur d'eau donnee par
!       e=es*humidi/100./(1-(1-humidi/100.)*es/pambia) mbar
!       ou es est la pression de saturation de la vapeur d'eau donnee par
!       es=6.105*exp(25.22*(tambia-273)/tambia-5.31*ln(tambia/273)) mbar
!
!       par example, pambia=1013, tambia=273, humidi=90
!       es=6.105 mbar
!       e=5.491 mbar
!       n=59.39" + 5.67" (contribution de la vapeur d'eau)
!---------------------------------------------------------------------- 
      real refraction(3)
!
      include 'clic_parameter.inc'
      include 'clic_par.inc'
!
      real tmin, tmax, pmin, pmax, hmin, hmax
      real hum, alpha, alpha0, beta, beta0, es, e
      real alphad, alphaw, betad, betaw, c1d, c1w
      real c2d, c2w, c3d, c3w
      data tmin/223./,tmax/323./
      data pmin/690./,pmax/790./
      data hmin/0./hmax/100./
      data alpha0/0.00029255/,beta0/.001254/
      character text*80
!
      if((r_tamb.lt.tmin.or.r_tamb.gt.tmax).or.   &
        (r_pamb.lt.pmin.or.r_pamb.gt.pmax).or.    &
        (r_humid.lt.hmin.or.r_humid.gt.hmax))then
         if (r_tamb.lt.tmin.or.r_tamb.gt.tmax) &
             call message (6,3,'meteo',  &
             'ambient temperature out of limits')
         if (r_pamb.lt.pmin.or.r_pamb.gt.pmax) &
             call message (6,3,'meteo', &
             'ambient pressure out of limits')
         if (r_humid.lt.hmin.or.r_humid.gt.hmax) &
             call message (6,3,'meteo', &
             'ambient humidity out of limits')
         return
      endif
      hum=r_humid/100.
! calcul des coefficients de la refraction radio
!
! calcul de la pression de saturation de la vapeur d'eau
      es=6.105*exp(25.22*(r_tamb-273) &
        /r_tamb-5.31*log(r_tamb/273))
!
! calcul de la pression partielle de la vapeur d'eau
      e=es *hum /(1- (1-hum) *es /r_pamb)
!
! calcul des coefficients alpha et beta pour une atmosphere
! seche et une atmosphere contenant de la vapeur d'eau
      alphad=77.6 *r_pamb /r_tamb *1d-06
      alphaw=3.73e-01 *e /r_tamb**2
      betad=beta0 *273 /r_tamb  !identique que pour l'optique
!
!       hauteur caracteristique de la distribution de la vapeur d'eau
!       = 2.5 km et betaw=beta0/hd*2.5, ou hd, l'hauteur
!       caracteristique de l'atmosphere seche (ou de la distribution
!       de densite de n2 et o2) est de 7.99 km
!
      betaw=beta0 /3.2 *273 /r_tamb
!
! maintenant on calcule c1, c2 et c3 pour n2+o2 et pour h2o
      c1d=alphad *(1-betad)
      c1w=alphaw *(1-betaw)
      c2d=-alphad *(betad-alphad/2.)
      c2w=-alphaw *(betaw-alphaw/2.)
      c3d=3 *alphad *(betad -alphad/2.)**2
      c3w=3 *alphaw *(betaw -alphaw/2.)**2
!
! 1 pour radio
      refraction(1) = c1d +c1w
      refraction(2) = c2d +c2w
      refraction(3) = c3d +c3w
!
    end subroutine refrac


