module noema_tsys_parameters
  !---------------------------------------------------------------------
  ! 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 :: binversion=1
  !
  ! 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
  real(kind=4),    parameter :: trec(nb) = (/ 35.,45.,55. /)       ! [K] Trec values
  real(kind=4),    parameter :: feff(nb) = (/ 0.96, 0.94, 0.90 /)  ! [ ] Forward efficiencies
  !
  ! 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]
  ! 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
  character(len=filename_length) :: tsysfile
  integer(kind=4) :: nc
  !
  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
  !
  if (sic_present(optcont,0)) then
    call noema_tsys_continuum(tsysfile,error)
    if (error)  continue
  else
    call noema_tsys_table(tsysfile,error)
    if (error)  continue
  endif
  !
  call noema_tsys_clean()
  !
end subroutine noema_tsys
!
subroutine noema_tsys_setup(rfstep,lofstep,error)
  use gbl_message
  use gkernel_interfaces
  use astro_interfaces, except_this=>noema_tsys_setup
  use astro_types
  use ast_line
  use noema_tsys_parameters
  !---------------------------------------------------------------------
  ! @ private
  ! Set up the parameters
  !---------------------------------------------------------------------
  real(kind=4), intent(in)    :: rfstep   !
  real(kind=4), intent(in)    :: lofstep  !
  logical,      intent(inout) :: error    !
  ! Local
  character(len=*), parameter :: rname='TSYS'
  type(receiver_t) :: rec
  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(rec,noema_mode,error)
  if (error)  return
  !
  if (rec%desc%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,rec%desc%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(rec%desc%lohard(1,ib)/1000.)-1
    lof_max(ib) = ceiling(rec%desc%lohard(2,ib)/1000.)+1
    rf_min(ib) = floor(rec%desc%rflim(1,ib)/1000.)-1
    rf_max(ib) = ceiling(rec%desc%rflim(2,ib)/1000.)+1
  enddo
  !
  rf_step = rfstep
  lof_step = lofstep
  !
  ! Number of RF/IF frequencies
  nrf = (rf_max(rec%desc%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(rec%desc%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
  !
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,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(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
  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.,error)
  if (error)  return
  !
  ! Vectorized Trec and Feff:
  allocate(vtrec(nrf),vfeff(nrf),stat=ier)
  if (failed_allocate(rname,'Trec & Feff buffers',ier,error))  return
  vtrec(:) = 1e4   ! Blank value: very bad Trec (but valid in computations)
  vfeff(:) = 1e-4  ! Blank value: very bad Feff (but valid in computations)
  do ib=1,nb
    where (rf.ge.rf_min(ib) .and. rf.le.rf_max(ib))
      vtrec = trec(ib)
      vfeff = feff(ib)
    end where
  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(binversion,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,error)
  use gbl_message
  use gkernel_interfaces
  use gkernel_types
  use atm_interfaces_public
  use astro_interfaces, except_this=>noema_tsys_continuum
  use noema_tsys_parameters
  !---------------------------------------------------------------------
  ! @ private
  ! Compute the Tsys + Opacity table
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: file
  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
  real(kind=4), allocatable :: vtrec(:),vfeff(:),temi(:),taut(:)
  real(kind=4), allocatable :: tsys(:,:,:,:,:)
  type(time_t) :: time
  !
  ! 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,error)
  if (error)  return
  !
  ! Vectorized Trec and Feff. There are just defined for bookkeeping in the
  ! output table.
  allocate(vtrec(nlof),vfeff(nlof),stat=ier)
  if (failed_allocate(rname,'Trec & Feff buffers',ier,error))  return
  vtrec(:) = 1e4   ! Blank value: very bad Trec (but valid in computations)
  vfeff(:) = 1e-4  ! Blank value: very bad Feff (but valid in computations)
  do ib=1,nb
    where (lof.ge.rf_min(ib) .and. lof.le.rf_max(ib))
      vtrec = trec(ib)
      vfeff = feff(ib)
    end where
  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
    ! Parameters
    integer(kind=4), parameter :: nsb=2  ! LSB+USB
    real(kind=4), parameter :: if_min=4.    ! [GHz] IF range (min)
    real(kind=4), parameter :: if_max=12.   ! [GHz] IF range (max)
    !
    ! 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
    !
    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
        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)
    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)
        return
      endif
    enddo
    foeff = 1e-4  ! Blank value: very bad Feff (but valid in computations)
    !
  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)
        return
      endif
    enddo
    terec = 1e4   ! Blank value: very bad Trec (but valid in computations)
    !
  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(binversion,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
