subroutine clic_wvr(line,error)
  use gkernel_interfaces
  use gildas_def
  use classic_api
  !---------------------------------------------------------------------
  ! Command WVR
  ! It processes all scans as encountered, except cwvr scans,
  ! to deduce the atmospheric parameter from the wvr.
  ! options /CMODE (1) /NOWRITE (2)
  !---------------------------------------------------------------------
  character(len=*) :: line          !
  logical :: error                  !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_clic.inc'
  include 'clic_par.inc'
  include 'gbl_pi.inc'
  include 'clic_dheader.inc'
  include 'clic_proc_par.inc'
  include 'gbl_memory.inc'
  ! Local
  logical :: end, do_write
  integer(kind=address_length) :: data_in, kin
  integer(kind=data_length)    :: ldata_in
  !      INTEGER IA, IC , S_SCAN
  !      CHARACTER SOURCE1*12
  integer :: mvoc3
  integer :: wvrmode,wvrcpol,wvrprev
  parameter (mvoc3=6)
  character(len=12) :: voc3(mvoc3), arg3
  data voc3/'TR_GE','LAB','TREC','DIODE','NOCAL','DUAL'/
  !------------------------------------------------------------------------
  ! Code:
  call check_input_file(error)
  if (error) return
  call check_index(error)
  if (error) return
  do_write = .not.sic_present(2,0)
  if (do_write) then
    call check_output_file(error)
    if (error) return
    call check_equal_file(error)
    if (error) return
  endif
  !
  ! wvr calibration
  !
  ! default option value
  !      WVRMODE = 4
  ! 24-feb-2004 JMW
  wvrmode = 3                  ! To use ambient load and avoid diode
  wvrcpol = 0
  wvrprev = 0
  ! /CMODE : new option value
  if (sic_present(1,0)) then
    ! read wvr calibration mode
    arg3 = 'DIODE'
    call clic_kw(line,1,1,arg3,wvrmode,voc3,mvoc3,.false.,error,.true.)
    if (error) return
    ! read degree of polynome to be removed
    call sic_i4(line,1,2,wvrcpol,.false.,error)
    if (error) return
    call sic_i4(line,1,3,wvrprev,.false.,error)
    if (error) return
  endif
  PRINT *, WVRMODE, WVRCPOL,WVRPREV
  !
  ! Loop on current index
  call get_first(.true.,error)
  if (error) return
  end = .false.
  do while (.not.end)
    !
    ! Get storage and data
    call get_data (ldata_in,data_in,error)
    if (error) return
    kin = gag_pointer(data_in,memory)
    call sub_wvr(ldata_in,memory(kin),wvrmode,wvrcpol,wvrprev,error)
    if (error) return
    !
    if (do_write) then
      call write_scan (.false.,error)
      if (error) return
    endif
    !
    ! Next observation
    if (sic_ctrlc()) then
      error = .true.
      return
    endif
    error = .false.
    call get_next(end, error)
    if (error) return
  enddo
  !
  return
end subroutine clic_wvr
!
subroutine sub_wvr(ldata_in,data,wvrmode,wvrcpol,wvrprev,error)
  use classic_api
  use clic_buffers
  !---------------------------------------------------------------------
  ! Process a WVR data
  !
  ! Arguments
  !     LDATA_IN      Integer Length of data array
  !     DATA(*)       (*)     Data array
  !
  ! oct-01, RM: add calibration of wvr
  !---------------------------------------------------------------------
  integer(kind=data_length) :: ldata_in               !
  real :: data(ldata_in)            !
  integer :: wvrmode                !
  integer :: wvrcpol                !
  integer :: wvrprev                !
  logical :: error                  !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_clic.inc'
  include 'clic_par.inc'
  include 'clic_dheader.inc'
  include 'clic_proc_par.inc'
  ! Local
  integer :: i, k, kin
  ! wvr variables:
  integer :: mcwvrdump            ! nombre de dump maximum pour la calibration du wvr
  ! mcwvrdump aussi defini dans wvr_cali et bev_polfit
  parameter(mcwvrdump=128)
  integer :: status, j, l
  character(len=160) :: message2
  character(len=80) :: chain
  integer :: wvrstat(mcwvrdump,mnant)
  real :: wvr(mcwvrdump,mwvrch,mnant)
  logical :: save_wvr(mnant), do_reference
  real :: saved_wvrtcal(mwvrch,mnant), saved_wvrtrec(mwvrch,mnant)
  real :: saved_wvraver(mwvrch,mnant)
  save saved_wvrtcal, saved_wvrtrec, saved_wvraver, save_wvr,   &
    do_reference
  data save_wvr/mnant*.false./, do_reference/.false./
  !------------------------------------------------------------------------
  ! Code:
  if (r_proc.eq.p_pass) return
  !
  ! wvr calibration
  do j =1, r_nant
    r_wvrmode(j) = wvrmode
  enddo
  if ( ((r_proc.eq.p_cal).or.(r_proc.eq.p_skydip))   &
    .and. (wvrmode.le.5) ) then
    do i=1, r_ndump
      ! mise en memoire (data(kin)) du data_header du dump I
      kin = (i-1)*r_ldump + 1
      call decode_header (data(kin))
      ! construction des tableaux necessaires a la routine de calibration du wvr
      do j = 1, r_nant
        if (r_wvrnch(j).eq.3) then
          wvrstat(i,j) = dh_wvrstat(j)
          do l = 1, r_wvrnch(j)
            wvr(i,l,j) = dh_wvr(l,j)
          enddo
        endif
      enddo
    enddo
    ! averaged scan
    kin = r_ldump*r_ndump + 1
    call decode_header (data(kin))
    do j = 1, r_nant
      if (r_wvrnch(j).eq.3.and.wvrstat(1,j).eq.10) then
        do k = 1, r_wvrnch(j)
          r_wvraver(k,j) = dh_wvr(k,j)
        enddo
        ! calibration du wvr
        call wvr_cali(j, wvr, wvrstat,   &
          wvrmode, wvrcpol, wvrprev, message2, status)
        if (status.gt.1) then
          call  message(8,1,'SUB_WVR',message2)
        else
          !
          ! Save trec, tcal
          do i=1, r_wvrnch(j)
            saved_wvrtcal(i,j) = r_wvrtcal(i,j)
            saved_wvrtrec(i,j) = r_wvrtrec(i,j)
          enddo
          write (chain,1000) r_kant(j),   &
            (r_wvrtcal(i,j), i=1,r_wvrnch(j))
1000      format('A',i0,' Tcal= ',3f10.2)
          call message(2,1,'SUB_WVR',chain(1:40))
          save_wvr(j) = .true.
        endif
      elseif (r_wvrnch(j).eq.3.and.wvrstat(1,j).ne.10) then
          do i=1,r_wvrnch(j)
             r_wvrtcal(i,j) = saved_wvrtcal(i,j)
             r_wvrtrec(i,j) = saved_wvrtrec(i,j)
          enddo
      endif
    enddo
    do_reference = .true.
  !
  ! Other scans ...
  else
    kin = 1+r_ndump*r_ldump
    call decode_header (data(kin))
    ! Restore  trec, tcal
    do j=1, r_nant
      if (save_wvr(j) .and. r_wvrnch(j).gt.0) then
        do i=1, r_wvrnch(j)
          r_wvrtcal(i,j) = saved_wvrtcal(i,j)
          r_wvrtrec(i,j) = saved_wvrtrec(i,j)
          ! save WVR measurement for all following scans just after a CWVR
          if (do_reference) then
            saved_wvraver(i,j) = r_wvraver(i,j)
          endif
        !                  R_WVRREF(I,J) = SAVED_WVRAVER(I,J)
        enddo
      endif
    enddo
    error = .false.
    call do_wvr (.false.,error)
    do_reference = .false.
  endif
  return
