module noema_tsys_interpolation
  !---------------------------------------------------------------------
  ! Ad-hoc types and methods which allows to define some models
  !---------------------------------------------------------------------
  !
  public :: model_parabol,model_gaussian,model_parabol_gaussian
  public :: parabol_t,gaussian_t,model_t
  private
  !
  integer(kind=4), parameter :: model_parabol=1
  integer(kind=4), parameter :: model_gaussian=2
  integer(kind=4), parameter :: model_parabol_gaussian=3  ! Both combined
  !
  type :: parabol_t
    ! f(x) = offset+slope*x+factor*x**2
    real(kind=4), public :: offset=0.  ! [K]
    real(kind=4), public :: slope=0.   ! [K/GHz]
    real(kind=4), public :: factor=0.  ! [K/GHz**2]
  contains
    procedure, private :: compute => parabol_compute
  end type parabol_t
  !
  type :: gaussian_t
    ! f(x) = amp*exp(-(x-pos)**2/(2*wid**2))
    real(kind=4), public :: amp=0.  ! [K]
    real(kind=4), public :: pos=0.  ! [GHz]
    real(kind=4), public :: wid=0.  ! [GHz]
  contains
    procedure, private :: compute => gauss_compute
  end type gaussian_t
  !
  type :: model_t
    integer(kind=4),  public :: itype    ! 1=parabol, 2=gaussian
    type(parabol_t),  public :: parabol  ! Used if parabolic
    type(gaussian_t), public :: gauss    ! Used if gaussian
  contains
    procedure, public :: add     => model_add
    procedure, public :: compute => model_compute
  end type model_t
  !
contains
  !
  function parabol_compute(parabol,x)
    !-------------------------------------------------------------------
    ! Compute value at X
    !-------------------------------------------------------------------
    real(kind=4) :: parabol_compute
    class(parabol_t), intent(in) :: parabol
    real(kind=4),     intent(in) :: x
    parabol_compute = parabol%offset + parabol%slope*x  &
                    + parabol%factor*x**2
  end function parabol_compute
  !
  function gauss_compute(gauss,x)
    !-------------------------------------------------------------------
    ! Compute value at X
    !-------------------------------------------------------------------
    real(kind=4) :: gauss_compute
    class(gaussian_t), intent(in) :: gauss
    real(kind=4),      intent(in) :: x
    gauss_compute = gauss%amp * exp( -(x-gauss%pos)**2/(2*gauss%wid**2) )
  end function gauss_compute
  !
  subroutine model_add(model1,model2,error)
    use gbl_message
    !-------------------------------------------------------------------
    ! Add model2 into model1
    !-------------------------------------------------------------------
    class(model_t), intent(inout) :: model1
    type(model_t),  intent(in)    :: model2
    logical,        intent(inout) :: error
    !
    character(len=*), parameter :: rname='TSYS>MODEL>ADD'
    logical :: done
    !
    done = .false.
    if (model1%itype.eq.model_parabol) then
      if (model2%itype.eq.model_parabol) then
        model1%parabol%offset = model1%parabol%offset  &
                              + model2%parabol%offset
        model1%parabol%slope  = model1%parabol%slope  &
                              + model2%parabol%slope
        model1%parabol%factor = model1%parabol%factor  &
                              + model2%parabol%factor
        done = .true.
      elseif (model2%itype.eq.model_gaussian) then
        model1%itype = model_parabol_gaussian
        model1%gauss = model2%gauss
        done = .true.
      endif
    endif
    !
    if (.not.done) then
      call astro_message(seve%e,rname,'Model combination not implemented')
      error = .true.
      return
    endif
  end subroutine model_add
  !
  function model_compute(model,x)
    !-------------------------------------------------------------------
    ! Compute value at X
    !-------------------------------------------------------------------
    real(kind=4) :: model_compute
    class(model_t), intent(in) :: model
    real(kind=4),   intent(in) :: x
    select case (model%itype)
    case (model_parabol)
      model_compute = model%parabol%compute(x)
    case (model_gaussian)
      model_compute = model%gauss%compute(x)
    case (model_parabol_gaussian)
      model_compute = model%parabol%compute(x) + model%gauss%compute(x)
    case default
      model_compute = 0.
    end select
  end function model_compute
end module noema_tsys_interpolation

