!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! General parsing with /WEIGHT option
parse /weight
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
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
casa_narg = pro%parse%command%narg
!
if (casa_narg.eq.0) then
   let do_help yes
else if (casa_narg.eq.1) then
   if ("&1".eq."?") then
      let do_help yes
   endif
else if (mod(casa_narg,2).ne.0) then
   let do_help yes
else
   let do_help no
endif
!
if (do_help) then
  say "I-FITS_TO_UVT: Usage"
  say "  @ fits_to_uvt uvfits_file [/WEIGHT [Read [Print]]]"
  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]]]"
  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"
  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
   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
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'
!
! The header keyword allows us to avoid reading the data
! ***JP: Can't we do this with
define fits a 'in_dir''in_file'"."'in_ext' header
define double obsfreq
let obsfreq 0.
if (exist(a%ctype2)) then
   if (a%ctype2.eq."COMPLEX") then
      ! We cannot assume that the uvfits file has 4 axes
      for k 3 to size(a%naxis)
         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 not supported"
               return error
            endif
         endif
      next ! k
   endif
endif
! Converts to uvt
vector\fits 'in_dir''in_file'.'in_ext' to 'ou_file'-tmp.uvt /style casa
!
! Step 2: Patch the header for coordinates
define header bgdf 'ou_file'-tmp.uvt write /global ! ***JP: Why /global?
!
if exist(a%aips_su%col%raepo) then
   define integer nsou
   define integer dims[8]
   sic\compute dims dimof a%aips_su%col%raepo
   let nsou dims[1]
   !
   ! Handle Mosaic as well as single fields here
   !
   define double ra dec
   if (nsou.eq.0) then
      ! Single field
      let ra a%aips_su%col%raepo*pi/180
      let dec a%aips_su%col%decepo*pi/180
      let bgdf%a0 ra
      let bgdf%d0 dec
   else
      ! Mosaic
      define real offx[nsou] offy[nsou]
      let ra a%aips_su%col%raepo[1]
      let dec a%aips_su%col%decepo[1]
      !
      let offx (a%aips_su%col%raepo-ra)*cos(dec*pi/180)*3600.0
      let offy (a%aips_su%col%decepo-dec)*3600.0
      !
      let ra ra*pi/180
      let dec dec*pi/180
      message W FITS_TO_UVT "Found a "'nsou'" fields mosaic with offsets:"
      for j 1 to nsou
         message I FITS_tO_UVT "("'offx[j]'","'offy[j]'") arcsec"
      next
      !
      let offx offx*pi/180/3600
      let offy offy*pi/180/3600
      !
      delete /var bgdf
      !
      if (nsou.gt.1024) then
         ! VECTOR\RUN (run uv_update_fields) can not ingest more than 2048
         ! real input values (1 offset provides 2 values). Use old code, very
         ! greedy in memory
         !
         define uv bgdf 'ou_file'-tmp.uvt write /global  ! Now change the data too...
         define integer ioffx ioffy isou
         !
         let ioffx bgdf%dim[1]-1
         let ioffy bgdf%dim[1]
         for i 1 to bgdf%nvisi
            let isou bgdf[ioffx,i]
            let bgdf[ioffx,i] offx[isou]
            let bgdf[ioffy,i] offy[isou]
         next ! i
      else
         ! New code, uses a blocking factor for Read/Write
         ! but tasks have a limited number of parameters.
         !
         sic output uv_update_fields.init
            say "TASK\CHARACTER " "Input_File" "UVDATA$" 'ou_file'-tmp.uvt
            say "TASK\INTEGER   " "N_fields  " "NFIELDS$" 'nsou'
            for i 1 to nsou
               say "TASK\REAL " "Offsets" "FIELD_"'i'"$[2]" 'offx[i]' 'offy[i]'
            next ! i
            say "TASK\GO"
         sic output
         vector\run uv_update_fields * /nowindow
         define head bgdf 'ou_file'-tmp.uvt write /global ! More changes still needed
      endif
      bgdf%a0 = ra
      bgdf%d0 = dec
   endif
  !
  define character c_ra*13 c_dec*14
  if (ra.lt.0) then
     let ra ra+2.d0*pi
  endif
  !
  let c_ra ra /sexa h r
  let c_dec dec /sexa d r
  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
delete /var a
!
define double r8 lightspeed x8
define character key*12
define integer j
let lightspeed 299792.458d0
!
! Protect against clumsy Extragalactic issues...
define double fratio
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)
   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"
      endif
   next ! i
   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
let nstokes bgdf%nstokes
!
delete /var bgdf
!
! Step 3 - Optionally re-compute the weights
!          ELSE select only one Stokes parameter
!
if (.not.do_casa) then
   if (nstokes.ne.1) then
      clean\uv_stokes NONE 'ou_file'-tmp 'ou_file'
      sic delete 'ou_file'-tmp.uvt
   else
      sic rename 'ou_file'-tmp.uvt  'ou_file'.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
!
begin data gag_scratch:uv_splitpolar.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\go
end data gag_scratch:uv_splitpolar.init
!
if exist(casa_name) then
   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) then
   vector\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
      vector\run uv_casa gag_scratch:uv_casa.init /nowind
   endif
else
   vector\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
   vector\run uv_splitpolar gag_scratch:uv_splitpolar.init /nowind
   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 UV_SPLITPOLAR 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
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