end subroutine sub_wvr
!
!
subroutine wvr_cali(iant, wvr, wvrstat, wvrmode,   &
    wvrcpol, wvrprev, message, status)
  use gkernel_interfaces
  use classic_api  
  !---------------------------------------------------------------------
  ! Author: 18-Oct 2001 Michael Bremer, IRAM
  ! Routine to calibrate the WVR data. Each calibration phase is stored
  ! individually, and the difference hot/ambient can be corrected with a
  ! polynomial of degree wvrcpol (fit with Bevington routines in real*8
  ! attached at the end of this file, independent of NAG or LAPACK).
  !
  ! INPUT: wvr       real*4   raw radiometer counts
  !        wvrstat   integer  instrumental state flag
  !        n_dumps      integer  number of subscans
  !        wvrmode      integer  calibration mode. 1=trec+gain external,
  !                                                2=trec+gain laboratory,
  !                                                3=trec lab, gain calibrated
  !                                                4=trec+gain calibrated
  !        wvrcpol      integer  degree+1 of the polynomial fitted through
  !                              the ambient load counts to improve the Hot
  !                              load counts background subtraction.
  !        wvrprev      integer  if 0: re-calculate wvrtcal, 1: don't re-calculate
  !        wvrtamb      real*4   load temperature in K
  !        wvrtpel      real*4   Peltier temperature in K
  !        wvrlab_tcal  real*4   laboratory value for wvrtcal
  !        wvrlab_trec  real*4   laboratory value for wvrtrec
  !        wvrlab_tdio  real*4   laboratory value for noise diode temperature
  !
  ! OUTPUT:  wvramb     real*4    counts on ambient load for each channel
  !          wvrtcal    real*4    gain K/counts for each channel
  !          wvrtrec    real*4    receiver temperature for each channel
  !          message    character*160   detailed accumulated errors
  !          status     integer   0=ok, 1=warning, 2=error
  !---------------------------------------------------------------------
  include 'clic_parameter.inc'
  integer, parameter :: mcwvrdump=128
  integer :: iant                      !
  real :: wvr(mcwvrdump,mwvrch,mnant)  !
  integer :: wvrstat(mcwvrdump,mnant)  !
  integer :: wvrmode                   !
  integer :: wvrcpol                   !
  integer :: wvrprev                   !
  character(len=160) :: message        !
  integer :: status                    !
  ! Global
  include 'clic_par.inc'
  ! Local
  logical :: f_hot,f_amb,f_ambok ,f_pel, badgain, badpelt
  ! f_hot=noise tube on
  ! f_amb=ambient load on: commanded
  ! f_ambOK=ambient load on: sensor
  ! f3=Peltier Alert on
  !
  character(len=1) :: chan_id(mwvrch)
  integer :: trouble_load, i_hot, i_cold, k, k_last, ic, ix, ii
  integer :: bit_hot, bit_ambok, bit_pel
  parameter (bit_hot=z'00000004', bit_ambok=z'00000002',   &
    bit_pel=z'00000040')
  integer :: max_fp, kplus1, pfit
  parameter(max_fp = 16, pfit=0)
  integer :: num_cold(max_fp), num_hot(max_fp)
  !
  real :: wvrhot(mwvrch)
  real :: rnum1, rnum2, delta(mwvrch), ww(max_fp)
  real :: tmp
  real*8 :: xx_cold(max_fp), xx_hot(max_fp), sum_cold(max_fp,mwvrch)
  real*8 :: sum_hot(max_fp,mwvrch), a(max_fp), w(max_fp), chisqr
  real :: wvr_cts0(mwvrch,mnant)
  data chan_id /'1','2','3'/
  !
  !==========================================================================
  !
  !      print *, 'iant ',iant, ' wvrmode ',wvrmode, ' WVRCPOL ',WVRCPOL
  trouble_load = 0
  badgain = .false.
  badpelt = .false.
  i_hot  = 0
  i_cold = 0
  !
  ! safeguard against strange data:
  if (r_ndump .lt. 1 ) then
    message = 'Error: r_ndump < 1, no serious data.'
    status=2
    return
  endif
  !
  k_last = -1
  do ix = 1, r_ndump
    k  = wvrstat(ix,iant)
    ! this form is only accepted by Linux g77
    ! checked in the actual bits -- RL
    f_hot = iand(k,bit_hot)   .ne.0
    f_ambok = iand(k,bit_ambok) .ne.0
    ! la commande n'est pas dans le status -- RL.
    !          F_AMB = IAND(K,2) .EQ. 2
    f_amb = f_ambok
    f_pel = iand(k,bit_pel) .ne.0
    !
    badpelt = badpelt.or.f_pel
    !
    ! always ignore the first point after a change in operational mode flag
    !
    if (f_amb.and.f_ambok) then
      if (f_hot) then
        if (k .eq. k_last) then
          do ic = 1, mwvrch
            sum_hot(i_hot,ic)=sum_hot(i_hot,ic)+wvr(ix,ic,iant)
          enddo
          num_hot(i_hot) = num_hot(i_hot)+1
          xx_hot(i_hot) = xx_hot(i_hot) + ix
        else
          i_hot = i_hot+1
          num_hot(i_hot)  = 0
          xx_hot(i_hot)   = 0.0
          do ic = 1, mwvrch
            sum_hot(i_hot,ic)=0.0
          enddo
        endif
      else
        if (k .eq. k_last) then
          do ic = 1, mwvrch
            sum_cold(i_cold,ic)=sum_cold(i_cold,ic)+wvr(ix,ic,iant)
          enddo
          num_cold(i_cold) = num_cold(i_cold)+1
          xx_cold(i_cold) = xx_cold(i_cold) + ix
        else
          i_cold = i_cold+1
          num_cold(i_cold)  = 0
          xx_cold(i_cold)   = 0.0
          do ic = 1, mwvrch
            sum_cold(i_cold,ic)=0.0
          enddo
        endif
      endif
    else
      trouble_load = trouble_load+1
    endif
    k_last = k
  enddo
  !
  ! calculate average counts on ambient (wvramb) and hot (wvrhot) observation,
  ! wvramb is necessary for tsys estimate by another subroutine.
  !
  do ic = 1, mwvrch
    r_wvramb(ic,iant) = 0.0
    wvrhot(ic) = 0.0
  enddo
  rnum1 = 0.0
  rnum2 = 0.0
  do ix = 1, i_cold
    if (num_cold(ix) .gt. 0) then
      do ic = 1, mwvrch
        r_wvramb(ic,iant) = r_wvramb(ic,iant) + sum_cold(ix,ic)
      enddo
      rnum1 = rnum1 + num_cold(ix)
    endif
  enddo
  do ix = 1, i_hot
    if (num_hot(ix) .gt. 0) then
      do ic = 1, mwvrch
        wvrhot(ic) = wvrhot(ic) + sum_hot(ix,ic)
      enddo
      rnum2 = rnum2 + num_hot(ix)
    endif
  enddo
  do ic = 1, mwvrch
    r_wvramb(ic,iant) = r_wvramb(ic,iant)/max(1.,rnum1)
    wvrhot(ic) = wvrhot(ic)/max(1.,rnum2)
  enddo
  !      print *, (iant, ic, R_WVRAMB(IC,IANT), WVRHOT(IC), ic=1, MWVRCH)
  !
  ! If requested (and possible): polynomial fit through cold calibration
  ! phases to determine offset of hot calibration phases.
  ! Shift X axis into [-1,1] interval for higher fit precision
  ! Calculate the average calibration points
  !
  do ix = 1, i_cold
    do ic = 1, mwvrch
      sum_cold(ix,ic) = sum_cold(ix,ic)/max(1,num_cold(ix))   &
        - r_wvramb(ic,iant)
    enddo
    xx_cold(ix) = xx_cold(ix)/max(1,num_cold(ix))   &
      * 2.0 / float(r_ndump) - 1.0
  enddo
  do ix = 1, i_hot
    do ic = 1, mwvrch
      sum_hot(ix,ic) = sum_hot(ix,ic)/max(1,num_hot(ix))   &
        - r_wvramb(ic,iant)
    enddo
    xx_hot(ix) = xx_hot(ix)/max(1,num_hot(ix))   &
      * 2.0 / float(r_ndump) - 1.0
  enddo
  !
  if ((wvrcpol .ne. 0).and.(i_cold.ge.2)) then
    !
    kplus1 = max(min(wvrcpol,i_cold-1),1)
    do ix = 1, max_fp
      ww(ix) = 0.0
      if (ix .le. i_cold) ww(ix) = 1.0
    enddo
    do ic = 1, mwvrch
      do ix = 1, max_fp
        w(ix) = 1.0
      enddo
      ix = 0
      call bev_polfit (xx_cold, sum_cold(1,ic), w, i_cold,   &
        kplus1-1, ix, a, chisqr)
      delta(ic) = 0.0
      do ix = 1, i_hot
        tmp = a(kplus1)
        if (kplus1 .gt. 1) then
          do ii = kplus1-1,1,-1
            tmp = tmp * xx_hot(ix) + a(ii)
          enddo
        endif
        delta(ic) = delta(ic) + (sum_hot(ix,ic) - tmp)
      enddo
      delta(ic) = delta(ic) / float(i_hot)
    enddo
  else
    do ic = 1, mwvrch
      delta(ic) = wvrhot(ic)-r_wvramb(ic,iant)
    enddo
  !         print *, delta
  endif
  ! Philosophy: always write the gains and receiver temperatures
  !             which were actually applied into the header.
  !
  ! Wvrmode 1: DO NOTHING, trec & gains come from the calling program
  ! Wvrmode 2: apply laboratory Trec and Gains.
  ! Wvrmode 3: apply laboratory Trec and use actual calibration for Gains.
  ! Wvrmode 4: apply actual calibration for Gains and Trec.
  !
  !      BADGAIN = (RNUM1.EQ.0).OR. (RNUM2.EQ.0) no diode anymore
  badgain = (rnum1.eq.0)
  if (wvrmode .eq. 2) then
    do ic = 1, mwvrch
      r_wvrtcal(ic,iant) = r_wvrlabtcal(ic,iant)
      r_wvrtrec(ic,iant) = r_wvrlabtrec(ic,iant)
    enddo
  elseif (wvrmode .eq. 3) then
    do ic = 1, mwvrch
      badgain = badgain .or. (r_wvramb(ic,iant).lt.0.0001)
      r_wvrtrec(ic,iant) = r_wvrlabtrec(ic,iant)
      if (wvrprev .eq. 0) r_wvrtcal(ic,iant) = (r_wvrtrec(ic,iant)+r_wvrtamb(iant))   &
                       /max(r_wvramb(ic,iant),0.0001)
    enddo
  elseif (wvrmode .eq. 4) then
    do ic = 1, mwvrch
      badgain = badgain .or. (delta(ic).lt.0.0001)
      if (wvrprev .eq. 0) r_wvrtcal(ic,iant) = r_wvrlabtdio(ic,iant)   &
                          /max(delta(ic),0.0001)
    !            Y = DELTA(IC)/MAX(R_WVRAMB(IC,IANT),0.0001)
    !            R_WVRTREC(IC,IANT) = R_WVRLABTDIO(IC,IANT)/Y
    !     $      - R_WVRTAMB(IANT)
    enddo
  elseif (wvrmode .eq. 5) then
    do ic = 1, mwvrch
      wvr_cts0(ic,iant) = r_wvrtrec(ic,iant)
      if (wvrprev .eq. 0) r_wvrtcal(ic,iant) = r_wvrtamb(iant)   &
               /max((r_wvramb(ic,iant) - wvr_cts0(ic,iant)) ,0.0001)
    enddo
  elseif (wvrmode .eq. 6) then
    wvr_cts0(1,iant) = r_wvrtrec(1,iant)
    r_wvrtcal(1,iant) = 0.0
    do ic = 2, mwvrch
      wvr_cts0(ic,iant) = r_wvrtrec(ic,iant)
      if (wvrprev .eq. 0) r_wvrtcal(ic,iant) = r_wvrtamb(iant)   &
        /max((r_wvramb(ic,iant) - wvr_cts0(ic,iant)),0.0001)
    enddo
  endif
  !
  status = 0
  message = ' '
  !
  ! Reason to worry but one can continue: Ambient load movement slow
  if (trouble_load .gt. 2) then
    status = 1
    message = 'Ambient load slow.'
  endif
  !
  ! Look how far we're off relative to the lab values. If > 30%, something
  ! went wrong for sure. Take Lab values to avoid data loss.
  !
  do ic = 1, mwvrch
    tmp = abs(r_wvrtrec(ic,iant)-r_wvrlabtrec(ic,iant))   &
      /r_wvrlabtrec(ic,iant)
    !         print *, 'ic, R_WVRTREC(IC,IANT), R_WVRLABTREC(IC,IANT)'
    !         print *, ic, R_WVRTREC(IC,IANT), R_WVRLABTREC(IC,IANT)
    if (tmp.gt.0.3) then
      status=1
      message = message(1:lenc(message))//   &
        ' too large TREC deviation in Channel '//chan_id(ic)
    !     PRINT*,R_WVRTREC(IC,IANT),' <=> ',R_WVRLABTREC(IC,IANT),TMP
    !            R_WVRTREC(IC,IANT) = R_WVRLABTREC(IC,IANT)
    endif
    !         print *, 'ic, R_WVRTCAL(IC,IANT), R_WVRLABTCAL(IC,IANT)'
    !         print *, ic, R_WVRTCAL(IC,IANT), R_WVRLABTCAL(IC,IANT)
    tmp = abs(r_wvrtcal(ic,iant)-r_wvrlabtcal(ic,iant))   &
      /r_wvrlabtcal(ic,iant)
    if (tmp.gt.0.3) then
      status=1
    !            MESSAGE = MESSAGE(1:LENC(MESSAGE))//
    !     $      ' too large GAIN deviation in Channel '//CHAN_ID(IC)
    !            PRINT*,R_WVRTCAL(IC,IANT),' <=> ',R_WVRLABTCAL(IC,IANT),TMP
    !            R_WVRTCAL(IC,IANT) = R_WVRLABTCAL(IC,IANT)
    endif
  enddo
  !
  ! Reason to check instrument (and don't use this calibration):
  !   1) a calibration phase is missing, or the difference between phases
  !      is useless,
  !   2) the Peltier regulation has a serious problem,
  !   3) the load is not in front of the horn.
  !
  if (badgain) then
    status = 2
    message = message(1:lenc(message))//' Bad calibration.'
  endif
  if (badpelt) then
    status = 2
    message =  message(1:lenc(message))//' Peltier Alert.'
  endif
  if (trouble_load .eq. r_ndump) then
    status = 2
    message =  message(1:lenc(message))//' Load did not move.'
  endif