module noema_tsys_parameters
  use noema_tsys_interpolation
  !---------------------------------------------------------------------
  ! Parameters (and variables deduced from these) which are shared by
  ! the 2 tables produced by the command NOEMA\TSYS
  !---------------------------------------------------------------------
  !
  ! Data format
  integer(kind=4), parameter :: tsysversion=1
  integer(kind=4), parameter :: contversion=2
  !
  ! Physical parameters
  real(kind=4),    parameter :: h0=2.560    ! [km]  NOEMA altitude
  real(kind=4),    parameter :: p0=1013.0   ! [HPa] At sea level
  real(kind=4)               :: p1          ! [HPa] At site altitude
  integer(kind=4), parameter :: nt=2        ! Number of atmosphere temperatures
  real(kind=4),    parameter :: t(nt) = (/ 273.,283. /)  ! [K]
  !
  ! Hardware
  real(kind=4),    parameter :: gim=0.05    ! [   ] Image gain ratio
  integer(kind=4), parameter :: nb=3        !       Number of bands
  !
  type(parabol_t),  parameter :: nullparabol = parabol_t(0.,0.,0.)
  type(gaussian_t), parameter :: nullgauss = gaussian_t(0.,0.,0.)
  ! Trec values: for each band, provide parabola coefficients.
  type(parabol_t), parameter :: trec_band1 = parabol_t(37.1,0.,0.)  ! Flat C.Fischer 26-jun-2026
  type(parabol_t), parameter :: trec_band2 = parabol_t(45.0,0.,0.)  ! Flat
  type(parabol_t), parameter :: trec_band3 = parabol_t(55.0,0.,0.)  ! Flat
  type(model_t), parameter :: trec_receiver(nb) = [   &
      model_t(model_parabol,trec_band1,nullgauss),  &
      model_t(model_parabol,trec_band2,nullgauss),  &
      model_t(model_parabol,trec_band3,nullgauss) ]
  ! Dichroic contribution if DBR mode:
  type(parabol_t),  parameter :: tdic_band1 = parabol_t(291.9,-5.45,0.0267)  ! C.Fischer 26-jun-2026
  type(parabol_t),  parameter :: tdic_band2 = parabol_t(0.,0.,0.)
  type(gaussian_t), parameter :: tdic_band3 = gaussian_t(13.798,241.938,2.824)
  type(model_t),    parameter :: trec_dichroic(nb) = [  &
      model_t(model_parabol, tdic_band1, nullgauss),  &
      model_t(model_parabol, tdic_band2, nullgauss),  &
      model_t(model_gaussian,nullparabol,tdic_band3) ]
  !
  real(kind=4),    parameter :: trec_blank=1e4  ! [K] Very bad Trec (but valid in computations)
  ! Feff values: for each band, provide parabola coefficients.
  type(parabol_t), parameter :: feff_band1 = parabol_t(0.96,0.,0.)  ! Flat
  type(parabol_t), parameter :: feff_band2 = parabol_t(0.94,0.,0.)  ! Flat
  type(parabol_t), parameter :: feff_band3 = parabol_t(0.90,0.,0.)  ! Flat
  type(model_t),   save      :: feff(nb) = [  &
      model_t(model_parabol,feff_band1,nullgauss),  &
      model_t(model_parabol,feff_band2,nullgauss),  &
      model_t(model_parabol,feff_band3,nullgauss) ]
  real(kind=4),    parameter :: feff_blank=1e-4 ! [ ] Very bad Feff (but valid in computations)
  !
  ! Frequencies. The ranges are defined at run time thanks to
  ! the subroutine 'rec_define_noema'
  real(kind=4)                 :: rf_step      ! [GHz]
  real(kind=4)                 :: rf_min(nb)   ! [GHz]
  real(kind=4)                 :: rf_max(nb)   ! [GHz]
  integer(kind=4)              :: nrf          !
  real(kind=4),    allocatable :: rf(:)        ! [GHz]
  real(kind=4)                 :: lof_step     ! [GHz]
  real(kind=4)                 :: lof_min(nb)  ! [GHz]
  real(kind=4)                 :: lof_max(nb)  ! [GHz]
  integer(kind=4)              :: nlof         !
  real(kind=4),    allocatable :: lof(:)       ! [GHz]
  !
  ! Airmass
  real(kind=4),    parameter   :: a_step=0.5  ! [Neper]
  real(kind=4),    parameter   :: a_min=1.    ! [Neper] Elevation 90 deg
  real(kind=4),    parameter   :: a_max=6.    ! [Neper] Elevation ~9.5 deg
  integer(kind=4)              :: na          !
  real(kind=4),    allocatable :: a(:)        !
  !
  ! PWV
  real(kind=4),    parameter   :: w_step=0.5  ! [mm]
  real(kind=4),    parameter   :: w_min=2.    ! [mm]
  real(kind=4),    parameter   :: w_max=7.    ! [mm]
  integer(kind=4)              :: nw          !
  real(kind=4),    allocatable :: w(:)        !
  !
