! GILDAS team
!   Author: S.Guilloteau  Laboratoire d'Astrophysique de Bordeaux
!--------------------------------------------------------------------
!
! General parsing with /WEIGHT and /STOKES options
parse /weight /stokes
if exist(casa_blocks)
  delete /var casa_blocks casa_narg
endif
define integer casa_blocks[2] casa_narg /global
define logical do_casa do_help do_stokes
casa_blocks = 0 5000
if (pro%parse%weight%narg.eq.2) let casa_blocks[2] = 'pro%parse%weight%arg[2]'
if (pro%parse%weight%narg.ge.1) let casa_blocks[1] = 'pro%parse%weight%arg[1]'
!
do_casa = pro%parse%weight%narg.ge.0    ! /WEIGHT option requires use of UV_CASA task
do_stokes = pro%parse%stokes%narg.ge.0  ! /STOKES option implies keeping Stokes parameter(s)
casa_narg = pro%parse%command%narg      ! See if additional keywords are present on line
!
do_help = no
if casa_narg.eq.0 then
  do_help = yes
else if casa_narg.eq.1 then
  if ("&1".eq."?") then
    do_help = yes
  endif
else if mod(casa_narg,2).ne.0 then
  do_help = yes
endif
!
if do_help then
  say "I-FITS_TO_UVT: Usage"
  say "  @ fits_to_uvt uvfits_file [/WEIGHT [Read [Print]]] [/STOKES] "
  say "    UV Table file name will be derived from fits file name"
  say " or "
  say "  @ fits_to_uvt uvfits_file uvtable_file [KEY Value [KEY Value ...]]] -"
  say "                      [/WEIGHT Read [Print]]] [/STOKES]"
  say "   UV table file name must have no extension "
  say "      Fits default file type is .uvfits"
  say "      UV table file type will be .uvt"
  say "  Optional arguments are (in arbitrary order) "
  say "   FREQUENCY           Rest_frequency_value   (in MHz)"
  say "   VELOCITY            Source_velocity_value  (in km/s)"
  say "   LINE                Line_name"
  say "  Options"
  say "   /WEIGHT Read Print  Recompute weights with specified blocking factor"
  say "   /STOKES Keep all Stokes parameters in intermediate file instead of reducing them on-the-fly"
  return
endif
!
! Step 1 : convert the AIPS UVFITS file to GILDAS UVT
!
define character in_file*256 in_ext*12 ou_file*256 in_dir*256
if (casa_narg.ge.2) then
  sic parse "&2" ou_file in_ext in_dir
  if in_ext.ne." " then
    if in_ext.ne."uvt" then
      message E "fits_to_uvt"  "The output file type must be .uvt (or empty)"
      return error
    endif
  endif
  let ou_file 'in_dir''ou_file'
endif
!
sic parse "&1" in_file in_ext in_dir
if in_ext.eq." " let in_ext = "uvfits"
if casa_narg.eq.1  let ou_file = 'in_file'
!
defin fits a 'in_dir''in_file'.'in_ext' HEADER  ! Do not read the data
!
! It should be a UVFITS file
!
! Verify the Frequencies (pending a better implementation in the FITS command)
define double obsfreq fratio
obsfreq = 0.
if (exist(a%ctype2)) then
  if (a%ctype2.eq."COMPLEX") then
    for k 3 to size(a%naxis)      ! We cannot assume it is just 4
      if (a%ctype'k'.eq."FREQ") then
        let obsfreq a%crval'k'
      else if (a%ctype'k'.eq."IF") then
        let n_if a%naxis[k] /new integer
        if (n_if.gt.1) then
          message e "fits_to_uvt" "More than 1 IF in UVFITS file"
          let do /Prompt "Type C to Continue (with lot of errors), Q to stop" /new char*1
          if (do.ne."C") return error
        endif
      endif
    next 
  endif
endif
if (obsfreq.eq.0) then
  message e "fits_to_uvt" "Input file is not a UVFITS"
  return error
endif
if (exist(a%restfreq)) then
  let fratio a%restfreq/obsfreq
  if (fratio.gt.1.004) then
    SYMBOL RESTFREQ NOTHING
    message W FITS_TO_UVT "Rest Frequency to Observed Frequency ratio is too large"
    message W FITS_TO_UVT "Rest Frequency ignored (probably extragalactic stuff)"
    message W FITS_TO_UVT "Estimated redshift "'1D-5*nint(1D5*(fratio-1d0))'" for Rest Frequency "'nint(a%restfreq*1D-6)'" MHz"
    PAUSE
  endif