!
!      write(*,*) 'message ',message
end subroutine wvr_cali
!
subroutine do_wvr (again,error)
  use gkernel_interfaces
  use gildas_def
  use classic_api  
  !---------------------------------------------------------------------
  ! The WVR MODEL program is called for each antenna.
  !---------------------------------------------------------------------
  logical :: again                  !
  logical :: error                  !
  ! Global
  real :: air_mass_m
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  include 'clic_clic.inc'
  include 'clic_display.inc'
  include 'clic_proc_par.inc'
  include 'gbl_pi.inc'
  ! Local
  integer :: ia, ic, ntrec
  real ::  awater
  character(len=160) :: ch
  integer :: ilevel, status
  real :: airmass, elevation
  !------------------------------------------------------------------------
  ! Code:
  ! Force input values if desired
  ilevel = 1
  ntrec = 0
  awater = 0
  !
  ! Necessary preparation calls:
  !
  call atm_atmosp(r_tamb, r_pamb, r_alti)
  !
  ! elevation in degrees
  elevation = 180.0*r_el/pi
  airmass = air_mass_m(elevation, r_alti)
  !
  do ia=1, r_nant
    if (r_wvrnch(ia).eq.3) then
      call wvr_model (ia,airmass,status)
      !            IF (.NOT.AGAIN) THEN
      write(ch,1000) r_kant(ia),r_wvrmode(ia),r_wvrh2o(ia),   &
        (r_wvrdpath(ic,ia),ic=1,r_wvrnch(ia)),   &
        (r_wvrliq(ic,ia),ic=1,r_wvrnch(ia))
      call message(ilevel,1,'DO_WVR',ch(1:lenc(ch)))