end module noema_tsys_parameters
!
subroutine noema_tsys(line,error)
  use gbl_message
  use gkernel_interfaces
  use astro_interfaces, except_this=>noema_tsys
  !---------------------------------------------------------------------
  ! @ private
  ! Support routine for command
  !   NOEMA\TSYS TableName [/CONTINUUM] [/DBR]
  ! Compute the Tsys  binary table
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: line
  logical,          intent(inout) :: error
  ! Local
  character(len=*), parameter :: rname='TSYS'
  integer(kind=4), parameter :: optcont=1
  integer(kind=4), parameter :: optdbr=2
  character(len=filename_length) :: tsysfile
  integer(kind=4) :: nc
  logical :: docont,dodbr
  !
  call sic_ch(line,0,1,tsysfile,nc,.true.,error)
  if (error)  return
  !
  if (gag_inquire(tsysfile,nc).eq.0) then
    call astro_message(seve%e,rname,  &
      'File '//tsysfile(1:nc)//' already exists. Remove it first.')
    error = .true.
    if (error)  return
  endif
  !
  docont = sic_present(optcont,0)
  dodbr = sic_present(optdbr,0)
  !
  if (docont) then
    call noema_tsys_continuum(tsysfile,dodbr,error)
    if (error)  continue
  else
    call noema_tsys_table(tsysfile,dodbr,error)
    if (error)  continue
  endif
  !
  call noema_tsys_clean()
  !
end subroutine noema_tsys
!
subroutine noema_tsys_setup(rfstep,lofstep,dbr,trec,error)
  use gbl_message
  use gkernel_interfaces
  use astro_interfaces
  use astro_types
  use ast_line
  use noema_tsys_parameters
  use noema_tsys_interpolation
  !---------------------------------------------------------------------
  ! @ no-interface
  ! Set up the parameters
  !---------------------------------------------------------------------
  real(kind=4),  intent(in)    :: rfstep   !
  real(kind=4),  intent(in)    :: lofstep  !
  logical,       intent(in)    :: dbr      ! DBR mode active?
  type(model_t), intent(out)   :: trec(nb) !
  logical,       intent(inout) :: error    !
  ! Local
  character(len=*), parameter :: rname='TSYS'
  type(receiver_desc_t) :: rdesc
  integer(kind=4) :: ib,ia,iw,irf,ilof,ier
  !
  p1 = p0*2.0**(-h0/5.5)  ! [HPa] Pressure at altitude h0
  !
  ! Get receiver parameters
  call rec_define_noema(rdesc,noema_mode,error)
  if (error)  return
  !
  if (rdesc%n_rbands.ne.nb) then
    ! If error, adapt Trec and Feff arrays
    call astro_message(seve%e,rname,'Number of bands not supported')
    error = .true.
    return
  endif
  !
  ! Frequency ranges
  do ib=1,rdesc%n_rbands
    ! Compute our frequency range. Be conservative (floor/ceiling) + align
    ! to the nearest GHz (purely cosmetic) + 1 more GHz at boundary because
    ! in some cases (e.g. Doppler effect) one has to explore slightly beyond
    ! the usual limits.
    lof_min(ib) = floor(rdesc%lohard(1,ib)/1000.)-1
    lof_max(ib) = ceiling(rdesc%lohard(2,ib)/1000.)+1
    rf_min(ib) = floor(rdesc%rflim(1,ib)/1000.)-1
    rf_max(ib) = ceiling(rdesc%rflim(2,ib)/1000.)+1
  enddo
  !
  rf_step = rfstep
  lof_step = lofstep
  !
  ! Number of RF/IF frequencies
  nrf = (rf_max(rdesc%n_rbands)-rf_min(1))/rf_step+1  ! Assume that bands are ordered increasingly
  ! Number of LO frequencies: the whole range is sampled with no gap between
  ! bands. Beware this feature is used by PMS.
  nlof = (lof_max(rdesc%n_rbands)-lof_min(1))/lof_step+1  ! Assume that bands are ordered increasingly
  ! Number of airmasses: easy
  na = (a_max-a_min)/a_step+1
  ! Number of pwv: easy
  nw = (w_max-w_min)/w_step+1
  !
  ! Define the vectors
  allocate(rf(nrf),lof(nlof),a(na),w(nw),stat=ier)
  if (failed_allocate(rname,'dimension buffers',ier,error))  return
  ! RF frequencies
  do irf=1,nrf
    rf(irf) = rf_min(1)+(irf-1)*rf_step
  enddo
  ! LO frequencies
  do ilof=1,nlof
    lof(ilof) = lof_min(1)+(ilof-1)*lof_step
  enddo
  ! Airmasses
  do ia=1,na
    a(ia) = a_min+(ia-1)*a_step
  enddo
  ! PWV
  do iw=1,nw
    w(iw) = w_min+(iw-1)*w_step
  enddo
  !
  ! Trec: prepare parabola coefficients for each band
  do ib=1,nb
    ! Receiver temperature: always
    trec(ib) = trec_receiver(ib)
    ! Dichroic temperature: if dbr mode
    if (dbr) then
      call trec(ib)%add(trec_dichroic(ib),error)
      if (error)  return
    endif
  enddo
  !
end subroutine noema_tsys_setup
!
subroutine noema_tsys_clean()
  use noema_tsys_parameters
  !---------------------------------------------------------------------
  ! @ private
  ! Deallocate the global buffers. There is no need to keep them
  ! allocated after the command has ended
  !---------------------------------------------------------------------
  !
  if (allocated(rf))   deallocate(rf)
  if (allocated(lof))  deallocate(lof)
  if (allocated(a))    deallocate(a)
  if (allocated(w))    deallocate(w)
  !
end subroutine noema_tsys_clean
!
subroutine noema_tsys_table(file,dbr,error)
  use gbl_message
  use gkernel_interfaces
  use gkernel_types
  use atm_interfaces_public
  use astro_interfaces, except_this=>noema_tsys_table
  use astro_types
  use noema_tsys_parameters
  !---------------------------------------------------------------------
  ! @ private
  ! Compute the Tsys + Opacity table
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: file
  logical,          intent(in)    :: dbr
  logical,          intent(inout) :: error
  ! Local
  character(len=*), parameter :: rname='TSYS'
  character(len=message_length) :: mess
  integer(kind=4) :: if,ia,iw,it,ier,ib
  real(kind=4) :: temis,temii,tatm,tauox,tauw,dummy,taut
  integer(kind=4), allocatable :: band(:)  ! Band number for each RF
  type(model_t) :: trec(nb)
  real(kind=4), allocatable :: vtrec(:),vfeff(:)
  real(kind=4), allocatable :: tsys(:,:,:,:)
  type(time_t) :: time
  !
  ! Parameters
  real(kind=4), parameter :: intfreq=0.  ! [GHz] Intermediate frequency
  ! IF (used to compute the image frequency) is set to 0 because:
  ! 1) typical values show a Tsys difference near 0% at the center of
  !    the bands (where Tsys is flat), and less than 2% at the band
  !    sides (where Tsys varies faster in one sideband than in the
  !    other). => NB: probably not true anymore now that gim is 0.05
  ! 2) it is quite difficult/impossible to produce a generic Tsys table
  !    which would know in advance what is the image frequency distance
  !    and side (lower or upper). In other words we can not know what is
  !    the image frequency associated to a given signal frequency.
  !
  !
  ! Set up the parameters and define the frequency sampling. The RF is
  ! sampled every GHz (this produces a table of reasonable size). LO
  ! sampling is actually unused here.
  call noema_tsys_setup(1.,1.,dbr,trec,error)
  if (error)  return
  !
  ! Vectorized Trec and Feff:
  allocate(band(nrf),vtrec(nrf),vfeff(nrf),stat=ier)
  if (failed_allocate(rname,'Trec & Feff buffers',ier,error))  return
  ! Band number for each RF freq (side product, not in data)
  band(:) = 0
  do ib=1,nb
    where (rf.ge.rf_min(ib) .and. rf.le.rf_max(ib))
      band = ib
    end where
  enddo
  vtrec(:) = trec_blank
  vfeff(:) = feff_blank
  do if=1,nrf
    if (band(if).eq.0)  cycle
    vtrec(if) = trec(band(if))%compute(rf(if))
    vfeff(if) = feff(band(if))%compute(rf(if))
  enddo
  !
  call astro_message(seve%i,rname,'Computing Tsys table with')
  write (mess,10)  nrf,' frequencies  from ',rf(1),' to ',rf(nrf),' x '
  call astro_message(seve%i,rname,mess)
  write (mess,10)  na,' airmasses    from ',a(1),' to ',a(na),' x '
  call astro_message(seve%i,rname,mess)
  write (mess,10)  nw,' pwv          from ',w(1),' to ',w(nw),' x '
  call astro_message(seve%i,rname,mess)
  write (mess,10)  nt,' temperatures from ',t(1),' to ',t(nt)
  call astro_message(seve%i,rname,mess)