endif
!
if (do_stokes) then
  ! /STYLE CASA is an (awkward) way to keep all Stokes parameters.
  ! It **may** also imply keeping flagged data. 
  ! All that should be changed at some stage
  fits 'in_dir''in_file'.'in_ext' to 'ou_file'-tmp.uvt /style casa
else
  fits 'in_dir''in_file'.'in_ext' to 'ou_file'-tmp.uvt 
endif
SYMBOL RESTFREQ SOMETHING ! Avoid an error message on the next line
delet /SYMBOL RESTFREQ
!
! Step 2 : patch the Header for coordinates...
defin header bgdf 'ou_file'-tmp.uvt write /global  ! Don't change the data either...
!
if exist(a%aips_su%col%raepo) then
  define char c_ra*15 c_dec*14
  define integer nsou
  !
  ! Handle Mosaic as well as single fields here
  !
  define double ra dec 
  let nsou size(a%aips_su%col%raepo)
  if (nsou.le.1) then
    !
    let nsou 0    
    let ra a%aips_su%col%raepo*pi/180
    if (ra.lt.0) let ra ra+2*pi
    let dec a%aips_su%col%decepo*pi/180
    let bgdf%a0 ra
    let bgdf%d0 dec
    let c_ra ra /sexa h r 
    let c_dec dec /sexa d r
  else
    delete /var bgdf ! Header will be modified directly where needed
    !
    ! New code with IMAGER command UV_FIELDS
    define double dm dp
    comput dm min a%aips_su%col%raepo
    comput dp max a%aips_su%col%raepo
    if (dm.lt.0) then
      let dm dm+360
      let dp dp+360
    endif
    let ra (dm+dp)/2*pi/180
    comput dm min a%aips_su%col%decepo
    comput dp max a%aips_su%col%decepo
    let dec (dm+dp)/2*pi/180
    let c_ra ra /sexa h r 
    let c_dec dec /sexa d r
    !
    uv_fields a%aips_su%col%raepo a%aips_su%col%decepo DEGREE -
      /Center 'C_RA' 'C_DEC' /File 'ou_file'-tmp.uvt
    define head bgdf 'ou_file'-tmp.uvt write /global
    !
  endif
  !
  say "R.A. :"'c_ra'
  say "Dec. :"'c_dec'  
  !  
  bgdf%ra = ra
  bgdf%dec = dec
else
  ! Single fields:
  ! Assume RA & Dec from phase center
  if (bgdf%a0.eq.0.and.bgdf%d0.eq.0) then
    SAY "Phase center is 0,0 => please check source coordinates afterwards."
  else
    bgdf%ra = bgdf%a0
    bgdf%dec = bgdf%d0
  endif
endif
!
if exist(a%aips_su%col%source) then
  if (nsou.eq.0) then
    bgdf%source = 'a%aips_su%col%source'
  else
    bgdf%source = 'a%aips_su%col%source[1]'
  endif
endif
delet /var a
!
define double r8 lightspeed x8
define character key*12
define integer j
let lightspeed = 299792.458d0
!
! Protect against clumsy Extragalactic issues...
! Normally, this should have been done before !
!
! Velocities in excess of 2000 km/s are presumably Extragalactic 
if (bgdf%veloff.gt.2000) then
  message W FITS_TO_UVT "Excessive Velocity "'bgdf%veloff'" reset to Zero and Rest Frequency adjusted accordingly"
  !! MODIFY bgdf /Velocity 0 ! This DOES NOT WORK
  bgdf%convert[2,1] = bgdf%restfre*(1-bgdf%veloff/lightspeed)
endif
!
! But this may also be in the Frequency definitions
let fratio bgdf%restfre/bgdf%convert[2,1]
if (fratio.gt.1.004d0) then
  message W FITS_TO_UVT "Rest Frequency to Observed Frequency ratio is too large"
  message W FITS_TO_UVT "Rest Frequency ignored (probably extragalactic stuff)"
  message W FITS_TO_UVT "Velocity reset to Zero and Rest Frequency adjusted accordingly"
  let fratio = (1.d0-bgdf%veloff/lightspeed)
  message W FITS_TO_UVT "Estimated redshift "'1D-5*nint(1D5*(1d0/fratio-1d0))'" for Rest Frequency "'nint(bgdf%restfre)'" MHz"
  let bgdf%restfre bgdf%restfre*fratio
  let bgdf%veloff = 0
  let bgdf%velres = bgdf%velres/fratio