1000  format('A',i0,' M',i1,' w=',f7.3,' Dp=',3f7.0,' lq=',3f6.3)
      !     ENDIF
      if (status.ne.0) then
        call  message(8,1,'DO_WVR','Problem in ATM routine')
      endif
    endif
  enddo
  return
end subroutine do_wvr
!
subroutine wvr_model(ia,airmass, status)
  use classic_api  
  !---------------------------------------------------------------------
  ! M. Bremer, 17-Oct-2001
  ! Tested with small "frame" program using WVR test data sets.
  ! Calculates an atmospherical model for phase correction for the
  ! triple-band radiometer, assumes operational radiometers, i.e.
  ! antennas not yet equipped with WVRs must NOT call this routine.
  !
  ! LINK LIBRARY:
  !     libatm.a
  !
  ! BEFORE calling wvr_model in an antenna-specific loop:
  !        call atm_atmosp(r_tamb, r_pamb, r_alti)
  !
  ! INPUT:
  !
  !     real wvrfreq(mwvrch)  I  frequencies
  !     real wvrbw(mwvrch)    I  bandwidth
  !     real r_pamb           I  atm. press
  !     real r_tamb           I  atm. Temp
  !     real r_alti           I  observatory alititude
  !     real airmass          I  airmass
  !     real wvrfeff(mwvrch)  I  Forward efficiency for each channel
  !     real wvrtcal(mwvrch)  I  k/count channel gains
  !     real wvrtrec(mwvrch)  I  receiver temperatures (per channel)
  !     real wvraver(mwvrch)  I  average counts of current obs, which
  !                              must be on the sky
  !     real wvramb(mwvrch)   I  average counts on last ambient measurement
  !     real wvrtamb          I  last load temperature
  !
  ! OUTPUT:
  !     real wvrtatm          O  WVR central channel "clear sky"
  !                              atmospheric temperature
  !     real wvrtsys (mwvrch) O  WVR channel system temperature
  !     real wvrdpath(mwvrch) O  factors for channels for
  !                              Tsky to path conversion [microns/K]
  !     real wvrh2o           O  Precipitable amount of water vapour [mm]
  !     real wvrliq(mwvrch)   O  Tsky weight factors for each channel
  !                              for combination into cloud emission []
  !     real wvrdcloud(mwvrch)O  (experimental:) factors to convert
  !                              the cloud emission into liquid phase shifts.
  !                              Units: [microns/K]
  !     integer status        O  atm standard error codes, +10 superimposed
  !                              if iteration for water does not reproduce
  !                              t_triple to 1e-4 (relative error)
  !
  ! MEMO:
  !
  ! vapor_path =sum(ic=1,mwvrch){wvrdpath(ic)*(tsky(ic)}
  ! cloud_path =sum(ic=1,mwvrch){wvrdcloud(ic)*wvrliq(ic)*tsky(ic)}
  !
  ! where tsky(ic) = atmospheric emission in Kelvin along the line of sight
  !---------------------------------------------------------------------
  integer :: ia                     !
  real :: airmass                   !
  integer :: status                 !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  include 'clic_clic.inc'
  ! Local
  integer :: ic
  real :: wvrtaut(mwvrch)
  real :: b, c1, c2, t_triple, tsky(mwvrch)
  real :: temib(mwvrch), tamb, dpdtri, tcloud
  real :: a1,a2,a3, b1,b2,b3, c, wvr_cts0(mwvrch,mnant)
  !----------------------------------------------
  !
  status = 0
  !
  ! Ambient temperature as seen by the instrument should be a
  ! combination of outside and receiver cabin temperature.
  !
  !      TAMB = R_WVRTAMB(IA) * 0.5 + R_TAMB * 0.5
  tamb = r_wvrtamb(ia)
  !
  ! Remove first order instrumental effects:
  !
  c1 = (r_wvrfreq(1,ia) / r_wvrfreq(2,ia))**2
  c2 = (r_wvrfreq(2,ia) / r_wvrfreq(3,ia))**2
  b = (1.-c1)/(1.-c2)
  !
  do ic = 1, mwvrch
    if (r_wvrtcal(ic,ia).le.0) then
      status = 1
      print *, 'No calibration for antenna ',ia
      return
    endif
    if (r_wvrmode(ia).ge.5) then
      wvr_cts0(ic,ia) = r_wvrtrec(ic,ia)
      tsky(ic)=(r_wvraver(ic,ia)-wvr_cts0(ic,ia))*   &
        r_wvrtcal(ic,ia)
    else
      tsky(ic)=(r_wvraver(ic,ia)*r_wvrtcal(ic,ia)-   &
        r_wvrtrec(ic,ia)-   &
        (1.-r_wvrfeff(ic,ia)) * tamb)/r_wvrfeff(ic,ia)
    endif
  enddo
  !
  ! Remove clouds and second order instrumental effects:
  !
  t_triple = b*(tsky(2)-tsky(3)*c2) - (tsky(1)-tsky(2)*c1)
  !      T_TRIPLE =  (TSKY(1)-TSKY(2)*C1) - B*(TSKY(2)-TSKY(3)*C2)
  if (r_wvrmode(ia).eq.6) then
     t_triple = tsky(2)-tsky(3)*c2
  endif
  !
  call atm_tri (ia,t_triple,b,c1,c2,airmass,   &
    dpdtri, temib, wvrtaut, status)
  !
  ! build the dTcoud/dTsky factors
  !
  do ic = 1, mwvrch
    r_wvrliq(ic,ia) = (1. - temib(ic)/tsky(ic))
  enddo
  !
  ! build the clear sky "dpath(microns)/dTsky(Kelvin) factors
  !
  r_wvrdpath(1,ia) = -dpdtri
  r_wvrdpath(2,ia) =  dpdtri * (c1 + b)
  r_wvrdpath(3,ia) = -dpdtri *  c2 * b

  if (r_wvrmode(ia).eq.6) then
   r_wvrdpath(1,ia) =  0.0
   r_wvrdpath(2,ia) =  dpdtri
   r_wvrdpath(3,ia) = -dpdtri *  c2
  endif
  !
  !      R_WVRDPATH(1,IA) =  DPDTRI
  !      R_WVRDPATH(2,IA) = -DPDTRI * (C1 + B)
  !      R_WVRDPATH(3,IA) =  DPDTRI *  C2 * B
  !
  if (atmmodel.eq.'1985') then
    !         print *, 'Old ATM: Fudge factor'
    !        Simulate approximately the effect of NEWATM on the delay factors
    !        Assignment of the coefficients could be pulled out of the antenna loop
    a1 = -5.81000e-03
    a2 = -5.79000e-03
    a3 = -5.77000e-03
    b1 =  1.17452
    b2 =  1.16929
    b3 =  1.16532
    c  =  1.08000
    !
    r_wvrdpath(1,ia) = (a1*r_wvrh2o(ia)+b1)*c*r_wvrdpath(1,ia)
    r_wvrdpath(2,ia) = (a2*r_wvrh2o(ia)+b2)*c*r_wvrdpath(2,ia)
    r_wvrdpath(3,ia) = (a3*r_wvrh2o(ia)+b3)*c*r_wvrdpath(3,ia)
  endif
  !
  ! WVR tsys definition after R. Lucas (1995),
  ! "Practical implementation of phase correction", IRAM Report
  !
  do ic = 1, mwvrch
    r_wvrtsys(ic,ia)=r_wvraver(ic,ia)*r_wvrtcal(ic,ia)   &
      /r_wvrfeff(ic,ia)
  enddo
  !
  ! Classical Tsys
  !
  !c       do ic = 1, mwvrch
  !c           tcal = (wvrtamb - tsky(ic))/wvrfeff(ic) *
  !c     $            exp(wvrtaut(ic) * airmass)
  !c           wvrtsys(ic) = tcal * wvraver(ic)/(wvramb(ic)-wvraver(ic))
  !c        enddo
  !
  tcloud = 278.0
  call atm_tri_cl(ia,tcloud)
!
end subroutine wvr_model
!
!------------------------------------------------------------------------
subroutine atm_tri(ia,t_triple,b,c1,c2,airmass,   &
    dpdtri, temib, wvrtaut, ier)
  use atm_interfaces_public
  use classic_api
  !---------------------------------------------------------------------
  ! Purpose: determines the amount of water vapor for the triple frequency
  !          radiometer.
  ! INPUT:  real*4 t_triple: weighted sum of the 3 monitoring bands in Kelvin
  !        wvrfreq(mwvrch) : effective central monitoring frequencies in GHz
  !          wvrbw(mwvrch) : channel band widths
  !                b,c1,c2 : weighting factors between the bands
  !                airmass : Air mass, "one" in zenith
  ! OUTPUT: real*4 wvrh2o   : precipitable amount of water vapor in mm (Zenith)
  !                dpdtri  : gradient dpath/dt_triple in microns/K
  !                wvrtatm : atmospherical temperature (center water line)
  !           temib(mwvrch): "blue sky" emission at the given elevation,
  !                          i.e. modelled monitor band signals without
  !                          clouds in Kelvin
  !                path_out: "blue sky" optical path in microns
  !         wvrtaut(mwvrch): total clear sky opacity of the wvr channels
  !         integer*4 ier  : error flag.
  !
  ! NOTE: Routine needs a previous call to  atm_atmosp(t0, p0, h0), by
  !       preference OUTSIDE the antenna specific loop.
  !
  ! Author: Michael Bremer, IRAM 10-Jun-1999
  !---------------------------------------------------------------------
  include 'clic_parameter.inc'
  integer :: ia                     !
  real :: t_triple                  !
  real :: b                         !
  real :: c1                        !
  real :: c2                        !
  real :: airmass                   !
  real :: dpdtri                    !
  real :: temib(mwvrch)             !
  real :: wvrtaut(mwvrch)           !
  integer :: ier                    !
  ! Global
  include 'clic_par.inc'
  ! Local
  integer :: i, nval, ic, ib
  parameter (nval = 3)
  real :: f_ghz
  real :: tatm, tauox, tauw, taut, path
  real :: wa, wband(-1:1)
  real :: w(nval), temia(mwvrch)
  real :: tri(nval), patha(nval), tri_water
  real :: ave_tsky, ave_path, ave_taut, ave_tatm
  real :: tsky, hl, hr
  !
  ! The 3-point weighted sum over the passbands corresponds to the
  ! average over a polynomial of 2nd degree (Simpson formula).
  data wband /0.16666667, 0.6666666, 0.16666667/
  !--------------------------------------------------
  w(2) = 0
  !
  if (r_wvrmode(ia).ge.5) then
    if (r_wvrmode(ia).eq.6) then
      call dual_water(ia,t_triple,b,c1,c2,airmass,   &
        tri_water,ier)
      r_wvrh2o(ia) = tri_water
      w(2) = r_wvrh2o(ia)
    else
      call triple_water(ia,t_triple,b,c1,c2,airmass,   &
        tri_water,ier)
      r_wvrh2o(ia) = tri_water
      w(2) = r_wvrh2o(ia)
    endif
  else
    do i =1, r_nant
      w(2) = w(2)+r_h2omm(1,i)
    enddo
    w(2) = w(2)/r_nant
  endif
  w(1) = w(2)*0.9
  w(3) = w(2)*1.1
  !
  !      TT = ABS(T_TRIPLE)
  !
  do i = 1, nval
    do ic = 1, mwvrch
      wa =  w(i)
      ave_tsky = 0.0
      ave_path = 0.0
      do ib = -1,1
        f_ghz = 0.001*(r_wvrfreq(ic,ia) + ib*r_wvrbw(ic,ia)*0.5)
        call atm_transm(wa, airmass, f_ghz, tsky, tatm,   &
          tauox, tauw, taut, ier)
        call atm_path(wa, airmass, f_ghz, path, ier)
        ave_tsky = ave_tsky + tsky * wband(ib)
        ave_path = ave_path + path * wband(ib)
      enddo
      temia(ic) =  ave_tsky
      if (ic .eq. 2) patha(i) =  ave_path
    enddo
    tri(i)  =  b * (temia(2) - c2 * temia(3)) -   &
      (temia(1) - c1 * temia(2))
  !         TRI(I)  =  (TEMIA(1) - C1 * TEMIA(2)) -
  !     $              B * (TEMIA(2) - C2 * TEMIA(3))
  enddo
  !
  ! checked for unusual temperature and pressure values
  ! (150-500K, 300-1500 mbar in case of a meteo station problem):
  ! no problem with having different "tri" values for the water values,
  ! poly_3 won't crash.
  !
  ! calculate the actual amount of water
  !      R_WVRH2O(IA) = W(2)
  !      DPDTRI = (PATHA(3)-PATHA(1)) / (TRI(3)-TRI(1))
  ! Use second order accuracy for the derivative (JMW, Nov 24 2003)
  hl     = tri(2)-tri(1)
  hr     = tri(3)-tri(2)
  dpdtri =  -hr/(hl*(hl+hr)) * patha(1) +   &
    (hr-hl)/(hr*hl)  * patha(2) +   &
    hl/(hr*(hl+hr)) * patha(3)
  !
  ! Conversion from cm/K to microns/K
  dpdtri = dpdtri * 1e4
  !
  ! Expected blue sky contribution to the bands (incl. other
  ! components than H2O):
  !
  do ic = 1, mwvrch
    ave_tsky = 0.0
    ave_path = 0.0
    ave_taut = 0.0
    ave_tatm = 0.0
    do ib = -1,1
      f_ghz = 0.001*(r_wvrfreq(ic,ia) + ib*r_wvrbw(ic,ia)*0.5)
      !
      ! calls to libatm.a
      !
      call atm_transm(r_wvrh2o(ia), airmass, f_ghz,   &
        tsky, tatm, tauox, tauw, taut, ier)
      call atm_path(r_wvrh2o(ia), airmass, f_ghz, path, ier)
      !
      ave_tsky = ave_tsky + tsky * wband(ib)
      ave_path = ave_path + path * wband(ib)
      ave_taut = ave_taut + taut * wband(ib)
      ave_tatm = ave_tatm + tatm * wband(ib)
    enddo
    temib(ic) =  ave_tsky
    wvrtaut(ic) = ave_taut
    if (ic .eq. 2) then
      r_wvrpath(ia) = ave_path*1e4
      r_wvrtatm(ia) = ave_tatm
    endif
  enddo
!
end subroutine atm_tri
!
!------------------------------------------------------------------------
!
function air_mass_m (elevation, altitude)
  !---------------------------------------------------------------------
  ! NIC	SOLVE support routine
  !	Compute air masses
  ! 10-JUL-1995 modified by M. Bremer
  !
  ! Arguments :
  !	ELEV		R*4	elevation in degrees		Input
  !	AIR_MASS	R*4	number of airmasses		Output
  !       ALTITUDE        R*4     altitude of observatory above
  !                               sea level                       Input
  !---------------------------------------------------------------------
  real*4 ::  air_mass_m             !
  real*4 ::  elevation              !
  real*4 ::  altitude               !
  ! Local
  integer :: index
  real*4 ::  h0_al(7)
  real*8 ::  hz, h0, r0, r1, pi, r0_al
  real*8 :: elv, eps, gam
  !
  !     earth radius (in km)
  parameter (r0 = 6370.0, pi = 3.141592653589793238d0)
  !
  ! DEPENDENCY OF SCALE HEIGHT H0_AL ON ALTITUDE (BOTH IN KM)
  ! FROM ALLEN C.W. 1991, ASTROPHYSICAL QUANTITIES, THE ATHLONE PRESS, P. 122)
  !
  ! ALTITUDE OVER SEA LEVEL  0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0
  data  h0_al        / 8.4, 8.3, 8.2, 8.0, 7.8, 7.5, 7.2/
  !
  ! LINEAR INTERPOLATION BETWEEN NEAREST VALUES IN ALTITUDE FOR SCALE HEIGHT
  index = int(altitude) + 1
  h0    = h0_al(index) + (h0_al(index+1) - h0_al(index)) *   &
    (altitude - index - 1)
  !
  r0_al = r0 + altitude
  !
  elv = elevation*pi/180
  r1  = r0_al + h0
  eps = asin( r0_al / r1 * cos(elv) )
  gam = pi/2 - elv - eps
  hz  = r0_al*r0_al + r1*r1 - 2*r0_al*r1*cos(gam)
  hz  = sqrt(max(hz,h0*h0))    ! avoid less than one air mass
  !
  air_mass_m = hz/h0
  return