10 format(I5,A,F6.2,A,F6.2,A)
  !
  ! Now compute Tsys
  allocate(tsys(nrf,na,nw,nt),stat=ier)
  if (failed_allocate(rname,'tsys buffers',ier,error))  return
  !
  call gtime_init(time,nt*nw*na*nrf,error)
  if (error)  return
  !
  do it=1,nt
    call atm_atmosp(t(it),p1,h0)
    do iw=1,nw
      do ia=1,na
        do if=1,nrf
          ! Signal
          call atm_transm(w(iw),a(ia),rf(if),temis,tatm,tauox,tauw,taut,ier)
          ! Image
          if (intfreq.eq.0.) then
            temii = temis
          else
            call atm_transm(w(iw),a(ia),rf(if)+2.*intfreq,temii,tatm,tauox,tauw,dummy,ier)
          endif
          ! Store Tsys at current airmass
          tsys(if,ia,iw,it) = ( gim * (vfeff(if)*temii+(1.0-vfeff(if))*t(it) + vtrec(if)) +  &
                                      (vfeff(if)*temis+(1.0-vfeff(if))*t(it) + vtrec(if))    &
                              ) / vfeff(if) * exp(taut*a(ia))
          !
          call gtime_current(time)
          if (sic_ctrlc()) then
            call astro_message(seve%e,rname,'Aborted')
            error = .true.
            return
          endif
          !
        enddo
      enddo
    enddo
  enddo
  !
  call noema_tsys_write_bintable(file,error)
  if (error)  return
  !