endif
!
! Parse the other arguments
if casa_narg.gt.2 then
  !
  ! Build the SIC\MODIFY bgdf /FREQUENCY Name RestFreq /VELOCITY Velocity
  ! command
  define charac A_LineName*16
  define double A_restFreq
  define double A_Velocity
  !
  let A_Velocity bgdf%veloff
  let A_RestFreq bgdf%restfre
  let A_LineName bgdf%line   /format a12  ! To handle spaces...
  !
  !
  for i 3 to casa_narg by 2
    let KEY 'pro%arg[i]' /upper
    j = i+1
    !
    if key.eq."FREQUENCY" then
      let A_RestFreq 'pro%arg[j]'
    else if key.eq."VELOCITY" then
      let A_Velocity 'pro%arg[j]'
    else if key.eq."LINE" then
      Let A_LineName = pro%arg[j] /format a12
    else
      say "Keyword "'key'" ignored"
    end if
  next
  if (A_LineName.eq." ") LET A_LineName = "None"
  !
  sic output gag_scratch:modify.sic
    say "SIC\MODIFY bgdf /FREQUENCY " A_LineName A_RestFreq " /VELOCITY " A_Velocity -
    /format A A12 1PG23.16 A 1PG21.4
  sic output
  say "Executing "
  type gag_scratch:modify.sic
  @ gag_scratch:modify.sic
endif
!
if bgdf%unit.eq."UNCALIB" then
  bgdf%unit = "Jy"
endif
!
define integer nstokes
nstokes = bgdf%nstokes
!
dele /var bgdf
!
! Step 3 - Optionally re-compute the weights
!          ELSE select only one Stokes parameter
!
if .not.do_casa then
  if (do_stokes).or.(nstokes.eq.1) then
    sic rename 'ou_file'-tmp.uvt  'ou_file'.uvt
  else  
    STOKES NONE 'ou_file'-tmp 'ou_file'
    sic delete 'ou_file'-tmp.uvt
  endif
  return
endif
!
! Step 3 : prepare the UV table for imaging in Gildas
begin data gag_scratch:uv_casa.init
  TASK\FILE   "Input multi-polarization UV Table" INPUT$ 'casa_name'-tmp.uvt
  TASK\FILE   "Output single polarization UV Table" OUTPUT$ 'casa_name'.uvt
  TASK\CHARACTER  "Stokes parameter" STOKES$ NONE
  TASK\VALUES   "First and last values of each valid range" RANGES$ 20 -20
  TASK\CHARACTER "Type of values" CTYPE$                    CHANNEL
  TASK\REAL      "Rejection Threshold" THRESHOLD$           5.0
  TASK\INTEGER   "Blocking & Print factor" BLOCK$[2]        'casa_blocks[1]' 'casa_blocks[2]'
  TASK\LOGICAL   "Keep anomalous rescale" KEEP$             NO
  TASK\LOGICAL   "Trim flagged data" TRIM$                  YES
  TASK\INTEGER   "Weight column to test flag"  WCOL$        0
  TASK\GO
end data gag_scratch:uv_casa.init
!
if exist(casa_name)
  delete /var casa_name
endif
define logical old_tee
let old_tee sic%tee
let sic%tee yes
define character*256 casa_name /global
let casa_name 'ou_file'
define character filename*256
let filename 'ou_file'".uvt"
!
! Compress polarization information and attempt to recompute weights and flag data.
if casa_narg.eq.1
  run uv_casa gag_scratch:uv_casa.init /nowind
  if .not.file(filename) then
    message w "FITS_TO_UVT"  "Could not create "'ou_file'".uvt with UV_CASA"
    message w "FITS_TO_UVT"  "Trying with smaller block size ..."
    if (casa_blocks[1].eq.0) then
      let casa_blocks 1000
    else
      let casa_blocks casa_blocks[1]/4
    endif
    run uv_casa gag_scratch:uv_casa.init /nowind
  endif
else
  run uv_casa gag_scratch:uv_casa.init
endif
!
let sic%tee old_tee
!
! Step 4: remove temporary file and issue Success or Failure message
if .not.file(filename) then
  STOKES NONE 'ou_file'"-tmp.uvt" 'ou_file'".uvt"
  sic delete 'ou_file'-tmp.uvt
  message e "FITS_TO_UVT"  "Could not create "'ou_file'".uvt with UV_CASA"
  message w "FITS_TO_UVT"  "Used STOKES NONE instead. "
  message I "FITS_TO_UVT"  "You may try again with "
  say  "                      @ fits_to_uvt ... /BLOCK Value "
  say  "                 where Value < "'casa_blocks[1]'
  RETURN ERROR
else
  sic delete 'ou_file'-tmp.uvt
ENDIF