end function air_mass_m
!
!*************************************************************************
!
subroutine poly_3(x,y,para)
  !---------------------------------------------------------------------
  ! Calculate the 3rd degree polynomial parameters going through 4 points:
  ! y = d + x*(c + x*(b + x*a) )
  ! para(1,2,3,4) = (a,b,c,d)
  ! Caution: all x must be different from each other. No rezoning to [-1,1] is
  !          done, values of x>100 can result in dubious results, especially
  !          for "d" (the other parameters depend on differences)
  !
  !  Input: real*8 x(4), y(4)
  ! Output: real*8 para(4)
  !
  !  Speed: about 30 times faster than a Gauss-Jordan matrix inversion
  !
  ! Author: M. Bremer, 10-Jun-1999 (tested, OK)
  !---------------------------------------------------------------------
  real*4 :: x(4)                    !
  real*4 :: y(4)                    !
  real*4 :: para(4)                 !
  ! Local
  integer :: i, j
  real*4 :: dx(3),dy(3),dx2(3),dx3(3),fr1(3),fr2(3),fr3(3)
  real*4 :: a,b,c,d,df1,df2,dfr1,dfr2
  !
  ! use smallest available x for determination of "d"
  !
  j = 1
  do i = 2,4
    if ( abs(x(i)) .lt. abs(x(j)) ) j = i
  enddo
  !
  do i = 1,3
    dy (i) = y(i) - y(i+1)
    dx (i) = x(i) - x(i+1)
    dx2(i) = x(i)**2 - x(i+1)**2
    dx3(i) = x(i)**3 - x(i+1)**3
    fr1(i) = dy(i)  / dx(i)
    fr2(i) = dx2(i) / dx(i)
    fr3(i) = dx3(i) / dx(i)
  enddo
  df1 = 1./(fr2(1) - fr2(2))
  df2 = 1./(fr2(2) - fr2(3))
  !
  dfr1 = fr1(1) - fr1(2)
  dfr2 = fr1(2) - fr1(3)
  !
  a =  (dfr1*df1 - dfr2*df2)/   &
    ((fr3(1)-fr3(2))*df1 - (fr3(2)-fr3(3))*df2)
  b =  (dfr1 - a*(fr3(1)-fr3(2)) ) * df1
  c =  (dy(1)-a*dx3(1)-b*dx2(1))/dx(1)
  d = y(j) - x(j)*(c + x(j)*(b + a*x(j)) )
  para(1) = a
  para(2) = b
  para(3) = c
  para(4) = d