contains
  subroutine noema_tsys_write_bintable(file,error)
    use gildas_def
    use gbl_format
    !-------------------------------------------------------------------
    !
    !-------------------------------------------------------------------
    character(len=*), intent(in)    :: file
    logical,          intent(inout) :: error
    ! Local
    integer(kind=4) :: ier,nfile,lun,currec,recpos
    character(len=message_length) :: mess
    character(len=4) :: tab_code
    integer(kind=4), parameter :: reclen=128  ! Words
    integer(kind=4) :: buffer(reclen)
    !
    ier = sic_getlun(lun)
    nfile = len_trim(file)
    open(unit=lun,file=file(1:nfile),status='NEW',access='DIRECT',   &
        form='UNFORMATTED',iostat=ier,recl=reclen*facunf)
    if (ier.ne.0) then
      call astro_message(seve%e,rname,'Filename: '//file)
      call putios('E-ATM, Open error: ',ier)
      error = .true.
      goto 99
    endif
    !
    call gdf_getcod(tab_code)
    call chtoby(tab_code,buffer(1),4)
    call i4toi4(tsysversion,buffer(2),1)
    call r4tor4(p1,buffer(3),1)
    call r4tor4(gim,buffer(4),1)
    call r4tor4(intfreq,buffer(5),1)
    call i4toi4(nrf,buffer(6),1)
    call i4toi4(na,buffer(7),1)
    call i4toi4(nw,buffer(8),1)
    call i4toi4(nt,buffer(9),1)
    currec = 1
    recpos = 10
    !
    call noema_tsys_write_binarray(lun,rf,nrf,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,a,na,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,w,nw,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,t,nt,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,vtrec,nrf,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,vfeff,nrf,buffer,currec,recpos,error)
    if (error)  goto 98
    !
    call noema_tsys_write_binarray(lun,tsys,nrf*na*nw*nt,buffer,currec,recpos,error)
    if (error)  goto 98
    !
    if (recpos.ne.1) then
      ! Flush last record
      write(lun,rec=currec,iostat=ier)  buffer
      if (ier.ne.0) then
        write(mess,'(A,I0)') 'Error writing record ',currec
        call astro_message(seve%e,rname,mess)
        error = .true.
        goto 98
      endif
    endif
    !
    write(mess,'(I0,A)') currec,' records written'
    call astro_message(seve%i,rname,mess)
    !
98  close(lun)
99  call sic_frelun(lun)
  end subroutine noema_tsys_write_bintable
  !
end subroutine noema_tsys_table
!
subroutine noema_tsys_continuum(file,dbr,error)
  use gbl_message
  use gkernel_interfaces
  use gkernel_types
  use atm_interfaces_public
  use astro_interfaces, except_this=>noema_tsys_continuum
  use astro_types
  use ast_line
  use noema_tsys_parameters
  !---------------------------------------------------------------------
  ! @ private
  ! Compute the Tsys + Opacity table
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: file
  logical,          intent(in)    :: dbr
  logical,          intent(inout) :: error
  ! Local
  character(len=*), parameter :: rname='TSYS'
  character(len=message_length) :: mess
  integer(kind=4) :: irf,ilof,ia,iw,it,ier,ib
  real(kind=4) :: tatm,tauox,tauw
  integer(kind=4), allocatable :: band(:)  ! Band number for each LOF
  type(model_t) :: trec(nb)
  real(kind=4), allocatable :: vtrec(:),vfeff(:),temi(:),taut(:)
  real(kind=4), allocatable :: tsys(:,:,:,:,:)
  type(time_t) :: time
  type(receiver_desc_t) :: rdesc
  !
  ! Elements
  integer(kind=4), parameter :: ne=3  ! Number of elements stored (Tsys_aver, Tsys_min, Tsys_max)
  integer(kind=4), parameter :: imin=1   ! Index for Tsys_min
  integer(kind=4), parameter :: iaver=2  ! Index for Tsys_aver
  integer(kind=4), parameter :: imax=3   ! Index for Tsys_max
  !
  !
  ! Set up the parameters and define the frequency sampling. The RF is
  ! sampled every 0.1 GHz (this gives good estimation of the average Tsys
  ! over the side band (and this parameter does not influence the table
  ! size). The LO frequency is sampled every GHz (this produces a table
  ! of reasonable size).
  call noema_tsys_setup(0.1,1.0,dbr,trec,error)
  if (error)  return
  !
  ! Get receiver parameters
  call rec_define_noema(rdesc,noema_mode,error)
  if (error)  return
  !
  ! Vectorized Trec and Feff. There are just defined for bookkeeping in the
  ! output table.
  allocate(band(nlof),vtrec(nlof),vfeff(nlof),stat=ier)
  if (failed_allocate(rname,'Trec & Feff buffers',ier,error))  return
  ! Band number for each RF freq (side product, not in data)
  band(:) = 0
  do ib=1,nb
    where (lof.ge.rf_min(ib) .and. lof.le.rf_max(ib))
      band = ib
    end where
  enddo
  vtrec(:) = trec_blank
  vfeff(:) = feff_blank
  do ilof=1,nlof
    if (band(ilof).eq.0)  cycle
    vtrec(ilof) = trec(band(ilof))%compute(lof(ilof))
    vfeff(ilof) = feff(band(ilof))%compute(lof(ilof))
  enddo
  !
  call astro_message(seve%i,rname,'Computing Tsys continuum table with')
  write (mess,10)  ne,  ' elements                              x '
  call astro_message(seve%i,rname,mess)
  write (mess,10)  nlof,' LO frequencies  from ',lof(1),' to ',lof(nlof),' x '
  call astro_message(seve%i,rname,mess)
  write (mess,10)  na,  ' airmasses       from ',a(1),  ' to ',a(na),    ' x '
  call astro_message(seve%i,rname,mess) 
  write (mess,10)  nw,  ' pwv             from ',w(1),  ' to ',w(nw),    ' x '
  call astro_message(seve%i,rname,mess)
  write (mess,10)  nt,  ' temperatures    from ',t(1),  ' to ',t(nt)
  call astro_message(seve%i,rname,mess)
10 format(I5,A,F6.2,A,F6.2,A)
  !
  ! Now compute Tsys
  allocate(temi(nrf),taut(nrf),tsys(ne,nlof,na,nw,nt),stat=ier)
  if (failed_allocate(rname,'tsys buffers',ier,error))  return
  !
  call gtime_init(time,nt*nw*na,error)
  if (error)  return
  !
  do it=1,nt
    call atm_atmosp(t(it),p1,h0)
    do iw=1,nw
      do ia=1,na
        ! Compute Temi and Tau for each frequency. They will be used to compute
        ! the Tsys in the 2 sidebands. The sampling is done at 'if_step'
        do irf=1,nrf
          ! Signal
          call atm_transm(w(iw),a(ia),rf(irf),temi(irf),tatm,tauox,tauw,taut(irf),ier)
        enddo
        do ilof=1,nlof
          call tsys_at_lof(t(it),a(ia),lof(ilof),  &
                           tsys(iaver,ilof,ia,iw,it),   &
                           tsys(imin, ilof,ia,iw,it),   &
                           tsys(imax, ilof,ia,iw,it))
          !
          if (sic_ctrlc()) then
            call astro_message(seve%e,rname,'Aborted')
            error = .true.
            return
          endif
          !
        enddo
        call gtime_current(time)
      enddo
    enddo
  enddo
  !
  call noema_tsys_write_bintable(file,error)
  if (error)  return
  !
contains
  subroutine tsys_at_lof(temp,air,lof,tsys_aver,tsys_min,tsys_max)
    !-------------------------------------------------------------------
    ! Compute the average, minimum, and maximum Tsys for the input Flo
    !-------------------------------------------------------------------
    real(kind=4), intent(in)  :: temp
    real(kind=4), intent(in)  :: air
    real(kind=4), intent(in)  :: lof
    real(kind=4), intent(out) :: tsys_aver
    real(kind=4), intent(out) :: tsys_min
    real(kind=4), intent(out) :: tsys_max
    ! Local
    integer(kind=4) :: isb,isig,iima,ntsys
    integer(kind=size_length) :: ilof
    real(kind=4) :: fmin,fmax,foreff,temrec,tsys,tsys_sum,if_min,if_max
    ! Parameters
    integer(kind=4), parameter :: nsb=2  ! LSB+USB
    !
    ! Position of lof in the RF array
    call gr4_dicho(int(nrf,kind=size_length),rf,lof,ilof)
    if (rf(ilof).ne.lof) then
      ! It is better to have it aligned so that the signal and
      ! image frequencies are exact mirrors w/t the LO freq
      call astro_message(seve%w,rname,'LOF not on RF grid')
    endif
    !
    if_min = rdesc%iflim(1)/1e3  ! [GHz] IF range
    if_max = rdesc%iflim(2)/1e3  ! [GHz] IF range
    ntsys = 0
    tsys_sum = 0.
    tsys_min = 1e10
    tsys_max = 0.
    do isb=1,nsb
      if (isb.eq.1) then
        fmin = lof - if_max
        fmax = lof - if_min
      else
        fmin = lof + if_min
        fmax = lof + if_max
      endif
      do irf=1,nrf
        if (rf(irf).lt.fmin .or. rf(irf).gt.fmax)  cycle
        !
        ! Position of signal and image frequencies in RF array
        isig = irf
        iima = ilof + (ilof-isig)
        !
        ! Feff and Trec at signal frequency
        foreff = foeff(rf(isig))
        temrec = terec(rf(isig))
        !
        ntsys = ntsys+1
        tsys = ( gim * (foreff*temi(iima)+(1.0-foreff)*temp + temrec) +  &
                       (foreff*temi(isig)+(1.0-foreff)*temp + temrec)    &
               ) / foreff * exp(taut(isig)*air)
        ! tsys_sum = tsys_sum + tsys**2
        tsys_sum = tsys_sum + 1./tsys**2
        if (tsys.lt.tsys_min)  tsys_min = tsys
        if (tsys.gt.tsys_max)  tsys_max = tsys
      enddo
    enddo
    !
    ! Post-processing
    if (ntsys.eq.0) then
      tsys_aver = 0.
    elseif (gag_isreal(tsys_sum).eq.0) then
      ! tsys_aver = sqrt(tsys_sum/ntsys)
      tsys_aver = 1./sqrt(tsys_sum/ntsys)
    else
      tsys_aver = 1e10  ! Avoid +Inf in table
    endif
    if (gag_isreal(tsys_max).eq.1)  tsys_max = 1e10  ! Trap +Inf too
    !
  end subroutine tsys_at_lof
  !
  function foeff(rf)
    real(kind=4) :: foeff
    real(kind=4), intent(in) :: rf
    ! Local
    integer(kind=4) :: ib
    !
    do ib=1,nb
      if (rf.ge.rf_min(ib) .and. rf.le.rf_max(ib)) then
        foeff = feff(ib)%compute(rf)
        return
      endif
    enddo
    foeff = feff_blank
  end function foeff
  !
  function terec(rf)
    real(kind=4) :: terec
    real(kind=4), intent(in) :: rf
    ! Local
    integer(kind=4) :: ib
    !
    do ib=1,nb
      if (rf.ge.rf_min(ib) .and. rf.le.rf_max(ib)) then
        terec = trec(ib)%compute(rf)
        return
      endif
    enddo
    terec = trec_blank
  end function terec
  !
  subroutine noema_tsys_write_bintable(file,error)
    use gildas_def
    use gbl_format
    !-------------------------------------------------------------------
    ! Specific to the continuum table
    !-------------------------------------------------------------------
    character(len=*), intent(in)    :: file
    logical,          intent(inout) :: error
    ! Local
    integer(kind=4) :: ier,nfile,lun,currec,recpos
    character(len=message_length) :: mess
    character(len=4) :: tab_code
    integer(kind=4), parameter :: reclen=128  ! Words
    integer(kind=4) :: buffer(reclen)
    !
    ier = sic_getlun(lun)
    nfile = len_trim(file)
    open(unit=lun,file=file(1:nfile),status='NEW',access='DIRECT',   &
        form='UNFORMATTED',iostat=ier,recl=reclen*facunf)
    if (ier.ne.0) then
      call astro_message(seve%e,rname,'Filename: '//file)
      call putios('E-ATM, Open error: ',ier)
      error = .true.
      goto 99
    endif
    !
    call gdf_getcod(tab_code)
    call chtoby(tab_code,buffer(1),4)
    call i4toi4(contversion,buffer(2),1)
    call r4tor4(p1,buffer(3),1)
    call r4tor4(gim,buffer(4),1)
    call i4toi4(ne,buffer(5),1)
    call i4toi4(nlof,buffer(6),1)
    call i4toi4(na,buffer(7),1)
    call i4toi4(nw,buffer(8),1)
    call i4toi4(nt,buffer(9),1)
    currec = 1
    recpos = 10
    !
    ! NB: There is no description of the 'elements' which are stored.
    call noema_tsys_write_binarray(lun,lof,nlof,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,a,na,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,w,nw,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,t,nt,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,vtrec,nlof,buffer,currec,recpos,error)
    if (error)  goto 98
    call noema_tsys_write_binarray(lun,vfeff,nlof,buffer,currec,recpos,error)
    if (error)  goto 98
    !
    call noema_tsys_write_binarray(lun,tsys,ne*nlof*na*nw*nt,buffer,currec,recpos,error)
    if (error)  goto 98
    !
    if (recpos.ne.1) then
      ! Flush last record
      write(lun,rec=currec,iostat=ier)  buffer
      if (ier.ne.0) then
        write(mess,'(A,I0)') 'Error writing record ',currec
        call astro_message(seve%e,rname,mess)
        error = .true.
        goto 98
      endif
    endif
    !
    write(mess,'(I0,A)') currec,' records written'
    call astro_message(seve%i,rname,mess)
    !
98  close(lun)
99  call sic_frelun(lun)
  end subroutine noema_tsys_write_bintable
  !
end subroutine noema_tsys_continuum
!
subroutine noema_tsys_write_binarray(lun,array,n,buffer,currec,recpos,error)
  use gbl_message
  use astro_interfaces, except_this=>noema_tsys_write_binarray
  !---------------------------------------------------------------------
  ! @ private
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)    :: lun
  integer(kind=4), intent(in)    :: n
  real(kind=4),    intent(in)    :: array(n)
  integer(kind=4), intent(inout) :: buffer(:)
  integer(kind=4), intent(inout) :: currec
  integer(kind=4), intent(inout) :: recpos
  logical,         intent(inout) :: error
  ! Local
  character(len=*), parameter :: rname='TSYS'
  integer(kind=4), parameter :: reclen=128
  character(len=message_length) :: mess
  integer(kind=4) :: nwritetot,nwritecur,ier
  !
  nwritetot = 0
  do while (nwritetot.lt.n)
    !
    nwritecur = min(n-nwritetot,reclen-recpos+1)
    call r4tor4(array(nwritetot+1),buffer(recpos),nwritecur)
    nwritetot = nwritetot+nwritecur
    recpos = recpos+nwritecur
    !
    if (recpos.gt.reclen) then
      ! print *,"Writing record ",currec
      write(lun,rec=currec,iostat=ier)  buffer
      if (ier.ne.0) then
        write(mess,'(A,I0)') 'Error writing record ',currec
        call astro_message(seve%e,rname,mess)
        error = .true.
        return
      endif
      currec = currec+1
      recpos = 1
    endif
    !
  enddo
end subroutine noema_tsys_write_binarray