end subroutine poly_3
!
!*************************************************************************
subroutine atm_tri_cl(ia,tcloud)
  use classic_api  
  !---------------------------------------------------------------------
  ! MB 16-Aug-2001
  ! Simple cloud model after Staelin (1966), J. Geophys. Res. 71, 2875
  ! Take the difference between the extreme lowfreq/highfreq channels to
  ! get a good result (central channel might be contaminated by residual
  ! water vapor emission). Taking the difference should remove
  ! background fluctuations.
  ! No airmass is needed here.
  !---------------------------------------------------------------------
  integer :: ia                     !
  real :: tcloud                    !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  ! Local
  integer :: ib, ic
  real :: refrac_liquid, f_ghz, wband(-1:1)
  real :: bintegral(mwvrch), tmp, vlum2
  parameter(refrac_liquid = 5.0, vlum2 = 89875.54305)
  !
  ! The 3-point weighted sum over the passbands corresponds to the
  ! average over a polynomial of 2nd degree (Simpson formula).
  data wband /0.16666667, 0.6666666, 0.16666667/
  !
  do ic = 1, mwvrch
    tmp = 0.0
    do ib = -1,1
      f_ghz = r_wvrfreq(ic,ia) + ib*r_wvrbw(ic,ia)*0.5
      tmp = tmp + wband(ib) * (f_ghz * f_ghz) / vlum2
    enddo
    bintegral(ic) = tmp
  enddo
  !
  tmp = (refrac_liquid - 1.) /   &
    (tcloud * (bintegral(3) - bintegral(1)) *   &
    10.0**(0.0122*(291.-tcloud)-2.) )
  !
  r_wvrdcloud(1,ia) = - tmp
  r_wvrdcloud(2,ia) =   0.0
  r_wvrdcloud(3,ia) =   tmp
!
end subroutine atm_tri_cl
!=======================================================================
! SUBROUTINE BEV_POLFIT.F
!
! SOURCE
!   BEVINGTON, PAGES 140-142.
!
! PURPOSE
!   MAKE A LEAST-SQUARES FIT TO DATA WITH A POLYNOMIAL CURVE
!      Y = A(1) + A(2)*X + A(3)*X**2 + A(3)*X**3 + . . .
!
! USAGE
!   CALL POLFIT (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, CHISQR)
!
! DESCRIPTION OF PARAMETERS
!   X	   - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE
!   Y	   - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
!   SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS
!   NPTS   - NUMBER OF PAIRS OF DATA POINTS
!   NTERMS - NUMBER OF COEFFICIENTS (DEGREE OF POLYNOMIAL + 1)
!   MODE   - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT
!	     +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
!	      0 (NO WEIGHTING) WEIGHT(I) = 1.
!	     -1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
!   A	   - ARRAY OF COEFFICIENTS OF POLYNOMIAL
!   CHISQR - REDUCED CHI SQUARE FOR FIT
!
! SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
!   DETERM (ARRAY, NORDER)
!      EVALUATES THE DETERMINANT OF A SYMETRICAL
!      TWO-DIMENSIONAL MATRIX OF ORDER NORDER
!
! COMMENTS
!   DIMENSION STATEMENT VALID FOR NTERMS UP TO 16
!
subroutine bev_polfit (x,y,sigmay,npts,nterms,mode,a,chisqr)
  integer :: npts                   !
  real*8 :: x(npts)                 !
  real*8 :: y(npts)                 !
  real*8 :: sigmay(npts)            !
  integer :: nterms                 !
  integer :: mode                   !
  real*8 :: a(*)                    !
  real*8 :: chisqr                  !
  ! Local
  real*8 :: sumx,sumy,xterm,yterm,array,bev_determ,chisq
  integer :: mcwvrdump, mcdmp2
  parameter(mcwvrdump=128, mcdmp2=2*mcwvrdump)
  dimension sumx(mcdmp2),sumy(mcdmp2),array(mcwvrdump,mcwvrdump)
  !
  integer :: n,nmax,i,j,k,l, free
  double precision xi,yi, weight, delta
  !
  ! ACCUMULATE WEIGHTED SUMS
  !
nmax=2*nterms-1
  do 13 n=1,nmax
13 sumx(n)=0.
  do 15 j=1,nterms
15 sumy(j)=0.
  chisq=0.
do 50 i=1,npts
    xi=x(i)
    yi=y(i)
if (mode) 32,37,39
32  if (yi) 35,37,33
33  weight=1./yi
    goto 41
35  weight=1./(-yi)
    goto 41
37  weight=1.
    goto 41
39  weight=1./sigmay(i)**2
41  xterm=weight
    do 44 n=1,nmax
      sumx(n)=sumx(n)+xterm
44  xterm=xterm*xi
yterm=weight*yi
    do 48 n=1,nterms
      sumy(n)=sumy(n)+yterm
48  yterm=yterm*xi
chisq=chisq+weight*yi**2
50 continue
  !
  ! CONSTRUCT MATRICES AND CALCULATE COEFFICIENTS
  !
do 54 j=1,nterms
    do 54 k=1,nterms
      n=j+k-1
54 array(j,k)=sumx(n)
  delta=bev_determ (array,nterms)
  if (delta) 61,57,61
57 chisqr=0.
  do 59 j=1,nterms
59 a(j)=0.
  goto 80
61 do 70 l=1,nterms
do 66 j=1,nterms
      do 65 k=1,nterms
        n=j+k-1
65    array(j,k)=sumx(n)
66  array(j,l)=sumy(j)
70 a(l)=bev_determ (array,nterms) /delta
  !
  ! CALCULATE CHI SQUARE
  !
do 75 j=1,nterms
    chisq=chisq-2.*a(j)*sumy(j)
    do 75 k=1,nterms
      n=j+k-1
75 chisq=chisq+a(j)*a(k)*sumx(n)
free=npts-nterms
chisqr=chisq/free
80 return
end subroutine bev_polfit
!========================================================================
! FUNCTION BEV_DETERM.F
!
! SOURCE
!   BEVINGTON, PAGE 294.
!
! PURPOSE
!   CALCULATE THE DETERMINANT OF A SQUARE MATRIX
!
! USAGE
!   DET = DETERM (ARRAY, NORDER)
!
! DESCRIPTION OF PARAMETERS
!   ARRAY  - MATRIX
!   NORDER - ORDER OF DETERMINANT (DEGREE OF MATRIX)
!
! SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
!   NONE
!
! COMMENTS
!   THIS SUBPROGRAM DESTROYS THE INPUT MATRIX ARRAY
!   DIMENSION STATEMENT VALID FOR NORDER UP TO 16
!
real*8 function bev_determ (array,norder)
  double precision array,save
  dimension array(16,16)
  integer i,j,k,k1
  !
  integer norder
  !
bev_determ=1.
do 50 k=1,norder
    !
    ! INTERCHANGE COLUMNS IF DIAGONAL ELEMENT IS ZERO
    !
    if (array(k,k)) 41,21,41
21  do 23 j=k,norder
      if (array(k,j)) 31,23,31
23  continue
    bev_determ=0.
    goto 60
31  do 34 i=k,norder
      save=array(i,j)
      array(i,j)=array(i,k)
34  array(i,k)=save
    bev_determ=-bev_determ
    !
    ! SUBTRACT ROW K FROM LOWER ROWS TO GET DIAGONAL MATRIX
    !
41  bev_determ=bev_determ*array(k,k)
    if (k-norder) 43,50,50
43  k1=k+1
    do 46 i=k1,norder
      do 46 j=k1,norder
46  array(i,j)=array(i,j)-array(i,k)*array(k,j)/array(k,k)
50 continue
60 return
end function bev_determ
!
subroutine triple_water(ia,t_triple,b,c1,c2,airmass,   &
    tri_water,ier)
  use atm_interfaces_public
  use classic_api
  !---------------------------------------------------------------------
  ! Test routine trying to derive water content from 22 GHz radiometers
  !---------------------------------------------------------------------
  integer :: ia                     !
  real :: t_triple                  !
  real :: b                         !
  real :: c1                        !
  real :: c2                        !
  real :: airmass                   !
  real :: tri_water                 !
  integer :: ier                    !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  ! Local
  integer :: i, j, k
  real :: f_ghz, tri
  real :: tatm, tauox, tauw, taut, dtri, dwa, deltawa, err
  real :: wa, wband(-1:1)
  real :: temia(mwvrch)
  real :: ave_tsky, tsky
  character(len=256) :: ch
  !
  ! The 3-point weighted sum over the passbands corresponds to the
  ! average over a polynomial of 2nd degree (Simpson formula).
  data wband /0.16666667, 0.6666666, 0.16666667/
  !
  ! use a reasonable starting value (first pol)
  wa = min(10.,max(0.5,r_h2omm(1,ia)))
  dwa  = 0.02
  err = 1e10
  k = 0
  !
  ! Loop
10 continue
  k = k + 1
  do i = 1, mwvrch
    ave_tsky = 0.0
    do j = -1,1
      f_ghz = 0.001*(r_wvrfreq(i,ia) + j*r_wvrbw(i,ia)*0.5)
      call atm_transm(wa, airmass, f_ghz, tsky, tatm,   &
        tauox, tauw, taut, ier)
      ave_tsky = ave_tsky + tsky * wband(j)
    enddo
    temia(i) =  ave_tsky
  enddo
  tri  =  b * (temia(2) - c2 * temia(3)) -   &
    (temia(1) - c1 * temia(2))
  !
  do i = 1, mwvrch
    ave_tsky = 0.0
    do j = -1,1
      f_ghz = 0.001*(r_wvrfreq(i,ia) + j*r_wvrbw(i,ia)*0.5)
      call atm_transm(wa+dwa, airmass, f_ghz, tsky, tatm,   &
        tauox, tauw, taut, ier)
      ave_tsky = ave_tsky + tsky * wband(j)
    enddo
    temia(i) =  ave_tsky
  enddo
  dtri  =  b * (temia(2) - c2 * temia(3))  -   &
    (temia(1) - c1 * temia(2)) - tri
  err = tri - t_triple
  write (ch,'(''Iteration: '',i2,'' current water: '',f5.2, ''delta: '', f8.4)')  &
    k,wa,err
!        CALL MESSAGE (2,1,'TRI_WATER',CH)  ! test - comment this message out later MB 20-Sep-2012
  if (abs(err).ge.0.001 .and. dtri.ne.0 .and. k.le.10) then
    deltawa = dwa * err / dtri
    if(abs(dwa).ge.abs(deltawa/10.)) dwa = deltawa/10.
    wa = max(0.01,min(wa - deltawa,50.0))
    goto 10
  endif
  tri_water = wa
end subroutine triple_water
!
subroutine dual_water(ia,t_triple,b,c1,c2,airmass,   &
    tri_water,ier)
  use atm_interfaces_public
  use classic_api
  !---------------------------------------------------------------------
  ! Test routine trying to derive water content from 22 GHz radiometers
  !---------------------------------------------------------------------
  integer :: ia                     !
  real :: t_triple                  !
  real :: b                         !
  real :: c1                        !
  real :: c2                        !
  real :: airmass                   !
  real :: tri_water                 !
  integer :: ier                    !
  ! Global
  include 'clic_parameter.inc'
  include 'clic_par.inc'
  ! Local
  integer :: i, j, k
  real :: f_ghz, tri
  real :: tatm, tauox, tauw, taut, dtri, dwa, deltawa, err
  real :: wa, wband(-1:1)
  real :: temia(mwvrch)
  real :: ave_tsky, tsky
  character(len=256) :: ch
  !
  ! The 3-point weighted sum over the passbands corresponds to the
  ! average over a polynomial of 2nd degree (Simpson formula).
  data wband /0.16666667, 0.6666666, 0.16666667/
  !
  ! use a reasonable starting value (first pol)
  wa = min(10.,max(0.5,r_h2omm(1,ia)))
  dwa  = 0.02
  err = 1e10
  k = 0
  !
  ! Loop
10 continue
  k = k + 1
  do i = 1, mwvrch
    ave_tsky = 0.0
    do j = -1,1
      f_ghz = 0.001*(r_wvrfreq(i,ia) + j*r_wvrbw(i,ia)*0.5)
      call atm_transm(wa, airmass, f_ghz, tsky, tatm,   &
        tauox, tauw, taut, ier)
      ave_tsky = ave_tsky + tsky * wband(j)
    enddo
    temia(i) =  ave_tsky
  enddo
  tri  =  (temia(2) - c2 * temia(3))
  !
  do i = 1, mwvrch
    ave_tsky = 0.0
    do j = -1,1
      f_ghz = 0.001*(r_wvrfreq(i,ia) + j*r_wvrbw(i,ia)*0.5)
      call atm_transm(wa+dwa, airmass, f_ghz, tsky, tatm,   &
        tauox, tauw, taut, ier)
      ave_tsky = ave_tsky + tsky * wband(j)
    enddo
    temia(i) =  ave_tsky
  enddo
  dtri  =  temia(2) - c2 * temia(3)  - tri
  err = tri - t_triple
  write (ch,'(''Iteration: '',i2,'' current water: '',f5.2, ''delta: '', f8.4)')  &
    k,wa,err
  !      CALL MESSAGE (2,1,'TRI_WATER',CH)
  if (abs(err).ge.0.01 .and. dtri.ne.0 .and. k.le.10) then
    deltawa = dwa * err / dtri
    if(abs(dwa).ge.abs(deltawa/10.)) dwa = deltawa/10.
    wa = max(0.01,min(wa - deltawa,50.0))
    goto 10
  endif
  tri_water = wa
end subroutine dual_water
